From 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 Mon Sep 17 00:00:00 2001 From: Joe Hunkeler Date: Tue, 11 Aug 2015 16:51:37 -0400 Subject: Repatch (from linux) of OSX IRAF --- unix/README | 130 + unix/as | 1 + unix/as.cygwin/aclrb.c | 16 + unix/as.cygwin/aclrc.c | 16 + unix/as.cygwin/aclrd.c | 16 + unix/as.cygwin/aclri.c | 16 + unix/as.cygwin/aclrl.c | 16 + unix/as.cygwin/aclrr.c | 16 + unix/as.cygwin/aclrs.c | 16 + unix/as.cygwin/amovc.c | 17 + unix/as.cygwin/amovd.c | 17 + unix/as.cygwin/amovi.c | 17 + unix/as.cygwin/amovl.c | 17 + unix/as.cygwin/amovr.c | 17 + unix/as.cygwin/amovs.c | 17 + unix/as.cygwin/bytmov.c | 23 + unix/as.cygwin/ieee.gx | 420 ++ unix/as.cygwin/ieeed.x | 355 ++ unix/as.cygwin/ieeer.x | 385 ++ unix/as.cygwin/zrtadr.s | 6 + unix/as.cygwin/zsvjmp.s | 73 + unix/as.cygwin/zsvjmp.s.RH6 | 62 + unix/as.cygwin/zsvjmp.s.SL40 | 72 + unix/as.cygwin/zz.c | 10 + unix/as.cygwin/zzdebug.c | 48 + unix/as.freebsd/aclrb.c | 16 + unix/as.freebsd/aclrc.c | 16 + unix/as.freebsd/aclrd.c | 16 + unix/as.freebsd/aclri.c | 16 + unix/as.freebsd/aclrl.c | 16 + unix/as.freebsd/aclrr.c | 16 + unix/as.freebsd/aclrs.c | 16 + unix/as.freebsd/amovc.c | 17 + unix/as.freebsd/amovd.c | 17 + unix/as.freebsd/amovi.c | 17 + unix/as.freebsd/amovl.c | 17 + unix/as.freebsd/amovr.c | 17 + unix/as.freebsd/amovs.c | 17 + unix/as.freebsd/bytmov.c | 23 + unix/as.freebsd/ieee.gx | 371 ++ unix/as.freebsd/ieeed.x | 338 ++ unix/as.freebsd/ieeer.x | 338 ++ unix/as.freebsd/zrtadr.s | 6 + unix/as.freebsd/zsvjmp.s | 49 + unix/as.freebsd/zz.c | 10 + unix/as.freebsd/zzdebug.c | 48 + unix/as.freebsd/zzz.c | 5 + unix/as.freebsd/zzz.s | 21 + unix/as.i386/aclrb.c | 16 + unix/as.i386/aclrc.c | 16 + unix/as.i386/aclrd.c | 16 + unix/as.i386/aclri.c | 16 + unix/as.i386/aclrl.c | 16 + unix/as.i386/aclrr.c | 16 + unix/as.i386/aclrs.c | 16 + unix/as.i386/amods.s | 68 + unix/as.i386/amovc.c | 16 + unix/as.i386/amovd.c | 16 + unix/as.i386/amovi.c | 16 + unix/as.i386/amovl.c | 16 + unix/as.i386/amovr.c | 16 + unix/as.i386/amovs.c | 16 + unix/as.i386/bytmov.c | 22 + unix/as.i386/ieee.gx | 318 ++ unix/as.i386/ieeed.x | 287 ++ unix/as.i386/ieeer.x | 287 ++ unix/as.i386/zsvjmp.s | 45 + unix/as.i386/zzdebug.c | 48 + unix/as.linux/aclrb.c | 16 + unix/as.linux/aclrc.c | 16 + unix/as.linux/aclrd.c | 16 + unix/as.linux/aclri.c | 16 + unix/as.linux/aclrl.c | 16 + unix/as.linux/aclrr.c | 16 + unix/as.linux/aclrs.c | 16 + unix/as.linux/amovc.c | 17 + unix/as.linux/amovd.c | 17 + unix/as.linux/amovi.c | 17 + unix/as.linux/amovl.c | 17 + unix/as.linux/amovr.c | 17 + unix/as.linux/amovs.c | 17 + unix/as.linux/bytmov.c | 23 + unix/as.linux/ieee.gx | 420 ++ unix/as.linux/ieeed.x | 355 ++ unix/as.linux/ieeer.x | 385 ++ unix/as.linux/zrtadr.s | 6 + unix/as.linux/zsvjmp.s | 73 + unix/as.linux/zsvjmp.s.OLD | 61 + unix/as.linux/zsvjmp.s.RH6 | 62 + unix/as.linux/zsvjmp.s.SL40 | 72 + unix/as.linux/zz.c | 10 + unix/as.linux/zzdebug.c | 48 + unix/as.linux64/aclrb.c | 16 + unix/as.linux64/aclrc.c | 16 + unix/as.linux64/aclrd.c | 16 + unix/as.linux64/aclri.c | 16 + unix/as.linux64/aclrl.c | 16 + unix/as.linux64/aclrr.c | 16 + unix/as.linux64/aclrs.c | 16 + unix/as.linux64/amovc.c | 17 + unix/as.linux64/amovd.c | 17 + unix/as.linux64/amovi.c | 17 + unix/as.linux64/amovl.c | 17 + unix/as.linux64/amovr.c | 17 + unix/as.linux64/amovs.c | 17 + unix/as.linux64/bytmov.c | 23 + unix/as.linux64/ieee.gx | 391 ++ unix/as.linux64/ieeed.x | 356 ++ unix/as.linux64/ieeer.x | 345 ++ unix/as.linux64/zrtadr.s | 6 + unix/as.linux64/zsvjmp.s | 48 + unix/as.linux64/zsvjmp.s.BAD | 60 + unix/as.linux64/zsvjmp_c | 170 + unix/as.linux64/zsvjmp_demo.c | 13 + unix/as.linux64/zzdebug.c | 48 + unix/as.linuxppc/README | 68 + unix/as.linuxppc/aclrb.c | 16 + unix/as.linuxppc/aclrc.c | 16 + unix/as.linuxppc/aclrd.c | 16 + unix/as.linuxppc/aclri.c | 16 + unix/as.linuxppc/aclrl.c | 16 + unix/as.linuxppc/aclrr.c | 16 + unix/as.linuxppc/aclrs.c | 16 + unix/as.linuxppc/amovc.c | 17 + unix/as.linuxppc/amovd.c | 17 + unix/as.linuxppc/amovi.c | 17 + unix/as.linuxppc/amovl.c | 17 + unix/as.linuxppc/amovr.c | 17 + unix/as.linuxppc/amovs.c | 17 + unix/as.linuxppc/bytmov.c | 23 + unix/as.linuxppc/ieee.gx | 420 ++ unix/as.linuxppc/ieeed.x | 355 ++ unix/as.linuxppc/ieeer.x | 385 ++ unix/as.linuxppc/zsvjmp.s | 112 + unix/as.linuxppc/zz.c | 10 + unix/as.linuxppc/zzdebug.c | 48 + unix/as.macintel/aclrb.c | 16 + unix/as.macintel/aclrc.c | 16 + unix/as.macintel/aclrd.c | 16 + unix/as.macintel/aclri.c | 16 + unix/as.macintel/aclrl.c | 16 + unix/as.macintel/aclrr.c | 16 + unix/as.macintel/aclrs.c | 16 + unix/as.macintel/amovc.c | 17 + unix/as.macintel/amovd.c | 17 + unix/as.macintel/amovi.c | 17 + unix/as.macintel/amovl.c | 17 + unix/as.macintel/amovr.c | 17 + unix/as.macintel/amovs.c | 17 + unix/as.macintel/bytmov.c | 23 + unix/as.macintel/f2c.tar.gz | Bin 0 -> 1013694 bytes unix/as.macintel/ieee.gx | 391 ++ unix/as.macintel/ieeed.x | 356 ++ unix/as.macintel/ieeer.x | 345 ++ unix/as.macintel/zrtadr.s | 6 + unix/as.macintel/zsvjmp.s | 46 + unix/as.macintel/zsvjmp.s.bak | 59 + unix/as.macintel/zz_exit.c | 5 + unix/as.macintel/zz_zsvjmp.c | 17 + unix/as.macintel/zzdebug.c | 48 + unix/as.macosx/README | 68 + unix/as.macosx/aclrb.c | 16 + unix/as.macosx/aclrc.c | 16 + unix/as.macosx/aclrd.c | 16 + unix/as.macosx/aclri.c | 16 + unix/as.macosx/aclrl.c | 16 + unix/as.macosx/aclrr.c | 16 + unix/as.macosx/aclrs.c | 16 + unix/as.macosx/amovc.c | 17 + unix/as.macosx/amovd.c | 17 + unix/as.macosx/amovi.c | 17 + unix/as.macosx/amovl.c | 17 + unix/as.macosx/amovr.c | 17 + unix/as.macosx/amovs.c | 17 + unix/as.macosx/bytmov.c | 23 + unix/as.macosx/ieee.gx | 391 ++ unix/as.macosx/ieeed.x | 356 ++ unix/as.macosx/ieeer.x | 345 ++ unix/as.macosx/zsvjmp.s | 123 + unix/as.macosx/zsvjmp.s.OLD | 124 + unix/as.macosx/zsvjmp_i386.s | 95 + unix/as.macosx/zsvjmp_ppc.s | 123 + unix/as.macosx/zz.c | 10 + unix/as.macosx/zzdebug.c | 48 + unix/as.mc68020/README | 4 + unix/as.mc68020/aclrb.c | 16 + unix/as.mc68020/aclrc.c | 16 + unix/as.mc68020/aclrd.c | 16 + unix/as.mc68020/aclri.c | 16 + unix/as.mc68020/aclrl.c | 16 + unix/as.mc68020/aclrr.c | 16 + unix/as.mc68020/aclrs.c | 16 + unix/as.mc68020/amovc.c | 17 + unix/as.mc68020/amovd.c | 17 + unix/as.mc68020/amovi.c | 17 + unix/as.mc68020/amovl.c | 17 + unix/as.mc68020/amovr.c | 17 + unix/as.mc68020/amovs.c | 17 + unix/as.mc68020/bytmov.c | 23 + unix/as.mc68020/ieee.gx | 318 ++ unix/as.mc68020/ieeed.x | 287 ++ unix/as.mc68020/ieeer.x | 287 ++ unix/as.mc68020/ishift.s | 44 + unix/as.mc68020/zsvjmp.s | 37 + unix/as.mc68020/zsvjmp.s.ORIG | 49 + unix/as.redhat | 1 + unix/as.rs6000/aclrb.c | 16 + unix/as.rs6000/aclrc.c | 16 + unix/as.rs6000/aclrd.c | 16 + unix/as.rs6000/aclri.c | 16 + unix/as.rs6000/aclrl.c | 16 + unix/as.rs6000/aclrr.c | 16 + unix/as.rs6000/aclrs.c | 16 + unix/as.rs6000/amovc.c | 16 + unix/as.rs6000/amovd.c | 16 + unix/as.rs6000/amovi.c | 16 + unix/as.rs6000/amovl.c | 16 + unix/as.rs6000/amovr.c | 16 + unix/as.rs6000/amovs.c | 16 + unix/as.rs6000/bytmov.c | 22 + unix/as.rs6000/ieee.gx | 318 ++ unix/as.rs6000/ieeed.x | 289 ++ unix/as.rs6000/ieeer.x | 289 ++ unix/as.rs6000/zsvjmp.s | 29 + unix/as.rs6000/zzdebug.c | 48 + unix/as.sparc/aclrb.c | 16 + unix/as.sparc/aclrc.c | 16 + unix/as.sparc/aclrd.c | 16 + unix/as.sparc/aclri.c | 16 + unix/as.sparc/aclrl.c | 16 + unix/as.sparc/aclrr.c | 16 + unix/as.sparc/aclrs.c | 16 + unix/as.sparc/amovc.c | 16 + unix/as.sparc/amovd.c | 16 + unix/as.sparc/amovi.c | 16 + unix/as.sparc/amovl.c | 16 + unix/as.sparc/amovr.c | 16 + unix/as.sparc/amovs.c | 16 + unix/as.sparc/as.sparc/aclrb.c | 16 + unix/as.sparc/as.sparc/aclrc.c | 16 + unix/as.sparc/as.sparc/aclrd.c | 16 + unix/as.sparc/as.sparc/aclri.c | 16 + unix/as.sparc/as.sparc/aclrl.c | 16 + unix/as.sparc/as.sparc/aclrr.c | 16 + unix/as.sparc/as.sparc/aclrs.c | 16 + unix/as.sparc/as.sparc/amovc.c | 17 + unix/as.sparc/as.sparc/amovd.c | 17 + unix/as.sparc/as.sparc/amovi.c | 17 + unix/as.sparc/as.sparc/amovl.c | 17 + unix/as.sparc/as.sparc/amovr.c | 17 + unix/as.sparc/as.sparc/amovs.c | 17 + unix/as.sparc/as.sparc/bytmov.c | 23 + unix/as.sparc/as.sparc/enbint.s | 20 + unix/as.sparc/as.sparc/ieee.gx | 366 ++ unix/as.sparc/as.sparc/ieeed.x | 335 ++ unix/as.sparc/as.sparc/ieeer.x | 335 ++ unix/as.sparc/as.sparc/oscmd.s | 369 ++ unix/as.sparc/as.sparc/zrtadr.s | 6 + unix/as.sparc/as.sparc/zsvjmp.s | 33 + unix/as.sparc/as.sparc/zsvjmp.s.OLD | 59 + unix/as.sparc/as.sparc/zzdebug.c | 48 + unix/as.sparc/bytmov.c | 22 + unix/as.sparc/ieee.gx | 318 ++ unix/as.sparc/ieeed.x | 287 ++ unix/as.sparc/ieeer.x | 287 ++ unix/as.sparc/oscmd.s | 369 ++ unix/as.sparc/zrtadr.s | 6 + unix/as.sparc/zsvjmp.s | 32 + unix/as.sparc/zsvjmp.s.OLD | 59 + unix/as.sparc/zzdebug.c | 48 + unix/as.ssol/aclrb.c | 16 + unix/as.ssol/aclrc.c | 16 + unix/as.ssol/aclrd.c | 16 + unix/as.ssol/aclri.c | 16 + unix/as.ssol/aclrl.c | 16 + unix/as.ssol/aclrr.c | 16 + unix/as.ssol/aclrs.c | 16 + unix/as.ssol/amovc.c | 16 + unix/as.ssol/amovd.c | 16 + unix/as.ssol/amovi.c | 16 + unix/as.ssol/amovl.c | 16 + unix/as.ssol/amovr.c | 16 + unix/as.ssol/amovs.c | 16 + unix/as.ssol/as.ssol/aclrb.c | 16 + unix/as.ssol/as.ssol/aclrc.c | 16 + unix/as.ssol/as.ssol/aclrd.c | 16 + unix/as.ssol/as.ssol/aclri.c | 16 + unix/as.ssol/as.ssol/aclrl.c | 16 + unix/as.ssol/as.ssol/aclrr.c | 16 + unix/as.ssol/as.ssol/aclrs.c | 16 + unix/as.ssol/as.ssol/amovc.c | 17 + unix/as.ssol/as.ssol/amovd.c | 17 + unix/as.ssol/as.ssol/amovi.c | 17 + unix/as.ssol/as.ssol/amovl.c | 17 + unix/as.ssol/as.ssol/amovr.c | 17 + unix/as.ssol/as.ssol/amovs.c | 17 + unix/as.ssol/as.ssol/bytmov.c | 23 + unix/as.ssol/as.ssol/enbint.s | 20 + unix/as.ssol/as.ssol/ieee.gx | 366 ++ unix/as.ssol/as.ssol/ieeed.x | 335 ++ unix/as.ssol/as.ssol/ieeer.x | 335 ++ unix/as.ssol/as.ssol/oscmd.s | 369 ++ unix/as.ssol/as.ssol/zrtadr.s | 6 + unix/as.ssol/as.ssol/zsvjmp.s | 32 + unix/as.ssol/as.ssol/zsvjmp.s.OLD | 59 + unix/as.ssol/as.ssol/zzdebug.c | 48 + unix/as.ssol/bytmov.c | 22 + unix/as.ssol/enbint.s | 20 + unix/as.ssol/ieee.gx | 318 ++ unix/as.ssol/ieeed.x | 287 ++ unix/as.ssol/ieeer.x | 287 ++ unix/as.ssol/oscmd.s | 369 ++ unix/as.ssol/zrtadr.s | 6 + unix/as.ssol/zsvjmp.s | 32 + unix/as.ssol/zsvjmp.s.OLD | 59 + unix/as.ssol/zzdebug.c | 48 + unix/as.sunos/aclrb.c | 16 + unix/as.sunos/aclrc.c | 16 + unix/as.sunos/aclrd.c | 16 + unix/as.sunos/aclri.c | 16 + unix/as.sunos/aclrl.c | 16 + unix/as.sunos/aclrr.c | 16 + unix/as.sunos/aclrs.c | 16 + unix/as.sunos/amovc.c | 17 + unix/as.sunos/amovd.c | 17 + unix/as.sunos/amovi.c | 17 + unix/as.sunos/amovl.c | 17 + unix/as.sunos/amovr.c | 17 + unix/as.sunos/amovs.c | 17 + unix/as.sunos/bytmov.c | 23 + unix/as.sunos/ieee.gx | 371 ++ unix/as.sunos/ieeed.x | 338 ++ unix/as.sunos/ieeer.x | 338 ++ unix/as.sunos/zsvjmp.s | 50 + unix/as.sunos/zsvjmp_p.s | 48 + unix/as.sunos/zz.c | 10 + unix/as.sunos/zz.s | 27 + unix/as.sunos/zzdebug.c | 48 + unix/as.sunos/zzz.c | 5 + unix/as.vax/README | 34 + unix/as.vax/aaddks.s | 40 + unix/as.vax/aadds.s | 42 + unix/as.vax/aclr.s | 64 + unix/as.vax/aluir.s | 54 + unix/as.vax/aluis.s | 56 + unix/as.vax/amapr.s | 82 + unix/as.vax/amaps.s | 86 + unix/as.vax/amov.s | 94 + unix/as.vax/awsur.s | 44 + unix/as.vax/awsus.s | 47 + unix/as.vax/bitfields.s | 42 + unix/as.vax/bytmov.s | 80 + unix/as.vax/cyboow.s | 93 + unix/as.vax/ieeed.s | 182 + unix/as.vax/ieeer.s | 153 + unix/as.vax/ishift.s | 57 + unix/as.vax/zsvjmp.s | 35 + unix/as.vax/zsvjmp.s.ORIG | 55 + unix/bin | 1 + unix/bin.cygwin/arch_includes/fio.h | 146 + unix/bin.cygwin/arch_includes/pllseg.h | 62 + unix/bin.cygwin/arch_includes/plrseg.h | 68 + unix/bin.cygwin/f2c.e.exe | Bin 0 -> 268298 bytes unix/bin.cygwin/f2c.h | 228 + unix/bin.cygwin/fio.h | 146 + unix/bin.cygwin/libf2c.a | Bin 0 -> 147408 bytes unix/bin.cygwin/pllseg.h | 62 + unix/bin.cygwin/plrseg.h | 68 + unix/bin.freebsd/README | 12 + unix/bin.freebsd/f2c.1.gz | Bin 0 -> 3529 bytes unix/bin.freebsd/f2c.e | Bin 0 -> 249949 bytes unix/bin.freebsd/f2c.h | 223 + unix/bin.freebsd/libf2c.a | Bin 0 -> 220124 bytes unix/bin.linux/alloc.e | Bin 0 -> 8552 bytes unix/bin.linux/f2c.1 | 222 + unix/bin.linux/f2c.1.gz | Bin 0 -> 3101 bytes unix/bin.linux/f2c.e | Bin 0 -> 243520 bytes unix/bin.linux/f2c.h | 252 ++ unix/bin.linux/generic.e | Bin 0 -> 19633 bytes unix/bin.linux/iraf.h | 1 + unix/bin.linux/libboot.a | Bin 0 -> 47746 bytes unix/bin.linux/libf2c.a | Bin 0 -> 219906 bytes unix/bin.linux/libos.a | Bin 0 -> 153212 bytes unix/bin.linux/mach.h | 1 + unix/bin.linux/mkpkg.e | Bin 0 -> 211117 bytes unix/bin.linux/rmbin.e | Bin 0 -> 177270 bytes unix/bin.linux/rmfiles.e | Bin 0 -> 177729 bytes unix/bin.linux/rpp.e | Bin 0 -> 83988 bytes unix/bin.linux/rtar.e | Bin 0 -> 191738 bytes unix/bin.linux/sgi2gif.e | Bin 0 -> 13968 bytes unix/bin.linux/sgi2svg.e | Bin 0 -> 8706 bytes unix/bin.linux/sgi2uapl.e | Bin 0 -> 12606 bytes unix/bin.linux/sgi2ueps.e | Bin 0 -> 13490 bytes unix/bin.linux/sgi2uhpgl.e | Bin 0 -> 7346 bytes unix/bin.linux/sgi2uhplj.e | Bin 0 -> 7631 bytes unix/bin.linux/sgi2uimp.e | Bin 0 -> 9390 bytes unix/bin.linux/sgi2uptx.e | Bin 0 -> 6505 bytes unix/bin.linux/sgi2uqms.e | Bin 0 -> 8671 bytes unix/bin.linux/sgi2xbm.e | Bin 0 -> 7424 bytes unix/bin.linux/sgidispatch.e | Bin 0 -> 9875 bytes unix/bin.linux/wtar.e | Bin 0 -> 196998 bytes unix/bin.linux/xc.e | Bin 0 -> 188077 bytes unix/bin.linux/xpp.e | Bin 0 -> 210792 bytes unix/bin.linux/xyacc.e | Bin 0 -> 46252 bytes unix/bin.linux64/alloc.e | Bin 0 -> 17513 bytes unix/bin.linux64/f2c.1 | 222 + unix/bin.linux64/f2c.1.gz | Bin 0 -> 3101 bytes unix/bin.linux64/f2c.e | Bin 0 -> 747284 bytes unix/bin.linux64/f2c.h | 252 ++ unix/bin.linux64/generic.e | Bin 0 -> 43808 bytes unix/bin.linux64/iraf.h | 1 + unix/bin.linux64/libboot.a | Bin 0 -> 197720 bytes unix/bin.linux64/libf2c.a | Bin 0 -> 1016980 bytes unix/bin.linux64/libos.a | Bin 0 -> 626136 bytes unix/bin.linux64/mach.h | 1 + unix/bin.linux64/mkpkg.e | Bin 0 -> 674658 bytes unix/bin.linux64/rmbin.e | Bin 0 -> 592579 bytes unix/bin.linux64/rmfiles.e | Bin 0 -> 591560 bytes unix/bin.linux64/rpp.e | Bin 0 -> 315237 bytes unix/bin.linux64/rtar.e | Bin 0 -> 621736 bytes unix/bin.linux64/sgi2gif.e | Bin 0 -> 25531 bytes unix/bin.linux64/sgi2svg.e | Bin 0 -> 17669 bytes unix/bin.linux64/sgi2uapl.e | Bin 0 -> 24473 bytes unix/bin.linux64/sgi2ueps.e | Bin 0 -> 23192 bytes unix/bin.linux64/sgi2uhpgl.e | Bin 0 -> 15415 bytes unix/bin.linux64/sgi2uhplj.e | Bin 0 -> 16357 bytes unix/bin.linux64/sgi2uimp.e | Bin 0 -> 19202 bytes unix/bin.linux64/sgi2uptx.e | Bin 0 -> 14424 bytes unix/bin.linux64/sgi2uqms.e | Bin 0 -> 18339 bytes unix/bin.linux64/sgi2xbm.e | Bin 0 -> 15251 bytes unix/bin.linux64/sgidispatch.e | Bin 0 -> 21432 bytes unix/bin.linux64/wtar.e | Bin 0 -> 635761 bytes unix/bin.linux64/xc.e | Bin 0 -> 601201 bytes unix/bin.linux64/xpp.e | Bin 0 -> 651974 bytes unix/bin.linux64/xyacc.e | Bin 0 -> 92618 bytes unix/bin.macintel/alloc.e | Bin 0 -> 14984 bytes unix/bin.macintel/f2c.1 | 222 + unix/bin.macintel/f2c.e | Bin 0 -> 339736 bytes unix/bin.macintel/f2c.h | 252 ++ unix/bin.macintel/generic.e | Bin 0 -> 34284 bytes unix/bin.macintel/iraf.h | 1 + unix/bin.macintel/libboot.a | Bin 0 -> 144832 bytes unix/bin.macintel/libf2c.a | Bin 0 -> 245488 bytes unix/bin.macintel/libos.a | Bin 0 -> 500112 bytes unix/bin.macintel/mach.h | 1 + unix/bin.macintel/mkpkg.e | Bin 0 -> 381588 bytes unix/bin.macintel/rmbin.e | Bin 0 -> 322052 bytes unix/bin.macintel/rmfiles.e | Bin 0 -> 321516 bytes unix/bin.macintel/rpp.e | Bin 0 -> 84304 bytes unix/bin.macintel/rtar.e | Bin 0 -> 322944 bytes unix/bin.macintel/sgi2gif.e | Bin 0 -> 16508 bytes unix/bin.macintel/sgi2svg.e | Bin 0 -> 14948 bytes unix/bin.macintel/sgi2uapl.e | Bin 0 -> 16136 bytes unix/bin.macintel/sgi2ueps.e | Bin 0 -> 15872 bytes unix/bin.macintel/sgi2uhpgl.e | Bin 0 -> 10404 bytes unix/bin.macintel/sgi2uhplj.e | Bin 0 -> 10796 bytes unix/bin.macintel/sgi2uimp.e | Bin 0 -> 15152 bytes unix/bin.macintel/sgi2uptx.e | Bin 0 -> 10264 bytes unix/bin.macintel/sgi2uqms.e | Bin 0 -> 15092 bytes unix/bin.macintel/sgi2xbm.e | Bin 0 -> 10536 bytes unix/bin.macintel/sgidispatch.e | Bin 0 -> 15260 bytes unix/bin.macintel/wtar.e | Bin 0 -> 330648 bytes unix/bin.macintel/xc.e | Bin 0 -> 331184 bytes unix/bin.macintel/xpp.e | Bin 0 -> 374820 bytes unix/bin.macintel/xyacc.e | Bin 0 -> 57612 bytes unix/bin.macosx/alloc.e | Bin 0 -> 13976 bytes unix/bin.macosx/f2c.1.gz | Bin 0 -> 3101 bytes unix/bin.macosx/f2c.e | Bin 0 -> 269176 bytes unix/bin.macosx/f2c.h | 228 + unix/bin.macosx/generic.e | Bin 0 -> 23952 bytes unix/bin.macosx/iraf.h | 1 + unix/bin.macosx/libboot.a | Bin 0 -> 39192 bytes unix/bin.macosx/libf2c.a | Bin 0 -> 188864 bytes unix/bin.macosx/libos.a | Bin 0 -> 152840 bytes unix/bin.macosx/mach.h | 1 + unix/bin.macosx/mkpkg.e | Bin 0 -> 263940 bytes unix/bin.macosx/rmbin.e | Bin 0 -> 219812 bytes unix/bin.macosx/rmfiles.e | Bin 0 -> 223780 bytes unix/bin.macosx/rpp.e | Bin 0 -> 62604 bytes unix/bin.macosx/rtar.e | Bin 0 -> 224088 bytes unix/bin.macosx/sgi2gif.e | Bin 0 -> 14596 bytes unix/bin.macosx/sgi2svg.e | Bin 0 -> 13960 bytes unix/bin.macosx/sgi2uapl.e | Bin 0 -> 18592 bytes unix/bin.macosx/sgi2ueps.e | Bin 0 -> 14352 bytes unix/bin.macosx/sgi2uhpgl.e | Bin 0 -> 9704 bytes unix/bin.macosx/sgi2uhplj.e | Bin 0 -> 9864 bytes unix/bin.macosx/sgi2uimp.e | Bin 0 -> 14012 bytes unix/bin.macosx/sgi2uptx.e | Bin 0 -> 9620 bytes unix/bin.macosx/sgi2uqms.e | Bin 0 -> 14032 bytes unix/bin.macosx/sgi2xbm.e | Bin 0 -> 9776 bytes unix/bin.macosx/sgidispatch.e | Bin 0 -> 14040 bytes unix/bin.macosx/wtar.e | Bin 0 -> 228852 bytes unix/bin.macosx/xc.e | Bin 0 -> 232984 bytes unix/bin.macosx/xpp.e | Bin 0 -> 264144 bytes unix/bin.macosx/xyacc.e | Bin 0 -> 50056 bytes unix/bin.redhat | 1 + unix/bin.sunos/README | 12 + unix/bin.sunos/f2c.1.gz | Bin 0 -> 3101 bytes unix/bin.sunos/f2c.h | 229 + unix/boot/README | 19 + unix/boot/bootProto.h | 53 + unix/boot/bootlib/README | 53 + unix/boot/bootlib/_bytmov.c | 41 + unix/boot/bootlib/bootlib.h | 36 + unix/boot/bootlib/envinit.c | 269 ++ unix/boot/bootlib/index.c | 39 + unix/boot/bootlib/kproto32.h | 80 + unix/boot/bootlib/kproto64.h | 80 + unix/boot/bootlib/mkpkg | 49 + unix/boot/bootlib/mkpkg.sh | 16 + unix/boot/bootlib/osaccess.c | 27 + unix/boot/bootlib/osamovb.c | 34 + unix/boot/bootlib/oschdir.c | 43 + unix/boot/bootlib/osclose.c | 29 + unix/boot/bootlib/oscmd.c | 27 + unix/boot/bootlib/oscreatedir.c | 18 + unix/boot/bootlib/oscrfile.c | 36 + unix/boot/bootlib/osdelete.c | 19 + unix/boot/bootlib/osdir.c | 93 + unix/boot/bootlib/osfcopy.c | 84 + unix/boot/bootlib/osfdate.c | 20 + unix/boot/bootlib/osfiletype.c | 116 + unix/boot/bootlib/osfn2vfn.c | 81 + unix/boot/bootlib/osfpathname.c | 41 + unix/boot/bootlib/osgetenv.c | 127 + unix/boot/bootlib/osgetowner.c | 28 + unix/boot/bootlib/osopen.c | 29 + unix/boot/bootlib/osproto.h | 136 + unix/boot/bootlib/osputenv.c | 72 + unix/boot/bootlib/osread.c | 18 + unix/boot/bootlib/ossetfmode.c | 18 + unix/boot/bootlib/ossetowner.c | 21 + unix/boot/bootlib/ossettime.c | 24 + unix/boot/bootlib/osstrpak.c | 34 + unix/boot/bootlib/osstrupk.c | 44 + unix/boot/bootlib/ossubdir.c | 31 + unix/boot/bootlib/ossymlink.c | 35 + unix/boot/bootlib/ossysfile.c | 113 + unix/boot/bootlib/ostime.c | 113 + unix/boot/bootlib/oswrite.c | 49 + unix/boot/bootlib/rindex.c | 33 + unix/boot/bootlib/tape.c | 271 ++ unix/boot/bootlib/vfn2osfn.c | 147 + unix/boot/generic.new/README | 3 + unix/boot/generic.new/chario.c | 188 + unix/boot/generic.new/chario.o | Bin 0 -> 7340 bytes unix/boot/generic.new/generic.c | 892 ++++ unix/boot/generic.new/generic.e | Bin 0 -> 45720 bytes unix/boot/generic.new/generic.hlp | 245 ++ unix/boot/generic.new/generic.o | Bin 0 -> 37528 bytes unix/boot/generic.new/lex.sed | 7 + unix/boot/generic.new/lexyy.c | 2045 +++++++++ unix/boot/generic.new/lexyy.o | Bin 0 -> 53040 bytes unix/boot/generic.new/mkpkg.sh | 18 + unix/boot/generic.new/tok.l | 111 + unix/boot/generic.new/yywrap.c | 10 + unix/boot/generic.new/yywrap.o | Bin 0 -> 2148 bytes unix/boot/generic.new/z | 16 + unix/boot/generic/README | 3 + unix/boot/generic/chario.c | 188 + unix/boot/generic/generic.c | 892 ++++ unix/boot/generic/generic.hlp | 245 ++ unix/boot/generic/lex.sed | 7 + unix/boot/generic/lexyy.c | 679 +++ unix/boot/generic/mkpkg.sh | 18 + unix/boot/generic/tok.l | 91 + unix/boot/generic/yywrap.c | 10 + unix/boot/generic/z | 20 + unix/boot/mkpkg.sh | 21 + unix/boot/mkpkg/README | 54 + unix/boot/mkpkg/char.c | 478 ++ unix/boot/mkpkg/extern.h | 18 + unix/boot/mkpkg/fdcache.c | 190 + unix/boot/mkpkg/fncache.c | 228 + unix/boot/mkpkg/host.c | 917 ++++ unix/boot/mkpkg/main.c | 347 ++ unix/boot/mkpkg/mkpkg | 33 + unix/boot/mkpkg/mkpkg.h | 254 ++ unix/boot/mkpkg/mkpkg.hlp | 626 +++ unix/boot/mkpkg/mkpkg.sh | 9 + unix/boot/mkpkg/pkg.c | 902 ++++ unix/boot/mkpkg/scanlib.c | 355 ++ unix/boot/mkpkg/sflist.c | 321 ++ unix/boot/mkpkg/tok.c | 1457 +++++++ unix/boot/rmbin/README | 1 + unix/boot/rmbin/mkpkg.sh | 6 + unix/boot/rmbin/rmbin.c | 264 ++ unix/boot/rmbin/rmbin.hlp | 70 + unix/boot/rmfiles/README | 4 + unix/boot/rmfiles/mkpkg.sh | 6 + unix/boot/rmfiles/rmfiles.c | 383 ++ unix/boot/rmfiles/rmfiles.hlp | 95 + unix/boot/rtar/README | 5 + unix/boot/rtar/mkpkg.sh | 6 + unix/boot/rtar/rtar.c | 863 ++++ unix/boot/rtar/rtar.hlp | 165 + unix/boot/rtar/rtar.ms | 125 + unix/boot/spp/README | 43 + unix/boot/spp/mkpkg.sh | 12 + unix/boot/spp/mkxc.sh | 6 + unix/boot/spp/mkxc_dbg.sh | 6 + unix/boot/spp/rpp/README | 40 + unix/boot/spp/rpp/mkpkg.sh | 13 + unix/boot/spp/rpp/ratlibc/README | 1 + unix/boot/spp/rpp/ratlibc/cant.c | 16 + unix/boot/spp/rpp/ratlibc/close.c | 10 + unix/boot/spp/rpp/ratlibc/endst.c | 10 + unix/boot/spp/rpp/ratlibc/getarg.c | 28 + unix/boot/spp/rpp/ratlibc/getlin.c | 32 + unix/boot/spp/rpp/ratlibc/initst.c | 18 + unix/boot/spp/rpp/ratlibc/mkpkg.sh | 9 + unix/boot/spp/rpp/ratlibc/open.c | 30 + unix/boot/spp/rpp/ratlibc/putch.c | 15 + unix/boot/spp/rpp/ratlibc/putlin.c | 16 + unix/boot/spp/rpp/ratlibc/r4tocstr.c | 22 + unix/boot/spp/rpp/ratlibc/ratdef.h | 73 + unix/boot/spp/rpp/ratlibc/remark.c | 43 + unix/boot/spp/rpp/ratlibf/README | 1 + unix/boot/spp/rpp/ratlibf/addset.f | 13 + unix/boot/spp/rpp/ratlibf/addstr.f | 16 + unix/boot/spp/rpp/ratlibf/amatch.f | 68 + unix/boot/spp/rpp/ratlibf/catsub.f | 28 + unix/boot/spp/rpp/ratlibf/clower.f | 12 + unix/boot/spp/rpp/ratlibf/concat.f | 8 + unix/boot/spp/rpp/ratlibf/ctoc.f | 14 + unix/boot/spp/rpp/ratlibf/ctoi.f | 26 + unix/boot/spp/rpp/ratlibf/ctomn.f | 30 + unix/boot/spp/rpp/ratlibf/cupper.f | 10 + unix/boot/spp/rpp/ratlibf/delete.f | 13 + unix/boot/spp/rpp/ratlibf/docant.f | 13 + unix/boot/spp/rpp/ratlibf/dodash.f | 18 + unix/boot/spp/rpp/ratlibf/dsdbiu.f | 47 + unix/boot/spp/rpp/ratlibf/dsdump.f | 28 + unix/boot/spp/rpp/ratlibf/dsfree.f | 44 + unix/boot/spp/rpp/ratlibf/dsget.f | 45 + unix/boot/spp/rpp/ratlibf/dsinit.f | 17 + unix/boot/spp/rpp/ratlibf/enter.f | 34 + unix/boot/spp/rpp/ratlibf/equal.f | 15 + unix/boot/spp/rpp/ratlibf/error.f | 5 + unix/boot/spp/rpp/ratlibf/errsub.f | 22 + unix/boot/spp/rpp/ratlibf/esc.f | 27 + unix/boot/spp/rpp/ratlibf/fcopy.f | 10 + unix/boot/spp/rpp/ratlibf/filset.f | 63 + unix/boot/spp/rpp/ratlibf/fmtdat.f | 23 + unix/boot/spp/rpp/ratlibf/fold.f | 12 + unix/boot/spp/rpp/ratlibf/gctoi.f | 61 + unix/boot/spp/rpp/ratlibf/getc.f | 6 + unix/boot/spp/rpp/ratlibf/getccl.f | 25 + unix/boot/spp/rpp/ratlibf/getpat.f | 6 + unix/boot/spp/rpp/ratlibf/getwrd.f | 20 + unix/boot/spp/rpp/ratlibf/gfnarg.f | 142 + unix/boot/spp/rpp/ratlibf/index.f | 13 + unix/boot/spp/rpp/ratlibf/insub.f | 11 + unix/boot/spp/rpp/ratlibf/itoc.f | 35 + unix/boot/spp/rpp/ratlibf/length.f | 9 + unix/boot/spp/rpp/ratlibf/locate.f | 16 + unix/boot/spp/rpp/ratlibf/lookup.f | 24 + unix/boot/spp/rpp/ratlibf/lower.f | 5 + unix/boot/spp/rpp/ratlibf/makpat.f | 90 + unix/boot/spp/rpp/ratlibf/maksub.f | 40 + unix/boot/spp/rpp/ratlibf/match.f | 16 + unix/boot/spp/rpp/ratlibf/mkpkg.sh | 18 + unix/boot/spp/rpp/ratlibf/mktabl.f | 17 + unix/boot/spp/rpp/ratlibf/mntoc.f | 52 + unix/boot/spp/rpp/ratlibf/omatch.f | 60 + unix/boot/spp/rpp/ratlibf/outsub.f | 22 + unix/boot/spp/rpp/ratlibf/patsiz.f | 28 + unix/boot/spp/rpp/ratlibf/prompt.f | 11 + unix/boot/spp/rpp/ratlibf/putc.f | 5 + unix/boot/spp/rpp/ratlibf/putdec.f | 20 + unix/boot/spp/rpp/ratlibf/putint.f | 10 + unix/boot/spp/rpp/ratlibf/putstr.f | 27 + unix/boot/spp/rpp/ratlibf/query.f | 12 + unix/boot/spp/rpp/ratlibf/rmtabl.f | 21 + unix/boot/spp/rpp/ratlibf/scopy.f | 15 + unix/boot/spp/rpp/ratlibf/sctabl.f | 54 + unix/boot/spp/rpp/ratlibf/sdrop.f | 15 + unix/boot/spp/rpp/ratlibf/skipbl.f | 9 + unix/boot/spp/rpp/ratlibf/slstr.f | 32 + unix/boot/spp/rpp/ratlibf/stake.f | 15 + unix/boot/spp/rpp/ratlibf/stclos.f | 20 + unix/boot/spp/rpp/ratlibf/stcopy.f | 14 + unix/boot/spp/rpp/ratlibf/stlu.f | 36 + unix/boot/spp/rpp/ratlibf/strcmp.f | 30 + unix/boot/spp/rpp/ratlibf/strim.f | 16 + unix/boot/spp/rpp/ratlibf/termin.f | 8 + unix/boot/spp/rpp/ratlibf/trmout.f | 8 + unix/boot/spp/rpp/ratlibf/type.f | 16 + unix/boot/spp/rpp/ratlibf/upper.f | 12 + unix/boot/spp/rpp/ratlibf/wkday.f | 14 + unix/boot/spp/rpp/ratlibr/Makefile | 33 + unix/boot/spp/rpp/ratlibr/addset.r | 18 + unix/boot/spp/rpp/ratlibr/addstr.r | 19 + unix/boot/spp/rpp/ratlibr/amatch.r | 55 + unix/boot/spp/rpp/ratlibr/catsub.r | 27 + unix/boot/spp/rpp/ratlibr/clower.r | 18 + unix/boot/spp/rpp/ratlibr/concat.r | 15 + unix/boot/spp/rpp/ratlibr/ctoc.r | 18 + unix/boot/spp/rpp/ratlibr/ctoi.r | 37 + unix/boot/spp/rpp/ratlibr/ctomn.r | 59 + unix/boot/spp/rpp/ratlibr/cupper.r | 14 + unix/boot/spp/rpp/ratlibr/defs | 138 + unix/boot/spp/rpp/ratlibr/delete.r | 21 + unix/boot/spp/rpp/ratlibr/docant.r | 25 + unix/boot/spp/rpp/ratlibr/dodash.r | 22 + unix/boot/spp/rpp/ratlibr/dsdbiu.r | 45 + unix/boot/spp/rpp/ratlibr/dsdump.r | 34 + unix/boot/spp/rpp/ratlibr/dsfree.r | 53 + unix/boot/spp/rpp/ratlibr/dsget.r | 50 + unix/boot/spp/rpp/ratlibr/dsinit.r | 29 + unix/boot/spp/rpp/ratlibr/enter.r | 40 + unix/boot/spp/rpp/ratlibr/equal.r | 15 + unix/boot/spp/rpp/ratlibr/error.r | 10 + unix/boot/spp/rpp/ratlibr/errsub.r | 26 + unix/boot/spp/rpp/ratlibr/esc.r | 24 + unix/boot/spp/rpp/ratlibr/fcopy.r | 16 + unix/boot/spp/rpp/ratlibr/filset.r | 35 + unix/boot/spp/rpp/ratlibr/fmtdat.r | 34 + unix/boot/spp/rpp/ratlibr/fold.r | 16 + unix/boot/spp/rpp/ratlibr/fort | 0 unix/boot/spp/rpp/ratlibr/gctoi.r | 58 + unix/boot/spp/rpp/ratlibr/getc.r | 13 + unix/boot/spp/rpp/ratlibr/getccl.r | 29 + unix/boot/spp/rpp/ratlibr/getpat.r | 12 + unix/boot/spp/rpp/ratlibr/getwrd.r | 25 + unix/boot/spp/rpp/ratlibr/gfnarg.r | 115 + unix/boot/spp/rpp/ratlibr/index.r | 14 + unix/boot/spp/rpp/ratlibr/insub.r | 16 + unix/boot/spp/rpp/ratlibr/itoc.r | 50 + unix/boot/spp/rpp/ratlibr/length.r | 12 + unix/boot/spp/rpp/ratlibr/locate.r | 17 + unix/boot/spp/rpp/ratlibr/lookup.r | 30 + unix/boot/spp/rpp/ratlibr/lower.r | 11 + unix/boot/spp/rpp/ratlibr/makpat.r | 70 + unix/boot/spp/rpp/ratlibr/maksub.r | 34 + unix/boot/spp/rpp/ratlibr/match.r | 18 + unix/boot/spp/rpp/ratlibr/mktabl.r | 24 + unix/boot/spp/rpp/ratlibr/mntoc.r | 74 + unix/boot/spp/rpp/ratlibr/omatch.r | 48 + unix/boot/spp/rpp/ratlibr/outsub.r | 25 + unix/boot/spp/rpp/ratlibr/patsiz.r | 21 + unix/boot/spp/rpp/ratlibr/prompt.r | 19 + unix/boot/spp/rpp/ratlibr/putc.r | 11 + unix/boot/spp/rpp/ratlibr/putdec.r | 20 + unix/boot/spp/rpp/ratlibr/putint.r | 18 + unix/boot/spp/rpp/ratlibr/putstr.r | 23 + unix/boot/spp/rpp/ratlibr/query.r | 17 + unix/boot/spp/rpp/ratlibr/rmtabl.r | 27 + unix/boot/spp/rpp/ratlibr/scopy.r | 19 + unix/boot/spp/rpp/ratlibr/sctabl.r | 59 + unix/boot/spp/rpp/ratlibr/sdrop.r | 20 + unix/boot/spp/rpp/ratlibr/skipbl.r | 13 + unix/boot/spp/rpp/ratlibr/slstr.r | 36 + unix/boot/spp/rpp/ratlibr/stake.r | 20 + unix/boot/spp/rpp/ratlibr/stclos.r | 24 + unix/boot/spp/rpp/ratlibr/stcopy.r | 17 + unix/boot/spp/rpp/ratlibr/stlu.r | 36 + unix/boot/spp/rpp/ratlibr/strcmp.r | 24 + unix/boot/spp/rpp/ratlibr/strim.r | 18 + unix/boot/spp/rpp/ratlibr/termin.r | 12 + unix/boot/spp/rpp/ratlibr/trmout.r | 12 + unix/boot/spp/rpp/ratlibr/type.r | 99 + unix/boot/spp/rpp/ratlibr/upper.r | 16 + unix/boot/spp/rpp/ratlibr/wkday.r | 23 + unix/boot/spp/rpp/rpp.c | 31 + unix/boot/spp/rpp/rppfor/README | 1 + unix/boot/spp/rpp/rppfor/addchr.f | 10 + unix/boot/spp/rpp/rppfor/allblk.f | 15 + unix/boot/spp/rpp/rppfor/alldig.f | 18 + unix/boot/spp/rpp/rppfor/baderr.f | 5 + unix/boot/spp/rpp/rppfor/balpar.f | 41 + unix/boot/spp/rpp/rppfor/beginc.f | 72 + unix/boot/spp/rpp/rppfor/brknxt.f | 108 + unix/boot/spp/rpp/rppfor/cascod.f | 146 + unix/boot/spp/rpp/rppfor/caslab.f | 54 + unix/boot/spp/rpp/rppfor/declco.f | 120 + unix/boot/spp/rpp/rppfor/deftok.f | 237 + unix/boot/spp/rpp/rppfor/doarth.f | 93 + unix/boot/spp/rpp/rppfor/docode.f | 87 + unix/boot/spp/rpp/rppfor/doif.f | 81 + unix/boot/spp/rpp/rppfor/doincr.f | 70 + unix/boot/spp/rpp/rppfor/domac.f | 72 + unix/boot/spp/rpp/rppfor/dostat.f | 7 + unix/boot/spp/rpp/rppfor/dosub.f | 90 + unix/boot/spp/rpp/rppfor/eatup.f | 127 + unix/boot/spp/rpp/rppfor/elseif.f | 8 + unix/boot/spp/rpp/rppfor/endcod.f | 96 + unix/boot/spp/rpp/rppfor/entdef.f | 12 + unix/boot/spp/rpp/rppfor/entdkw.f | 14 + unix/boot/spp/rpp/rppfor/entfkw.f | 69 + unix/boot/spp/rpp/rppfor/entrkw.f | 151 + unix/boot/spp/rpp/rppfor/entxkw.f | 172 + unix/boot/spp/rpp/rppfor/errchk.f | 124 + unix/boot/spp/rpp/rppfor/errgo.f | 84 + unix/boot/spp/rpp/rppfor/errorc.f | 73 + unix/boot/spp/rpp/rppfor/evalr.f | 134 + unix/boot/spp/rpp/rppfor/finit.f | 79 + unix/boot/spp/rpp/rppfor/forcod.f | 183 + unix/boot/spp/rpp/rppfor/fors.f | 87 + unix/boot/spp/rpp/rppfor/getdef.f | 136 + unix/boot/spp/rpp/rppfor/gettok.f | 104 + unix/boot/spp/rpp/rppfor/gnbtok.f | 73 + unix/boot/spp/rpp/rppfor/gocode.f | 83 + unix/boot/spp/rpp/rppfor/gtok.f | 213 + unix/boot/spp/rpp/rppfor/ifcode.f | 71 + unix/boot/spp/rpp/rppfor/iferrc.f | 168 + unix/boot/spp/rpp/rppfor/ifgo.f | 88 + unix/boot/spp/rpp/rppfor/ifparm.f | 26 + unix/boot/spp/rpp/rppfor/indent.f | 68 + unix/boot/spp/rpp/rppfor/initkw.f | 86 + unix/boot/spp/rpp/rppfor/labelc.f | 75 + unix/boot/spp/rpp/rppfor/labgen.f | 68 + unix/boot/spp/rpp/rppfor/lex.f | 119 + unix/boot/spp/rpp/rppfor/litral.f | 76 + unix/boot/spp/rpp/rppfor/lndict.f | 86 + unix/boot/spp/rpp/rppfor/ludef.f | 84 + unix/boot/spp/rpp/rppfor/mapid.f | 13 + unix/boot/spp/rpp/rppfor/mkpkg.sh | 22 + unix/boot/spp/rpp/rppfor/ngetch.f | 94 + unix/boot/spp/rpp/rppfor/ogotos.f | 78 + unix/boot/spp/rpp/rppfor/otherc.f | 75 + unix/boot/spp/rpp/rppfor/outch.f | 120 + unix/boot/spp/rpp/rppfor/outcon.f | 80 + unix/boot/spp/rpp/rppfor/outdon.f | 118 + unix/boot/spp/rpp/rppfor/outdwe.f | 4 + unix/boot/spp/rpp/rppfor/outgo.f | 69 + unix/boot/spp/rpp/rppfor/outnum.f | 22 + unix/boot/spp/rpp/rppfor/outstr.f | 30 + unix/boot/spp/rpp/rppfor/outtab.f | 69 + unix/boot/spp/rpp/rppfor/parse.f | 257 ++ unix/boot/spp/rpp/rppfor/pbnum.f | 17 + unix/boot/spp/rpp/rppfor/pbstr.f | 75 + unix/boot/spp/rpp/rppfor/poicod.f | 172 + unix/boot/spp/rpp/rppfor/push.f | 9 + unix/boot/spp/rpp/rppfor/putbak.f | 73 + unix/boot/spp/rpp/rppfor/putchr.f | 71 + unix/boot/spp/rpp/rppfor/puttok.f | 11 + unix/boot/spp/rpp/rppfor/ratfor.f | 128 + unix/boot/spp/rpp/rppfor/relate.f | 66 + unix/boot/spp/rpp/rppfor/repcod.f | 10 + unix/boot/spp/rpp/rppfor/retcod.f | 88 + unix/boot/spp/rpp/rppfor/sdupl.f | 20 + unix/boot/spp/rpp/rppfor/skpblk.f | 73 + unix/boot/spp/rpp/rppfor/squash.f | 104 + unix/boot/spp/rpp/rppfor/strdcl.f | 170 + unix/boot/spp/rpp/rppfor/swcode.f | 99 + unix/boot/spp/rpp/rppfor/swend.f | 187 + unix/boot/spp/rpp/rppfor/swvar.f | 21 + unix/boot/spp/rpp/rppfor/synerr.f | 98 + unix/boot/spp/rpp/rppfor/thenco.f | 90 + unix/boot/spp/rpp/rppfor/ulstal.f | 69 + unix/boot/spp/rpp/rppfor/uniqid.f | 116 + unix/boot/spp/rpp/rppfor/unstak.f | 58 + unix/boot/spp/rpp/rppfor/untils.f | 80 + unix/boot/spp/rpp/rppfor/whilec.f | 72 + unix/boot/spp/rpp/rppfor/whiles.f | 69 + unix/boot/spp/rpp/rpprat/Makefile | 44 + unix/boot/spp/rpp/rpprat/addchr.r | 15 + unix/boot/spp/rpp/rpprat/allblk.r | 22 + unix/boot/spp/rpp/rpprat/alldig.r | 17 + unix/boot/spp/rpp/rpprat/baderr.r | 12 + unix/boot/spp/rpp/rpprat/balpar.r | 40 + unix/boot/spp/rpp/rpprat/beginc.r | 20 + unix/boot/spp/rpp/rpprat/brknxt.r | 45 + unix/boot/spp/rpp/rpprat/cascod.r | 71 + unix/boot/spp/rpp/rpprat/caslab.r | 48 + unix/boot/spp/rpp/rpprat/common | 79 + unix/boot/spp/rpp/rpprat/declco.r | 72 + unix/boot/spp/rpp/rpprat/defs | 138 + unix/boot/spp/rpp/rpprat/deftok.r | 162 + unix/boot/spp/rpp/rpprat/doarth.r | 30 + unix/boot/spp/rpp/rpprat/docode.r | 33 + unix/boot/spp/rpp/rpprat/doif.r | 25 + unix/boot/spp/rpp/rpprat/doincr.r | 17 + unix/boot/spp/rpp/rpprat/domac.r | 18 + unix/boot/spp/rpp/rpprat/dostat.r | 13 + unix/boot/spp/rpp/rpprat/dosub.r | 31 + unix/boot/spp/rpp/rpprat/eatup.r | 69 + unix/boot/spp/rpp/rpprat/elseif.r | 13 + unix/boot/spp/rpp/rpprat/endcod.r | 36 + unix/boot/spp/rpp/rpprat/entdef.r | 19 + unix/boot/spp/rpp/rpprat/entdkw.r | 41 + unix/boot/spp/rpp/rpprat/entfkw.r | 14 + unix/boot/spp/rpp/rpprat/entrkw.r | 56 + unix/boot/spp/rpp/rpprat/entxkw.r | 51 + unix/boot/spp/rpp/rpprat/errchk.r | 42 + unix/boot/spp/rpp/rpprat/errgo.r | 29 + unix/boot/spp/rpp/rpprat/errorc.r | 20 + unix/boot/spp/rpp/rpprat/evalr.r | 56 + unix/boot/spp/rpp/rpprat/finit.r | 24 + unix/boot/spp/rpp/rpprat/forcod.r | 101 + unix/boot/spp/rpp/rpprat/fors.r | 29 + unix/boot/spp/rpp/rpprat/fort | 0 unix/boot/spp/rpp/rpprat/getdef.r | 62 + unix/boot/spp/rpp/rpprat/gettok.r | 90 + unix/boot/spp/rpp/rpprat/gnbtok.r | 19 + unix/boot/spp/rpp/rpprat/gocode.r | 25 + unix/boot/spp/rpp/rpprat/gtok.r | 161 + unix/boot/spp/rpp/rpprat/ifcode.r | 17 + unix/boot/spp/rpp/rpprat/iferrc.r | 85 + unix/boot/spp/rpp/rpprat/ifgo.r | 23 + unix/boot/spp/rpp/rpprat/ifparm.r | 31 + unix/boot/spp/rpp/rpprat/indent.r | 12 + unix/boot/spp/rpp/rpprat/initkw.r | 34 + unix/boot/spp/rpp/rpprat/labelc.r | 19 + unix/boot/spp/rpp/rpprat/labgen.r | 13 + unix/boot/spp/rpp/rpprat/lex.r | 49 + unix/boot/spp/rpp/rpprat/litral.r | 20 + unix/boot/spp/rpp/rpprat/lndict.r | 30 + unix/boot/spp/rpp/rpprat/ludef.r | 29 + unix/boot/spp/rpp/rpprat/mapid.r | 19 + unix/boot/spp/rpp/rpprat/ngetch.r | 34 + unix/boot/spp/rpp/rpprat/ogotos.r | 20 + unix/boot/spp/rpp/rpprat/otherc.r | 18 + unix/boot/spp/rpp/rpprat/outch.r | 51 + unix/boot/spp/rpp/rpprat/outcon.r | 21 + unix/boot/spp/rpp/rpprat/outdon.r | 58 + unix/boot/spp/rpp/rpprat/outdwe.r | 13 + unix/boot/spp/rpp/rpprat/outgo.r | 13 + unix/boot/spp/rpp/rpprat/outnum.r | 24 + unix/boot/spp/rpp/rpprat/outstr.r | 33 + unix/boot/spp/rpp/rpprat/outtab.r | 12 + unix/boot/spp/rpp/rpprat/parse.r | 144 + unix/boot/spp/rpp/rpprat/pbnum.r | 20 + unix/boot/spp/rpp/rpprat/pbstr.r | 69 + unix/boot/spp/rpp/rpprat/poicod.r | 56 + unix/boot/spp/rpp/rpprat/push.r | 13 + unix/boot/spp/rpp/rpprat/putbak.r | 18 + unix/boot/spp/rpp/rpprat/putchr.r | 15 + unix/boot/spp/rpp/rpprat/puttok.r | 13 + unix/boot/spp/rpp/rpprat/ratfor.r | 70 + unix/boot/spp/rpp/rpprat/relate.r | 59 + unix/boot/spp/rpp/rpprat/repcod.r | 16 + unix/boot/spp/rpp/rpprat/retcod.r | 30 + unix/boot/spp/rpp/rpprat/sdupl.r | 25 + unix/boot/spp/rpp/rpprat/skpblk.r | 17 + unix/boot/spp/rpp/rpprat/squash.r | 53 + unix/boot/spp/rpp/rpprat/strdcl.r | 96 + unix/boot/spp/rpp/rpprat/swcode.r | 44 + unix/boot/spp/rpp/rpprat/swend.r | 106 + unix/boot/spp/rpp/rpprat/swvar.r | 22 + unix/boot/spp/rpp/rpprat/synerr.r | 37 + unix/boot/spp/rpp/rpprat/thenco.r | 25 + unix/boot/spp/rpp/rpprat/ulstal.r | 15 + unix/boot/spp/rpp/rpprat/uniqid.r | 49 + unix/boot/spp/rpp/rpprat/unstak.r | 42 + unix/boot/spp/rpp/rpprat/untils.r | 26 + unix/boot/spp/rpp/rpprat/whilec.r | 17 + unix/boot/spp/rpp/rpprat/whiles.r | 14 + unix/boot/spp/rpp/test.r | 212 + unix/boot/spp/rpp/x | 18 + unix/boot/spp/test.x | 13 + unix/boot/spp/xc.c | 1970 +++++++++ unix/boot/spp/xc.hlp | 197 + unix/boot/spp/xpp.h | 12 + unix/boot/spp/xpp/README | 6 + unix/boot/spp/xpp/decl.c | 565 +++ unix/boot/spp/xpp/lex.sed | 9 + unix/boot/spp/xpp/lexyy.c | 2932 +++++++++++++ unix/boot/spp/xpp/mkpkg.sh | 15 + unix/boot/spp/xpp/xpp.h | 94 + unix/boot/spp/xpp/xpp.l | 476 ++ unix/boot/spp/xpp/xpp.l.orig | 188 + unix/boot/spp/xpp/xppProto.h | 55 + unix/boot/spp/xpp/xppcode.c | 1826 ++++++++ unix/boot/spp/xpp/xppcode.c.bak | 1705 ++++++++ unix/boot/spp/xpp/xppmain.c | 225 + unix/boot/spp/xpp/zztest.x | 19 + unix/boot/vmcached/README | 17 + unix/boot/vmcached/notes | 364 ++ unix/boot/vmcached/vmcache.c | 1566 +++++++ unix/boot/vmcached/vmcache.h | 19 + unix/boot/vmcached/vmcached.c | 568 +++ unix/boot/wtar/README | 21 + unix/boot/wtar/mkpkg.sh | 6 + unix/boot/wtar/wtar.c | 717 +++ unix/boot/wtar/wtar.hlp | 89 + unix/boot/xyacc/Makefile | 21 + unix/boot/xyacc/README | 117 + unix/boot/xyacc/debug/dc.y | 306 ++ unix/boot/xyacc/debug/y.output | 331 ++ unix/boot/xyacc/debug/ytab.x | 645 +++ unix/boot/xyacc/dextern.h | 382 ++ unix/boot/xyacc/mkpkg.sh | 7 + unix/boot/xyacc/y1.c | 1307 ++++++ unix/boot/xyacc/y2.c | 1952 +++++++++ unix/boot/xyacc/y3.c | 606 +++ unix/boot/xyacc/y4.c | 528 +++ unix/boot/xyacc/yaccpar.x | 238 + unix/f2c/README | 186 + unix/f2c/changes | 3482 +++++++++++++++ unix/f2c/f2c.1 | 222 + unix/f2c/f2c.1t | 391 ++ unix/f2c/f2c.h | 223 + unix/f2c/f2c.pdf | Bin 0 -> 73606 bytes unix/f2c/f2c.ps | 5342 +++++++++++++++++++++++ unix/f2c/fc | 366 ++ unix/f2c/getopt.c | 102 + unix/f2c/index | 45 + unix/f2c/index.html | 57 + unix/f2c/libf2c/1 | 1 + unix/f2c/libf2c/Notice | 23 + unix/f2c/libf2c/README | 374 ++ unix/f2c/libf2c/abort_.c | 22 + unix/f2c/libf2c/arith.h | 9 + unix/f2c/libf2c/arithchk.c | 248 ++ unix/f2c/libf2c/backspac.c | 76 + unix/f2c/libf2c/c_abs.c | 20 + unix/f2c/libf2c/c_cos.c | 23 + unix/f2c/libf2c/c_div.c | 53 + unix/f2c/libf2c/c_exp.c | 25 + unix/f2c/libf2c/c_log.c | 23 + unix/f2c/libf2c/c_sin.c | 23 + unix/f2c/libf2c/c_sqrt.c | 41 + unix/f2c/libf2c/cabs.c | 33 + unix/f2c/libf2c/close.c | 101 + unix/f2c/libf2c/comptry.bat | 5 + unix/f2c/libf2c/ctype.c | 2 + unix/f2c/libf2c/ctype.h | 47 + unix/f2c/libf2c/d_abs.c | 18 + unix/f2c/libf2c/d_acos.c | 19 + unix/f2c/libf2c/d_asin.c | 19 + unix/f2c/libf2c/d_atan.c | 19 + unix/f2c/libf2c/d_atn2.c | 19 + unix/f2c/libf2c/d_cnjg.c | 19 + unix/f2c/libf2c/d_cos.c | 19 + unix/f2c/libf2c/d_cosh.c | 19 + unix/f2c/libf2c/d_dim.c | 16 + unix/f2c/libf2c/d_exp.c | 19 + unix/f2c/libf2c/d_imag.c | 16 + unix/f2c/libf2c/d_int.c | 19 + unix/f2c/libf2c/d_lg10.c | 21 + unix/f2c/libf2c/d_log.c | 19 + unix/f2c/libf2c/d_mod.c | 46 + unix/f2c/libf2c/d_nint.c | 20 + unix/f2c/libf2c/d_prod.c | 16 + unix/f2c/libf2c/d_sign.c | 18 + unix/f2c/libf2c/d_sin.c | 19 + unix/f2c/libf2c/d_sinh.c | 19 + unix/f2c/libf2c/d_sqrt.c | 19 + unix/f2c/libf2c/d_tan.c | 19 + unix/f2c/libf2c/d_tanh.c | 19 + unix/f2c/libf2c/derf_.c | 18 + unix/f2c/libf2c/derfc_.c | 20 + unix/f2c/libf2c/dfe.c | 151 + unix/f2c/libf2c/dolio.c | 26 + unix/f2c/libf2c/dtime_.c | 63 + unix/f2c/libf2c/due.c | 77 + unix/f2c/libf2c/ef1asc_.c | 25 + unix/f2c/libf2c/ef1cmc_.c | 20 + unix/f2c/libf2c/endfile.c | 160 + unix/f2c/libf2c/erf_.c | 22 + unix/f2c/libf2c/erfc_.c | 22 + unix/f2c/libf2c/err.c | 293 ++ unix/f2c/libf2c/etime_.c | 57 + unix/f2c/libf2c/exit_.c | 43 + unix/f2c/libf2c/f2c.h | 223 + unix/f2c/libf2c/f2c.h0 | 223 + unix/f2c/libf2c/f2ch.add | 162 + unix/f2c/libf2c/f77_aloc.c | 44 + unix/f2c/libf2c/f77vers.c | 97 + unix/f2c/libf2c/fio.h | 141 + unix/f2c/libf2c/fmt.c | 530 +++ unix/f2c/libf2c/fmt.h | 105 + unix/f2c/libf2c/fmtlib.c | 51 + unix/f2c/libf2c/fp.h | 28 + unix/f2c/libf2c/ftell64_.c | 52 + unix/f2c/libf2c/ftell_.c | 52 + unix/f2c/libf2c/getarg_.c | 36 + unix/f2c/libf2c/getenv_.c | 62 + unix/f2c/libf2c/h_abs.c | 18 + unix/f2c/libf2c/h_dim.c | 16 + unix/f2c/libf2c/h_dnnt.c | 19 + unix/f2c/libf2c/h_indx.c | 32 + unix/f2c/libf2c/h_len.c | 16 + unix/f2c/libf2c/h_mod.c | 16 + unix/f2c/libf2c/h_nint.c | 19 + unix/f2c/libf2c/h_sign.c | 18 + unix/f2c/libf2c/hl_ge.c | 18 + unix/f2c/libf2c/hl_gt.c | 18 + unix/f2c/libf2c/hl_le.c | 18 + unix/f2c/libf2c/hl_lt.c | 18 + unix/f2c/libf2c/i77vers.c | 343 ++ unix/f2c/libf2c/i_abs.c | 18 + unix/f2c/libf2c/i_dim.c | 16 + unix/f2c/libf2c/i_dnnt.c | 19 + unix/f2c/libf2c/i_indx.c | 32 + unix/f2c/libf2c/i_len.c | 16 + unix/f2c/libf2c/i_mod.c | 16 + unix/f2c/libf2c/i_nint.c | 19 + unix/f2c/libf2c/i_sign.c | 18 + unix/f2c/libf2c/iargc_.c | 17 + unix/f2c/libf2c/iio.c | 159 + unix/f2c/libf2c/ilnw.c | 83 + unix/f2c/libf2c/inquire.c | 117 + unix/f2c/libf2c/l_ge.c | 18 + unix/f2c/libf2c/l_gt.c | 18 + unix/f2c/libf2c/l_le.c | 18 + unix/f2c/libf2c/l_lt.c | 18 + unix/f2c/libf2c/lbitbits.c | 68 + unix/f2c/libf2c/lbitshft.c | 17 + unix/f2c/libf2c/libf2c.lbc | 153 + unix/f2c/libf2c/libf2c.sy | 153 + unix/f2c/libf2c/lio.h | 74 + unix/f2c/libf2c/lread.c | 806 ++++ unix/f2c/libf2c/lwrite.c | 314 ++ unix/f2c/libf2c/main.c | 148 + unix/f2c/libf2c/makefile.sy | 190 + unix/f2c/libf2c/makefile.u | 219 + unix/f2c/libf2c/makefile.vc | 195 + unix/f2c/libf2c/makefile.wat | 189 + unix/f2c/libf2c/math.hvc | 3 + unix/f2c/libf2c/mkfile.plan9 | 162 + unix/f2c/libf2c/mkpkg.sh | 5 + unix/f2c/libf2c/open.c | 301 ++ unix/f2c/libf2c/pow_ci.c | 26 + unix/f2c/libf2c/pow_dd.c | 19 + unix/f2c/libf2c/pow_di.c | 41 + unix/f2c/libf2c/pow_hh.c | 39 + unix/f2c/libf2c/pow_ii.c | 39 + unix/f2c/libf2c/pow_qq.c | 39 + unix/f2c/libf2c/pow_ri.c | 41 + unix/f2c/libf2c/pow_zi.c | 60 + unix/f2c/libf2c/pow_zz.c | 29 + unix/f2c/libf2c/qbitbits.c | 72 + unix/f2c/libf2c/qbitshft.c | 17 + unix/f2c/libf2c/r_abs.c | 18 + unix/f2c/libf2c/r_acos.c | 19 + unix/f2c/libf2c/r_asin.c | 19 + unix/f2c/libf2c/r_atan.c | 19 + unix/f2c/libf2c/r_atn2.c | 19 + unix/f2c/libf2c/r_cnjg.c | 18 + unix/f2c/libf2c/r_cos.c | 19 + unix/f2c/libf2c/r_cosh.c | 19 + unix/f2c/libf2c/r_dim.c | 16 + unix/f2c/libf2c/r_exp.c | 19 + unix/f2c/libf2c/r_imag.c | 16 + unix/f2c/libf2c/r_int.c | 19 + unix/f2c/libf2c/r_lg10.c | 21 + unix/f2c/libf2c/r_log.c | 19 + unix/f2c/libf2c/r_mod.c | 46 + unix/f2c/libf2c/r_nint.c | 20 + unix/f2c/libf2c/r_sign.c | 18 + unix/f2c/libf2c/r_sin.c | 19 + unix/f2c/libf2c/r_sinh.c | 19 + unix/f2c/libf2c/r_sqrt.c | 19 + unix/f2c/libf2c/r_tan.c | 19 + unix/f2c/libf2c/r_tanh.c | 19 + unix/f2c/libf2c/rawio.h | 41 + unix/f2c/libf2c/rdfmt.c | 553 +++ unix/f2c/libf2c/rewind.c | 30 + unix/f2c/libf2c/rsfe.c | 91 + unix/f2c/libf2c/rsli.c | 109 + unix/f2c/libf2c/rsne.c | 618 +++ unix/f2c/libf2c/s_cat.c | 86 + unix/f2c/libf2c/s_cmp.c | 50 + unix/f2c/libf2c/s_copy.c | 57 + unix/f2c/libf2c/s_paus.c | 96 + unix/f2c/libf2c/s_rnge.c | 32 + unix/f2c/libf2c/s_stop.c | 48 + unix/f2c/libf2c/scomptry.bat | 5 + unix/f2c/libf2c/sfe.c | 47 + unix/f2c/libf2c/sig_die.c | 51 + unix/f2c/libf2c/signal1.h | 35 + unix/f2c/libf2c/signal1.h0 | 35 + unix/f2c/libf2c/signal_.c | 21 + unix/f2c/libf2c/signbit.c | 24 + unix/f2c/libf2c/sue.c | 90 + unix/f2c/libf2c/sysdep1.h | 66 + unix/f2c/libf2c/sysdep1.h0 | 66 + unix/f2c/libf2c/system_.c | 42 + unix/f2c/libf2c/typesize.c | 18 + unix/f2c/libf2c/uio.c | 75 + unix/f2c/libf2c/uninit.c | 377 ++ unix/f2c/libf2c/util.c | 57 + unix/f2c/libf2c/wref.c | 294 ++ unix/f2c/libf2c/wrtfmt.c | 377 ++ unix/f2c/libf2c/wsfe.c | 78 + unix/f2c/libf2c/wsle.c | 42 + unix/f2c/libf2c/wsne.c | 32 + unix/f2c/libf2c/xsum0.out | 182 + unix/f2c/libf2c/xwsne.c | 77 + unix/f2c/libf2c/z_abs.c | 18 + unix/f2c/libf2c/z_cos.c | 21 + unix/f2c/libf2c/z_div.c | 50 + unix/f2c/libf2c/z_exp.c | 23 + unix/f2c/libf2c/z_log.c | 121 + unix/f2c/libf2c/z_sin.c | 21 + unix/f2c/libf2c/z_sqrt.c | 35 + unix/f2c/libf77 | 5169 ++++++++++++++++++++++ unix/f2c/libi77 | 7453 ++++++++++++++++++++++++++++++++ unix/f2c/mkpkg.sh | 6 + unix/f2c/msdos/README | 48 + unix/f2c/msdos/ccb.bat | 64 + unix/f2c/msdos/ccm.bat | 90 + unix/f2c/msdos/ccs.bat | 71 + unix/f2c/msdos/etime.exe.gz | Bin 0 -> 4956 bytes unix/f2c/msdos/f2c.exe.gz | Bin 0 -> 141545 bytes unix/f2c/msdos/f2cx.exe.gz | Bin 0 -> 140359 bytes unix/f2c/msdos/index.html | 32 + unix/f2c/mswin/README | 19 + unix/f2c/mswin/f2c.exe.gz | Bin 0 -> 133262 bytes unix/f2c/mswin/index.html | 16 + unix/f2c/mswin/makefile.vc | 76 + unix/f2c/src/README | 186 + unix/f2c/src/cds.c | 195 + unix/f2c/src/data.c | 502 +++ unix/f2c/src/defines.h | 300 ++ unix/f2c/src/defs.h | 1073 +++++ unix/f2c/src/equiv.c | 412 ++ unix/f2c/src/error.c | 347 ++ unix/f2c/src/exec.c | 984 +++++ unix/f2c/src/expr.c | 3738 ++++++++++++++++ unix/f2c/src/f2c.1 | 222 + unix/f2c/src/f2c.1t | 391 ++ unix/f2c/src/f2c.h | 223 + unix/f2c/src/format.c | 2613 +++++++++++ unix/f2c/src/format.h | 12 + unix/f2c/src/formatdata.c | 1263 ++++++ unix/f2c/src/ftypes.h | 64 + unix/f2c/src/gram.c | 1957 +++++++++ unix/f2c/src/gram.dcl | 416 ++ unix/f2c/src/gram.exec | 143 + unix/f2c/src/gram.expr | 146 + unix/f2c/src/gram.head | 293 ++ unix/f2c/src/gram.io | 175 + unix/f2c/src/index.html | 150 + unix/f2c/src/init.c | 526 +++ unix/f2c/src/intr.c | 1087 +++++ unix/f2c/src/io.c | 1509 +++++++ unix/f2c/src/iob.h | 26 + unix/f2c/src/lex.c | 1749 ++++++++ unix/f2c/src/machdefs.h | 31 + unix/f2c/src/main.c | 792 ++++ unix/f2c/src/makefile.u | 117 + unix/f2c/src/makefile.vc | 76 + unix/f2c/src/malloc.c | 183 + unix/f2c/src/mem.c | 272 ++ unix/f2c/src/memset.c | 72 + unix/f2c/src/misc.c | 1398 ++++++ unix/f2c/src/mkfile.plan9 | 107 + unix/f2c/src/mkpkg.sh | 5 + unix/f2c/src/names.c | 835 ++++ unix/f2c/src/names.h | 19 + unix/f2c/src/niceprintf.c | 445 ++ unix/f2c/src/niceprintf.h | 16 + unix/f2c/src/notice | 23 + unix/f2c/src/output.c | 1753 ++++++++ unix/f2c/src/output.h | 64 + unix/f2c/src/p1defs.h | 158 + unix/f2c/src/p1output.c | 728 ++++ unix/f2c/src/parse.h | 47 + unix/f2c/src/parse_args.c | 558 +++ unix/f2c/src/pccdefs.h | 64 + unix/f2c/src/pread.c | 990 +++++ unix/f2c/src/proc.c | 1834 ++++++++ unix/f2c/src/put.c | 458 ++ unix/f2c/src/putpcc.c | 2169 ++++++++++ unix/f2c/src/sysdep.c | 699 +++ unix/f2c/src/sysdep.h | 101 + unix/f2c/src/sysdep.hd | 1 + unix/f2c/src/sysdeptest.c | 23 + unix/f2c/src/tokdefs.h | 100 + unix/f2c/src/tokens | 100 + unix/f2c/src/usignal.h | 7 + unix/f2c/src/vax.c | 585 +++ unix/f2c/src/version.c | 2 + unix/f2c/src/xsum.c | 239 + unix/f2c/src/xsum.out | 59 + unix/f2c/src/xsum0.out | 59 + unix/f2c/src/xsum1.out | 59 + unix/gdev/README | 126 + unix/gdev/iism70/README | 18 + unix/gdev/iism70/m70.h | 27 + unix/gdev/iism70/mkpkg | 15 + unix/gdev/iism70/zclm70.x | 12 + unix/gdev/iism70/zopm70.x | 14 + unix/gdev/iism70/zrdm70.x | 14 + unix/gdev/iism70/zstm70.x | 28 + unix/gdev/iism70/zwrm70.x | 14 + unix/gdev/iism70/zwtm70.x | 13 + unix/gdev/iism75/README | 24 + unix/gdev/iism75/iis.h | 106 + unix/gdev/iism75/m75.h | 28 + unix/gdev/iism75/m75put.x | 160 + unix/gdev/iism75/mkpkg | 18 + unix/gdev/iism75/zclm75.x | 19 + unix/gdev/iism75/zopm75.x | 32 + unix/gdev/iism75/zrdm75.x | 163 + unix/gdev/iism75/zstm75.x | 28 + unix/gdev/iism75/zwrm75.x | 76 + unix/gdev/iism75/zwtm75.x | 29 + unix/gdev/iism75/zzrdii.x | 17 + unix/gdev/iism75/zzwrii.x | 17 + unix/gdev/m70vms/README | 68 + unix/gdev/m70vms/fcbu.inc | 6 + unix/gdev/m70vms/m70.h | 30 + unix/gdev/m70vms/m70cls.f | 26 + unix/gdev/m70vms/m70get.f | 43 + unix/gdev/m70vms/m70io.f | 75 + unix/gdev/m70vms/m70mcl.f | 35 + unix/gdev/m70vms/m70opn.f | 41 + unix/gdev/m70vms/m70rel.f | 19 + unix/gdev/m70vms/m70wt.f | 44 + unix/gdev/m70vms/m70wti.f | 46 + unix/gdev/m70vms/mkpkg | 29 + unix/gdev/m70vms/zclm70.x | 24 + unix/gdev/m70vms/zopm70.x | 59 + unix/gdev/m70vms/zrdm70.x | 36 + unix/gdev/m70vms/zstm70.x | 28 + unix/gdev/m70vms/zwrm70.x | 36 + unix/gdev/m70vms/zwtm70.x | 44 + unix/gdev/mkpkg | 12 + unix/gdev/mkpkg.sh | 3 + unix/gdev/sgidev/README | 24 + unix/gdev/sgidev/README.gif | 438 ++ unix/gdev/sgidev/mkpkg | 9 + unix/gdev/sgidev/mkpkg.sh | 60 + unix/gdev/sgidev/sgi2gif.c | 731 ++++ unix/gdev/sgidev/sgi2svg.c | 245 ++ unix/gdev/sgidev/sgi2uapl.c | 545 +++ unix/gdev/sgidev/sgi2ueps.c | 530 +++ unix/gdev/sgidev/sgi2uhpgl.c | 160 + unix/gdev/sgidev/sgi2uhplj.c | 223 + unix/gdev/sgidev/sgi2uimp.c | 341 ++ unix/gdev/sgidev/sgi2uptx.c | 61 + unix/gdev/sgidev/sgi2uqms.c | 296 ++ unix/gdev/sgidev/sgi2xbm.c | 135 + unix/gdev/sgidev/sgiUtil.c | 132 + unix/gdev/sgidev/sgiUtil.h | 10 + unix/gdev/sgidev/sgidispatch.c | 70 + unix/gdev/zfiogd.x | 420 ++ unix/hlib/README | 13 + unix/hlib/allocate.cl | 11 + unix/hlib/buglog.csh | 130 + unix/hlib/buglog.sh | 140 + unix/hlib/cl.csh | 153 + unix/hlib/cl.csh.ORIG | 212 + unix/hlib/cl.sh | 165 + unix/hlib/cllogout.cl | 5 + unix/hlib/clpackage.cl | 59 + unix/hlib/clpackage.hd | 86 + unix/hlib/clpackage.men | 13 + unix/hlib/config.h | 79 + unix/hlib/d1mach.f | 463 ++ unix/hlib/deallocate.cl | 12 + unix/hlib/devstatus.cl | 30 + unix/hlib/diskspace.cl | 7 + unix/hlib/ecl.csh | 1 + unix/hlib/ecl.sh | 164 + unix/hlib/extern.pkg | 41 + unix/hlib/extern.pkg.DEF | 16 + unix/hlib/extern.pkg.IRAFNET | 16 + unix/hlib/extpkg.cl | 58 + unix/hlib/f77.sh | 296 ++ unix/hlib/f77.sh.bak | 297 ++ unix/hlib/fc.csh | 37 + unix/hlib/fc.sh | 30 + unix/hlib/gripes.cl | 65 + unix/hlib/helplog.csh | 128 + unix/hlib/helplog.sh | 138 + unix/hlib/i1mach.f | 661 +++ unix/hlib/install.csh | 3484 +++++++++++++++ unix/hlib/install.old | 943 ++++ unix/hlib/install.port | 943 ++++ unix/hlib/iraf.h | 1 + unix/hlib/iraf32.h | 162 + unix/hlib/iraf64.h | 164 + unix/hlib/irafarch.csh | 270 ++ unix/hlib/irafarch.sh | 270 ++ unix/hlib/irafuser.csh | 215 + unix/hlib/irafuser.sh | 158 + unix/hlib/knet.h | 93 + unix/hlib/libboot.a | 1 + unix/hlib/libc/README | 25 + unix/hlib/libc/alloc.h | 8 + unix/hlib/libc/ctype.h | 32 + unix/hlib/libc/error.h | 12 + unix/hlib/libc/finfo.h | 19 + unix/hlib/libc/fpoll.h | 59 + unix/hlib/libc/fset.h | 64 + unix/hlib/libc/iraf.h | 192 + unix/hlib/libc/kernel.h | 107 + unix/hlib/libc/knames.h | 371 ++ unix/hlib/libc/kproto.h | 496 +++ unix/hlib/libc/kproto.h.bak | 494 +++ unix/hlib/libc/lexnum.h | 9 + unix/hlib/libc/libc.h | 330 ++ unix/hlib/libc/main.h | 6 + unix/hlib/libc/math.h | 24 + unix/hlib/libc/protect.h | 7 + unix/hlib/libc/prstat.h | 19 + unix/hlib/libc/prtype.h | 7 + unix/hlib/libc/setjmp.h | 25 + unix/hlib/libc/spp.h | 161 + unix/hlib/libc/stdarg-cygwin.h | 135 + unix/hlib/libc/stdarg-freebsd.h | 90 + unix/hlib/libc/stdarg-linux.h | 142 + unix/hlib/libc/stdarg-osx.h | 133 + unix/hlib/libc/stdarg-solaris.h | 64 + unix/hlib/libc/stdarg.h | 40 + unix/hlib/libc/stdio.h | 99 + unix/hlib/libc/ttset.h | 27 + unix/hlib/libc/vosproto.h | 4035 +++++++++++++++++ unix/hlib/libc/xnames.h | 244 ++ unix/hlib/libc/xwhen.h | 10 + unix/hlib/libc/zfstat.h | 8 + unix/hlib/libos.a | 1 + unix/hlib/login.cl | 182 + unix/hlib/mach.h | 1 + unix/hlib/mach32.h | 34 + unix/hlib/mach64.h | 34 + unix/hlib/math.h | 59 + unix/hlib/mkfloat.csh | 143 + unix/hlib/mkfloat.sh | 142 + unix/hlib/mkiraf.csh | 119 + unix/hlib/mkiraf.sh | 194 + unix/hlib/mkmlist.csh | 21 + unix/hlib/mkmlist.sh | 19 + unix/hlib/mkpkg.inc | 77 + unix/hlib/mkpkg.sf.CYGW | 50 + unix/hlib/mkpkg.sf.FBSD | 40 + unix/hlib/mkpkg.sf.I386 | 92 + unix/hlib/mkpkg.sf.LNUX | 41 + unix/hlib/mkpkg.sf.LNUX64 | 41 + unix/hlib/mkpkg.sf.MACX | 41 + unix/hlib/mkpkg.sf.OS4 | 82 + unix/hlib/mkpkg.sf.S34 | 122 + unix/hlib/mkpkg.sf.SF2C | 37 + unix/hlib/mkpkg.sf.SSUN | 65 + unix/hlib/mkpkg.sf.SUN3 | 54 + unix/hlib/mkpkg.sf.SUN4 | 55 + unix/hlib/mkpkg.sf.SX86 | 41 + unix/hlib/motd | 14 + unix/hlib/r1mach.f | 376 ++ unix/hlib/setup.csh | 21 + unix/hlib/setup.sh | 18 + unix/hlib/spy.cl | 31 + unix/hlib/strip | 0 unix/hlib/strip.iraf | 66 + unix/hlib/sysinfo | 2503 +++++++++++ unix/hlib/uninstall | 365 ++ unix/hlib/util.csh/.repo_desc | 27 + unix/hlib/util.csh/.repo_local | 200 + unix/hlib/util.csh/.repo_manifest | 200 + unix/hlib/util.csh/.repo_pkgs | 22 + unix/hlib/util.csh/.zzsetenv.def | 1 + unix/hlib/util.csh/README | 19 + unix/hlib/util.csh/check_update | 68 + unix/hlib/util.csh/chk64 | 17 + unix/hlib/util.csh/fget | 185 + unix/hlib/util.csh/iraf_latest | 91 + unix/hlib/util.csh/iraf_update | 100 + unix/hlib/util.csh/mkarch | 58 + unix/hlib/util.csh/mkbindist | 80 + unix/hlib/util.csh/mkclean | 121 + unix/hlib/util.csh/mkdist | 25 + unix/hlib/util.csh/mkproto | 114 + unix/hlib/util.csh/mksrc | 117 + unix/hlib/util.csh/mksysgen | 50 + unix/hlib/util.csh/mkup | 30 + unix/hlib/util.csh/mkupx | 15 + unix/hlib/util.csh/pkgclean | 89 + unix/hlib/util.csh/pkgdel | 17 + unix/hlib/util.csh/pkgenv | 15 + unix/hlib/util.csh/pkgget | 192 + unix/hlib/util.csh/pkginit | 43 + unix/hlib/util.csh/pkginst | 86 + unix/hlib/util.csh/pkgrepo | 13 + unix/hlib/util.csh/pkgupdate | 106 + unix/hlib/util.csh/self_update | 37 + unix/hlib/util.sh | 115 + unix/hlib/utime | 0 unix/hlib/vocl.csh | 1 + unix/hlib/vocl.sh | 165 + unix/hlib/zzsetenv.def | 119 + unix/mc68000/README | 71 + unix/mc68000/ishift.SUN | 44 + unix/mc68000/zsvjmp.FX | 49 + unix/mc68000/zsvjmp.ISI | 52 + unix/mc68000/zsvjmp.SUN | 49 + unix/mkpkg | 17 + unix/mkpkg.sh | 27 + unix/os/README | 7 + unix/os/alloc.c | 273 ++ unix/os/dio.c | 9 + unix/os/doc/Mach.notes | 32 + unix/os/doc/os.hd | 71 + unix/os/doc/os.ms | 4249 ++++++++++++++++++ unix/os/doc/ostoc.ms | 130 + unix/os/doc/zalocd.hlp | 53 + unix/os/doc/zardbf.hlp | 56 + unix/os/doc/zawrbf.hlp | 56 + unix/os/doc/zawset.hlp | 42 + unix/os/doc/zawtbf.hlp | 34 + unix/os/doc/zcall.hlp | 39 + unix/os/doc/zclcpr.hlp | 33 + unix/os/doc/zcldir.hlp | 28 + unix/os/doc/zcldpr.hlp | 38 + unix/os/doc/zclsbf.hlp | 32 + unix/os/doc/zclstx.hlp | 35 + unix/os/doc/zfacss.hlp | 37 + unix/os/doc/zfaloc.hlp | 34 + unix/os/doc/zfchdr.hlp | 29 + unix/os/doc/zfdele.hlp | 29 + unix/os/doc/zfgcwd.hlp | 26 + unix/os/doc/zfinfo.hlp | 66 + unix/os/doc/zfiobf.hlp | 53 + unix/os/doc/zfiolp.hlp | 54 + unix/os/doc/zfiomt.hlp | 65 + unix/os/doc/zfiopr.hlp | 58 + unix/os/doc/zfiosf.hlp | 51 + unix/os/doc/zfiotx.hlp | 44 + unix/os/doc/zfioty.hlp | 75 + unix/os/doc/zflstx.hlp | 33 + unix/os/doc/zfmkcp.hlp | 40 + unix/os/doc/zfpath.hlp | 32 + unix/os/doc/zfprot.hlp | 47 + unix/os/doc/zfrnam.hlp | 40 + unix/os/doc/zfsubd.hlp | 76 + unix/os/doc/zfxdir.hlp | 31 + unix/os/doc/zgettx.hlp | 57 + unix/os/doc/zgfdir.hlp | 37 + unix/os/doc/zgtime.hlp | 28 + unix/os/doc/zgtpid.hlp | 25 + unix/os/doc/zintpr.hlp | 34 + unix/os/doc/zlocpr.hlp | 35 + unix/os/doc/zlocva.hlp | 47 + unix/os/doc/zmain.hlp | 62 + unix/os/doc/zmaloc.hlp | 71 + unix/os/doc/zmfree.hlp | 36 + unix/os/doc/znottx.hlp | 45 + unix/os/doc/zopcpr.hlp | 33 + unix/os/doc/zopdir.hlp | 34 + unix/os/doc/zopdpr.hlp | 37 + unix/os/doc/zopnbf.hlp | 53 + unix/os/doc/zopntx.hlp | 55 + unix/os/doc/zoscmd.hlp | 36 + unix/os/doc/zpanic.hlp | 32 + unix/os/doc/zputtx.hlp | 59 + unix/os/doc/zraloc.hlp | 45 + unix/os/doc/zsektx.hlp | 43 + unix/os/doc/zsttbf.hlp | 53 + unix/os/doc/zstttx.hlp | 50 + unix/os/doc/zsvjmp.hlp | 65 + unix/os/doc/ztslee.hlp | 31 + unix/os/doc/zxgmes.hlp | 35 + unix/os/doc/zxwhen.hlp | 70 + unix/os/doc/zzclmt.hlp | 47 + unix/os/doc/zzopmt.hlp | 62 + unix/os/doc/zzrdmt.hlp | 37 + unix/os/doc/zzrwmt.hlp | 31 + unix/os/doc/zzwrmt.hlp | 36 + unix/os/doc/zzwtmt.hlp | 41 + unix/os/getproc.c | 134 + unix/os/gmttolst.c | 73 + unix/os/irafpath.c | 165 + unix/os/mkpkg | 98 + unix/os/mkpkg.sh | 42 + unix/os/mkproto | 5 + unix/os/net/README | 90 + unix/os/net/accept.c | 26 + unix/os/net/connect.c | 27 + unix/os/net/ctype.h | 4 + unix/os/net/eprintf.c | 15 + unix/os/net/ghostbynm.c | 37 + unix/os/net/ghostent.c | 137 + unix/os/net/gsocknm.c | 23 + unix/os/net/hostdb.c | 39 + unix/os/net/htonl.c | 22 + unix/os/net/htons.c | 16 + unix/os/net/in.h | 134 + unix/os/net/inetaddr.c | 92 + unix/os/net/kutil.c | 342 ++ unix/os/net/listen.c | 22 + unix/os/net/mkpkg | 25 + unix/os/net/netdb.h | 44 + unix/os/net/ntohl.c | 22 + unix/os/net/ntohs.c | 16 + unix/os/net/rexec.c | 160 + unix/os/net/socket.c | 25 + unix/os/net/socket.h | 109 + unix/os/net/tcpclose.c | 16 + unix/os/net/tcpread.c | 26 + unix/os/net/tcpwrite.c | 23 + unix/os/net/types.h | 39 + unix/os/net/zfioks.c | 441 ++ unix/os/net/zzdebug.x | 92 + unix/os/prwait.c | 175 + unix/os/tape.c | 508 +++ unix/os/zalloc.c | 206 + unix/os/zawset.c | 154 + unix/os/zcall.c | 91 + unix/os/zdojmp.c | 38 + unix/os/zfacss.c | 124 + unix/os/zfaloc.c | 104 + unix/os/zfchdr.c | 57 + unix/os/zfdele.c | 27 + unix/os/zfgcwd.c | 65 + unix/os/zfinfo.c | 99 + unix/os/zfiobf.c | 888 ++++ unix/os/zfioks.c | 2101 +++++++++ unix/os/zfiolp.c | 239 + unix/os/zfiomt.c | 1911 ++++++++ unix/os/zfiond.c | 918 ++++ unix/os/zfiopl.c | 279 ++ unix/os/zfiopr.c | 499 +++ unix/os/zfiosf.c | 126 + unix/os/zfiotx.c | 991 +++++ unix/os/zfioty.c | 127 + unix/os/zflink.c | 45 + unix/os/zfmkcp.c | 71 + unix/os/zfmkdr.c | 44 + unix/os/zfnbrk.c | 63 + unix/os/zfpath.c | 50 + unix/os/zfpoll.c | 129 + unix/os/zfprot.c | 103 + unix/os/zfrmdr.c | 39 + unix/os/zfrnam.c | 50 + unix/os/zfsubd.c | 104 + unix/os/zfunc.c | 80 + unix/os/zfutim.c | 68 + unix/os/zfxdir.c | 51 + unix/os/zgcmdl.c | 91 + unix/os/zghost.c | 25 + unix/os/zglobl.c | 19 + unix/os/zgmtco.c | 49 + unix/os/zgtenv.c | 245 ++ unix/os/zgtime.c | 65 + unix/os/zgtpid.c | 18 + unix/os/zintpr.c | 29 + unix/os/zlocpr.c | 61 + unix/os/zlocva.c | 24 + unix/os/zmain.c | 204 + unix/os/zmaloc.c | 39 + unix/os/zmfree.c | 35 + unix/os/zopdir.c | 468 ++ unix/os/zopdpr.c | 201 + unix/os/zoscmd.c | 219 + unix/os/zpanic.c | 103 + unix/os/zraloc.c | 37 + unix/os/zshlib.c | 18 + unix/os/zwmsec.c | 109 + unix/os/zxwhen.c | 499 +++ unix/os/zzdbg.c | 158 + unix/os/zzepro.c | 84 + unix/os/zzexit.c | 17 + unix/os/zzpstr.c | 176 + unix/os/zzsetk.c | 38 + unix/os/zzstrt.c | 628 +++ unix/portkit/README | 356 ++ unix/portkit/d1mach.f.ieee | 273 ++ unix/portkit/i1mach.f.ieee | 379 ++ unix/portkit/ishift.s.68000 | 44 + unix/portkit/mach.h.ieee | 37 + unix/portkit/r1mach.f.ieee | 191 + unix/portkit/spp.h.ieee | 139 + unix/portkit/zsvjmp.s.68000 | 37 + unix/portkit/zsvjmp.s.FX | 49 + unix/portkit/zsvjmp.s.HP800 | 48 + unix/portkit/zsvjmp.s.ISI | 52 + unix/portkit/zsvjmp.s.SPARC | 59 + unix/reboot | 26 + unix/rmbin.sh | 7 + unix/setarch.sh | 9 + unix/shlib/README | 2 + unix/shlib/S.nm.added | 0 unix/shlib/S.nm.deleted | 0 unix/shlib/S.nm.f68881 | 2605 +++++++++++ unix/shlib/S.nm.ffpa | 2605 +++++++++++ unix/shlib/S.nm.generic | 0 unix/shlib/S.nm.i386 | 2440 +++++++++++ unix/shlib/S.nm.new | 2864 ++++++++++++ unix/shlib/S.nm.old | 2864 ++++++++++++ unix/shlib/S.nm.pg | 2423 +++++++++++ unix/shlib/S.nm.sparc | 2865 ++++++++++++ unix/shlib/S.nm.ssun | 2864 ++++++++++++ unix/shlib/S.s | 2890 +++++++++++++ unix/shlib/S.ver.f68881 | 1 + unix/shlib/S.ver.ffpa | 1 + unix/shlib/S.ver.generic | 1 + unix/shlib/S.ver.i386 | 1 + unix/shlib/S.ver.pg | 1 + unix/shlib/S.ver.sparc | 1 + unix/shlib/S.ver.ssun | 1 + unix/shlib/Slib.c | 85 + unix/shlib/V.s | 2886 +++++++++++++ unix/shlib/aout.c | 59 + unix/shlib/coff.c | 87 + unix/shlib/edsym-sos4.c | 598 +++ unix/shlib/edsym-ssol.c | 265 ++ unix/shlib/elf.c | 96 + unix/shlib/inode.c | 28 + unix/shlib/mapfile | 2 + unix/shlib/medit.c | 77 + unix/shlib/mkpkg | 103 + unix/shlib/mkpkg.sh | 12 + unix/shlib/mkshlib.csh.403 | 497 +++ unix/shlib/mkshlib.csh.411 | 516 +++ unix/shlib/mkshlib.sos4 | 554 +++ unix/shlib/mkshlib.ssol | 1 + unix/shlib/mkshlib.ssol-sc2 | 447 ++ unix/shlib/mkshlib.ssol-sc34 | 483 +++ unix/shlib/omit.f68881 | 15 + unix/shlib/omit.ffpa | 16 + unix/shlib/omit.generic | 11 + unix/shlib/omit.i386 | 11 + unix/shlib/omit.pg | 15 + unix/shlib/omit.sparc | 11 + unix/shlib/omit.ssun | 11 + unix/shlib/zzzend.c | 8 + unix/sun/Gterm.hlp | 198 + unix/sun/Imtool.hlp | 420 ++ unix/sun/Makefile | 67 + unix/sun/README | 5 + unix/sun/arrow.c | 66 + unix/sun/fifo.c | 759 ++++ unix/sun/gterm.c | 1984 +++++++++ unix/sun/gterm.esc | 46 + unix/sun/gterm.h | 18 + unix/sun/gterm.icon | 34 + unix/sun/gterm.icon.OLD | 34 + unix/sun/gterm.man | 784 ++++ unix/sun/gtermio.c | 1224 ++++++ unix/sun/halley.lut | 257 ++ unix/sun/heat.lut | 257 ++ unix/sun/imtool.c | 4488 +++++++++++++++++++ unix/sun/imtool.cross | 4 + unix/sun/imtool.cursor | 4 + unix/sun/imtool.h | 13 + unix/sun/imtool.icon | 66 + unix/sun/imtool.icon.NEW | 34 + unix/sun/imtool.man | 713 +++ unix/sun/imtool.square | 4 + unix/sun/imtoolrc | 48 + unix/sun/mksuntool.csh | 39 + unix/sun/mouse.c | 47 + unix/sun/notify_read.c | 85 + unix/sun/screendump.c | 549 +++ unix/sun/ss1.patch | 31 + 1740 files changed, 255424 insertions(+) create mode 100644 unix/README create mode 120000 unix/as create mode 100644 unix/as.cygwin/aclrb.c create mode 100644 unix/as.cygwin/aclrc.c create mode 100644 unix/as.cygwin/aclrd.c create mode 100644 unix/as.cygwin/aclri.c create mode 100644 unix/as.cygwin/aclrl.c create mode 100644 unix/as.cygwin/aclrr.c create mode 100644 unix/as.cygwin/aclrs.c create mode 100644 unix/as.cygwin/amovc.c create mode 100644 unix/as.cygwin/amovd.c create mode 100644 unix/as.cygwin/amovi.c create mode 100644 unix/as.cygwin/amovl.c create mode 100644 unix/as.cygwin/amovr.c create mode 100644 unix/as.cygwin/amovs.c create mode 100644 unix/as.cygwin/bytmov.c create mode 100644 unix/as.cygwin/ieee.gx create mode 100644 unix/as.cygwin/ieeed.x create mode 100644 unix/as.cygwin/ieeer.x create mode 100644 unix/as.cygwin/zrtadr.s create mode 100644 unix/as.cygwin/zsvjmp.s create mode 100644 unix/as.cygwin/zsvjmp.s.RH6 create mode 100644 unix/as.cygwin/zsvjmp.s.SL40 create mode 100644 unix/as.cygwin/zz.c create mode 100644 unix/as.cygwin/zzdebug.c create mode 100644 unix/as.freebsd/aclrb.c create mode 100644 unix/as.freebsd/aclrc.c create mode 100644 unix/as.freebsd/aclrd.c create mode 100644 unix/as.freebsd/aclri.c create mode 100644 unix/as.freebsd/aclrl.c create mode 100644 unix/as.freebsd/aclrr.c create mode 100644 unix/as.freebsd/aclrs.c create mode 100644 unix/as.freebsd/amovc.c create mode 100644 unix/as.freebsd/amovd.c create mode 100644 unix/as.freebsd/amovi.c create mode 100644 unix/as.freebsd/amovl.c create mode 100644 unix/as.freebsd/amovr.c create mode 100644 unix/as.freebsd/amovs.c create mode 100644 unix/as.freebsd/bytmov.c create mode 100644 unix/as.freebsd/ieee.gx create mode 100644 unix/as.freebsd/ieeed.x create mode 100644 unix/as.freebsd/ieeer.x create mode 100644 unix/as.freebsd/zrtadr.s create mode 100644 unix/as.freebsd/zsvjmp.s create mode 100644 unix/as.freebsd/zz.c create mode 100644 unix/as.freebsd/zzdebug.c create mode 100644 unix/as.freebsd/zzz.c create mode 100644 unix/as.freebsd/zzz.s create mode 100644 unix/as.i386/aclrb.c create mode 100644 unix/as.i386/aclrc.c create mode 100644 unix/as.i386/aclrd.c create mode 100644 unix/as.i386/aclri.c create mode 100644 unix/as.i386/aclrl.c create mode 100644 unix/as.i386/aclrr.c create mode 100644 unix/as.i386/aclrs.c create mode 100644 unix/as.i386/amods.s create mode 100644 unix/as.i386/amovc.c create mode 100644 unix/as.i386/amovd.c create mode 100644 unix/as.i386/amovi.c create mode 100644 unix/as.i386/amovl.c create mode 100644 unix/as.i386/amovr.c create mode 100644 unix/as.i386/amovs.c create mode 100644 unix/as.i386/bytmov.c create mode 100644 unix/as.i386/ieee.gx create mode 100644 unix/as.i386/ieeed.x create mode 100644 unix/as.i386/ieeer.x create mode 100644 unix/as.i386/zsvjmp.s create mode 100644 unix/as.i386/zzdebug.c create mode 100644 unix/as.linux/aclrb.c create mode 100644 unix/as.linux/aclrc.c create mode 100644 unix/as.linux/aclrd.c create mode 100644 unix/as.linux/aclri.c create mode 100644 unix/as.linux/aclrl.c create mode 100644 unix/as.linux/aclrr.c create mode 100644 unix/as.linux/aclrs.c create mode 100644 unix/as.linux/amovc.c create mode 100644 unix/as.linux/amovd.c create mode 100644 unix/as.linux/amovi.c create mode 100644 unix/as.linux/amovl.c create mode 100644 unix/as.linux/amovr.c create mode 100644 unix/as.linux/amovs.c create mode 100644 unix/as.linux/bytmov.c create mode 100644 unix/as.linux/ieee.gx create mode 100644 unix/as.linux/ieeed.x create mode 100644 unix/as.linux/ieeer.x create mode 100644 unix/as.linux/zrtadr.s create mode 100644 unix/as.linux/zsvjmp.s create mode 100644 unix/as.linux/zsvjmp.s.OLD create mode 100644 unix/as.linux/zsvjmp.s.RH6 create mode 100644 unix/as.linux/zsvjmp.s.SL40 create mode 100644 unix/as.linux/zz.c create mode 100644 unix/as.linux/zzdebug.c create mode 100644 unix/as.linux64/aclrb.c create mode 100644 unix/as.linux64/aclrc.c create mode 100644 unix/as.linux64/aclrd.c create mode 100644 unix/as.linux64/aclri.c create mode 100644 unix/as.linux64/aclrl.c create mode 100644 unix/as.linux64/aclrr.c create mode 100644 unix/as.linux64/aclrs.c create mode 100644 unix/as.linux64/amovc.c create mode 100644 unix/as.linux64/amovd.c create mode 100644 unix/as.linux64/amovi.c create mode 100644 unix/as.linux64/amovl.c create mode 100644 unix/as.linux64/amovr.c create mode 100644 unix/as.linux64/amovs.c create mode 100644 unix/as.linux64/bytmov.c create mode 100644 unix/as.linux64/ieee.gx create mode 100644 unix/as.linux64/ieeed.x create mode 100644 unix/as.linux64/ieeer.x create mode 100644 unix/as.linux64/zrtadr.s create mode 100644 unix/as.linux64/zsvjmp.s create mode 100644 unix/as.linux64/zsvjmp.s.BAD create mode 100644 unix/as.linux64/zsvjmp_c create mode 100644 unix/as.linux64/zsvjmp_demo.c create mode 100644 unix/as.linux64/zzdebug.c create mode 100644 unix/as.linuxppc/README create mode 100644 unix/as.linuxppc/aclrb.c create mode 100644 unix/as.linuxppc/aclrc.c create mode 100644 unix/as.linuxppc/aclrd.c create mode 100644 unix/as.linuxppc/aclri.c create mode 100644 unix/as.linuxppc/aclrl.c create mode 100644 unix/as.linuxppc/aclrr.c create mode 100644 unix/as.linuxppc/aclrs.c create mode 100644 unix/as.linuxppc/amovc.c create mode 100644 unix/as.linuxppc/amovd.c create mode 100644 unix/as.linuxppc/amovi.c create mode 100644 unix/as.linuxppc/amovl.c create mode 100644 unix/as.linuxppc/amovr.c create mode 100644 unix/as.linuxppc/amovs.c create mode 100644 unix/as.linuxppc/bytmov.c create mode 100644 unix/as.linuxppc/ieee.gx create mode 100644 unix/as.linuxppc/ieeed.x create mode 100644 unix/as.linuxppc/ieeer.x create mode 100644 unix/as.linuxppc/zsvjmp.s create mode 100644 unix/as.linuxppc/zz.c create mode 100644 unix/as.linuxppc/zzdebug.c create mode 100644 unix/as.macintel/aclrb.c create mode 100644 unix/as.macintel/aclrc.c create mode 100644 unix/as.macintel/aclrd.c create mode 100644 unix/as.macintel/aclri.c create mode 100644 unix/as.macintel/aclrl.c create mode 100644 unix/as.macintel/aclrr.c create mode 100644 unix/as.macintel/aclrs.c create mode 100644 unix/as.macintel/amovc.c create mode 100644 unix/as.macintel/amovd.c create mode 100644 unix/as.macintel/amovi.c create mode 100644 unix/as.macintel/amovl.c create mode 100644 unix/as.macintel/amovr.c create mode 100644 unix/as.macintel/amovs.c create mode 100644 unix/as.macintel/bytmov.c create mode 100644 unix/as.macintel/f2c.tar.gz create mode 100644 unix/as.macintel/ieee.gx create mode 100644 unix/as.macintel/ieeed.x create mode 100644 unix/as.macintel/ieeer.x create mode 100644 unix/as.macintel/zrtadr.s create mode 100644 unix/as.macintel/zsvjmp.s create mode 100644 unix/as.macintel/zsvjmp.s.bak create mode 100644 unix/as.macintel/zz_exit.c create mode 100644 unix/as.macintel/zz_zsvjmp.c create mode 100644 unix/as.macintel/zzdebug.c create mode 100644 unix/as.macosx/README create mode 100644 unix/as.macosx/aclrb.c create mode 100644 unix/as.macosx/aclrc.c create mode 100644 unix/as.macosx/aclrd.c create mode 100644 unix/as.macosx/aclri.c create mode 100644 unix/as.macosx/aclrl.c create mode 100644 unix/as.macosx/aclrr.c create mode 100644 unix/as.macosx/aclrs.c create mode 100644 unix/as.macosx/amovc.c create mode 100644 unix/as.macosx/amovd.c create mode 100644 unix/as.macosx/amovi.c create mode 100644 unix/as.macosx/amovl.c create mode 100644 unix/as.macosx/amovr.c create mode 100644 unix/as.macosx/amovs.c create mode 100644 unix/as.macosx/bytmov.c create mode 100644 unix/as.macosx/ieee.gx create mode 100644 unix/as.macosx/ieeed.x create mode 100644 unix/as.macosx/ieeer.x create mode 100644 unix/as.macosx/zsvjmp.s create mode 100644 unix/as.macosx/zsvjmp.s.OLD create mode 100644 unix/as.macosx/zsvjmp_i386.s create mode 100644 unix/as.macosx/zsvjmp_ppc.s create mode 100644 unix/as.macosx/zz.c create mode 100644 unix/as.macosx/zzdebug.c create mode 100644 unix/as.mc68020/README create mode 100644 unix/as.mc68020/aclrb.c create mode 100644 unix/as.mc68020/aclrc.c create mode 100644 unix/as.mc68020/aclrd.c create mode 100644 unix/as.mc68020/aclri.c create mode 100644 unix/as.mc68020/aclrl.c create mode 100644 unix/as.mc68020/aclrr.c create mode 100644 unix/as.mc68020/aclrs.c create mode 100644 unix/as.mc68020/amovc.c create mode 100644 unix/as.mc68020/amovd.c create mode 100644 unix/as.mc68020/amovi.c create mode 100644 unix/as.mc68020/amovl.c create mode 100644 unix/as.mc68020/amovr.c create mode 100644 unix/as.mc68020/amovs.c create mode 100644 unix/as.mc68020/bytmov.c create mode 100644 unix/as.mc68020/ieee.gx create mode 100644 unix/as.mc68020/ieeed.x create mode 100644 unix/as.mc68020/ieeer.x create mode 100644 unix/as.mc68020/ishift.s create mode 100644 unix/as.mc68020/zsvjmp.s create mode 100644 unix/as.mc68020/zsvjmp.s.ORIG create mode 120000 unix/as.redhat create mode 100644 unix/as.rs6000/aclrb.c create mode 100644 unix/as.rs6000/aclrc.c create mode 100644 unix/as.rs6000/aclrd.c create mode 100644 unix/as.rs6000/aclri.c create mode 100644 unix/as.rs6000/aclrl.c create mode 100644 unix/as.rs6000/aclrr.c create mode 100644 unix/as.rs6000/aclrs.c create mode 100644 unix/as.rs6000/amovc.c create mode 100644 unix/as.rs6000/amovd.c create mode 100644 unix/as.rs6000/amovi.c create mode 100644 unix/as.rs6000/amovl.c create mode 100644 unix/as.rs6000/amovr.c create mode 100644 unix/as.rs6000/amovs.c create mode 100644 unix/as.rs6000/bytmov.c create mode 100644 unix/as.rs6000/ieee.gx create mode 100644 unix/as.rs6000/ieeed.x create mode 100644 unix/as.rs6000/ieeer.x create mode 100644 unix/as.rs6000/zsvjmp.s create mode 100644 unix/as.rs6000/zzdebug.c create mode 100644 unix/as.sparc/aclrb.c create mode 100644 unix/as.sparc/aclrc.c create mode 100644 unix/as.sparc/aclrd.c create mode 100644 unix/as.sparc/aclri.c create mode 100644 unix/as.sparc/aclrl.c create mode 100644 unix/as.sparc/aclrr.c create mode 100644 unix/as.sparc/aclrs.c create mode 100644 unix/as.sparc/amovc.c create mode 100644 unix/as.sparc/amovd.c create mode 100644 unix/as.sparc/amovi.c create mode 100644 unix/as.sparc/amovl.c create mode 100644 unix/as.sparc/amovr.c create mode 100644 unix/as.sparc/amovs.c create mode 100644 unix/as.sparc/as.sparc/aclrb.c create mode 100644 unix/as.sparc/as.sparc/aclrc.c create mode 100644 unix/as.sparc/as.sparc/aclrd.c create mode 100644 unix/as.sparc/as.sparc/aclri.c create mode 100644 unix/as.sparc/as.sparc/aclrl.c create mode 100644 unix/as.sparc/as.sparc/aclrr.c create mode 100644 unix/as.sparc/as.sparc/aclrs.c create mode 100644 unix/as.sparc/as.sparc/amovc.c create mode 100644 unix/as.sparc/as.sparc/amovd.c create mode 100644 unix/as.sparc/as.sparc/amovi.c create mode 100644 unix/as.sparc/as.sparc/amovl.c create mode 100644 unix/as.sparc/as.sparc/amovr.c create mode 100644 unix/as.sparc/as.sparc/amovs.c create mode 100644 unix/as.sparc/as.sparc/bytmov.c create mode 100644 unix/as.sparc/as.sparc/enbint.s create mode 100644 unix/as.sparc/as.sparc/ieee.gx create mode 100644 unix/as.sparc/as.sparc/ieeed.x create mode 100644 unix/as.sparc/as.sparc/ieeer.x create mode 100644 unix/as.sparc/as.sparc/oscmd.s create mode 100644 unix/as.sparc/as.sparc/zrtadr.s create mode 100644 unix/as.sparc/as.sparc/zsvjmp.s create mode 100644 unix/as.sparc/as.sparc/zsvjmp.s.OLD create mode 100644 unix/as.sparc/as.sparc/zzdebug.c create mode 100644 unix/as.sparc/bytmov.c create mode 100644 unix/as.sparc/ieee.gx create mode 100644 unix/as.sparc/ieeed.x create mode 100644 unix/as.sparc/ieeer.x create mode 100644 unix/as.sparc/oscmd.s create mode 100644 unix/as.sparc/zrtadr.s create mode 100644 unix/as.sparc/zsvjmp.s create mode 100644 unix/as.sparc/zsvjmp.s.OLD create mode 100644 unix/as.sparc/zzdebug.c create mode 100644 unix/as.ssol/aclrb.c create mode 100644 unix/as.ssol/aclrc.c create mode 100644 unix/as.ssol/aclrd.c create mode 100644 unix/as.ssol/aclri.c create mode 100644 unix/as.ssol/aclrl.c create mode 100644 unix/as.ssol/aclrr.c create mode 100644 unix/as.ssol/aclrs.c create mode 100644 unix/as.ssol/amovc.c create mode 100644 unix/as.ssol/amovd.c create mode 100644 unix/as.ssol/amovi.c create mode 100644 unix/as.ssol/amovl.c create mode 100644 unix/as.ssol/amovr.c create mode 100644 unix/as.ssol/amovs.c create mode 100644 unix/as.ssol/as.ssol/aclrb.c create mode 100644 unix/as.ssol/as.ssol/aclrc.c create mode 100644 unix/as.ssol/as.ssol/aclrd.c create mode 100644 unix/as.ssol/as.ssol/aclri.c create mode 100644 unix/as.ssol/as.ssol/aclrl.c create mode 100644 unix/as.ssol/as.ssol/aclrr.c create mode 100644 unix/as.ssol/as.ssol/aclrs.c create mode 100644 unix/as.ssol/as.ssol/amovc.c create mode 100644 unix/as.ssol/as.ssol/amovd.c create mode 100644 unix/as.ssol/as.ssol/amovi.c create mode 100644 unix/as.ssol/as.ssol/amovl.c create mode 100644 unix/as.ssol/as.ssol/amovr.c create mode 100644 unix/as.ssol/as.ssol/amovs.c create mode 100644 unix/as.ssol/as.ssol/bytmov.c create mode 100644 unix/as.ssol/as.ssol/enbint.s create mode 100644 unix/as.ssol/as.ssol/ieee.gx create mode 100644 unix/as.ssol/as.ssol/ieeed.x create mode 100644 unix/as.ssol/as.ssol/ieeer.x create mode 100644 unix/as.ssol/as.ssol/oscmd.s create mode 100644 unix/as.ssol/as.ssol/zrtadr.s create mode 100644 unix/as.ssol/as.ssol/zsvjmp.s create mode 100644 unix/as.ssol/as.ssol/zsvjmp.s.OLD create mode 100644 unix/as.ssol/as.ssol/zzdebug.c create mode 100644 unix/as.ssol/bytmov.c create mode 100644 unix/as.ssol/enbint.s create mode 100644 unix/as.ssol/ieee.gx create mode 100644 unix/as.ssol/ieeed.x create mode 100644 unix/as.ssol/ieeer.x create mode 100644 unix/as.ssol/oscmd.s create mode 100644 unix/as.ssol/zrtadr.s create mode 100644 unix/as.ssol/zsvjmp.s create mode 100644 unix/as.ssol/zsvjmp.s.OLD create mode 100644 unix/as.ssol/zzdebug.c create mode 100644 unix/as.sunos/aclrb.c create mode 100644 unix/as.sunos/aclrc.c create mode 100644 unix/as.sunos/aclrd.c create mode 100644 unix/as.sunos/aclri.c create mode 100644 unix/as.sunos/aclrl.c create mode 100644 unix/as.sunos/aclrr.c create mode 100644 unix/as.sunos/aclrs.c create mode 100644 unix/as.sunos/amovc.c create mode 100644 unix/as.sunos/amovd.c create mode 100644 unix/as.sunos/amovi.c create mode 100644 unix/as.sunos/amovl.c create mode 100644 unix/as.sunos/amovr.c create mode 100644 unix/as.sunos/amovs.c create mode 100644 unix/as.sunos/bytmov.c create mode 100644 unix/as.sunos/ieee.gx create mode 100644 unix/as.sunos/ieeed.x create mode 100644 unix/as.sunos/ieeer.x create mode 100644 unix/as.sunos/zsvjmp.s create mode 100644 unix/as.sunos/zsvjmp_p.s create mode 100644 unix/as.sunos/zz.c create mode 100644 unix/as.sunos/zz.s create mode 100644 unix/as.sunos/zzdebug.c create mode 100644 unix/as.sunos/zzz.c create mode 100644 unix/as.vax/README create mode 100644 unix/as.vax/aaddks.s create mode 100644 unix/as.vax/aadds.s create mode 100644 unix/as.vax/aclr.s create mode 100644 unix/as.vax/aluir.s create mode 100644 unix/as.vax/aluis.s create mode 100644 unix/as.vax/amapr.s create mode 100644 unix/as.vax/amaps.s create mode 100644 unix/as.vax/amov.s create mode 100644 unix/as.vax/awsur.s create mode 100644 unix/as.vax/awsus.s create mode 100644 unix/as.vax/bitfields.s create mode 100644 unix/as.vax/bytmov.s create mode 100644 unix/as.vax/cyboow.s create mode 100644 unix/as.vax/ieeed.s create mode 100644 unix/as.vax/ieeer.s create mode 100644 unix/as.vax/ishift.s create mode 100644 unix/as.vax/zsvjmp.s create mode 100644 unix/as.vax/zsvjmp.s.ORIG create mode 120000 unix/bin create mode 100644 unix/bin.cygwin/arch_includes/fio.h create mode 100644 unix/bin.cygwin/arch_includes/pllseg.h create mode 100644 unix/bin.cygwin/arch_includes/plrseg.h create mode 100755 unix/bin.cygwin/f2c.e.exe create mode 100644 unix/bin.cygwin/f2c.h create mode 100644 unix/bin.cygwin/fio.h create mode 100644 unix/bin.cygwin/libf2c.a create mode 100644 unix/bin.cygwin/pllseg.h create mode 100644 unix/bin.cygwin/plrseg.h create mode 100644 unix/bin.freebsd/README create mode 100644 unix/bin.freebsd/f2c.1.gz create mode 100755 unix/bin.freebsd/f2c.e create mode 100644 unix/bin.freebsd/f2c.h create mode 100644 unix/bin.freebsd/libf2c.a create mode 100755 unix/bin.linux/alloc.e create mode 100644 unix/bin.linux/f2c.1 create mode 100644 unix/bin.linux/f2c.1.gz create mode 100755 unix/bin.linux/f2c.e create mode 100644 unix/bin.linux/f2c.h create mode 100755 unix/bin.linux/generic.e create mode 120000 unix/bin.linux/iraf.h create mode 100644 unix/bin.linux/libboot.a create mode 100644 unix/bin.linux/libf2c.a create mode 100644 unix/bin.linux/libos.a create mode 120000 unix/bin.linux/mach.h create mode 100755 unix/bin.linux/mkpkg.e create mode 100755 unix/bin.linux/rmbin.e create mode 100755 unix/bin.linux/rmfiles.e create mode 100755 unix/bin.linux/rpp.e create mode 100755 unix/bin.linux/rtar.e create mode 100755 unix/bin.linux/sgi2gif.e create mode 100755 unix/bin.linux/sgi2svg.e create mode 100755 unix/bin.linux/sgi2uapl.e create mode 100755 unix/bin.linux/sgi2ueps.e create mode 100755 unix/bin.linux/sgi2uhpgl.e create mode 100755 unix/bin.linux/sgi2uhplj.e create mode 100755 unix/bin.linux/sgi2uimp.e create mode 100755 unix/bin.linux/sgi2uptx.e create mode 100755 unix/bin.linux/sgi2uqms.e create mode 100755 unix/bin.linux/sgi2xbm.e create mode 100755 unix/bin.linux/sgidispatch.e create mode 100755 unix/bin.linux/wtar.e create mode 100755 unix/bin.linux/xc.e create mode 100755 unix/bin.linux/xpp.e create mode 100755 unix/bin.linux/xyacc.e create mode 100755 unix/bin.linux64/alloc.e create mode 100644 unix/bin.linux64/f2c.1 create mode 100644 unix/bin.linux64/f2c.1.gz create mode 100755 unix/bin.linux64/f2c.e create mode 100644 unix/bin.linux64/f2c.h create mode 100755 unix/bin.linux64/generic.e create mode 120000 unix/bin.linux64/iraf.h create mode 100644 unix/bin.linux64/libboot.a create mode 100644 unix/bin.linux64/libf2c.a create mode 100644 unix/bin.linux64/libos.a create mode 120000 unix/bin.linux64/mach.h create mode 100755 unix/bin.linux64/mkpkg.e create mode 100755 unix/bin.linux64/rmbin.e create mode 100755 unix/bin.linux64/rmfiles.e create mode 100755 unix/bin.linux64/rpp.e create mode 100755 unix/bin.linux64/rtar.e create mode 100755 unix/bin.linux64/sgi2gif.e create mode 100755 unix/bin.linux64/sgi2svg.e create mode 100755 unix/bin.linux64/sgi2uapl.e create mode 100755 unix/bin.linux64/sgi2ueps.e create mode 100755 unix/bin.linux64/sgi2uhpgl.e create mode 100755 unix/bin.linux64/sgi2uhplj.e create mode 100755 unix/bin.linux64/sgi2uimp.e create mode 100755 unix/bin.linux64/sgi2uptx.e create mode 100755 unix/bin.linux64/sgi2uqms.e create mode 100755 unix/bin.linux64/sgi2xbm.e create mode 100755 unix/bin.linux64/sgidispatch.e create mode 100755 unix/bin.linux64/wtar.e create mode 100755 unix/bin.linux64/xc.e create mode 100755 unix/bin.linux64/xpp.e create mode 100755 unix/bin.linux64/xyacc.e create mode 100755 unix/bin.macintel/alloc.e create mode 100644 unix/bin.macintel/f2c.1 create mode 100755 unix/bin.macintel/f2c.e create mode 100644 unix/bin.macintel/f2c.h create mode 100755 unix/bin.macintel/generic.e create mode 120000 unix/bin.macintel/iraf.h create mode 100644 unix/bin.macintel/libboot.a create mode 100644 unix/bin.macintel/libf2c.a create mode 100644 unix/bin.macintel/libos.a create mode 120000 unix/bin.macintel/mach.h create mode 100755 unix/bin.macintel/mkpkg.e create mode 100755 unix/bin.macintel/rmbin.e create mode 100755 unix/bin.macintel/rmfiles.e create mode 100755 unix/bin.macintel/rpp.e create mode 100755 unix/bin.macintel/rtar.e create mode 100755 unix/bin.macintel/sgi2gif.e create mode 100755 unix/bin.macintel/sgi2svg.e create mode 100755 unix/bin.macintel/sgi2uapl.e create mode 100755 unix/bin.macintel/sgi2ueps.e create mode 100755 unix/bin.macintel/sgi2uhpgl.e create mode 100755 unix/bin.macintel/sgi2uhplj.e create mode 100755 unix/bin.macintel/sgi2uimp.e create mode 100755 unix/bin.macintel/sgi2uptx.e create mode 100755 unix/bin.macintel/sgi2uqms.e create mode 100755 unix/bin.macintel/sgi2xbm.e create mode 100755 unix/bin.macintel/sgidispatch.e create mode 100755 unix/bin.macintel/wtar.e create mode 100755 unix/bin.macintel/xc.e create mode 100755 unix/bin.macintel/xpp.e create mode 100755 unix/bin.macintel/xyacc.e create mode 100755 unix/bin.macosx/alloc.e create mode 100644 unix/bin.macosx/f2c.1.gz create mode 100755 unix/bin.macosx/f2c.e create mode 100644 unix/bin.macosx/f2c.h create mode 100755 unix/bin.macosx/generic.e create mode 120000 unix/bin.macosx/iraf.h create mode 100644 unix/bin.macosx/libboot.a create mode 100644 unix/bin.macosx/libf2c.a create mode 100644 unix/bin.macosx/libos.a create mode 120000 unix/bin.macosx/mach.h create mode 100755 unix/bin.macosx/mkpkg.e create mode 100755 unix/bin.macosx/rmbin.e create mode 100755 unix/bin.macosx/rmfiles.e create mode 100755 unix/bin.macosx/rpp.e create mode 100755 unix/bin.macosx/rtar.e create mode 100755 unix/bin.macosx/sgi2gif.e create mode 100755 unix/bin.macosx/sgi2svg.e create mode 100755 unix/bin.macosx/sgi2uapl.e create mode 100755 unix/bin.macosx/sgi2ueps.e create mode 100755 unix/bin.macosx/sgi2uhpgl.e create mode 100755 unix/bin.macosx/sgi2uhplj.e create mode 100755 unix/bin.macosx/sgi2uimp.e create mode 100755 unix/bin.macosx/sgi2uptx.e create mode 100755 unix/bin.macosx/sgi2uqms.e create mode 100755 unix/bin.macosx/sgi2xbm.e create mode 100755 unix/bin.macosx/sgidispatch.e create mode 100755 unix/bin.macosx/wtar.e create mode 100755 unix/bin.macosx/xc.e create mode 100755 unix/bin.macosx/xpp.e create mode 100755 unix/bin.macosx/xyacc.e create mode 120000 unix/bin.redhat create mode 100644 unix/bin.sunos/README create mode 100644 unix/bin.sunos/f2c.1.gz create mode 100644 unix/bin.sunos/f2c.h create mode 100644 unix/boot/README create mode 100644 unix/boot/bootProto.h create mode 100644 unix/boot/bootlib/README create mode 100644 unix/boot/bootlib/_bytmov.c create mode 100644 unix/boot/bootlib/bootlib.h create mode 100644 unix/boot/bootlib/envinit.c create mode 100644 unix/boot/bootlib/index.c create mode 100644 unix/boot/bootlib/kproto32.h create mode 100644 unix/boot/bootlib/kproto64.h create mode 100644 unix/boot/bootlib/mkpkg create mode 100644 unix/boot/bootlib/mkpkg.sh create mode 100644 unix/boot/bootlib/osaccess.c create mode 100644 unix/boot/bootlib/osamovb.c create mode 100644 unix/boot/bootlib/oschdir.c create mode 100644 unix/boot/bootlib/osclose.c create mode 100644 unix/boot/bootlib/oscmd.c create mode 100644 unix/boot/bootlib/oscreatedir.c create mode 100644 unix/boot/bootlib/oscrfile.c create mode 100644 unix/boot/bootlib/osdelete.c create mode 100644 unix/boot/bootlib/osdir.c create mode 100644 unix/boot/bootlib/osfcopy.c create mode 100644 unix/boot/bootlib/osfdate.c create mode 100644 unix/boot/bootlib/osfiletype.c create mode 100644 unix/boot/bootlib/osfn2vfn.c create mode 100644 unix/boot/bootlib/osfpathname.c create mode 100644 unix/boot/bootlib/osgetenv.c create mode 100644 unix/boot/bootlib/osgetowner.c create mode 100644 unix/boot/bootlib/osopen.c create mode 100644 unix/boot/bootlib/osproto.h create mode 100644 unix/boot/bootlib/osputenv.c create mode 100644 unix/boot/bootlib/osread.c create mode 100644 unix/boot/bootlib/ossetfmode.c create mode 100644 unix/boot/bootlib/ossetowner.c create mode 100644 unix/boot/bootlib/ossettime.c create mode 100644 unix/boot/bootlib/osstrpak.c create mode 100644 unix/boot/bootlib/osstrupk.c create mode 100644 unix/boot/bootlib/ossubdir.c create mode 100644 unix/boot/bootlib/ossymlink.c create mode 100644 unix/boot/bootlib/ossysfile.c create mode 100644 unix/boot/bootlib/ostime.c create mode 100644 unix/boot/bootlib/oswrite.c create mode 100644 unix/boot/bootlib/rindex.c create mode 100644 unix/boot/bootlib/tape.c create mode 100644 unix/boot/bootlib/vfn2osfn.c create mode 100644 unix/boot/generic.new/README create mode 100644 unix/boot/generic.new/chario.c create mode 100644 unix/boot/generic.new/chario.o create mode 100644 unix/boot/generic.new/generic.c create mode 100755 unix/boot/generic.new/generic.e create mode 100644 unix/boot/generic.new/generic.hlp create mode 100644 unix/boot/generic.new/generic.o create mode 100644 unix/boot/generic.new/lex.sed create mode 100644 unix/boot/generic.new/lexyy.c create mode 100644 unix/boot/generic.new/lexyy.o create mode 100644 unix/boot/generic.new/mkpkg.sh create mode 100644 unix/boot/generic.new/tok.l create mode 100644 unix/boot/generic.new/yywrap.c create mode 100644 unix/boot/generic.new/yywrap.o create mode 100644 unix/boot/generic.new/z create mode 100644 unix/boot/generic/README create mode 100644 unix/boot/generic/chario.c create mode 100644 unix/boot/generic/generic.c create mode 100644 unix/boot/generic/generic.hlp create mode 100644 unix/boot/generic/lex.sed create mode 100644 unix/boot/generic/lexyy.c create mode 100644 unix/boot/generic/mkpkg.sh create mode 100644 unix/boot/generic/tok.l create mode 100644 unix/boot/generic/yywrap.c create mode 100644 unix/boot/generic/z create mode 100644 unix/boot/mkpkg.sh create mode 100644 unix/boot/mkpkg/README create mode 100644 unix/boot/mkpkg/char.c create mode 100644 unix/boot/mkpkg/extern.h create mode 100644 unix/boot/mkpkg/fdcache.c create mode 100644 unix/boot/mkpkg/fncache.c create mode 100644 unix/boot/mkpkg/host.c create mode 100644 unix/boot/mkpkg/main.c create mode 100644 unix/boot/mkpkg/mkpkg create mode 100644 unix/boot/mkpkg/mkpkg.h create mode 100644 unix/boot/mkpkg/mkpkg.hlp create mode 100644 unix/boot/mkpkg/mkpkg.sh create mode 100644 unix/boot/mkpkg/pkg.c create mode 100644 unix/boot/mkpkg/scanlib.c create mode 100644 unix/boot/mkpkg/sflist.c create mode 100644 unix/boot/mkpkg/tok.c create mode 100644 unix/boot/rmbin/README create mode 100644 unix/boot/rmbin/mkpkg.sh create mode 100644 unix/boot/rmbin/rmbin.c create mode 100644 unix/boot/rmbin/rmbin.hlp create mode 100644 unix/boot/rmfiles/README create mode 100644 unix/boot/rmfiles/mkpkg.sh create mode 100644 unix/boot/rmfiles/rmfiles.c create mode 100644 unix/boot/rmfiles/rmfiles.hlp create mode 100644 unix/boot/rtar/README create mode 100644 unix/boot/rtar/mkpkg.sh create mode 100644 unix/boot/rtar/rtar.c create mode 100644 unix/boot/rtar/rtar.hlp create mode 100644 unix/boot/rtar/rtar.ms create mode 100644 unix/boot/spp/README create mode 100644 unix/boot/spp/mkpkg.sh create mode 100644 unix/boot/spp/mkxc.sh create mode 100644 unix/boot/spp/mkxc_dbg.sh create mode 100644 unix/boot/spp/rpp/README create mode 100644 unix/boot/spp/rpp/mkpkg.sh create mode 100644 unix/boot/spp/rpp/ratlibc/README create mode 100644 unix/boot/spp/rpp/ratlibc/cant.c create mode 100644 unix/boot/spp/rpp/ratlibc/close.c create mode 100644 unix/boot/spp/rpp/ratlibc/endst.c create mode 100644 unix/boot/spp/rpp/ratlibc/getarg.c create mode 100644 unix/boot/spp/rpp/ratlibc/getlin.c create mode 100644 unix/boot/spp/rpp/ratlibc/initst.c create mode 100644 unix/boot/spp/rpp/ratlibc/mkpkg.sh create mode 100644 unix/boot/spp/rpp/ratlibc/open.c create mode 100644 unix/boot/spp/rpp/ratlibc/putch.c create mode 100644 unix/boot/spp/rpp/ratlibc/putlin.c create mode 100644 unix/boot/spp/rpp/ratlibc/r4tocstr.c create mode 100644 unix/boot/spp/rpp/ratlibc/ratdef.h create mode 100644 unix/boot/spp/rpp/ratlibc/remark.c create mode 100644 unix/boot/spp/rpp/ratlibf/README create mode 100644 unix/boot/spp/rpp/ratlibf/addset.f create mode 100644 unix/boot/spp/rpp/ratlibf/addstr.f create mode 100644 unix/boot/spp/rpp/ratlibf/amatch.f create mode 100644 unix/boot/spp/rpp/ratlibf/catsub.f create mode 100644 unix/boot/spp/rpp/ratlibf/clower.f create mode 100644 unix/boot/spp/rpp/ratlibf/concat.f create mode 100644 unix/boot/spp/rpp/ratlibf/ctoc.f create mode 100644 unix/boot/spp/rpp/ratlibf/ctoi.f create mode 100644 unix/boot/spp/rpp/ratlibf/ctomn.f create mode 100644 unix/boot/spp/rpp/ratlibf/cupper.f create mode 100644 unix/boot/spp/rpp/ratlibf/delete.f create mode 100644 unix/boot/spp/rpp/ratlibf/docant.f create mode 100644 unix/boot/spp/rpp/ratlibf/dodash.f create mode 100644 unix/boot/spp/rpp/ratlibf/dsdbiu.f create mode 100644 unix/boot/spp/rpp/ratlibf/dsdump.f create mode 100644 unix/boot/spp/rpp/ratlibf/dsfree.f create mode 100644 unix/boot/spp/rpp/ratlibf/dsget.f create mode 100644 unix/boot/spp/rpp/ratlibf/dsinit.f create mode 100644 unix/boot/spp/rpp/ratlibf/enter.f create mode 100644 unix/boot/spp/rpp/ratlibf/equal.f create mode 100644 unix/boot/spp/rpp/ratlibf/error.f create mode 100644 unix/boot/spp/rpp/ratlibf/errsub.f create mode 100644 unix/boot/spp/rpp/ratlibf/esc.f create mode 100644 unix/boot/spp/rpp/ratlibf/fcopy.f create mode 100644 unix/boot/spp/rpp/ratlibf/filset.f create mode 100644 unix/boot/spp/rpp/ratlibf/fmtdat.f create mode 100644 unix/boot/spp/rpp/ratlibf/fold.f create mode 100644 unix/boot/spp/rpp/ratlibf/gctoi.f create mode 100644 unix/boot/spp/rpp/ratlibf/getc.f create mode 100644 unix/boot/spp/rpp/ratlibf/getccl.f create mode 100644 unix/boot/spp/rpp/ratlibf/getpat.f create mode 100644 unix/boot/spp/rpp/ratlibf/getwrd.f create mode 100644 unix/boot/spp/rpp/ratlibf/gfnarg.f create mode 100644 unix/boot/spp/rpp/ratlibf/index.f create mode 100644 unix/boot/spp/rpp/ratlibf/insub.f create mode 100644 unix/boot/spp/rpp/ratlibf/itoc.f create mode 100644 unix/boot/spp/rpp/ratlibf/length.f create mode 100644 unix/boot/spp/rpp/ratlibf/locate.f create mode 100644 unix/boot/spp/rpp/ratlibf/lookup.f create mode 100644 unix/boot/spp/rpp/ratlibf/lower.f create mode 100644 unix/boot/spp/rpp/ratlibf/makpat.f create mode 100644 unix/boot/spp/rpp/ratlibf/maksub.f create mode 100644 unix/boot/spp/rpp/ratlibf/match.f create mode 100644 unix/boot/spp/rpp/ratlibf/mkpkg.sh create mode 100644 unix/boot/spp/rpp/ratlibf/mktabl.f create mode 100644 unix/boot/spp/rpp/ratlibf/mntoc.f create mode 100644 unix/boot/spp/rpp/ratlibf/omatch.f create mode 100644 unix/boot/spp/rpp/ratlibf/outsub.f create mode 100644 unix/boot/spp/rpp/ratlibf/patsiz.f create mode 100644 unix/boot/spp/rpp/ratlibf/prompt.f create mode 100644 unix/boot/spp/rpp/ratlibf/putc.f create mode 100644 unix/boot/spp/rpp/ratlibf/putdec.f create mode 100644 unix/boot/spp/rpp/ratlibf/putint.f create mode 100644 unix/boot/spp/rpp/ratlibf/putstr.f create mode 100644 unix/boot/spp/rpp/ratlibf/query.f create mode 100644 unix/boot/spp/rpp/ratlibf/rmtabl.f create mode 100644 unix/boot/spp/rpp/ratlibf/scopy.f create mode 100644 unix/boot/spp/rpp/ratlibf/sctabl.f create mode 100644 unix/boot/spp/rpp/ratlibf/sdrop.f create mode 100644 unix/boot/spp/rpp/ratlibf/skipbl.f create mode 100644 unix/boot/spp/rpp/ratlibf/slstr.f create mode 100644 unix/boot/spp/rpp/ratlibf/stake.f create mode 100644 unix/boot/spp/rpp/ratlibf/stclos.f create mode 100644 unix/boot/spp/rpp/ratlibf/stcopy.f create mode 100644 unix/boot/spp/rpp/ratlibf/stlu.f create mode 100644 unix/boot/spp/rpp/ratlibf/strcmp.f create mode 100644 unix/boot/spp/rpp/ratlibf/strim.f create mode 100644 unix/boot/spp/rpp/ratlibf/termin.f create mode 100644 unix/boot/spp/rpp/ratlibf/trmout.f create mode 100644 unix/boot/spp/rpp/ratlibf/type.f create mode 100644 unix/boot/spp/rpp/ratlibf/upper.f create mode 100644 unix/boot/spp/rpp/ratlibf/wkday.f create mode 100644 unix/boot/spp/rpp/ratlibr/Makefile create mode 100644 unix/boot/spp/rpp/ratlibr/addset.r create mode 100644 unix/boot/spp/rpp/ratlibr/addstr.r create mode 100644 unix/boot/spp/rpp/ratlibr/amatch.r create mode 100644 unix/boot/spp/rpp/ratlibr/catsub.r create mode 100644 unix/boot/spp/rpp/ratlibr/clower.r create mode 100644 unix/boot/spp/rpp/ratlibr/concat.r create mode 100644 unix/boot/spp/rpp/ratlibr/ctoc.r create mode 100644 unix/boot/spp/rpp/ratlibr/ctoi.r create mode 100644 unix/boot/spp/rpp/ratlibr/ctomn.r create mode 100644 unix/boot/spp/rpp/ratlibr/cupper.r create mode 100644 unix/boot/spp/rpp/ratlibr/defs create mode 100644 unix/boot/spp/rpp/ratlibr/delete.r create mode 100644 unix/boot/spp/rpp/ratlibr/docant.r create mode 100644 unix/boot/spp/rpp/ratlibr/dodash.r create mode 100644 unix/boot/spp/rpp/ratlibr/dsdbiu.r create mode 100644 unix/boot/spp/rpp/ratlibr/dsdump.r create mode 100644 unix/boot/spp/rpp/ratlibr/dsfree.r create mode 100644 unix/boot/spp/rpp/ratlibr/dsget.r create mode 100644 unix/boot/spp/rpp/ratlibr/dsinit.r create mode 100644 unix/boot/spp/rpp/ratlibr/enter.r create mode 100644 unix/boot/spp/rpp/ratlibr/equal.r create mode 100644 unix/boot/spp/rpp/ratlibr/error.r create mode 100644 unix/boot/spp/rpp/ratlibr/errsub.r create mode 100644 unix/boot/spp/rpp/ratlibr/esc.r create mode 100644 unix/boot/spp/rpp/ratlibr/fcopy.r create mode 100644 unix/boot/spp/rpp/ratlibr/filset.r create mode 100644 unix/boot/spp/rpp/ratlibr/fmtdat.r create mode 100644 unix/boot/spp/rpp/ratlibr/fold.r create mode 100644 unix/boot/spp/rpp/ratlibr/fort create mode 100644 unix/boot/spp/rpp/ratlibr/gctoi.r create mode 100644 unix/boot/spp/rpp/ratlibr/getc.r create mode 100644 unix/boot/spp/rpp/ratlibr/getccl.r create mode 100644 unix/boot/spp/rpp/ratlibr/getpat.r create mode 100644 unix/boot/spp/rpp/ratlibr/getwrd.r create mode 100644 unix/boot/spp/rpp/ratlibr/gfnarg.r create mode 100644 unix/boot/spp/rpp/ratlibr/index.r create mode 100644 unix/boot/spp/rpp/ratlibr/insub.r create mode 100644 unix/boot/spp/rpp/ratlibr/itoc.r create mode 100644 unix/boot/spp/rpp/ratlibr/length.r create mode 100644 unix/boot/spp/rpp/ratlibr/locate.r create mode 100644 unix/boot/spp/rpp/ratlibr/lookup.r create mode 100644 unix/boot/spp/rpp/ratlibr/lower.r create mode 100644 unix/boot/spp/rpp/ratlibr/makpat.r create mode 100644 unix/boot/spp/rpp/ratlibr/maksub.r create mode 100644 unix/boot/spp/rpp/ratlibr/match.r create mode 100644 unix/boot/spp/rpp/ratlibr/mktabl.r create mode 100644 unix/boot/spp/rpp/ratlibr/mntoc.r create mode 100644 unix/boot/spp/rpp/ratlibr/omatch.r create mode 100644 unix/boot/spp/rpp/ratlibr/outsub.r create mode 100644 unix/boot/spp/rpp/ratlibr/patsiz.r create mode 100644 unix/boot/spp/rpp/ratlibr/prompt.r create mode 100644 unix/boot/spp/rpp/ratlibr/putc.r create mode 100644 unix/boot/spp/rpp/ratlibr/putdec.r create mode 100644 unix/boot/spp/rpp/ratlibr/putint.r create mode 100644 unix/boot/spp/rpp/ratlibr/putstr.r create mode 100644 unix/boot/spp/rpp/ratlibr/query.r create mode 100644 unix/boot/spp/rpp/ratlibr/rmtabl.r create mode 100644 unix/boot/spp/rpp/ratlibr/scopy.r create mode 100644 unix/boot/spp/rpp/ratlibr/sctabl.r create mode 100644 unix/boot/spp/rpp/ratlibr/sdrop.r create mode 100644 unix/boot/spp/rpp/ratlibr/skipbl.r create mode 100644 unix/boot/spp/rpp/ratlibr/slstr.r create mode 100644 unix/boot/spp/rpp/ratlibr/stake.r create mode 100644 unix/boot/spp/rpp/ratlibr/stclos.r create mode 100644 unix/boot/spp/rpp/ratlibr/stcopy.r create mode 100644 unix/boot/spp/rpp/ratlibr/stlu.r create mode 100644 unix/boot/spp/rpp/ratlibr/strcmp.r create mode 100644 unix/boot/spp/rpp/ratlibr/strim.r create mode 100644 unix/boot/spp/rpp/ratlibr/termin.r create mode 100644 unix/boot/spp/rpp/ratlibr/trmout.r create mode 100644 unix/boot/spp/rpp/ratlibr/type.r create mode 100644 unix/boot/spp/rpp/ratlibr/upper.r create mode 100644 unix/boot/spp/rpp/ratlibr/wkday.r create mode 100644 unix/boot/spp/rpp/rpp.c create mode 100644 unix/boot/spp/rpp/rppfor/README create mode 100644 unix/boot/spp/rpp/rppfor/addchr.f create mode 100644 unix/boot/spp/rpp/rppfor/allblk.f create mode 100644 unix/boot/spp/rpp/rppfor/alldig.f create mode 100644 unix/boot/spp/rpp/rppfor/baderr.f create mode 100644 unix/boot/spp/rpp/rppfor/balpar.f create mode 100644 unix/boot/spp/rpp/rppfor/beginc.f create mode 100644 unix/boot/spp/rpp/rppfor/brknxt.f create mode 100644 unix/boot/spp/rpp/rppfor/cascod.f create mode 100644 unix/boot/spp/rpp/rppfor/caslab.f create mode 100644 unix/boot/spp/rpp/rppfor/declco.f create mode 100644 unix/boot/spp/rpp/rppfor/deftok.f create mode 100644 unix/boot/spp/rpp/rppfor/doarth.f create mode 100644 unix/boot/spp/rpp/rppfor/docode.f create mode 100644 unix/boot/spp/rpp/rppfor/doif.f create mode 100644 unix/boot/spp/rpp/rppfor/doincr.f create mode 100644 unix/boot/spp/rpp/rppfor/domac.f create mode 100644 unix/boot/spp/rpp/rppfor/dostat.f create mode 100644 unix/boot/spp/rpp/rppfor/dosub.f create mode 100644 unix/boot/spp/rpp/rppfor/eatup.f create mode 100644 unix/boot/spp/rpp/rppfor/elseif.f create mode 100644 unix/boot/spp/rpp/rppfor/endcod.f create mode 100644 unix/boot/spp/rpp/rppfor/entdef.f create mode 100644 unix/boot/spp/rpp/rppfor/entdkw.f create mode 100644 unix/boot/spp/rpp/rppfor/entfkw.f create mode 100644 unix/boot/spp/rpp/rppfor/entrkw.f create mode 100644 unix/boot/spp/rpp/rppfor/entxkw.f create mode 100644 unix/boot/spp/rpp/rppfor/errchk.f create mode 100644 unix/boot/spp/rpp/rppfor/errgo.f create mode 100644 unix/boot/spp/rpp/rppfor/errorc.f create mode 100644 unix/boot/spp/rpp/rppfor/evalr.f create mode 100644 unix/boot/spp/rpp/rppfor/finit.f create mode 100644 unix/boot/spp/rpp/rppfor/forcod.f create mode 100644 unix/boot/spp/rpp/rppfor/fors.f create mode 100644 unix/boot/spp/rpp/rppfor/getdef.f create mode 100644 unix/boot/spp/rpp/rppfor/gettok.f create mode 100644 unix/boot/spp/rpp/rppfor/gnbtok.f create mode 100644 unix/boot/spp/rpp/rppfor/gocode.f create mode 100644 unix/boot/spp/rpp/rppfor/gtok.f create mode 100644 unix/boot/spp/rpp/rppfor/ifcode.f create mode 100644 unix/boot/spp/rpp/rppfor/iferrc.f create mode 100644 unix/boot/spp/rpp/rppfor/ifgo.f create mode 100644 unix/boot/spp/rpp/rppfor/ifparm.f create mode 100644 unix/boot/spp/rpp/rppfor/indent.f create mode 100644 unix/boot/spp/rpp/rppfor/initkw.f create mode 100644 unix/boot/spp/rpp/rppfor/labelc.f create mode 100644 unix/boot/spp/rpp/rppfor/labgen.f create mode 100644 unix/boot/spp/rpp/rppfor/lex.f create mode 100644 unix/boot/spp/rpp/rppfor/litral.f create mode 100644 unix/boot/spp/rpp/rppfor/lndict.f create mode 100644 unix/boot/spp/rpp/rppfor/ludef.f create mode 100644 unix/boot/spp/rpp/rppfor/mapid.f create mode 100644 unix/boot/spp/rpp/rppfor/mkpkg.sh create mode 100644 unix/boot/spp/rpp/rppfor/ngetch.f create mode 100644 unix/boot/spp/rpp/rppfor/ogotos.f create mode 100644 unix/boot/spp/rpp/rppfor/otherc.f create mode 100644 unix/boot/spp/rpp/rppfor/outch.f create mode 100644 unix/boot/spp/rpp/rppfor/outcon.f create mode 100644 unix/boot/spp/rpp/rppfor/outdon.f create mode 100644 unix/boot/spp/rpp/rppfor/outdwe.f create mode 100644 unix/boot/spp/rpp/rppfor/outgo.f create mode 100644 unix/boot/spp/rpp/rppfor/outnum.f create mode 100644 unix/boot/spp/rpp/rppfor/outstr.f create mode 100644 unix/boot/spp/rpp/rppfor/outtab.f create mode 100644 unix/boot/spp/rpp/rppfor/parse.f create mode 100644 unix/boot/spp/rpp/rppfor/pbnum.f create mode 100644 unix/boot/spp/rpp/rppfor/pbstr.f create mode 100644 unix/boot/spp/rpp/rppfor/poicod.f create mode 100644 unix/boot/spp/rpp/rppfor/push.f create mode 100644 unix/boot/spp/rpp/rppfor/putbak.f create mode 100644 unix/boot/spp/rpp/rppfor/putchr.f create mode 100644 unix/boot/spp/rpp/rppfor/puttok.f create mode 100644 unix/boot/spp/rpp/rppfor/ratfor.f create mode 100644 unix/boot/spp/rpp/rppfor/relate.f create mode 100644 unix/boot/spp/rpp/rppfor/repcod.f create mode 100644 unix/boot/spp/rpp/rppfor/retcod.f create mode 100644 unix/boot/spp/rpp/rppfor/sdupl.f create mode 100644 unix/boot/spp/rpp/rppfor/skpblk.f create mode 100644 unix/boot/spp/rpp/rppfor/squash.f create mode 100644 unix/boot/spp/rpp/rppfor/strdcl.f create mode 100644 unix/boot/spp/rpp/rppfor/swcode.f create mode 100644 unix/boot/spp/rpp/rppfor/swend.f create mode 100644 unix/boot/spp/rpp/rppfor/swvar.f create mode 100644 unix/boot/spp/rpp/rppfor/synerr.f create mode 100644 unix/boot/spp/rpp/rppfor/thenco.f create mode 100644 unix/boot/spp/rpp/rppfor/ulstal.f create mode 100644 unix/boot/spp/rpp/rppfor/uniqid.f create mode 100644 unix/boot/spp/rpp/rppfor/unstak.f create mode 100644 unix/boot/spp/rpp/rppfor/untils.f create mode 100644 unix/boot/spp/rpp/rppfor/whilec.f create mode 100644 unix/boot/spp/rpp/rppfor/whiles.f create mode 100644 unix/boot/spp/rpp/rpprat/Makefile create mode 100644 unix/boot/spp/rpp/rpprat/addchr.r create mode 100644 unix/boot/spp/rpp/rpprat/allblk.r create mode 100644 unix/boot/spp/rpp/rpprat/alldig.r create mode 100644 unix/boot/spp/rpp/rpprat/baderr.r create mode 100644 unix/boot/spp/rpp/rpprat/balpar.r create mode 100644 unix/boot/spp/rpp/rpprat/beginc.r create mode 100644 unix/boot/spp/rpp/rpprat/brknxt.r create mode 100644 unix/boot/spp/rpp/rpprat/cascod.r create mode 100644 unix/boot/spp/rpp/rpprat/caslab.r create mode 100644 unix/boot/spp/rpp/rpprat/common create mode 100644 unix/boot/spp/rpp/rpprat/declco.r create mode 100644 unix/boot/spp/rpp/rpprat/defs create mode 100644 unix/boot/spp/rpp/rpprat/deftok.r create mode 100644 unix/boot/spp/rpp/rpprat/doarth.r create mode 100644 unix/boot/spp/rpp/rpprat/docode.r create mode 100644 unix/boot/spp/rpp/rpprat/doif.r create mode 100644 unix/boot/spp/rpp/rpprat/doincr.r create mode 100644 unix/boot/spp/rpp/rpprat/domac.r create mode 100644 unix/boot/spp/rpp/rpprat/dostat.r create mode 100644 unix/boot/spp/rpp/rpprat/dosub.r create mode 100644 unix/boot/spp/rpp/rpprat/eatup.r create mode 100644 unix/boot/spp/rpp/rpprat/elseif.r create mode 100644 unix/boot/spp/rpp/rpprat/endcod.r create mode 100644 unix/boot/spp/rpp/rpprat/entdef.r create mode 100644 unix/boot/spp/rpp/rpprat/entdkw.r create mode 100644 unix/boot/spp/rpp/rpprat/entfkw.r create mode 100644 unix/boot/spp/rpp/rpprat/entrkw.r create mode 100644 unix/boot/spp/rpp/rpprat/entxkw.r create mode 100644 unix/boot/spp/rpp/rpprat/errchk.r create mode 100644 unix/boot/spp/rpp/rpprat/errgo.r create mode 100644 unix/boot/spp/rpp/rpprat/errorc.r create mode 100644 unix/boot/spp/rpp/rpprat/evalr.r create mode 100644 unix/boot/spp/rpp/rpprat/finit.r create mode 100644 unix/boot/spp/rpp/rpprat/forcod.r create mode 100644 unix/boot/spp/rpp/rpprat/fors.r create mode 100644 unix/boot/spp/rpp/rpprat/fort create mode 100644 unix/boot/spp/rpp/rpprat/getdef.r create mode 100644 unix/boot/spp/rpp/rpprat/gettok.r create mode 100644 unix/boot/spp/rpp/rpprat/gnbtok.r create mode 100644 unix/boot/spp/rpp/rpprat/gocode.r create mode 100644 unix/boot/spp/rpp/rpprat/gtok.r create mode 100644 unix/boot/spp/rpp/rpprat/ifcode.r create mode 100644 unix/boot/spp/rpp/rpprat/iferrc.r create mode 100644 unix/boot/spp/rpp/rpprat/ifgo.r create mode 100644 unix/boot/spp/rpp/rpprat/ifparm.r create mode 100644 unix/boot/spp/rpp/rpprat/indent.r create mode 100644 unix/boot/spp/rpp/rpprat/initkw.r create mode 100644 unix/boot/spp/rpp/rpprat/labelc.r create mode 100644 unix/boot/spp/rpp/rpprat/labgen.r create mode 100644 unix/boot/spp/rpp/rpprat/lex.r create mode 100644 unix/boot/spp/rpp/rpprat/litral.r create mode 100644 unix/boot/spp/rpp/rpprat/lndict.r create mode 100644 unix/boot/spp/rpp/rpprat/ludef.r create mode 100644 unix/boot/spp/rpp/rpprat/mapid.r create mode 100644 unix/boot/spp/rpp/rpprat/ngetch.r create mode 100644 unix/boot/spp/rpp/rpprat/ogotos.r create mode 100644 unix/boot/spp/rpp/rpprat/otherc.r create mode 100644 unix/boot/spp/rpp/rpprat/outch.r create mode 100644 unix/boot/spp/rpp/rpprat/outcon.r create mode 100644 unix/boot/spp/rpp/rpprat/outdon.r create mode 100644 unix/boot/spp/rpp/rpprat/outdwe.r create mode 100644 unix/boot/spp/rpp/rpprat/outgo.r create mode 100644 unix/boot/spp/rpp/rpprat/outnum.r create mode 100644 unix/boot/spp/rpp/rpprat/outstr.r create mode 100644 unix/boot/spp/rpp/rpprat/outtab.r create mode 100644 unix/boot/spp/rpp/rpprat/parse.r create mode 100644 unix/boot/spp/rpp/rpprat/pbnum.r create mode 100644 unix/boot/spp/rpp/rpprat/pbstr.r create mode 100644 unix/boot/spp/rpp/rpprat/poicod.r create mode 100644 unix/boot/spp/rpp/rpprat/push.r create mode 100644 unix/boot/spp/rpp/rpprat/putbak.r create mode 100644 unix/boot/spp/rpp/rpprat/putchr.r create mode 100644 unix/boot/spp/rpp/rpprat/puttok.r create mode 100644 unix/boot/spp/rpp/rpprat/ratfor.r create mode 100644 unix/boot/spp/rpp/rpprat/relate.r create mode 100644 unix/boot/spp/rpp/rpprat/repcod.r create mode 100644 unix/boot/spp/rpp/rpprat/retcod.r create mode 100644 unix/boot/spp/rpp/rpprat/sdupl.r create mode 100644 unix/boot/spp/rpp/rpprat/skpblk.r create mode 100644 unix/boot/spp/rpp/rpprat/squash.r create mode 100644 unix/boot/spp/rpp/rpprat/strdcl.r create mode 100644 unix/boot/spp/rpp/rpprat/swcode.r create mode 100644 unix/boot/spp/rpp/rpprat/swend.r create mode 100644 unix/boot/spp/rpp/rpprat/swvar.r create mode 100644 unix/boot/spp/rpp/rpprat/synerr.r create mode 100644 unix/boot/spp/rpp/rpprat/thenco.r create mode 100644 unix/boot/spp/rpp/rpprat/ulstal.r create mode 100644 unix/boot/spp/rpp/rpprat/uniqid.r create mode 100644 unix/boot/spp/rpp/rpprat/unstak.r create mode 100644 unix/boot/spp/rpp/rpprat/untils.r create mode 100644 unix/boot/spp/rpp/rpprat/whilec.r create mode 100644 unix/boot/spp/rpp/rpprat/whiles.r create mode 100644 unix/boot/spp/rpp/test.r create mode 100644 unix/boot/spp/rpp/x create mode 100644 unix/boot/spp/test.x create mode 100644 unix/boot/spp/xc.c create mode 100644 unix/boot/spp/xc.hlp create mode 100644 unix/boot/spp/xpp.h create mode 100644 unix/boot/spp/xpp/README create mode 100644 unix/boot/spp/xpp/decl.c create mode 100644 unix/boot/spp/xpp/lex.sed create mode 100644 unix/boot/spp/xpp/lexyy.c create mode 100644 unix/boot/spp/xpp/mkpkg.sh create mode 100644 unix/boot/spp/xpp/xpp.h create mode 100644 unix/boot/spp/xpp/xpp.l create mode 100644 unix/boot/spp/xpp/xpp.l.orig create mode 100644 unix/boot/spp/xpp/xppProto.h create mode 100644 unix/boot/spp/xpp/xppcode.c create mode 100644 unix/boot/spp/xpp/xppcode.c.bak create mode 100644 unix/boot/spp/xpp/xppmain.c create mode 100644 unix/boot/spp/xpp/zztest.x create mode 100644 unix/boot/vmcached/README create mode 100644 unix/boot/vmcached/notes create mode 100644 unix/boot/vmcached/vmcache.c create mode 100644 unix/boot/vmcached/vmcache.h create mode 100644 unix/boot/vmcached/vmcached.c create mode 100644 unix/boot/wtar/README create mode 100644 unix/boot/wtar/mkpkg.sh create mode 100644 unix/boot/wtar/wtar.c create mode 100644 unix/boot/wtar/wtar.hlp create mode 100644 unix/boot/xyacc/Makefile create mode 100644 unix/boot/xyacc/README create mode 100644 unix/boot/xyacc/debug/dc.y create mode 100644 unix/boot/xyacc/debug/y.output create mode 100644 unix/boot/xyacc/debug/ytab.x create mode 100644 unix/boot/xyacc/dextern.h create mode 100644 unix/boot/xyacc/mkpkg.sh create mode 100644 unix/boot/xyacc/y1.c create mode 100644 unix/boot/xyacc/y2.c create mode 100644 unix/boot/xyacc/y3.c create mode 100644 unix/boot/xyacc/y4.c create mode 100644 unix/boot/xyacc/yaccpar.x create mode 100644 unix/f2c/README create mode 100644 unix/f2c/changes create mode 100644 unix/f2c/f2c.1 create mode 100644 unix/f2c/f2c.1t create mode 100644 unix/f2c/f2c.h create mode 100644 unix/f2c/f2c.pdf create mode 100644 unix/f2c/f2c.ps create mode 100644 unix/f2c/fc create mode 100644 unix/f2c/getopt.c create mode 100644 unix/f2c/index create mode 100644 unix/f2c/index.html create mode 100644 unix/f2c/libf2c/1 create mode 100644 unix/f2c/libf2c/Notice create mode 100644 unix/f2c/libf2c/README create mode 100644 unix/f2c/libf2c/abort_.c create mode 100644 unix/f2c/libf2c/arith.h create mode 100644 unix/f2c/libf2c/arithchk.c create mode 100644 unix/f2c/libf2c/backspac.c create mode 100644 unix/f2c/libf2c/c_abs.c create mode 100644 unix/f2c/libf2c/c_cos.c create mode 100644 unix/f2c/libf2c/c_div.c create mode 100644 unix/f2c/libf2c/c_exp.c create mode 100644 unix/f2c/libf2c/c_log.c create mode 100644 unix/f2c/libf2c/c_sin.c create mode 100644 unix/f2c/libf2c/c_sqrt.c create mode 100644 unix/f2c/libf2c/cabs.c create mode 100644 unix/f2c/libf2c/close.c create mode 100644 unix/f2c/libf2c/comptry.bat create mode 100644 unix/f2c/libf2c/ctype.c create mode 100644 unix/f2c/libf2c/ctype.h create mode 100644 unix/f2c/libf2c/d_abs.c create mode 100644 unix/f2c/libf2c/d_acos.c create mode 100644 unix/f2c/libf2c/d_asin.c create mode 100644 unix/f2c/libf2c/d_atan.c create mode 100644 unix/f2c/libf2c/d_atn2.c create mode 100644 unix/f2c/libf2c/d_cnjg.c create mode 100644 unix/f2c/libf2c/d_cos.c create mode 100644 unix/f2c/libf2c/d_cosh.c create mode 100644 unix/f2c/libf2c/d_dim.c create mode 100644 unix/f2c/libf2c/d_exp.c create mode 100644 unix/f2c/libf2c/d_imag.c create mode 100644 unix/f2c/libf2c/d_int.c create mode 100644 unix/f2c/libf2c/d_lg10.c create mode 100644 unix/f2c/libf2c/d_log.c create mode 100644 unix/f2c/libf2c/d_mod.c create mode 100644 unix/f2c/libf2c/d_nint.c create mode 100644 unix/f2c/libf2c/d_prod.c create mode 100644 unix/f2c/libf2c/d_sign.c create mode 100644 unix/f2c/libf2c/d_sin.c create mode 100644 unix/f2c/libf2c/d_sinh.c create mode 100644 unix/f2c/libf2c/d_sqrt.c create mode 100644 unix/f2c/libf2c/d_tan.c create mode 100644 unix/f2c/libf2c/d_tanh.c create mode 100644 unix/f2c/libf2c/derf_.c create mode 100644 unix/f2c/libf2c/derfc_.c create mode 100644 unix/f2c/libf2c/dfe.c create mode 100644 unix/f2c/libf2c/dolio.c create mode 100644 unix/f2c/libf2c/dtime_.c create mode 100644 unix/f2c/libf2c/due.c create mode 100644 unix/f2c/libf2c/ef1asc_.c create mode 100644 unix/f2c/libf2c/ef1cmc_.c create mode 100644 unix/f2c/libf2c/endfile.c create mode 100644 unix/f2c/libf2c/erf_.c create mode 100644 unix/f2c/libf2c/erfc_.c create mode 100644 unix/f2c/libf2c/err.c create mode 100644 unix/f2c/libf2c/etime_.c create mode 100644 unix/f2c/libf2c/exit_.c create mode 100644 unix/f2c/libf2c/f2c.h create mode 100644 unix/f2c/libf2c/f2c.h0 create mode 100644 unix/f2c/libf2c/f2ch.add create mode 100644 unix/f2c/libf2c/f77_aloc.c create mode 100644 unix/f2c/libf2c/f77vers.c create mode 100644 unix/f2c/libf2c/fio.h create mode 100644 unix/f2c/libf2c/fmt.c create mode 100644 unix/f2c/libf2c/fmt.h create mode 100644 unix/f2c/libf2c/fmtlib.c create mode 100644 unix/f2c/libf2c/fp.h create mode 100644 unix/f2c/libf2c/ftell64_.c create mode 100644 unix/f2c/libf2c/ftell_.c create mode 100644 unix/f2c/libf2c/getarg_.c create mode 100644 unix/f2c/libf2c/getenv_.c create mode 100644 unix/f2c/libf2c/h_abs.c create mode 100644 unix/f2c/libf2c/h_dim.c create mode 100644 unix/f2c/libf2c/h_dnnt.c create mode 100644 unix/f2c/libf2c/h_indx.c create mode 100644 unix/f2c/libf2c/h_len.c create mode 100644 unix/f2c/libf2c/h_mod.c create mode 100644 unix/f2c/libf2c/h_nint.c create mode 100644 unix/f2c/libf2c/h_sign.c create mode 100644 unix/f2c/libf2c/hl_ge.c create mode 100644 unix/f2c/libf2c/hl_gt.c create mode 100644 unix/f2c/libf2c/hl_le.c create mode 100644 unix/f2c/libf2c/hl_lt.c create mode 100644 unix/f2c/libf2c/i77vers.c create mode 100644 unix/f2c/libf2c/i_abs.c create mode 100644 unix/f2c/libf2c/i_dim.c create mode 100644 unix/f2c/libf2c/i_dnnt.c create mode 100644 unix/f2c/libf2c/i_indx.c create mode 100644 unix/f2c/libf2c/i_len.c create mode 100644 unix/f2c/libf2c/i_mod.c create mode 100644 unix/f2c/libf2c/i_nint.c create mode 100644 unix/f2c/libf2c/i_sign.c create mode 100644 unix/f2c/libf2c/iargc_.c create mode 100644 unix/f2c/libf2c/iio.c create mode 100644 unix/f2c/libf2c/ilnw.c create mode 100644 unix/f2c/libf2c/inquire.c create mode 100644 unix/f2c/libf2c/l_ge.c create mode 100644 unix/f2c/libf2c/l_gt.c create mode 100644 unix/f2c/libf2c/l_le.c create mode 100644 unix/f2c/libf2c/l_lt.c create mode 100644 unix/f2c/libf2c/lbitbits.c create mode 100644 unix/f2c/libf2c/lbitshft.c create mode 100644 unix/f2c/libf2c/libf2c.lbc create mode 100644 unix/f2c/libf2c/libf2c.sy create mode 100644 unix/f2c/libf2c/lio.h create mode 100644 unix/f2c/libf2c/lread.c create mode 100644 unix/f2c/libf2c/lwrite.c create mode 100644 unix/f2c/libf2c/main.c create mode 100644 unix/f2c/libf2c/makefile.sy create mode 100644 unix/f2c/libf2c/makefile.u create mode 100644 unix/f2c/libf2c/makefile.vc create mode 100644 unix/f2c/libf2c/makefile.wat create mode 100644 unix/f2c/libf2c/math.hvc create mode 100644 unix/f2c/libf2c/mkfile.plan9 create mode 100644 unix/f2c/libf2c/mkpkg.sh create mode 100644 unix/f2c/libf2c/open.c create mode 100644 unix/f2c/libf2c/pow_ci.c create mode 100644 unix/f2c/libf2c/pow_dd.c create mode 100644 unix/f2c/libf2c/pow_di.c create mode 100644 unix/f2c/libf2c/pow_hh.c create mode 100644 unix/f2c/libf2c/pow_ii.c create mode 100644 unix/f2c/libf2c/pow_qq.c create mode 100644 unix/f2c/libf2c/pow_ri.c create mode 100644 unix/f2c/libf2c/pow_zi.c create mode 100644 unix/f2c/libf2c/pow_zz.c create mode 100644 unix/f2c/libf2c/qbitbits.c create mode 100644 unix/f2c/libf2c/qbitshft.c create mode 100644 unix/f2c/libf2c/r_abs.c create mode 100644 unix/f2c/libf2c/r_acos.c create mode 100644 unix/f2c/libf2c/r_asin.c create mode 100644 unix/f2c/libf2c/r_atan.c create mode 100644 unix/f2c/libf2c/r_atn2.c create mode 100644 unix/f2c/libf2c/r_cnjg.c create mode 100644 unix/f2c/libf2c/r_cos.c create mode 100644 unix/f2c/libf2c/r_cosh.c create mode 100644 unix/f2c/libf2c/r_dim.c create mode 100644 unix/f2c/libf2c/r_exp.c create mode 100644 unix/f2c/libf2c/r_imag.c create mode 100644 unix/f2c/libf2c/r_int.c create mode 100644 unix/f2c/libf2c/r_lg10.c create mode 100644 unix/f2c/libf2c/r_log.c create mode 100644 unix/f2c/libf2c/r_mod.c create mode 100644 unix/f2c/libf2c/r_nint.c create mode 100644 unix/f2c/libf2c/r_sign.c create mode 100644 unix/f2c/libf2c/r_sin.c create mode 100644 unix/f2c/libf2c/r_sinh.c create mode 100644 unix/f2c/libf2c/r_sqrt.c create mode 100644 unix/f2c/libf2c/r_tan.c create mode 100644 unix/f2c/libf2c/r_tanh.c create mode 100644 unix/f2c/libf2c/rawio.h create mode 100644 unix/f2c/libf2c/rdfmt.c create mode 100644 unix/f2c/libf2c/rewind.c create mode 100644 unix/f2c/libf2c/rsfe.c create mode 100644 unix/f2c/libf2c/rsli.c create mode 100644 unix/f2c/libf2c/rsne.c create mode 100644 unix/f2c/libf2c/s_cat.c create mode 100644 unix/f2c/libf2c/s_cmp.c create mode 100644 unix/f2c/libf2c/s_copy.c create mode 100644 unix/f2c/libf2c/s_paus.c create mode 100644 unix/f2c/libf2c/s_rnge.c create mode 100644 unix/f2c/libf2c/s_stop.c create mode 100644 unix/f2c/libf2c/scomptry.bat create mode 100644 unix/f2c/libf2c/sfe.c create mode 100644 unix/f2c/libf2c/sig_die.c create mode 100644 unix/f2c/libf2c/signal1.h create mode 100644 unix/f2c/libf2c/signal1.h0 create mode 100644 unix/f2c/libf2c/signal_.c create mode 100644 unix/f2c/libf2c/signbit.c create mode 100644 unix/f2c/libf2c/sue.c create mode 100644 unix/f2c/libf2c/sysdep1.h create mode 100644 unix/f2c/libf2c/sysdep1.h0 create mode 100644 unix/f2c/libf2c/system_.c create mode 100644 unix/f2c/libf2c/typesize.c create mode 100644 unix/f2c/libf2c/uio.c create mode 100644 unix/f2c/libf2c/uninit.c create mode 100644 unix/f2c/libf2c/util.c create mode 100644 unix/f2c/libf2c/wref.c create mode 100644 unix/f2c/libf2c/wrtfmt.c create mode 100644 unix/f2c/libf2c/wsfe.c create mode 100644 unix/f2c/libf2c/wsle.c create mode 100644 unix/f2c/libf2c/wsne.c create mode 100644 unix/f2c/libf2c/xsum0.out create mode 100644 unix/f2c/libf2c/xwsne.c create mode 100644 unix/f2c/libf2c/z_abs.c create mode 100644 unix/f2c/libf2c/z_cos.c create mode 100644 unix/f2c/libf2c/z_div.c create mode 100644 unix/f2c/libf2c/z_exp.c create mode 100644 unix/f2c/libf2c/z_log.c create mode 100644 unix/f2c/libf2c/z_sin.c create mode 100644 unix/f2c/libf2c/z_sqrt.c create mode 100644 unix/f2c/libf77 create mode 100644 unix/f2c/libi77 create mode 100644 unix/f2c/mkpkg.sh create mode 100644 unix/f2c/msdos/README create mode 100644 unix/f2c/msdos/ccb.bat create mode 100644 unix/f2c/msdos/ccm.bat create mode 100644 unix/f2c/msdos/ccs.bat create mode 100644 unix/f2c/msdos/etime.exe.gz create mode 100644 unix/f2c/msdos/f2c.exe.gz create mode 100644 unix/f2c/msdos/f2cx.exe.gz create mode 100644 unix/f2c/msdos/index.html create mode 100644 unix/f2c/mswin/README create mode 100644 unix/f2c/mswin/f2c.exe.gz create mode 100644 unix/f2c/mswin/index.html create mode 100644 unix/f2c/mswin/makefile.vc create mode 100644 unix/f2c/src/README create mode 100644 unix/f2c/src/cds.c create mode 100644 unix/f2c/src/data.c create mode 100644 unix/f2c/src/defines.h create mode 100644 unix/f2c/src/defs.h create mode 100644 unix/f2c/src/equiv.c create mode 100644 unix/f2c/src/error.c create mode 100644 unix/f2c/src/exec.c create mode 100644 unix/f2c/src/expr.c create mode 100644 unix/f2c/src/f2c.1 create mode 100644 unix/f2c/src/f2c.1t create mode 100644 unix/f2c/src/f2c.h create mode 100644 unix/f2c/src/format.c create mode 100644 unix/f2c/src/format.h create mode 100644 unix/f2c/src/formatdata.c create mode 100644 unix/f2c/src/ftypes.h create mode 100644 unix/f2c/src/gram.c create mode 100644 unix/f2c/src/gram.dcl create mode 100644 unix/f2c/src/gram.exec create mode 100644 unix/f2c/src/gram.expr create mode 100644 unix/f2c/src/gram.head create mode 100644 unix/f2c/src/gram.io create mode 100644 unix/f2c/src/index.html create mode 100644 unix/f2c/src/init.c create mode 100644 unix/f2c/src/intr.c create mode 100644 unix/f2c/src/io.c create mode 100644 unix/f2c/src/iob.h create mode 100644 unix/f2c/src/lex.c create mode 100644 unix/f2c/src/machdefs.h create mode 100644 unix/f2c/src/main.c create mode 100644 unix/f2c/src/makefile.u create mode 100644 unix/f2c/src/makefile.vc create mode 100644 unix/f2c/src/malloc.c create mode 100644 unix/f2c/src/mem.c create mode 100644 unix/f2c/src/memset.c create mode 100644 unix/f2c/src/misc.c create mode 100644 unix/f2c/src/mkfile.plan9 create mode 100644 unix/f2c/src/mkpkg.sh create mode 100644 unix/f2c/src/names.c create mode 100644 unix/f2c/src/names.h create mode 100644 unix/f2c/src/niceprintf.c create mode 100644 unix/f2c/src/niceprintf.h create mode 100644 unix/f2c/src/notice create mode 100644 unix/f2c/src/output.c create mode 100644 unix/f2c/src/output.h create mode 100644 unix/f2c/src/p1defs.h create mode 100644 unix/f2c/src/p1output.c create mode 100644 unix/f2c/src/parse.h create mode 100644 unix/f2c/src/parse_args.c create mode 100644 unix/f2c/src/pccdefs.h create mode 100644 unix/f2c/src/pread.c create mode 100644 unix/f2c/src/proc.c create mode 100644 unix/f2c/src/put.c create mode 100644 unix/f2c/src/putpcc.c create mode 100644 unix/f2c/src/sysdep.c create mode 100644 unix/f2c/src/sysdep.h create mode 100644 unix/f2c/src/sysdep.hd create mode 100644 unix/f2c/src/sysdeptest.c create mode 100644 unix/f2c/src/tokdefs.h create mode 100644 unix/f2c/src/tokens create mode 100644 unix/f2c/src/usignal.h create mode 100644 unix/f2c/src/vax.c create mode 100644 unix/f2c/src/version.c create mode 100644 unix/f2c/src/xsum.c create mode 100644 unix/f2c/src/xsum.out create mode 100644 unix/f2c/src/xsum0.out create mode 100644 unix/f2c/src/xsum1.out create mode 100644 unix/gdev/README create mode 100644 unix/gdev/iism70/README create mode 100644 unix/gdev/iism70/m70.h create mode 100644 unix/gdev/iism70/mkpkg create mode 100644 unix/gdev/iism70/zclm70.x create mode 100644 unix/gdev/iism70/zopm70.x create mode 100644 unix/gdev/iism70/zrdm70.x create mode 100644 unix/gdev/iism70/zstm70.x create mode 100644 unix/gdev/iism70/zwrm70.x create mode 100644 unix/gdev/iism70/zwtm70.x create mode 100644 unix/gdev/iism75/README create mode 100644 unix/gdev/iism75/iis.h create mode 100644 unix/gdev/iism75/m75.h create mode 100644 unix/gdev/iism75/m75put.x create mode 100644 unix/gdev/iism75/mkpkg create mode 100644 unix/gdev/iism75/zclm75.x create mode 100644 unix/gdev/iism75/zopm75.x create mode 100644 unix/gdev/iism75/zrdm75.x create mode 100644 unix/gdev/iism75/zstm75.x create mode 100644 unix/gdev/iism75/zwrm75.x create mode 100644 unix/gdev/iism75/zwtm75.x create mode 100644 unix/gdev/iism75/zzrdii.x create mode 100644 unix/gdev/iism75/zzwrii.x create mode 100644 unix/gdev/m70vms/README create mode 100644 unix/gdev/m70vms/fcbu.inc create mode 100644 unix/gdev/m70vms/m70.h create mode 100644 unix/gdev/m70vms/m70cls.f create mode 100644 unix/gdev/m70vms/m70get.f create mode 100644 unix/gdev/m70vms/m70io.f create mode 100644 unix/gdev/m70vms/m70mcl.f create mode 100644 unix/gdev/m70vms/m70opn.f create mode 100644 unix/gdev/m70vms/m70rel.f create mode 100644 unix/gdev/m70vms/m70wt.f create mode 100644 unix/gdev/m70vms/m70wti.f create mode 100644 unix/gdev/m70vms/mkpkg create mode 100644 unix/gdev/m70vms/zclm70.x create mode 100644 unix/gdev/m70vms/zopm70.x create mode 100644 unix/gdev/m70vms/zrdm70.x create mode 100644 unix/gdev/m70vms/zstm70.x create mode 100644 unix/gdev/m70vms/zwrm70.x create mode 100644 unix/gdev/m70vms/zwtm70.x create mode 100644 unix/gdev/mkpkg create mode 100644 unix/gdev/mkpkg.sh create mode 100644 unix/gdev/sgidev/README create mode 100644 unix/gdev/sgidev/README.gif create mode 100644 unix/gdev/sgidev/mkpkg create mode 100644 unix/gdev/sgidev/mkpkg.sh create mode 100644 unix/gdev/sgidev/sgi2gif.c create mode 100644 unix/gdev/sgidev/sgi2svg.c create mode 100644 unix/gdev/sgidev/sgi2uapl.c create mode 100644 unix/gdev/sgidev/sgi2ueps.c create mode 100644 unix/gdev/sgidev/sgi2uhpgl.c create mode 100644 unix/gdev/sgidev/sgi2uhplj.c create mode 100644 unix/gdev/sgidev/sgi2uimp.c create mode 100644 unix/gdev/sgidev/sgi2uptx.c create mode 100644 unix/gdev/sgidev/sgi2uqms.c create mode 100644 unix/gdev/sgidev/sgi2xbm.c create mode 100644 unix/gdev/sgidev/sgiUtil.c create mode 100644 unix/gdev/sgidev/sgiUtil.h create mode 100644 unix/gdev/sgidev/sgidispatch.c create mode 100644 unix/gdev/zfiogd.x create mode 100644 unix/hlib/README create mode 100644 unix/hlib/allocate.cl create mode 100755 unix/hlib/buglog.csh create mode 100755 unix/hlib/buglog.sh create mode 100755 unix/hlib/cl.csh create mode 100755 unix/hlib/cl.csh.ORIG create mode 100755 unix/hlib/cl.sh create mode 100644 unix/hlib/cllogout.cl create mode 100644 unix/hlib/clpackage.cl create mode 100644 unix/hlib/clpackage.hd create mode 100644 unix/hlib/clpackage.men create mode 100644 unix/hlib/config.h create mode 100644 unix/hlib/d1mach.f create mode 100644 unix/hlib/deallocate.cl create mode 100644 unix/hlib/devstatus.cl create mode 100644 unix/hlib/diskspace.cl create mode 120000 unix/hlib/ecl.csh create mode 100755 unix/hlib/ecl.sh create mode 100644 unix/hlib/extern.pkg create mode 100644 unix/hlib/extern.pkg.DEF create mode 100644 unix/hlib/extern.pkg.IRAFNET create mode 100644 unix/hlib/extpkg.cl create mode 100755 unix/hlib/f77.sh create mode 100755 unix/hlib/f77.sh.bak create mode 100755 unix/hlib/fc.csh create mode 100755 unix/hlib/fc.sh create mode 100644 unix/hlib/gripes.cl create mode 100755 unix/hlib/helplog.csh create mode 100755 unix/hlib/helplog.sh create mode 100644 unix/hlib/i1mach.f create mode 100755 unix/hlib/install.csh create mode 100755 unix/hlib/install.old create mode 100755 unix/hlib/install.port create mode 120000 unix/hlib/iraf.h create mode 100644 unix/hlib/iraf32.h create mode 100644 unix/hlib/iraf64.h create mode 100755 unix/hlib/irafarch.csh create mode 100755 unix/hlib/irafarch.sh create mode 100755 unix/hlib/irafuser.csh create mode 100755 unix/hlib/irafuser.sh create mode 100644 unix/hlib/knet.h create mode 120000 unix/hlib/libboot.a create mode 100644 unix/hlib/libc/README create mode 100644 unix/hlib/libc/alloc.h create mode 100644 unix/hlib/libc/ctype.h create mode 100644 unix/hlib/libc/error.h create mode 100644 unix/hlib/libc/finfo.h create mode 100644 unix/hlib/libc/fpoll.h create mode 100644 unix/hlib/libc/fset.h create mode 100644 unix/hlib/libc/iraf.h create mode 100644 unix/hlib/libc/kernel.h create mode 100644 unix/hlib/libc/knames.h create mode 100644 unix/hlib/libc/kproto.h create mode 100644 unix/hlib/libc/kproto.h.bak create mode 100644 unix/hlib/libc/lexnum.h create mode 100644 unix/hlib/libc/libc.h create mode 100644 unix/hlib/libc/main.h create mode 100644 unix/hlib/libc/math.h create mode 100644 unix/hlib/libc/protect.h create mode 100644 unix/hlib/libc/prstat.h create mode 100644 unix/hlib/libc/prtype.h create mode 100644 unix/hlib/libc/setjmp.h create mode 100644 unix/hlib/libc/spp.h create mode 100755 unix/hlib/libc/stdarg-cygwin.h create mode 100644 unix/hlib/libc/stdarg-freebsd.h create mode 100644 unix/hlib/libc/stdarg-linux.h create mode 100644 unix/hlib/libc/stdarg-osx.h create mode 100644 unix/hlib/libc/stdarg-solaris.h create mode 100644 unix/hlib/libc/stdarg.h create mode 100644 unix/hlib/libc/stdio.h create mode 100644 unix/hlib/libc/ttset.h create mode 100644 unix/hlib/libc/vosproto.h create mode 100644 unix/hlib/libc/xnames.h create mode 100644 unix/hlib/libc/xwhen.h create mode 100644 unix/hlib/libc/zfstat.h create mode 120000 unix/hlib/libos.a create mode 100644 unix/hlib/login.cl create mode 120000 unix/hlib/mach.h create mode 100644 unix/hlib/mach32.h create mode 100644 unix/hlib/mach64.h create mode 100644 unix/hlib/math.h create mode 100755 unix/hlib/mkfloat.csh create mode 100755 unix/hlib/mkfloat.sh create mode 100755 unix/hlib/mkiraf.csh create mode 100755 unix/hlib/mkiraf.sh create mode 100755 unix/hlib/mkmlist.csh create mode 100755 unix/hlib/mkmlist.sh create mode 100644 unix/hlib/mkpkg.inc create mode 100644 unix/hlib/mkpkg.sf.CYGW create mode 100644 unix/hlib/mkpkg.sf.FBSD create mode 100644 unix/hlib/mkpkg.sf.I386 create mode 100644 unix/hlib/mkpkg.sf.LNUX create mode 100644 unix/hlib/mkpkg.sf.LNUX64 create mode 100644 unix/hlib/mkpkg.sf.MACX create mode 100644 unix/hlib/mkpkg.sf.OS4 create mode 100644 unix/hlib/mkpkg.sf.S34 create mode 100644 unix/hlib/mkpkg.sf.SF2C create mode 100644 unix/hlib/mkpkg.sf.SSUN create mode 100644 unix/hlib/mkpkg.sf.SUN3 create mode 100644 unix/hlib/mkpkg.sf.SUN4 create mode 100644 unix/hlib/mkpkg.sf.SX86 create mode 100644 unix/hlib/motd create mode 100644 unix/hlib/r1mach.f create mode 100755 unix/hlib/setup.csh create mode 100755 unix/hlib/setup.sh create mode 100644 unix/hlib/spy.cl create mode 100644 unix/hlib/strip create mode 100644 unix/hlib/strip.iraf create mode 100755 unix/hlib/sysinfo create mode 100755 unix/hlib/uninstall create mode 100644 unix/hlib/util.csh/.repo_desc create mode 100644 unix/hlib/util.csh/.repo_local create mode 100644 unix/hlib/util.csh/.repo_manifest create mode 100644 unix/hlib/util.csh/.repo_pkgs create mode 100644 unix/hlib/util.csh/.zzsetenv.def create mode 100644 unix/hlib/util.csh/README create mode 100755 unix/hlib/util.csh/check_update create mode 100755 unix/hlib/util.csh/chk64 create mode 100755 unix/hlib/util.csh/fget create mode 100755 unix/hlib/util.csh/iraf_latest create mode 100755 unix/hlib/util.csh/iraf_update create mode 100755 unix/hlib/util.csh/mkarch create mode 100755 unix/hlib/util.csh/mkbindist create mode 100755 unix/hlib/util.csh/mkclean create mode 100755 unix/hlib/util.csh/mkdist create mode 100755 unix/hlib/util.csh/mkproto create mode 100755 unix/hlib/util.csh/mksrc create mode 100755 unix/hlib/util.csh/mksysgen create mode 100755 unix/hlib/util.csh/mkup create mode 100755 unix/hlib/util.csh/mkupx create mode 100755 unix/hlib/util.csh/pkgclean create mode 100755 unix/hlib/util.csh/pkgdel create mode 100755 unix/hlib/util.csh/pkgenv create mode 100755 unix/hlib/util.csh/pkgget create mode 100755 unix/hlib/util.csh/pkginit create mode 100755 unix/hlib/util.csh/pkginst create mode 100755 unix/hlib/util.csh/pkgrepo create mode 100755 unix/hlib/util.csh/pkgupdate create mode 100755 unix/hlib/util.csh/self_update create mode 100755 unix/hlib/util.sh create mode 100644 unix/hlib/utime create mode 120000 unix/hlib/vocl.csh create mode 100755 unix/hlib/vocl.sh create mode 100644 unix/hlib/zzsetenv.def create mode 100644 unix/mc68000/README create mode 100644 unix/mc68000/ishift.SUN create mode 100644 unix/mc68000/zsvjmp.FX create mode 100644 unix/mc68000/zsvjmp.ISI create mode 100644 unix/mc68000/zsvjmp.SUN create mode 100644 unix/mkpkg create mode 100644 unix/mkpkg.sh create mode 100644 unix/os/README create mode 100644 unix/os/alloc.c create mode 100644 unix/os/dio.c create mode 100644 unix/os/doc/Mach.notes create mode 100644 unix/os/doc/os.hd create mode 100644 unix/os/doc/os.ms create mode 100644 unix/os/doc/ostoc.ms create mode 100644 unix/os/doc/zalocd.hlp create mode 100644 unix/os/doc/zardbf.hlp create mode 100644 unix/os/doc/zawrbf.hlp create mode 100644 unix/os/doc/zawset.hlp create mode 100644 unix/os/doc/zawtbf.hlp create mode 100644 unix/os/doc/zcall.hlp create mode 100644 unix/os/doc/zclcpr.hlp create mode 100644 unix/os/doc/zcldir.hlp create mode 100644 unix/os/doc/zcldpr.hlp create mode 100644 unix/os/doc/zclsbf.hlp create mode 100644 unix/os/doc/zclstx.hlp create mode 100644 unix/os/doc/zfacss.hlp create mode 100644 unix/os/doc/zfaloc.hlp create mode 100644 unix/os/doc/zfchdr.hlp create mode 100644 unix/os/doc/zfdele.hlp create mode 100644 unix/os/doc/zfgcwd.hlp create mode 100644 unix/os/doc/zfinfo.hlp create mode 100644 unix/os/doc/zfiobf.hlp create mode 100644 unix/os/doc/zfiolp.hlp create mode 100644 unix/os/doc/zfiomt.hlp create mode 100644 unix/os/doc/zfiopr.hlp create mode 100644 unix/os/doc/zfiosf.hlp create mode 100644 unix/os/doc/zfiotx.hlp create mode 100644 unix/os/doc/zfioty.hlp create mode 100644 unix/os/doc/zflstx.hlp create mode 100644 unix/os/doc/zfmkcp.hlp create mode 100644 unix/os/doc/zfpath.hlp create mode 100644 unix/os/doc/zfprot.hlp create mode 100644 unix/os/doc/zfrnam.hlp create mode 100644 unix/os/doc/zfsubd.hlp create mode 100644 unix/os/doc/zfxdir.hlp create mode 100644 unix/os/doc/zgettx.hlp create mode 100644 unix/os/doc/zgfdir.hlp create mode 100644 unix/os/doc/zgtime.hlp create mode 100644 unix/os/doc/zgtpid.hlp create mode 100644 unix/os/doc/zintpr.hlp create mode 100644 unix/os/doc/zlocpr.hlp create mode 100644 unix/os/doc/zlocva.hlp create mode 100644 unix/os/doc/zmain.hlp create mode 100644 unix/os/doc/zmaloc.hlp create mode 100644 unix/os/doc/zmfree.hlp create mode 100644 unix/os/doc/znottx.hlp create mode 100644 unix/os/doc/zopcpr.hlp create mode 100644 unix/os/doc/zopdir.hlp create mode 100644 unix/os/doc/zopdpr.hlp create mode 100644 unix/os/doc/zopnbf.hlp create mode 100644 unix/os/doc/zopntx.hlp create mode 100644 unix/os/doc/zoscmd.hlp create mode 100644 unix/os/doc/zpanic.hlp create mode 100644 unix/os/doc/zputtx.hlp create mode 100644 unix/os/doc/zraloc.hlp create mode 100644 unix/os/doc/zsektx.hlp create mode 100644 unix/os/doc/zsttbf.hlp create mode 100644 unix/os/doc/zstttx.hlp create mode 100644 unix/os/doc/zsvjmp.hlp create mode 100644 unix/os/doc/ztslee.hlp create mode 100644 unix/os/doc/zxgmes.hlp create mode 100644 unix/os/doc/zxwhen.hlp create mode 100644 unix/os/doc/zzclmt.hlp create mode 100644 unix/os/doc/zzopmt.hlp create mode 100644 unix/os/doc/zzrdmt.hlp create mode 100644 unix/os/doc/zzrwmt.hlp create mode 100644 unix/os/doc/zzwrmt.hlp create mode 100644 unix/os/doc/zzwtmt.hlp create mode 100644 unix/os/getproc.c create mode 100644 unix/os/gmttolst.c create mode 100644 unix/os/irafpath.c create mode 100644 unix/os/mkpkg create mode 100644 unix/os/mkpkg.sh create mode 100755 unix/os/mkproto create mode 100644 unix/os/net/README create mode 100644 unix/os/net/accept.c create mode 100644 unix/os/net/connect.c create mode 100644 unix/os/net/ctype.h create mode 100644 unix/os/net/eprintf.c create mode 100644 unix/os/net/ghostbynm.c create mode 100644 unix/os/net/ghostent.c create mode 100644 unix/os/net/gsocknm.c create mode 100644 unix/os/net/hostdb.c create mode 100644 unix/os/net/htonl.c create mode 100644 unix/os/net/htons.c create mode 100644 unix/os/net/in.h create mode 100644 unix/os/net/inetaddr.c create mode 100644 unix/os/net/kutil.c create mode 100644 unix/os/net/listen.c create mode 100644 unix/os/net/mkpkg create mode 100644 unix/os/net/netdb.h create mode 100644 unix/os/net/ntohl.c create mode 100644 unix/os/net/ntohs.c create mode 100644 unix/os/net/rexec.c create mode 100644 unix/os/net/socket.c create mode 100644 unix/os/net/socket.h create mode 100644 unix/os/net/tcpclose.c create mode 100644 unix/os/net/tcpread.c create mode 100644 unix/os/net/tcpwrite.c create mode 100644 unix/os/net/types.h create mode 100644 unix/os/net/zfioks.c create mode 100644 unix/os/net/zzdebug.x create mode 100644 unix/os/prwait.c create mode 100644 unix/os/tape.c create mode 100644 unix/os/zalloc.c create mode 100644 unix/os/zawset.c create mode 100644 unix/os/zcall.c create mode 100644 unix/os/zdojmp.c create mode 100644 unix/os/zfacss.c create mode 100644 unix/os/zfaloc.c create mode 100644 unix/os/zfchdr.c create mode 100644 unix/os/zfdele.c create mode 100644 unix/os/zfgcwd.c create mode 100644 unix/os/zfinfo.c create mode 100644 unix/os/zfiobf.c create mode 100644 unix/os/zfioks.c create mode 100644 unix/os/zfiolp.c create mode 100644 unix/os/zfiomt.c create mode 100644 unix/os/zfiond.c create mode 100644 unix/os/zfiopl.c create mode 100644 unix/os/zfiopr.c create mode 100644 unix/os/zfiosf.c create mode 100644 unix/os/zfiotx.c create mode 100644 unix/os/zfioty.c create mode 100644 unix/os/zflink.c create mode 100644 unix/os/zfmkcp.c create mode 100644 unix/os/zfmkdr.c create mode 100644 unix/os/zfnbrk.c create mode 100644 unix/os/zfpath.c create mode 100644 unix/os/zfpoll.c create mode 100644 unix/os/zfprot.c create mode 100644 unix/os/zfrmdr.c create mode 100644 unix/os/zfrnam.c create mode 100644 unix/os/zfsubd.c create mode 100644 unix/os/zfunc.c create mode 100644 unix/os/zfutim.c create mode 100644 unix/os/zfxdir.c create mode 100644 unix/os/zgcmdl.c create mode 100644 unix/os/zghost.c create mode 100644 unix/os/zglobl.c create mode 100644 unix/os/zgmtco.c create mode 100644 unix/os/zgtenv.c create mode 100644 unix/os/zgtime.c create mode 100644 unix/os/zgtpid.c create mode 100644 unix/os/zintpr.c create mode 100644 unix/os/zlocpr.c create mode 100644 unix/os/zlocva.c create mode 100644 unix/os/zmain.c create mode 100644 unix/os/zmaloc.c create mode 100644 unix/os/zmfree.c create mode 100644 unix/os/zopdir.c create mode 100644 unix/os/zopdpr.c create mode 100644 unix/os/zoscmd.c create mode 100644 unix/os/zpanic.c create mode 100644 unix/os/zraloc.c create mode 100644 unix/os/zshlib.c create mode 100644 unix/os/zwmsec.c create mode 100644 unix/os/zxwhen.c create mode 100644 unix/os/zzdbg.c create mode 100644 unix/os/zzepro.c create mode 100644 unix/os/zzexit.c create mode 100644 unix/os/zzpstr.c create mode 100644 unix/os/zzsetk.c create mode 100644 unix/os/zzstrt.c create mode 100644 unix/portkit/README create mode 100644 unix/portkit/d1mach.f.ieee create mode 100644 unix/portkit/i1mach.f.ieee create mode 100644 unix/portkit/ishift.s.68000 create mode 100644 unix/portkit/mach.h.ieee create mode 100644 unix/portkit/r1mach.f.ieee create mode 100644 unix/portkit/spp.h.ieee create mode 100644 unix/portkit/zsvjmp.s.68000 create mode 100644 unix/portkit/zsvjmp.s.FX create mode 100644 unix/portkit/zsvjmp.s.HP800 create mode 100644 unix/portkit/zsvjmp.s.ISI create mode 100644 unix/portkit/zsvjmp.s.SPARC create mode 100755 unix/reboot create mode 100644 unix/rmbin.sh create mode 100644 unix/setarch.sh create mode 100644 unix/shlib/README create mode 100644 unix/shlib/S.nm.added create mode 100644 unix/shlib/S.nm.deleted create mode 100644 unix/shlib/S.nm.f68881 create mode 100644 unix/shlib/S.nm.ffpa create mode 100644 unix/shlib/S.nm.generic create mode 100644 unix/shlib/S.nm.i386 create mode 100644 unix/shlib/S.nm.new create mode 100644 unix/shlib/S.nm.old create mode 100644 unix/shlib/S.nm.pg create mode 100644 unix/shlib/S.nm.sparc create mode 100644 unix/shlib/S.nm.ssun create mode 100644 unix/shlib/S.s create mode 100644 unix/shlib/S.ver.f68881 create mode 100644 unix/shlib/S.ver.ffpa create mode 100644 unix/shlib/S.ver.generic create mode 100644 unix/shlib/S.ver.i386 create mode 100644 unix/shlib/S.ver.pg create mode 100644 unix/shlib/S.ver.sparc create mode 100644 unix/shlib/S.ver.ssun create mode 100644 unix/shlib/Slib.c create mode 100644 unix/shlib/V.s create mode 100644 unix/shlib/aout.c create mode 100644 unix/shlib/coff.c create mode 100644 unix/shlib/edsym-sos4.c create mode 100644 unix/shlib/edsym-ssol.c create mode 100644 unix/shlib/elf.c create mode 100644 unix/shlib/inode.c create mode 100644 unix/shlib/mapfile create mode 100644 unix/shlib/medit.c create mode 100644 unix/shlib/mkpkg create mode 100644 unix/shlib/mkpkg.sh create mode 100755 unix/shlib/mkshlib.csh.403 create mode 100755 unix/shlib/mkshlib.csh.411 create mode 100755 unix/shlib/mkshlib.sos4 create mode 120000 unix/shlib/mkshlib.ssol create mode 100755 unix/shlib/mkshlib.ssol-sc2 create mode 100755 unix/shlib/mkshlib.ssol-sc34 create mode 100644 unix/shlib/omit.f68881 create mode 100644 unix/shlib/omit.ffpa create mode 100644 unix/shlib/omit.generic create mode 100644 unix/shlib/omit.i386 create mode 100644 unix/shlib/omit.pg create mode 100644 unix/shlib/omit.sparc create mode 100644 unix/shlib/omit.ssun create mode 100644 unix/shlib/zzzend.c create mode 100644 unix/sun/Gterm.hlp create mode 100644 unix/sun/Imtool.hlp create mode 100644 unix/sun/Makefile create mode 100644 unix/sun/README create mode 100644 unix/sun/arrow.c create mode 100644 unix/sun/fifo.c create mode 100644 unix/sun/gterm.c create mode 100644 unix/sun/gterm.esc create mode 100644 unix/sun/gterm.h create mode 100644 unix/sun/gterm.icon create mode 100644 unix/sun/gterm.icon.OLD create mode 100644 unix/sun/gterm.man create mode 100644 unix/sun/gtermio.c create mode 100644 unix/sun/halley.lut create mode 100644 unix/sun/heat.lut create mode 100644 unix/sun/imtool.c create mode 100644 unix/sun/imtool.cross create mode 100644 unix/sun/imtool.cursor create mode 100644 unix/sun/imtool.h create mode 100644 unix/sun/imtool.icon create mode 100644 unix/sun/imtool.icon.NEW create mode 100644 unix/sun/imtool.man create mode 100644 unix/sun/imtool.square create mode 100644 unix/sun/imtoolrc create mode 100755 unix/sun/mksuntool.csh create mode 100644 unix/sun/mouse.c create mode 100644 unix/sun/notify_read.c create mode 100644 unix/sun/screendump.c create mode 100644 unix/sun/ss1.patch (limited to 'unix') diff --git a/unix/README b/unix/README new file mode 100644 index 00000000..dcd73b5b --- /dev/null +++ b/unix/README @@ -0,0 +1,130 @@ +PC-IRAF HSI -- September 2001 + +The old (1985) README for the Unix HSI is preserved unchanged below. +We are not going to attempt to include updated, comprehensive documentation +here now, but a few pointers follow. See the Unix/IRAF or PC-IRAF system +manager's guide for more complete documentation. + + o To build the HSI on first sets the architecture (via "mkpkg " + in the iraf root), then types "reboot" in this directory. The + first time this is done on a platform there will be no system + libraries (libsys.a etc.) and the HSI will be compled with NOVOS + set. This builds the HSI with certain routines stubbed-out. It + is functional enough after a sucessful bootstrap to compile the + iraf system libraries ("mkpkg syslibs" at the iraf root). One + can then do another "reboot" to re-bootstrap the HSI. It will + be built this time using the iraf system libraries and will be + fully functional, and ready to sysgen the full iraf system. + + o The PC-IRAF HSI currently uses F2C for Fortran (SPP) to C + translation. Although F2C is available as an option on many + platforms, we integrate it into the HSI to avoid versioning + problems and to avoid an external dependency. The version of F2C + used is maintained in /local/src/f2c on Lepus. The README in that + directory contains instructions for building f2c for a platform. + Once the runtime files have been generated they are copied to the + HBIN for the target platform. + + +=============================================================================== +UNIX (a.k.a. host$) -- IRAF/UNIX System Interface (13Dec85 Dct) + + These directories contain those portions of the IRAF software which are +machine or host operating system dependent. The major directories are as +follows: + + as all assembler files (most of these are optional) + boot bootstrap utilities (mkpkg, xc, etc.) + hlib host library (config files, header files, etc.) + os the UNIX/IRAF kernel (LIBOS.A) + gdev ZFIOGD device driver (i/o to binary graphics devices) + +A graph of the IRAF/UNIX system interface directories is shown below. +------------------------------------------------------------------------------- +Thu Jan 16 16:37:52 MST 1986 + + |-as------------ + | + | |-bootlib------- + | |-generic------- + | |-mkpkg--------- + | |-rmbin--------- + | |-rtar---------- + | | + | | |-ratlibc------- + |-boot----------| |-ratlibf------- + | |-spp-----------|-rpp-----------|-ratlibr------- +|-unix----------| | | |-rppfor-------- + | | | |-rpprat-------- + | | |-xpp----------- + | |-vfn----------- + | |-wtar---------- + | | + | |-xyacc---------|-debug--------- + | + |-gdev----------|-iism70-------- + | + | + |-hlib----------|-libc---------- + | + |-os------------|-doc----------- + |-net----------- + + + +SYSTEM GENERATION PROCEDURE + + The bootstrap utilities must be built before the remainder of the IRAF +system can be built. The procedure for building the system from scratch given +a text-only distribution is outlined below. Those sites fortunate to receive +a binary distribution can skip all this, and proceed to editing the device +tables and other runtime files. + + + [1] Edit the config files in HLIB. The major files are iraf.h, config.h, + mach.h, libc/iraf.h, libc/libc.h, and libc/knames.h. All files should + be reviewed. + + [2] If the AS assembler files will not work on your machine, rename the + directory as VAXAS or some such, create a new, empty AS directory, + and code the file ZSVJMP.S therein. This is the only assembler file + required for the operation of IRAF; the autogeneration code will use + alternate (but less efficient) portable routines if any of the other + AS files are not found. To code ZSVJMP on a UNIX system, it may help + to write a small C program which calls longjmp and setjmp and use ADB + to disassemble it. Write a modified version which is callable from + Fortran and has the indicated calling sequence. + + [3] The directory OS contains the IRAF kernel for 4.2BSD UNIX. This will + have to be modified somewhat if a different version of UNIX is in use. + Manual pages are given in os/doc and the package is described in the + "System Interface Reference Manual", which any IRAF implementor should + already have. As of this writing the documentation is partially out + of date. + + [4] Edit the pathnames in the file ./hlib/libc/iraf.h. Make a symbolic + link /usr/include/iraf.h which points to this file (alternatively, copy + the file to /usr/include). Edit the pathnames in ./hlib/irafuser.csh. + Add references to your CSHELL .login and .cshrc files to pick up the + environment definitions and aliases in this file (alternatively, + add the appropriate SET/EXPORT environment definitions to your Bourne + shell login file, and make symbolic links pointing to the aliased + commands in some public directory). + + [5] Use source or login to pick up the environment defs and aliases. You + are now ready to compile the bootstrap utilities: + + % sh -x mkpkg.csh >& spool & + + This command should compile the libraries LIBOS.A and LIBBOOT.A and + install them in hlib, then compile and install all the bootstrap + utilities. + +Once this sequence has been successfully completed you should be able to +compile the machine independent part of IRAF by the following sequence of +commands: + + % cd $iraf + % mkpkg >& spool & + +Generation of the full system will take many hours. diff --git a/unix/as b/unix/as new file mode 120000 index 00000000..f5b0e154 --- /dev/null +++ b/unix/as @@ -0,0 +1 @@ +as.generic \ No newline at end of file diff --git a/unix/as.cygwin/aclrb.c b/unix/as.cygwin/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.cygwin/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.cygwin/aclrc.c b/unix/as.cygwin/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.cygwin/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/aclrd.c b/unix/as.cygwin/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.cygwin/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/aclri.c b/unix/as.cygwin/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.cygwin/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/aclrl.c b/unix/as.cygwin/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.cygwin/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/aclrr.c b/unix/as.cygwin/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.cygwin/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/aclrs.c b/unix/as.cygwin/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.cygwin/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/amovc.c b/unix/as.cygwin/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.cygwin/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/amovd.c b/unix/as.cygwin/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.cygwin/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/amovi.c b/unix/as.cygwin/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.cygwin/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/amovl.c b/unix/as.cygwin/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.cygwin/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/amovr.c b/unix/as.cygwin/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.cygwin/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/amovs.c b/unix/as.cygwin/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.cygwin/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.cygwin/bytmov.c b/unix/as.cygwin/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.cygwin/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.cygwin/ieee.gx b/unix/as.cygwin/ieee.gx new file mode 100644 index 00000000..d08b79ad --- /dev/null +++ b/unix/as.cygwin/ieee.gx @@ -0,0 +1,420 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +real fval +int ival[1] +$else +double fval +int ival[2] +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +$if (datatype == r) +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / +$else +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ +$endif + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end + + +$if (datatype == r) + +# IEEE_SIGMASK, IEEE_SIGRESTORE -- Routines for masking IEEE exceptions. +# +# ieee_sigmask() +# ieee_sigrestore() +# +# These routines are meant to be used only internally by the routines in +# this file. iee_sigmask saves the current IEEE FPU exception mask, and +# sets a new mask which masks the invalid operand exception. This is +# necessary to permit the routines in this file to handle NaN values without +# raising the IEEE invalid operand exception. iee_sigrestore restores +# the original exception mask. These routines are meant to be called as +# pairs to temporarily block the invalid operand exception within an IEEE +# conversion routine. + +procedure ieee_sigmask() +int fpucw +common /ieesig/ fpucw +begin + call gfpucw (fpucw) + call sfpucw (or (fpucw, 1)) +end + +procedure ieee_sigrestore() +int fpucw +common /ieesig/ fpucw +begin + call sfpucw (fpucw) +end + +$endif diff --git a/unix/as.cygwin/ieeed.x b/unix/as.cygwin/ieeed.x new file mode 100644 index 00000000..1670fd8d --- /dev/null +++ b/unix/as.cygwin/ieeed.x @@ -0,0 +1,355 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +double fval +int ival[2] + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7FF00000X +end + + diff --git a/unix/as.cygwin/ieeer.x b/unix/as.cygwin/ieeer.x new file mode 100644 index 00000000..b262f1b0 --- /dev/null +++ b/unix/as.cygwin/ieeer.x @@ -0,0 +1,385 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +real fval +int ival[1] + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7F800000X +end + + + +# IEEE_SIGMASK, IEEE_SIGRESTORE -- Routines for masking IEEE exceptions. +# +# ieee_sigmask() +# ieee_sigrestore() +# +# These routines are meant to be used only internally by the routines in +# this file. iee_sigmask saves the current IEEE FPU exception mask, and +# sets a new mask which masks the invalid operand exception. This is +# necessary to permit the routines in this file to handle NaN values without +# raising the IEEE invalid operand exception. iee_sigrestore restores +# the original exception mask. These routines are meant to be called as +# pairs to temporarily block the invalid operand exception within an IEEE +# conversion routine. + +procedure ieee_sigmask() +int fpucw +common /ieesig/ fpucw +begin + call gfpucw (fpucw) + call sfpucw (or (fpucw, 1)) +end + +procedure ieee_sigrestore() +int fpucw +common /ieesig/ fpucw +begin + call sfpucw (fpucw) +end + diff --git a/unix/as.cygwin/zrtadr.s b/unix/as.cygwin/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.cygwin/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.cygwin/zsvjmp.s b/unix/as.cygwin/zsvjmp.s new file mode 100644 index 00000000..5e9408f1 --- /dev/null +++ b/unix/as.cygwin/zsvjmp.s @@ -0,0 +1,73 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl _zsvjmp_ + .globl _sfpucw_ + .globl _gfpucw_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + #.globl mem_ + #mem_ = 0 + + .text +_zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + movl $0, 8(%esp) # change arg2 to zero + jmp _setjmp # let sigsetjmp do the rest + +_gfpucw_: # Get fpucw: gfpucw_ (&cur_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp), %dx + movl %edx,(%eax) + movl %ebp, %esp + popl %ebp + ret + +_sfpucw_: # Set fpucw: sfpucw_ (&new_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + movl (%eax), %eax + andl $0xf3f, %eax + fclex + movw %ax, 0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret diff --git a/unix/as.cygwin/zsvjmp.s.RH6 b/unix/as.cygwin/zsvjmp.s.RH6 new file mode 100644 index 00000000..983b2c5f --- /dev/null +++ b/unix/as.cygwin/zsvjmp.s.RH6 @@ -0,0 +1,62 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl zsvjmp_ + .globl setfpucw + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + movl $0, 8(%esp) # change arg2 to zero + jmp __sigsetjmp # let sigsetjmp do the rest + +setfpucw: + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp),%eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp),%dx + andl $0xfffff0c0,%edx + andl $0xf3f,%eax + orl %eax,%edx + movw %dx,0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret diff --git a/unix/as.cygwin/zsvjmp.s.SL40 b/unix/as.cygwin/zsvjmp.s.SL40 new file mode 100644 index 00000000..367f3728 --- /dev/null +++ b/unix/as.cygwin/zsvjmp.s.SL40 @@ -0,0 +1,72 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl zsvjmp_ + .globl sfpucw_ + .globl gfpucw_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + jmp __setjmp # let setjmp do the rest + +gfpucw_: # Get fpucw: gfpucw_ (&cur_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp), %dx + movl %edx,(%eax) + movl %ebp, %esp + popl %ebp + ret + +sfpucw_: # Set fpucw: sfpucw_ (&new_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + movl (%eax), %eax + andl $0xf3f, %eax + fclex + movw %ax, 0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret diff --git a/unix/as.cygwin/zz.c b/unix/as.cygwin/zz.c new file mode 100644 index 00000000..68aa838b --- /dev/null +++ b/unix/as.cygwin/zz.c @@ -0,0 +1,10 @@ +/* Compile with gcc -S to get demo assembler code. + */ +zsvjmp_(buf,status) +int *buf; +int *status; +{ + *status = 0; + buf[0] = *status; + setjmp (&buf[1]); +} diff --git a/unix/as.cygwin/zzdebug.c b/unix/as.cygwin/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.cygwin/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.freebsd/aclrb.c b/unix/as.freebsd/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.freebsd/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.freebsd/aclrc.c b/unix/as.freebsd/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.freebsd/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/aclrd.c b/unix/as.freebsd/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.freebsd/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/aclri.c b/unix/as.freebsd/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.freebsd/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/aclrl.c b/unix/as.freebsd/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.freebsd/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/aclrr.c b/unix/as.freebsd/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.freebsd/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/aclrs.c b/unix/as.freebsd/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.freebsd/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/amovc.c b/unix/as.freebsd/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.freebsd/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/amovd.c b/unix/as.freebsd/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.freebsd/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/amovi.c b/unix/as.freebsd/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.freebsd/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/amovl.c b/unix/as.freebsd/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.freebsd/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/amovr.c b/unix/as.freebsd/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.freebsd/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/amovs.c b/unix/as.freebsd/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.freebsd/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.freebsd/bytmov.c b/unix/as.freebsd/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.freebsd/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.freebsd/ieee.gx b/unix/as.freebsd/ieee.gx new file mode 100644 index 00000000..76a16a60 --- /dev/null +++ b/unix/as.freebsd/ieee.gx @@ -0,0 +1,371 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +real fval +int ival[1] +$else +double fval +int ival[2] +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +$if (datatype == r) +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / +$else +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ +$endif + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.freebsd/ieeed.x b/unix/as.freebsd/ieeed.x new file mode 100644 index 00000000..4bc194b1 --- /dev/null +++ b/unix/as.freebsd/ieeed.x @@ -0,0 +1,338 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +double fval +int ival[2] + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.freebsd/ieeer.x b/unix/as.freebsd/ieeer.x new file mode 100644 index 00000000..7649f73f --- /dev/null +++ b/unix/as.freebsd/ieeer.x @@ -0,0 +1,338 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +real fval +int ival[1] + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.freebsd/zrtadr.s b/unix/as.freebsd/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.freebsd/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.freebsd/zsvjmp.s b/unix/as.freebsd/zsvjmp.s new file mode 100644 index 00000000..bb4ba8ed --- /dev/null +++ b/unix/as.freebsd/zsvjmp.s @@ -0,0 +1,49 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the FreeBSD (x86) version of ZSVJMP. +# Modified to remove leading underscore for ELF (Jan99). + + .globl zsvjmp_ + .globl exit_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + .globl _mem_ + _mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + jmp _setjmp # let setjmp do the rest diff --git a/unix/as.freebsd/zz.c b/unix/as.freebsd/zz.c new file mode 100644 index 00000000..68aa838b --- /dev/null +++ b/unix/as.freebsd/zz.c @@ -0,0 +1,10 @@ +/* Compile with gcc -S to get demo assembler code. + */ +zsvjmp_(buf,status) +int *buf; +int *status; +{ + *status = 0; + buf[0] = *status; + setjmp (&buf[1]); +} diff --git a/unix/as.freebsd/zzdebug.c b/unix/as.freebsd/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.freebsd/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.freebsd/zzz.c b/unix/as.freebsd/zzz.c new file mode 100644 index 00000000..bf906de9 --- /dev/null +++ b/unix/as.freebsd/zzz.c @@ -0,0 +1,5 @@ +exit_(s) +int *s; +{ + exit (*s); +} diff --git a/unix/as.freebsd/zzz.s b/unix/as.freebsd/zzz.s new file mode 100644 index 00000000..3d216a97 --- /dev/null +++ b/unix/as.freebsd/zzz.s @@ -0,0 +1,21 @@ + .file "zzz.c" +gcc2_compiled.: +___gnu_compiled_c: +.text + .align 2 +.globl _exit_ + .type _exit_,@function +_exit_: + pushl %ebp + movl %esp,%ebp + movl 8(%ebp),%eax + movl (%eax),%edx + pushl %edx + call _exit + addl $4,%esp + .align 2,0x90 +L1: + leave + ret +Lfe1: + .size _exit_,Lfe1-_exit_ diff --git a/unix/as.i386/aclrb.c b/unix/as.i386/aclrb.c new file mode 100644 index 00000000..0ad8e775 --- /dev/null +++ b/unix/as.i386/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n); +} diff --git a/unix/as.i386/aclrc.c b/unix/as.i386/aclrc.c new file mode 100644 index 00000000..5f65a082 --- /dev/null +++ b/unix/as.i386/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.i386/aclrd.c b/unix/as.i386/aclrd.c new file mode 100644 index 00000000..2336f5ee --- /dev/null +++ b/unix/as.i386/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.i386/aclri.c b/unix/as.i386/aclri.c new file mode 100644 index 00000000..8dff5b08 --- /dev/null +++ b/unix/as.i386/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.i386/aclrl.c b/unix/as.i386/aclrl.c new file mode 100644 index 00000000..0fc61dd4 --- /dev/null +++ b/unix/as.i386/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.i386/aclrr.c b/unix/as.i386/aclrr.c new file mode 100644 index 00000000..78a56125 --- /dev/null +++ b/unix/as.i386/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.i386/aclrs.c b/unix/as.i386/aclrs.c new file mode 100644 index 00000000..2dc2da7a --- /dev/null +++ b/unix/as.i386/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.i386/amods.s b/unix/as.i386/amods.s new file mode 100644 index 00000000..1356c199 --- /dev/null +++ b/unix/as.i386/amods.s @@ -0,0 +1,68 @@ + .file "amods.o" +/# +/# AMODS -- Assembler version of the VOPS routine to work around a compiler +/* bug. +/# + .data + .data + .bss + .data + .align 4 + .bss + .align 4 +VAR_SEG1: .set .,.+4 + .text + .globl amods_ + .set LF1,12 +amods_: + pushl %ebp + movl %esp,%ebp + subl $12,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 20(%ebp),%eax + movl (%eax),%ebx + leal -1(%ebx),%eax + movl %eax,-8(%ebp) + xorl %eax,%eax + cmpl %eax,-8(%ebp) + jl .LE1 + movl 12(%ebp),%eax + leal -2(%eax),%eax + movl %eax,%esi + movl 8(%ebp),%eax + leal -2(%eax),%eax + movl %eax,-12(%ebp) + movl 16(%ebp),%eax + leal -2(%eax),%eax + movl %eax,%edi + movl $2,%ebx + addl %ebx,%esi + addl %ebx,%edi + addl -12(%ebp),%ebx +.L77003: + movw (%ebx),%ax + cwtd + idivw (%esi) /# buggy code in original + movw %ax,(%edi) /# + movl -8(%ebp),%eax + addl $2,%ebx + addl $2,%edi + addl $2,%esi + decl %eax + movl %eax,-8(%ebp) + testl %eax,%eax + jge .L77003 +.LE1: +/ASMQ + movl -24(%ebp),%ebx + movl -20(%ebp),%esi + movl -16(%ebp),%edi +/ASMEND0 + leave + ret +/FUNCEND + + .data + .text diff --git a/unix/as.i386/amovc.c b/unix/as.i386/amovc.c new file mode 100644 index 00000000..1eecb74b --- /dev/null +++ b/unix/as.i386/amovc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.i386/amovd.c b/unix/as.i386/amovd.c new file mode 100644 index 00000000..a56f3c09 --- /dev/null +++ b/unix/as.i386/amovd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.i386/amovi.c b/unix/as.i386/amovi.c new file mode 100644 index 00000000..930f93ae --- /dev/null +++ b/unix/as.i386/amovi.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.i386/amovl.c b/unix/as.i386/amovl.c new file mode 100644 index 00000000..e125c081 --- /dev/null +++ b/unix/as.i386/amovl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.i386/amovr.c b/unix/as.i386/amovr.c new file mode 100644 index 00000000..68abfd24 --- /dev/null +++ b/unix/as.i386/amovr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.i386/amovs.c b/unix/as.i386/amovs.c new file mode 100644 index 00000000..2864f699 --- /dev/null +++ b/unix/as.i386/amovs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.i386/bytmov.c b/unix/as.i386/bytmov.c new file mode 100644 index 00000000..8c5bb351 --- /dev/null +++ b/unix/as.i386/bytmov.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + bcopy ((char *)a + (*aoff-1), (char *)b + (*boff-1), *nbytes); +} diff --git a/unix/as.i386/ieee.gx b/unix/as.i386/ieee.gx new file mode 100644 index 00000000..619271fc --- /dev/null +++ b/unix/as.i386/ieee.gx @@ -0,0 +1,318 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # S386=2, 1 on other Suns +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemap$t (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.i386/ieeed.x b/unix/as.i386/ieeed.x new file mode 100644 index 00000000..6cdcf0bc --- /dev/null +++ b/unix/as.i386/ieeed.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # S386=2, 1 on other Suns + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapd (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.i386/ieeer.x b/unix/as.i386/ieeer.x new file mode 100644 index 00000000..ab4fee53 --- /dev/null +++ b/unix/as.i386/ieeer.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapr (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.i386/zsvjmp.s b/unix/as.i386/zsvjmp.s new file mode 100644 index 00000000..cdec4cf5 --- /dev/null +++ b/unix/as.i386/zsvjmp.s @@ -0,0 +1,45 @@ + .file "zsvjmp.s" + +/# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +/# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +/# the registers, effecting a call in the context of the procedure which +/# originally called ZSVJMP, but with the new status code. These are Fortran +/# callable procedures. +/# +/# zsvjmp (jmp_buf, status) # (returns status) +/# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +/# +/# These routines are directly comparable to the UNIX setjmp/longjmp, except +/# that they are Fortran callable kernel routines, i.e., trailing underscore, +/# call by reference, and no function returns. ZSVJMP requires an assembler +/# jacket routine to avoid modifying the call stack, but relies upon setjmp +/# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +/# calling longjmp to do the restore. In these routines, JMP_BUF consists +/# of one longword containing the address of the STATUS variable, followed +/# by the "jmp_buf" used by setjmp/longjmp. +/# +/# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl zsvjmp_ + + /# The following has nothing to do with ZSVJMP, and is included here + /# only because this assembler module is loaded with every process. + /# This code sets the value of the symbol MEM (the VOS or Fortran Mem + /# common) to zero, setting the origin for IRAF pointers to zero + /# rather than some arbitrary value, and ensuring that the MEM common + /# is aligned for all datatypes as well as page aligned. A further + /# advantage is that references to NULL pointers are likely to cause a + /# memory violation. + + .globl mem_ + mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx /# &jmpbuf to ECX + movl 8(%esp), %eax /# &status to EAX + movl %eax, (%ecx) /# store &status in jmpbuf[0] + clrl (%eax) /# zero the value of status + addl $4, %ecx /# change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) /# ... + jmp setjmp /# let setjmp do the rest diff --git a/unix/as.i386/zzdebug.c b/unix/as.i386/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.i386/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.linux/aclrb.c b/unix/as.linux/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.linux/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.linux/aclrc.c b/unix/as.linux/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.linux/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux/aclrd.c b/unix/as.linux/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.linux/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux/aclri.c b/unix/as.linux/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.linux/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux/aclrl.c b/unix/as.linux/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.linux/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux/aclrr.c b/unix/as.linux/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.linux/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux/aclrs.c b/unix/as.linux/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.linux/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux/amovc.c b/unix/as.linux/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.linux/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux/amovd.c b/unix/as.linux/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.linux/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux/amovi.c b/unix/as.linux/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.linux/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux/amovl.c b/unix/as.linux/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.linux/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux/amovr.c b/unix/as.linux/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.linux/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux/amovs.c b/unix/as.linux/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.linux/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux/bytmov.c b/unix/as.linux/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.linux/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.linux/ieee.gx b/unix/as.linux/ieee.gx new file mode 100644 index 00000000..d08b79ad --- /dev/null +++ b/unix/as.linux/ieee.gx @@ -0,0 +1,420 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +real fval +int ival[1] +$else +double fval +int ival[2] +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +$if (datatype == r) +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / +$else +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ +$endif + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end + + +$if (datatype == r) + +# IEEE_SIGMASK, IEEE_SIGRESTORE -- Routines for masking IEEE exceptions. +# +# ieee_sigmask() +# ieee_sigrestore() +# +# These routines are meant to be used only internally by the routines in +# this file. iee_sigmask saves the current IEEE FPU exception mask, and +# sets a new mask which masks the invalid operand exception. This is +# necessary to permit the routines in this file to handle NaN values without +# raising the IEEE invalid operand exception. iee_sigrestore restores +# the original exception mask. These routines are meant to be called as +# pairs to temporarily block the invalid operand exception within an IEEE +# conversion routine. + +procedure ieee_sigmask() +int fpucw +common /ieesig/ fpucw +begin + call gfpucw (fpucw) + call sfpucw (or (fpucw, 1)) +end + +procedure ieee_sigrestore() +int fpucw +common /ieesig/ fpucw +begin + call sfpucw (fpucw) +end + +$endif diff --git a/unix/as.linux/ieeed.x b/unix/as.linux/ieeed.x new file mode 100644 index 00000000..1670fd8d --- /dev/null +++ b/unix/as.linux/ieeed.x @@ -0,0 +1,355 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +double fval +int ival[2] + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7FF00000X +end + + diff --git a/unix/as.linux/ieeer.x b/unix/as.linux/ieeer.x new file mode 100644 index 00000000..b262f1b0 --- /dev/null +++ b/unix/as.linux/ieeer.x @@ -0,0 +1,385 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +real fval +int ival[1] + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7F800000X +end + + + +# IEEE_SIGMASK, IEEE_SIGRESTORE -- Routines for masking IEEE exceptions. +# +# ieee_sigmask() +# ieee_sigrestore() +# +# These routines are meant to be used only internally by the routines in +# this file. iee_sigmask saves the current IEEE FPU exception mask, and +# sets a new mask which masks the invalid operand exception. This is +# necessary to permit the routines in this file to handle NaN values without +# raising the IEEE invalid operand exception. iee_sigrestore restores +# the original exception mask. These routines are meant to be called as +# pairs to temporarily block the invalid operand exception within an IEEE +# conversion routine. + +procedure ieee_sigmask() +int fpucw +common /ieesig/ fpucw +begin + call gfpucw (fpucw) + call sfpucw (or (fpucw, 1)) +end + +procedure ieee_sigrestore() +int fpucw +common /ieesig/ fpucw +begin + call sfpucw (fpucw) +end + diff --git a/unix/as.linux/zrtadr.s b/unix/as.linux/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.linux/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.linux/zsvjmp.s b/unix/as.linux/zsvjmp.s new file mode 100644 index 00000000..2a88ca79 --- /dev/null +++ b/unix/as.linux/zsvjmp.s @@ -0,0 +1,73 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl zsvjmp_ + .globl sfpucw_ + .globl gfpucw_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + #.globl mem_ + #mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + movl $0, 8(%esp) # change arg2 to zero + jmp __sigsetjmp # let sigsetjmp do the rest + +gfpucw_: # Get fpucw: gfpucw_ (&cur_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp), %dx + movl %edx,(%eax) + movl %ebp, %esp + popl %ebp + ret + +sfpucw_: # Set fpucw: sfpucw_ (&new_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + movl (%eax), %eax + andl $0xf3f, %eax + fclex + movw %ax, 0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret diff --git a/unix/as.linux/zsvjmp.s.OLD b/unix/as.linux/zsvjmp.s.OLD new file mode 100644 index 00000000..01c26e58 --- /dev/null +++ b/unix/as.linux/zsvjmp.s.OLD @@ -0,0 +1,61 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl zsvjmp_ + .globl setfpucw + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + jmp __setjmp # let setjmp do the rest + +setfpucw: + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp),%eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp),%dx + andl $0xfffff0c0,%edx + andl $0xf3f,%eax + orl %eax,%edx + movw %dx,0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret diff --git a/unix/as.linux/zsvjmp.s.RH6 b/unix/as.linux/zsvjmp.s.RH6 new file mode 100644 index 00000000..983b2c5f --- /dev/null +++ b/unix/as.linux/zsvjmp.s.RH6 @@ -0,0 +1,62 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl zsvjmp_ + .globl setfpucw + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + movl $0, 8(%esp) # change arg2 to zero + jmp __sigsetjmp # let sigsetjmp do the rest + +setfpucw: + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp),%eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp),%dx + andl $0xfffff0c0,%edx + andl $0xf3f,%eax + orl %eax,%edx + movw %dx,0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret diff --git a/unix/as.linux/zsvjmp.s.SL40 b/unix/as.linux/zsvjmp.s.SL40 new file mode 100644 index 00000000..367f3728 --- /dev/null +++ b/unix/as.linux/zsvjmp.s.SL40 @@ -0,0 +1,72 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the SUN/UNIX 386i (80386) version of ZSVJMP. + + .globl zsvjmp_ + .globl sfpucw_ + .globl gfpucw_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx # &jmpbuf to ECX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%ecx) # store &status in jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %ecx # change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) # ... + jmp __setjmp # let setjmp do the rest + +gfpucw_: # Get fpucw: gfpucw_ (&cur_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp), %dx + movl %edx,(%eax) + movl %ebp, %esp + popl %ebp + ret + +sfpucw_: # Set fpucw: sfpucw_ (&new_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + movl (%eax), %eax + andl $0xf3f, %eax + fclex + movw %ax, 0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret diff --git a/unix/as.linux/zz.c b/unix/as.linux/zz.c new file mode 100644 index 00000000..68aa838b --- /dev/null +++ b/unix/as.linux/zz.c @@ -0,0 +1,10 @@ +/* Compile with gcc -S to get demo assembler code. + */ +zsvjmp_(buf,status) +int *buf; +int *status; +{ + *status = 0; + buf[0] = *status; + setjmp (&buf[1]); +} diff --git a/unix/as.linux/zzdebug.c b/unix/as.linux/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.linux/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.linux64/aclrb.c b/unix/as.linux64/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.linux64/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.linux64/aclrc.c b/unix/as.linux64/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.linux64/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/aclrd.c b/unix/as.linux64/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.linux64/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/aclri.c b/unix/as.linux64/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.linux64/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/aclrl.c b/unix/as.linux64/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.linux64/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/aclrr.c b/unix/as.linux64/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.linux64/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/aclrs.c b/unix/as.linux64/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.linux64/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/amovc.c b/unix/as.linux64/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.linux64/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/amovd.c b/unix/as.linux64/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.linux64/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/amovi.c b/unix/as.linux64/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.linux64/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/amovl.c b/unix/as.linux64/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.linux64/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/amovr.c b/unix/as.linux64/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.linux64/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/amovs.c b/unix/as.linux64/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.linux64/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linux64/bytmov.c b/unix/as.linux64/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.linux64/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.linux64/ieee.gx b/unix/as.linux64/ieee.gx new file mode 100644 index 00000000..9039b3d2 --- /dev/null +++ b/unix/as.linux64/ieee.gx @@ -0,0 +1,391 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (ival, val) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (val, ival) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.linux64/ieeed.x b/unix/as.linux64/ieeed.x new file mode 100644 index 00000000..167b0561 --- /dev/null +++ b/unix/as.linux64/ieeed.x @@ -0,0 +1,356 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (ival, val) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (val, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.linux64/ieeer.x b/unix/as.linux64/ieeer.x new file mode 100644 index 00000000..59ce8566 --- /dev/null +++ b/unix/as.linux64/ieeer.x @@ -0,0 +1,345 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (ival, val) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (val, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.linux64/zrtadr.s b/unix/as.linux64/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.linux64/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.linux64/zsvjmp.s b/unix/as.linux64/zsvjmp.s new file mode 100644 index 00000000..7a952958 --- /dev/null +++ b/unix/as.linux64/zsvjmp.s @@ -0,0 +1,48 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the FreeBSD (x86) version of ZSVJMP. +# Modified to remove leading underscore for ELF (Jan99). + + #.globl _zsvjmp_ + .globl zsvjmp_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + #.globl mem_ + #mem_ = 0 + .globl _mem_ + _mem_ = 0 + +zsvjmp_: + # %rsi ... &status %rdi ... &jumpbuf + movq %rsi, (%rdi) # store &status in jmpbuf[0] + movl $0, (%rsi) # zero the value of status + addq $8, %rdi # change point to &jmpbuf[1] + movl $0, %esi # change arg2 to zero + jmp __sigsetjmp # let sigsetjmp do the rest + diff --git a/unix/as.linux64/zsvjmp.s.BAD b/unix/as.linux64/zsvjmp.s.BAD new file mode 100644 index 00000000..74107830 --- /dev/null +++ b/unix/as.linux64/zsvjmp.s.BAD @@ -0,0 +1,60 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the FreeBSD (x86) version of ZSVJMP. +# Modified to remove leading underscore for ELF (Jan99). + + .globl _zsvjmp_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + .globl _mem_ + _mem_ = 0 + +_zsvjmp_: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 12(%ebp), %eax + movl $0, (%eax) + movl 12(%ebp), %eax + movl (%eax), %edx + movl 8(%ebp), %eax + movl %edx, (%eax) + movl 8(%ebp), %eax + addl $4, %eax + movl %eax, (%esp) + call L_setjmp$stub + leave + ret + .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5 +L_setjmp$stub: + .indirect_symbol _setjmp + hlt ; hlt ; hlt ; hlt ; hlt + .subsections_via_symbols diff --git a/unix/as.linux64/zsvjmp_c b/unix/as.linux64/zsvjmp_c new file mode 100644 index 00000000..2b42a0de --- /dev/null +++ b/unix/as.linux64/zsvjmp_c @@ -0,0 +1,170 @@ +/* +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedusres. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +*/ + + +#ifdef I386 + +/* +asm("# Set the address of the MEM common to zero."); +asm(".globl mem_"); +asm(" mem_ = 0"); +*/ + +/* +#if defined(MACOSX) +asm(".globl _mem_"); +asm(" _mem_ = 0"); +#endif +*/ + +#if defined(LINUX) +asm(".text"); +asm(".globl zsvjmp_"); +asm("zsvjmp_:"); +asm(" movl 4(%esp), %ecx # &jmpbuf to ECX"); +asm(" movl 8(%esp), %eax # &status to EAX"); +asm(" movl %eax, (%ecx) # store &status in jmpbuf[0]"); +asm(" movl $0, (%eax) # zero the value of status"); +asm(" addl $4, %ecx # change stack to point to &jmpbuf[1]"); +asm(" movl %ecx, 4(%esp) # ..."); +asm(" movl $0, 8(%esp) # change arg2 to zero"); +asm(" jmp __sigsetjmp # let sigsetjmp do the rest"); +#endif /* LINUX */ + +#if (defined(CYGWIN) || defined(MACOSX)) +asm(".text"); +asm(".globl _zsvjmp_"); +asm("_zsvjmp_:"); +asm(" movl 4(%esp), %ecx # &jmpbuf to ECX"); +asm(" movl 8(%esp), %eax # &status to EAX"); +asm(" movl %eax, (%ecx) # store &status in jmpbuf[0]"); +asm(" movl $0, (%eax) # zero the value of status"); +asm(" addl $4, %ecx # change stack to point to &jmpbuf[1]"); +asm(" movl %ecx, 4(%esp) # ..."); +asm(" movl $0, 8(%esp) # change arg2 to zero"); +asm(" jmp _setjmp # let setjmp do the rest"); +#endif /* CYGWIN || MACOSX */ + +#endif /* I386 */ + + +#ifdef X86_64 + +/* +asm("# Set the address of the MEM common to zero."); +asm(".globl mem_"); +asm(" mem_ = 0"); +*/ + +#ifdef SPP_LP64 +/* LP64-SPP */ +asm(".text"); +asm(".globl zsvjmp_"); +asm("zsvjmp_:"); +asm(" # %rsi ... &status %rdi ... &jumpbuf"); +asm(" movq %rsi, (%rdi) # store &status in jmpbuf[0]"); +asm(" movl $0, (%rsi) # zero the value of status"); +asm(" addq $8, %rdi # change point to &jmpbuf[1]"); +asm(" movl $0, %esi # change arg2 to zero"); +asm(" jmp __sigsetjmp # let sigsetjmp do the rest"); +#else +/* ILP64-SPP */ +asm(".text"); +asm(".globl zsvjmp_"); +asm("zsvjmp_:"); +asm(" # %rsi ... &status %rdi ... &jumpbuf"); +asm(" movq %rsi, (%rdi) # store &status in jmpbuf[0]"); +asm(" movq $0, (%rsi) # zero the value of status"); +asm(" addq $8, %rdi # change point to &jmpbuf[1]"); +asm(" movl $0, %esi # change arg2 to zero"); +asm(" jmp __sigsetjmp # let sigsetjmp do the rest"); +#endif + +#endif /* X86_64 */ + + +#ifdef POWERPC + +#if defined(LINUX) +/* +asm(" # Set the address of the MEM common to zero."); +asm(" .globl mem_"); +asm(" mem_ = 0"); +*/ +asm(".text"); +asm(" # ZSVJMP -- SPP callable SETJMP."); +asm(" .align 2"); +asm(" .globl zsvjmp_"); +asm(" .type zsvjmp_,@function"); +asm("zsvjmp_:"); +asm(" # R3 = buf, R4 = &status"); +asm(" li r11,0 # r11 = 0"); +asm(" stw r11,0(r4) # set *status to zero"); +asm(" stw r4,0(r3) # store &status in buf[0]"); +asm(" addi r3,r3,4 # reference buf[1] for sigsetjmp"); +asm(" li r4,0 # zero signal mask for sigsetjmp"); +asm(" b __sigsetjmp"); +#endif /* LINUX */ + +#if defined(MACOSX) +/* +asm(" # Set the address of the MEM common to zero."); +asm(" .globl _mem_"); +asm(" _mem_ = 0"); +*/ +asm(".text"); +asm(" # ZSVJMP -- SPP callable SETJMP."); +asm(" .align 2"); +asm(" .globl _zsvjmp_"); +asm("_zsvjmp_:"); +asm(" # R3 = buf, R4 = &status"); +asm(" li r11,0 # r11 = 0"); +asm(" stw r11,0(r4) # set *status to zero"); +asm(" stw r4,0(r3) # store &status in buf[0]"); +asm(" addi r3,r3,4 # reference buf[1] for setjmp"); +asm(" b L_setjmp$stub"); +asm("L2:"); +asm(" lwz r1,0(r1)"); +asm(" lwz r0,8(r1)"); +asm(" mtlr r0"); +asm(" lmw r30,-8(r1)"); +asm(" blr"); +asm(""); +asm(" # The setjmp code is only available in a dynamic library on 10.1."); +asm(".picsymbol_stub"); +asm("L_setjmp$stub:"); +asm(" .indirect_symbol _setjmp"); +asm(" mflr r0"); +asm(" bcl 20,31,L1$pb"); +asm("L1$pb:"); +asm(" mflr r11"); +asm(" addis r11,r11,ha16(L1$lz-L1$pb)"); +asm(" mtlr r0"); +asm(" lwz r12,lo16(L1$lz-L1$pb)(r11)"); +asm(" mtctr r12"); +asm(" addi r11,r11,lo16(L1$lz-L1$pb)"); +asm(" bctr"); +asm(".lazy_symbol_pointer"); +asm("L1$lz:"); +asm(" .indirect_symbol _setjmp"); +asm(" .long dyld_stub_binding_helper"); +#endif /* MACOSX */ + +#endif /* POWERPC */ diff --git a/unix/as.linux64/zsvjmp_demo.c b/unix/as.linux64/zsvjmp_demo.c new file mode 100644 index 00000000..3dd2d90e --- /dev/null +++ b/unix/as.linux64/zsvjmp_demo.c @@ -0,0 +1,13 @@ +/* Compile with gcc -S to get demo assembler code. + */ +#include + +#define import_spp +#include + +int zsvjmp_( XPOINTER *buf, XINT *status ) +{ + *status = 0; + ((XINT **)buf)[0] = status; + return sigsetjmp ((void *)((XINT **)buf+1),0); +} diff --git a/unix/as.linux64/zzdebug.c b/unix/as.linux64/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.linux64/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.linuxppc/README b/unix/as.linuxppc/README new file mode 100644 index 00000000..d19b2a3e --- /dev/null +++ b/unix/as.linuxppc/README @@ -0,0 +1,68 @@ +# LinuxPPC Assembler - LinuxPPC 2000, Aug 2000 + + .file "zz.c" +# zsvjmp_(buf,status) +# int *buf; +# int *status; +# { +# *status = 0; +# buf[0] = *status; +# setjmp (&buf[1]); +# } + +gcc2_compiled.: + .section ".text" + .align 2 + .globl zsvjmp_ + .type zsvjmp_,@function + + # Addressing: 12(31) means effective address (EA) is r31+12 + # lwz 9,12(31) means move value at EA to r9 + + # REGISTERS: r1 = stack pointer, r31 = frame pointer, r3+ = args + # Function always saves r1, r31 on stack. Sets up frame with + # required auto storage. Saves LR as well if any functions will + # be called. + +zsvjmp_: + # -- Push old r1 on stack; start new stack frame at r1 + stwu 1,-32(1) # Store word with update (push on stack) + # EA = r1-32; (r1) -> (EA), EA -> r1 + + # -- Save LR, r31 in stack frame + mflr 0 # Move from Link Register: LR -> r0 + stw 31,28(1) # Store word: r31 -> r1+28 + stw 0,36(1) # Store word: r0 -> r1+36 + + # -- Save r3 (arg1), r4 (arg2) on stack + mr 31,1 # Move register: r1 -> r31 + stw 3,8(31) # r3 -> r31+8 + stw 4,12(31) # r4 -> r31+12 + + # -- *status = 0; + lwz 9,12(31) # Load word and zero: (r31+12) -> r9 + li 0,0 # Load zero: 0 -> r0 + stw 0,0(9) # Store: r0 -> r9+0 + + # -- buf[0] = *status; + lwz 9,8(31) # buf -> r9 + lwz 11,12(31) # status -> r11 + lwz 0,0(11) # *status -> r0 + stw 0,0(9) # r0 -> buf[0] + + # -- setjmp (&buf[1]); + lwz 9,8(31) # buf -> r9 + addi 0,9,4 # Add immediate; r9+4 -> r0 + mr 3,0 # R3 is first arg + crxor 6,6,6 # Condition reg XOR: xor(b6,b6) -> b6 + bl setjmp # Branch to setjmp; addr(.L2) -> LR +.L2: + lwz 11,0(1) # load old r1 into r11 + lwz 0,4(11) # load old LR into r0 + mtlr 0 # restore return addr to LR + lwz 31,-4(11) # restore old r31 + mr 1,11 # restore old r1 + blr # Branch unconditionally (to LR addr) +.Lfe1: + .size zsvjmp_,.Lfe1-zsvjmp_ + .ident "GCC: (GNU) 2.95.2 19991024 (release/franzo)" diff --git a/unix/as.linuxppc/aclrb.c b/unix/as.linuxppc/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.linuxppc/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.linuxppc/aclrc.c b/unix/as.linuxppc/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.linuxppc/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/aclrd.c b/unix/as.linuxppc/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.linuxppc/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/aclri.c b/unix/as.linuxppc/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.linuxppc/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/aclrl.c b/unix/as.linuxppc/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.linuxppc/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/aclrr.c b/unix/as.linuxppc/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.linuxppc/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/aclrs.c b/unix/as.linuxppc/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.linuxppc/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/amovc.c b/unix/as.linuxppc/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.linuxppc/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/amovd.c b/unix/as.linuxppc/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.linuxppc/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/amovi.c b/unix/as.linuxppc/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.linuxppc/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/amovl.c b/unix/as.linuxppc/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.linuxppc/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/amovr.c b/unix/as.linuxppc/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.linuxppc/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/amovs.c b/unix/as.linuxppc/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.linuxppc/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.linuxppc/bytmov.c b/unix/as.linuxppc/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.linuxppc/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.linuxppc/ieee.gx b/unix/as.linuxppc/ieee.gx new file mode 100644 index 00000000..61a7caf0 --- /dev/null +++ b/unix/as.linuxppc/ieee.gx @@ -0,0 +1,420 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +real fval +int ival[1] +$else +double fval +int ival[2] +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +$if (datatype == r) +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / +$else +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ +$endif + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end + + +$if (datatype == r) + +# IEEE_SIGMASK, IEEE_SIGRESTORE -- Routines for masking IEEE exceptions. +# +# ieee_sigmask() +# ieee_sigrestore() +# +# These routines are meant to be used only internally by the routines in +# this file. iee_sigmask saves the current IEEE FPU exception mask, and +# sets a new mask which masks the invalid operand exception. This is +# necessary to permit the routines in this file to handle NaN values without +# raising the IEEE invalid operand exception. iee_sigrestore restores +# the original exception mask. These routines are meant to be called as +# pairs to temporarily block the invalid operand exception within an IEEE +# conversion routine. + +procedure ieee_sigmask() +int fpucw +common /ieesig/ fpucw +begin + call gfpucw (fpucw) + call sfpucw (or (fpucw, 80X)) +end + +procedure ieee_sigrestore() +int fpucw +common /ieesig/ fpucw +begin + call sfpucw (fpucw) +end + +$endif diff --git a/unix/as.linuxppc/ieeed.x b/unix/as.linuxppc/ieeed.x new file mode 100644 index 00000000..1670fd8d --- /dev/null +++ b/unix/as.linuxppc/ieeed.x @@ -0,0 +1,355 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +double fval +int ival[2] + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7FF00000X +end + + diff --git a/unix/as.linuxppc/ieeer.x b/unix/as.linuxppc/ieeer.x new file mode 100644 index 00000000..5d308876 --- /dev/null +++ b/unix/as.linuxppc/ieeer.x @@ -0,0 +1,385 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + call ieee_sigmask() + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + call ieee_sigrestore() + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + call ieee_sigrestore() + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + call ieee_sigmask() + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + call ieee_sigrestore() + } + } + + +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) { + call ieee_sigmask() + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + call ieee_sigrestore() + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + call ieee_sigmask() + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + call ieee_sigrestore() + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +real fval +int ival[1] + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7F800000X +end + + + +# IEEE_SIGMASK, IEEE_SIGRESTORE -- Routines for masking IEEE exceptions. +# +# ieee_sigmask() +# ieee_sigrestore() +# +# These routines are meant to be used only internally by the routines in +# this file. iee_sigmask saves the current IEEE FPU exception mask, and +# sets a new mask which masks the invalid operand exception. This is +# necessary to permit the routines in this file to handle NaN values without +# raising the IEEE invalid operand exception. iee_sigrestore restores +# the original exception mask. These routines are meant to be called as +# pairs to temporarily block the invalid operand exception within an IEEE +# conversion routine. + +procedure ieee_sigmask() +int fpucw +common /ieesig/ fpucw +begin + call gfpucw (fpucw) + call sfpucw (or (fpucw, 80X)) +end + +procedure ieee_sigrestore() +int fpucw +common /ieesig/ fpucw +begin + call sfpucw (fpucw) +end + diff --git a/unix/as.linuxppc/zsvjmp.s b/unix/as.linuxppc/zsvjmp.s new file mode 100644 index 00000000..c6a4fdd6 --- /dev/null +++ b/unix/as.linuxppc/zsvjmp.s @@ -0,0 +1,112 @@ +# ZSVJMP.S -- LinuxPPC version, August 2000. + + .file "zsvjmp.s" + .ident "NOAO/IRAF 21Aug2000 DCT" + .section ".text" + .align 2 + + # ZSVJMP -- SPP callable SETJMP. + + .globl zsvjmp_ + .type zsvjmp_,@function +zsvjmp_: + # R3 = buf, R4 = &status + li 11,0 # r11 = 0 + stw 11,0(4) # set *status to zero + stw 4,0(3) # store &status in buf[0] + addi 3,3,4 # reference buf[1] for sigsetjmp + li 4,0 # zero signal mask for sigsetjmp + b __sigsetjmp +.Lfe1: + .size zsvjmp_,.Lfe1-zsvjmp_ + + # Set the address of the MEM common to zero. + .globl mem_ + mem_ = 0 + + + # GFPUCW -- Get the FPU control register. + .align 2 + .globl gfpucw_ + .type gfpucw_,@function +gfpucw_: + stwu 1, -32(1) + stw 31, 28(1) + mr 31, 1 + stw 3, 8(31) + mffs 0 + stfd 0, 16(31) + lwz 0, 20(31) + mr 9, 0 + lwz 9, 8(31) + stw 0, 0(9) +.L3: + lwz 11, 0(1) + lwz 31, -4(11) + mr 1, 11 + blr +.Lfe2: + .size gfpucw_, .Lfe2-gfpucw_ + + + # SFPUCW -- Set the FPU control register. + + .align 2 + .globl sfpucw_ + .type sfpucw_,@function +sfpucw_: + stwu 1, -32(1) + stw 31, 28(1) + mr 31, 1 + stw 3, 8(31) + lis 0, 0xfff8 + stw 0, 16(31) + lwz 9, 8(31) + lwz 0, 0(9) + stw 0, 20(31) + lfd 0, 16(31) + mtfsf 255, 0 +.L4: + lwz 11, 0(1) + lwz 31, -4(11) + mr 1, 11 + blr +.Lfe3: + .size sfpucw_, .Lfe3-sfpucw_ + + + # CFPUCW -- Clear the exception flags in the FPU control register. + # So far I have not been able to find a way to make this work, at + # least with the current version of LinuxPPC. All of the instructions + # below fail, raising another SIGFPE if an exception condition is + # already present. ANY instruction involving the FPU will raise + # SIGFPE once the exception condition exists. Also, LinuxPPC + # sigaction does not block SIGFPE in the called exception handler, + # contrary to the manpage. It appears that the exception handling + # in the kernel needs to clear the exception condition but is not + # doing so. Supervisor level instructions appear to be required to + # clear the exception condition, so this has to be done in the kernel + # before the user level signal handler is called. + + .align 2 + .globl cfpucw_ + .type cfpucw_,@function +cfpucw_: + stwu 1, -32(1) + stw 31, 28(1) + mr 31, 1 + #mcrfs 0, 0 + #mtfsfi 0, 0 + #mtfsfi 3, 0 + #mtfsfi 3, 0 + #mtfsfi 5, 0 + #mtfsfb0 3 + #mtfsfb0 5 + #mtfsfb0 7 +.L5: + lwz 11, 0(1) + lwz 31, -4(11) + mr 1, 11 + blr +.Lfe4: + .size sfpucw_, .Lfe4-cfpucw_ diff --git a/unix/as.linuxppc/zz.c b/unix/as.linuxppc/zz.c new file mode 100644 index 00000000..68aa838b --- /dev/null +++ b/unix/as.linuxppc/zz.c @@ -0,0 +1,10 @@ +/* Compile with gcc -S to get demo assembler code. + */ +zsvjmp_(buf,status) +int *buf; +int *status; +{ + *status = 0; + buf[0] = *status; + setjmp (&buf[1]); +} diff --git a/unix/as.linuxppc/zzdebug.c b/unix/as.linuxppc/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.linuxppc/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.macintel/aclrb.c b/unix/as.macintel/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.macintel/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.macintel/aclrc.c b/unix/as.macintel/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.macintel/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/aclrd.c b/unix/as.macintel/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.macintel/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/aclri.c b/unix/as.macintel/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.macintel/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/aclrl.c b/unix/as.macintel/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.macintel/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/aclrr.c b/unix/as.macintel/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.macintel/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/aclrs.c b/unix/as.macintel/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.macintel/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/amovc.c b/unix/as.macintel/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.macintel/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/amovd.c b/unix/as.macintel/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.macintel/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/amovi.c b/unix/as.macintel/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.macintel/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/amovl.c b/unix/as.macintel/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.macintel/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/amovr.c b/unix/as.macintel/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.macintel/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/amovs.c b/unix/as.macintel/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.macintel/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macintel/bytmov.c b/unix/as.macintel/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.macintel/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.macintel/f2c.tar.gz b/unix/as.macintel/f2c.tar.gz new file mode 100644 index 00000000..65e090c6 Binary files /dev/null and b/unix/as.macintel/f2c.tar.gz differ diff --git a/unix/as.macintel/ieee.gx b/unix/as.macintel/ieee.gx new file mode 100644 index 00000000..9039b3d2 --- /dev/null +++ b/unix/as.macintel/ieee.gx @@ -0,0 +1,391 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (ival, val) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (val, ival) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.macintel/ieeed.x b/unix/as.macintel/ieeed.x new file mode 100644 index 00000000..167b0561 --- /dev/null +++ b/unix/as.macintel/ieeed.x @@ -0,0 +1,356 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (ival, val) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (val, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.macintel/ieeer.x b/unix/as.macintel/ieeer.x new file mode 100644 index 00000000..59ce8566 --- /dev/null +++ b/unix/as.macintel/ieeer.x @@ -0,0 +1,345 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (ival, val) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (val, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.macintel/zrtadr.s b/unix/as.macintel/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.macintel/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.macintel/zsvjmp.s b/unix/as.macintel/zsvjmp.s new file mode 100644 index 00000000..1ea8b4fa --- /dev/null +++ b/unix/as.macintel/zsvjmp.s @@ -0,0 +1,46 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the FreeBSD (x86) version of ZSVJMP. +# Modified to remove leading underscore for ELF (Jan99). + + .globl _zsvjmp_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl _mem_ + .abs _mem_, 0 + #_mem_ = 0 + +_zsvjmp_: + # %rsi ... &status %rdi ... &jumpbuf + movq %rsi, (%rdi) # store &status in jmpbuf[0] + movl $0, (%rsi) # zero the value of status + addq $8, %rdi # change point to &jmpbuf[1] + movl $0, %esi # change arg2 to zero + jmp _sigsetjmp # let sigsetjmp do the rest + diff --git a/unix/as.macintel/zsvjmp.s.bak b/unix/as.macintel/zsvjmp.s.bak new file mode 100644 index 00000000..781d4a86 --- /dev/null +++ b/unix/as.macintel/zsvjmp.s.bak @@ -0,0 +1,59 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the FreeBSD (x86) version of ZSVJMP. +# Modified to remove leading underscore for ELF (Jan99). + + .globl _zsvjmp_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + .globl _mem_ + _mem_ = 0 + +# *status = 0; +# buf[0] = &status; +# setjmp (&buf[1]); + + .text +_zsvjmp_: + movl 4(%esp), %edx # &jmpbuf to EDX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%edx) # store value-of &status in &jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %edx # change stack to point to &jmpbuf[1] + movl %edx, 4(%esp) + jmp L_setjmp$stub + leave + ret + .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5 +L_setjmp$stub: + .indirect_symbol _setjmp + hlt ; hlt ; hlt ; hlt ; hlt + .subsections_via_symbols diff --git a/unix/as.macintel/zz_exit.c b/unix/as.macintel/zz_exit.c new file mode 100644 index 00000000..bf906de9 --- /dev/null +++ b/unix/as.macintel/zz_exit.c @@ -0,0 +1,5 @@ +exit_(s) +int *s; +{ + exit (*s); +} diff --git a/unix/as.macintel/zz_zsvjmp.c b/unix/as.macintel/zz_zsvjmp.c new file mode 100644 index 00000000..a417f039 --- /dev/null +++ b/unix/as.macintel/zz_zsvjmp.c @@ -0,0 +1,17 @@ +#include + +/* Compile with gcc -S to get demo assembler code. In the actual ZSVJMP we + * need to execute basically these three lines of code but in the context of + * the routine calling the zsvjmp, so the stack needs to be adjusted + * accordingly (i.e. the assembler from this code WILL NOT work since the + * ZDOJMP will return here, and not the parent routine). + */ + +zsvjmp_(buf,status) +int *buf; +int *status; +{ + *status = 0; + buf[0] = *status; + setjmp (&buf[1]); +} diff --git a/unix/as.macintel/zzdebug.c b/unix/as.macintel/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.macintel/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.macosx/README b/unix/as.macosx/README new file mode 100644 index 00000000..d19b2a3e --- /dev/null +++ b/unix/as.macosx/README @@ -0,0 +1,68 @@ +# LinuxPPC Assembler - LinuxPPC 2000, Aug 2000 + + .file "zz.c" +# zsvjmp_(buf,status) +# int *buf; +# int *status; +# { +# *status = 0; +# buf[0] = *status; +# setjmp (&buf[1]); +# } + +gcc2_compiled.: + .section ".text" + .align 2 + .globl zsvjmp_ + .type zsvjmp_,@function + + # Addressing: 12(31) means effective address (EA) is r31+12 + # lwz 9,12(31) means move value at EA to r9 + + # REGISTERS: r1 = stack pointer, r31 = frame pointer, r3+ = args + # Function always saves r1, r31 on stack. Sets up frame with + # required auto storage. Saves LR as well if any functions will + # be called. + +zsvjmp_: + # -- Push old r1 on stack; start new stack frame at r1 + stwu 1,-32(1) # Store word with update (push on stack) + # EA = r1-32; (r1) -> (EA), EA -> r1 + + # -- Save LR, r31 in stack frame + mflr 0 # Move from Link Register: LR -> r0 + stw 31,28(1) # Store word: r31 -> r1+28 + stw 0,36(1) # Store word: r0 -> r1+36 + + # -- Save r3 (arg1), r4 (arg2) on stack + mr 31,1 # Move register: r1 -> r31 + stw 3,8(31) # r3 -> r31+8 + stw 4,12(31) # r4 -> r31+12 + + # -- *status = 0; + lwz 9,12(31) # Load word and zero: (r31+12) -> r9 + li 0,0 # Load zero: 0 -> r0 + stw 0,0(9) # Store: r0 -> r9+0 + + # -- buf[0] = *status; + lwz 9,8(31) # buf -> r9 + lwz 11,12(31) # status -> r11 + lwz 0,0(11) # *status -> r0 + stw 0,0(9) # r0 -> buf[0] + + # -- setjmp (&buf[1]); + lwz 9,8(31) # buf -> r9 + addi 0,9,4 # Add immediate; r9+4 -> r0 + mr 3,0 # R3 is first arg + crxor 6,6,6 # Condition reg XOR: xor(b6,b6) -> b6 + bl setjmp # Branch to setjmp; addr(.L2) -> LR +.L2: + lwz 11,0(1) # load old r1 into r11 + lwz 0,4(11) # load old LR into r0 + mtlr 0 # restore return addr to LR + lwz 31,-4(11) # restore old r31 + mr 1,11 # restore old r1 + blr # Branch unconditionally (to LR addr) +.Lfe1: + .size zsvjmp_,.Lfe1-zsvjmp_ + .ident "GCC: (GNU) 2.95.2 19991024 (release/franzo)" diff --git a/unix/as.macosx/aclrb.c b/unix/as.macosx/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.macosx/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.macosx/aclrc.c b/unix/as.macosx/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.macosx/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/aclrd.c b/unix/as.macosx/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.macosx/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/aclri.c b/unix/as.macosx/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.macosx/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/aclrl.c b/unix/as.macosx/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.macosx/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/aclrr.c b/unix/as.macosx/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.macosx/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/aclrs.c b/unix/as.macosx/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.macosx/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/amovc.c b/unix/as.macosx/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.macosx/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/amovd.c b/unix/as.macosx/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.macosx/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/amovi.c b/unix/as.macosx/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.macosx/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/amovl.c b/unix/as.macosx/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.macosx/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/amovr.c b/unix/as.macosx/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.macosx/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/amovs.c b/unix/as.macosx/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.macosx/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.macosx/bytmov.c b/unix/as.macosx/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.macosx/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.macosx/ieee.gx b/unix/as.macosx/ieee.gx new file mode 100644 index 00000000..64659cd3 --- /dev/null +++ b/unix/as.macosx/ieee.gx @@ -0,0 +1,391 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (ival, val) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (val, ival) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.macosx/ieeed.x b/unix/as.macosx/ieeed.x new file mode 100644 index 00000000..f29c1aa3 --- /dev/null +++ b/unix/as.macosx/ieeed.x @@ -0,0 +1,356 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (ival, val) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (val, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.macosx/ieeer.x b/unix/as.macosx/ieeer.x new file mode 100644 index 00000000..59ce8566 --- /dev/null +++ b/unix/as.macosx/ieeer.x @@ -0,0 +1,345 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (ival, val) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (val, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.macosx/zsvjmp.s b/unix/as.macosx/zsvjmp.s new file mode 100644 index 00000000..23308bf1 --- /dev/null +++ b/unix/as.macosx/zsvjmp.s @@ -0,0 +1,123 @@ +# ZSVJMP.S -- MacOS X version, September 2001, March 2002. + +.file "zsvjmp.s" + + # ZSVJMP -- SPP callable SETJMP. +.text + .align 2 + .globl _zsvjmp_ +_zsvjmp_: + # R3 = buf, R4 = &status + li r11,0 ; r11 = 0 + stw r11,0(r4) ; set *status to zero + stw r4,0(r3) ; store &status in buf[0] + addi r3,r3,4 ; reference buf[1] for setjmp + b L_setjmp$stub +L2: + lwz r1,0(r1) + lwz r0,8(r1) + mtlr r0 + lmw r30,-8(r1) + blr + + # The setjmp code is only available in a dynamic library on 10.1. +.picsymbol_stub +L_setjmp$stub: + .indirect_symbol _setjmp + mflr r0 + bcl 20,31,L1$pb +L1$pb: + mflr r11 + addis r11,r11,ha16(L1$lz-L1$pb) + mtlr r0 + lwz r12,lo16(L1$lz-L1$pb)(r11) + mtctr r12 + addi r11,r11,lo16(L1$lz-L1$pb) + bctr +.lazy_symbol_pointer +L1$lz: + .indirect_symbol _setjmp + .long dyld_stub_binding_helper +.text +.Lfe1: + + # Set the address of the MEM common to zero. + .globl _mem_ + _mem_ = 0 + + + # GFPSCR -- Return the contents of the PowerPC FPSCR register. +.text + .align 2 +.globl _gfpscr_ +_gfpscr_: + stmw r30,-8(r1) + stwu r1,-48(r1) + mr r30,r1 + mflr r0 + bcl 20,31,L2$pb +L2$pb: + mflr r31 + mtlr r0 + + mffs f0 + stfd f0, 16(r30) + lwz r0, 20(r30) + mr r3, r0 + + b L3 +L3: + lwz r1,0(r1) + lmw r30,-8(r1) + blr + + + # SFPSCR -- Set the contents of the PowerPC FPSCR register. +.text + .align 2 +.globl _sfpscr_ +_sfpscr_: + stmw r30,-8(r1) + stwu r1,-48(r1) + mr r30,r1 + mflr r0 + bcl 20,31,L4$pb +L4$pb: + mflr r31 + mtlr r0 + + lis r0, 0xfff8 + stw r0, 16(r30) + lwz r0, 0(r3) + stw r0, 20(r30) + lfd f0, 16(r30) + mtfsf 255, f0 + + b L5 +L5: + lwz r1,0(r1) + lmw r30,-8(r1) + blr + + + # GXER -- Return the contents of the PowerPC XER register. +.text + .align 2 +.globl _gxer_ +_gxer_: + stmw r30,-8(r1) + stwu r1,-48(r1) + mr r30,r1 + mflr r0 + bcl 20,31,L3$pb +L3$pb: + mflr r31 + mtlr r0 + + mfspr r3,1 + + b L4 +L4: + lwz r1,0(r1) + lmw r30,-8(r1) + blr diff --git a/unix/as.macosx/zsvjmp.s.OLD b/unix/as.macosx/zsvjmp.s.OLD new file mode 100644 index 00000000..7d631357 --- /dev/null +++ b/unix/as.macosx/zsvjmp.s.OLD @@ -0,0 +1,124 @@ +# ZSVJMP.S -- LinuxPPC version, September 2001. + +.file "zsvjmp.s" + + # ZSVJMP -- SPP callable SETJMP. +.text + .align 2 + .globl _zsvjmp_ +_zsvjmp_: + # R3 = buf, R4 = &status + li r11,0 ; r11 = 0 + stw r11,0(r4) ; set *status to zero + stw r4,0(r3) ; store &status in buf[0] + addi r3,r3,4 ; reference buf[1] for setjmp + b L_setjmp$stub +L2: + lwz r1,0(r1) + lwz r0,8(r1) + mtlr r0 + lmw r30,-8(r1) + blr + + # The setjmp code is only available in a dynamic library on 10.1. +.picsymbol_stub +L_setjmp$stub: + .indirect_symbol _setjmp + mflr r0 + bcl 20,31,L1$pb +L1$pb: + mflr r11 + addis r11,r11,ha16(L1$lz-L1$pb) + mtlr r0 + lwz r12,lo16(L1$lz-L1$pb)(r11) + mtctr r12 + addi r11,r11,lo16(L1$lz-L1$pb) + bctr +.lazy_symbol_pointer +L1$lz: + .indirect_symbol _setjmp + .long dyld_stub_binding_helper +.text +.Lfe1: + + # Set the address of the MEM common to zero. + .globl mem_ + mem_ = 0 + + + # GFPUCW -- Get the FPU control register. + .globl _gfpucw_ +_gfpucw_: + stwu r1, -32(r1) + stw r31, 28(r1) + mr r31, r1 + stw r3, 8(r31) + mffs f0 + stfd f0, 16(r31) + lwz r0, 20(r31) + mr r9, r0 + lwz r9, 8(r31) + stw r0, 0(r9) +.L3: + lwz r11, 0(r1) + lwz r31, -4(r11) + mr r1, r11 + blr +.Lfe2: + + + # SFPUCW -- Set the FPU control register. + + .globl _sfpucw_ +_sfpucw_: + stwu r1, -32(r1) + stw r31, 28(r1) + mr r31, r1 + stw r3, 8(r31) + lis r0, 0xfff8 + stw r0, 16(r31) + lwz r9, 8(r31) + lwz r0, 0(r9) + stw r0, 20(r31) + lfd f0, 16(r31) + mtfsf 255, f0 +.L4: + lwz r11, 0(r1) + lwz r31, -4(r11) + mr r1, r11 + blr +.Lfe3: + + + # CFPUCW -- Clear the exception flags in the FPU control register. + # So far I have not been able to find a way to make this work, at + # least with the current version of LinuxPPC. All of the instructions + # below fail, raising another SIGFPE if an exception condition is + # already present. ANY instruction involving the FPU will raise + # SIGFPE once the exception condition exists. Also, LinuxPPC + # sigaction does not block SIGFPE in the called exception handler, + # contrary to the manpage. It appears that the exception handling + # in the kernel needs to clear the exception condition but is not + # doing so. Supervisor level instructions appear to be required to + # clear the exception condition, so this has to be done in the kernel + # before the user level signal handler is called. + + .globl _cfpucw_ +_cfpucw_: + stwu r1, -32(r1) + stw r31, 28(r1) + mr r31, r1 + #mcrfs r0, 0 + #mtfsfi r0, 0 + #mtfsfi r3, 0 + #mtfsfi r3, 0 + #mtfsfi r5, 0 + #mtfsfb0 r3 + #mtfsfb0 r5 + #mtfsfb0 r7 +.L5: + lwz r11, 0(r1) + lwz r31, -4(r11) + mr r1, r11 + blr +.Lfe4: diff --git a/unix/as.macosx/zsvjmp_i386.s b/unix/as.macosx/zsvjmp_i386.s new file mode 100644 index 00000000..113fba8a --- /dev/null +++ b/unix/as.macosx/zsvjmp_i386.s @@ -0,0 +1,95 @@ + .file "zsvjmp.s" + +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. +# +# zsvjmp (jmp_buf, status) # (returns status) +# zdojmp (jmp_buf, status) # (passes status to zsvjmp) +# +# These routines are directly comparable to the UNIX setjmp/longjmp, except +# that they are Fortran callable kernel routines, i.e., trailing underscore, +# call by reference, and no function returns. ZSVJMP requires an assembler +# jacket routine to avoid modifying the call stack, but relies upon setjmp +# to do the real work. ZDOJMP is implemented as a portable C routine in OS, +# calling longjmp to do the restore. In these routines, JMP_BUF consists +# of one longword containing the address of the STATUS variable, followed +# by the "jmp_buf" used by setjmp/longjmp. +# +# This file contains the OS X Intel (x86) version of ZSVJMP. +# Modified to remove leading underscore for ELF (Jan99). + + .globl _zsvjmp_ + .globl _sfpucw_ + .globl _gfpucw_ + .globl _gfpusw_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the VOS or Fortran Mem + # common) to zero, setting the origin for IRAF pointers to zero + # rather than some arbitrary value, and ensuring that the MEM common + # is aligned for all datatypes as well as page aligned. A further + # advantage is that references to NULL pointers are likely to cause a + # memory violation. + + .globl mem_ + mem_ = 0 + .globl _mem_ + _mem_ = 0 + + .text +_zsvjmp_: + movl 4(%esp), %edx # &jmpbuf to EDX + movl 8(%esp), %eax # &status to EAX + movl %eax, (%edx) # store value-of &status in &jmpbuf[0] + movl $0, (%eax) # zero the value of status + addl $4, %edx # change stack to point to &jmpbuf[1] + movl %edx, 4(%esp) + jmp L_setjmp$stub + leave + ret +_gfpucw_: # Get fpucw: gfpucw_ (&cur_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + fnstcw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp), %dx + movl %edx,(%eax) + movl %ebp, %esp + popl %ebp + ret + +_sfpucw_: # Set fpucw: sfpucw_ (&new_fpucw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + movl (%eax), %eax + andl $0xf3f, %eax + fclex + movw %ax, 0xfffffffe(%ebp) + fldcw 0xfffffffe(%ebp) + leave + ret + +_gfpusw_: # Get fpusw: gfpusw_ (&cur_fpusw) + pushl %ebp + movl %esp,%ebp + subl $0x4,%esp + movl 0x8(%ebp), %eax + fstsw 0xfffffffe(%ebp) + movw 0xfffffffe(%ebp), %dx + movl %edx,(%eax) + movl %ebp, %esp + popl %ebp + ret + + .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5 +L_setjmp$stub: + .indirect_symbol _setjmp + hlt ; hlt ; hlt ; hlt ; hlt + .subsections_via_symbols diff --git a/unix/as.macosx/zsvjmp_ppc.s b/unix/as.macosx/zsvjmp_ppc.s new file mode 100644 index 00000000..23308bf1 --- /dev/null +++ b/unix/as.macosx/zsvjmp_ppc.s @@ -0,0 +1,123 @@ +# ZSVJMP.S -- MacOS X version, September 2001, March 2002. + +.file "zsvjmp.s" + + # ZSVJMP -- SPP callable SETJMP. +.text + .align 2 + .globl _zsvjmp_ +_zsvjmp_: + # R3 = buf, R4 = &status + li r11,0 ; r11 = 0 + stw r11,0(r4) ; set *status to zero + stw r4,0(r3) ; store &status in buf[0] + addi r3,r3,4 ; reference buf[1] for setjmp + b L_setjmp$stub +L2: + lwz r1,0(r1) + lwz r0,8(r1) + mtlr r0 + lmw r30,-8(r1) + blr + + # The setjmp code is only available in a dynamic library on 10.1. +.picsymbol_stub +L_setjmp$stub: + .indirect_symbol _setjmp + mflr r0 + bcl 20,31,L1$pb +L1$pb: + mflr r11 + addis r11,r11,ha16(L1$lz-L1$pb) + mtlr r0 + lwz r12,lo16(L1$lz-L1$pb)(r11) + mtctr r12 + addi r11,r11,lo16(L1$lz-L1$pb) + bctr +.lazy_symbol_pointer +L1$lz: + .indirect_symbol _setjmp + .long dyld_stub_binding_helper +.text +.Lfe1: + + # Set the address of the MEM common to zero. + .globl _mem_ + _mem_ = 0 + + + # GFPSCR -- Return the contents of the PowerPC FPSCR register. +.text + .align 2 +.globl _gfpscr_ +_gfpscr_: + stmw r30,-8(r1) + stwu r1,-48(r1) + mr r30,r1 + mflr r0 + bcl 20,31,L2$pb +L2$pb: + mflr r31 + mtlr r0 + + mffs f0 + stfd f0, 16(r30) + lwz r0, 20(r30) + mr r3, r0 + + b L3 +L3: + lwz r1,0(r1) + lmw r30,-8(r1) + blr + + + # SFPSCR -- Set the contents of the PowerPC FPSCR register. +.text + .align 2 +.globl _sfpscr_ +_sfpscr_: + stmw r30,-8(r1) + stwu r1,-48(r1) + mr r30,r1 + mflr r0 + bcl 20,31,L4$pb +L4$pb: + mflr r31 + mtlr r0 + + lis r0, 0xfff8 + stw r0, 16(r30) + lwz r0, 0(r3) + stw r0, 20(r30) + lfd f0, 16(r30) + mtfsf 255, f0 + + b L5 +L5: + lwz r1,0(r1) + lmw r30,-8(r1) + blr + + + # GXER -- Return the contents of the PowerPC XER register. +.text + .align 2 +.globl _gxer_ +_gxer_: + stmw r30,-8(r1) + stwu r1,-48(r1) + mr r30,r1 + mflr r0 + bcl 20,31,L3$pb +L3$pb: + mflr r31 + mtlr r0 + + mfspr r3,1 + + b L4 +L4: + lwz r1,0(r1) + lmw r30,-8(r1) + blr diff --git a/unix/as.macosx/zz.c b/unix/as.macosx/zz.c new file mode 100644 index 00000000..68aa838b --- /dev/null +++ b/unix/as.macosx/zz.c @@ -0,0 +1,10 @@ +/* Compile with gcc -S to get demo assembler code. + */ +zsvjmp_(buf,status) +int *buf; +int *status; +{ + *status = 0; + buf[0] = *status; + setjmp (&buf[1]); +} diff --git a/unix/as.macosx/zzdebug.c b/unix/as.macosx/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.macosx/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.mc68020/README b/unix/as.mc68020/README new file mode 100644 index 00000000..b931f6ca --- /dev/null +++ b/unix/as.mc68020/README @@ -0,0 +1,4 @@ +AS -- Routines specially optimized (not necessary in assembler) for the local +host machine. This is done without compromising the portability of the system +(see hlib$mkpkg.sf.*). + diff --git a/unix/as.mc68020/aclrb.c b/unix/as.mc68020/aclrb.c new file mode 100644 index 00000000..0ad8e775 --- /dev/null +++ b/unix/as.mc68020/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n); +} diff --git a/unix/as.mc68020/aclrc.c b/unix/as.mc68020/aclrc.c new file mode 100644 index 00000000..5f65a082 --- /dev/null +++ b/unix/as.mc68020/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/aclrd.c b/unix/as.mc68020/aclrd.c new file mode 100644 index 00000000..2336f5ee --- /dev/null +++ b/unix/as.mc68020/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/aclri.c b/unix/as.mc68020/aclri.c new file mode 100644 index 00000000..8dff5b08 --- /dev/null +++ b/unix/as.mc68020/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/aclrl.c b/unix/as.mc68020/aclrl.c new file mode 100644 index 00000000..0fc61dd4 --- /dev/null +++ b/unix/as.mc68020/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/aclrr.c b/unix/as.mc68020/aclrr.c new file mode 100644 index 00000000..78a56125 --- /dev/null +++ b/unix/as.mc68020/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/aclrs.c b/unix/as.mc68020/aclrs.c new file mode 100644 index 00000000..2dc2da7a --- /dev/null +++ b/unix/as.mc68020/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/amovc.c b/unix/as.mc68020/amovc.c new file mode 100644 index 00000000..90c59c15 --- /dev/null +++ b/unix/as.mc68020/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/amovd.c b/unix/as.mc68020/amovd.c new file mode 100644 index 00000000..6cca4dc6 --- /dev/null +++ b/unix/as.mc68020/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/amovi.c b/unix/as.mc68020/amovi.c new file mode 100644 index 00000000..5cd72417 --- /dev/null +++ b/unix/as.mc68020/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/amovl.c b/unix/as.mc68020/amovl.c new file mode 100644 index 00000000..2d8be93b --- /dev/null +++ b/unix/as.mc68020/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/amovr.c b/unix/as.mc68020/amovr.c new file mode 100644 index 00000000..62981c44 --- /dev/null +++ b/unix/as.mc68020/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/amovs.c b/unix/as.mc68020/amovs.c new file mode 100644 index 00000000..855d2882 --- /dev/null +++ b/unix/as.mc68020/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.mc68020/bytmov.c b/unix/as.mc68020/bytmov.c new file mode 100644 index 00000000..c02dd4c5 --- /dev/null +++ b/unix/as.mc68020/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if (a + *aoff != b + *boff) + bcopy ((char *)a + (*aoff-1), (char *)b + (*boff-1), *nbytes); +} diff --git a/unix/as.mc68020/ieee.gx b/unix/as.mc68020/ieee.gx new file mode 100644 index 00000000..fb3e34a4 --- /dev/null +++ b/unix/as.mc68020/ieee.gx @@ -0,0 +1,318 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemap$t (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.mc68020/ieeed.x b/unix/as.mc68020/ieeed.x new file mode 100644 index 00000000..081b4760 --- /dev/null +++ b/unix/as.mc68020/ieeed.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapd (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.mc68020/ieeer.x b/unix/as.mc68020/ieeer.x new file mode 100644 index 00000000..ab4fee53 --- /dev/null +++ b/unix/as.mc68020/ieeer.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapr (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.mc68020/ishift.s b/unix/as.mc68020/ishift.s new file mode 100644 index 00000000..cfd6d7e9 --- /dev/null +++ b/unix/as.mc68020/ishift.s @@ -0,0 +1,44 @@ +|# IAND, IOR, ISHIFT -- Bitwise boolean integer functions for the NCAR +|# package. The shift function must rotate the bits left and around +|# if the nbits to shift argument is positive, and zero fill at the left +|# if the shift is negative (right shift). +|# +|# (SUN/UNIX MC68xxx version) + +|# AND -- Bitwise boolean AND: C = AND (A, B) + .text + .globl _iand_ +_iand_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + andl a0@,d0 + rts + + +|# OR -- Bitwise boolean OR: C = OR (A, B) + .text + .globl _ior_ +_ior_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + orl a0@,d0 + rts + + +|# ISHIFT -- Bitwise shift: C = ISHIFT (A, NBITS), +=left + .text + .globl _ishift_ +_ishift_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + movl a0@,d1 + blt L1 + roll d1,d0 |# left rotate (high bits come in at right) + rts +L1: + negl d1 + lsrl d1,d0 |# logical shift right (zero at left) + rts diff --git a/unix/as.mc68020/zsvjmp.s b/unix/as.mc68020/zsvjmp.s new file mode 100644 index 00000000..efebe43e --- /dev/null +++ b/unix/as.mc68020/zsvjmp.s @@ -0,0 +1,37 @@ +|# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +|# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +|# the registers, effecting a call in the context of the procedure which +|# originally called ZSVJMP, but with the new status code. These are Fortran +|# callable procedures. +|# +|# (SUN/UNIX MC68xxx version) + + .text + .globl _zsvjmp_ + + |# The following has nothing to do with ZSVJMP, and is included here + |# only because this assembler module is loaded with every process. + |# This code sets the value of the symbol MEM (the Mem common) to zero, + |# setting the origin for IRAF pointers to zero rather than some + |# arbitrary value, and ensuring that the MEM common is aligned for + |# all datatypes as well as page aligned. A further advantage is that + |# references to NULL pointers will cause a memory violation. + + .globl _mem_ + _mem_ = 0 + + JMPBUF = 4 + STATUS = 8 + + |# The strategy here is to build on the services provided by the C + |# setjmp/longjmp. Note that we cannot do this by writing a C function + |# which calls setjmp, because the procedure which calls setjmp cannot + |# return before the longjmp is executed. + +_zsvjmp_: |# CALL ZSVJMP (JMPBUF, STATUS) + movl sp@(JMPBUF),a0 |# set A0 to point to jmp_buf + movl sp@(STATUS),a1 |# A1 = status variable + movl a1,a0@ |# JB[0] = addr of status variable + clrl a1@ |# return zero status + addql #4,sp@(JMPBUF) |# skip first cell of jmp_buf + jmp _setjmp |# let setjmp do the rest. diff --git a/unix/as.mc68020/zsvjmp.s.ORIG b/unix/as.mc68020/zsvjmp.s.ORIG new file mode 100644 index 00000000..4789d053 --- /dev/null +++ b/unix/as.mc68020/zsvjmp.s.ORIG @@ -0,0 +1,49 @@ +|# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +|# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +|# the registers, effecting a call in the context of the procedure which +|# originally called ZSVJMP, but with the new status code. These are Fortran +|# callable procedures. +|# +|# (SUN/UNIX MC68xxx version) + + .text + .globl _zsvjmp_ + .globl _zdojmp_ + + |# The following has nothing to do with ZSVJMP, and is included here + |# only because this assembler module is loaded with every process. + |# This code sets the value of the symbol MEM (the Mem common) to zero, + |# setting the origin for IRAF pointers to zero rather than some + |# arbitrary value, and ensuring that the MEM common is aligned for + |# all datatypes as well as page aligned. A further advantage is that + |# references to NULL pointers will cause a memory violation. + + .globl _mem_ + _mem_ = 0 + + JMPBUF = 4 + STATUS = 8 + REGMASK = 0xfcfc |# D2-D7,A2-A5,A6,A7=sp + +_zsvjmp_: + movl sp@(JMPBUF),a0 |# set A0 to point to jmpbuf + movl sp@(STATUS),a1 |# A1 = status variable + movl a1,a0@ |# JB[1] = addr of status variable + clrl a1@ |# status = 0 + movl sp@+,a1 |# A1 = return address + movl a1,a0@(4) |# JB[2] = return address for longjmp + moveml #REGMASK,a0@(8) |# save register + jmp a1@ |# return from subroutine + +_zdojmp_: + movl sp@(STATUS),a0 + movl a0@,d0 |# D0 = status value + bne L1 |# branch if not equal to zero + moveq #1,d0 |# status must be nonzero +L1: + movl sp@(JMPBUF),a0 |# set A0 to point to jmpbuf + movl a0@,a1 |# get addr of zsvjmp status variable + movl d0,a1@ |# set the status value + moveml a0@(8),#REGMASK |# restore registers + movl a0@(4),a1 |# get return address of zsvjmp + jmp a1@ |# return from zsvjmp diff --git a/unix/as.redhat b/unix/as.redhat new file mode 120000 index 00000000..46c90679 --- /dev/null +++ b/unix/as.redhat @@ -0,0 +1 @@ +as.linux \ No newline at end of file diff --git a/unix/as.rs6000/aclrb.c b/unix/as.rs6000/aclrb.c new file mode 100644 index 00000000..0ad8e775 --- /dev/null +++ b/unix/as.rs6000/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n); +} diff --git a/unix/as.rs6000/aclrc.c b/unix/as.rs6000/aclrc.c new file mode 100644 index 00000000..5f65a082 --- /dev/null +++ b/unix/as.rs6000/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/aclrd.c b/unix/as.rs6000/aclrd.c new file mode 100644 index 00000000..2336f5ee --- /dev/null +++ b/unix/as.rs6000/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/aclri.c b/unix/as.rs6000/aclri.c new file mode 100644 index 00000000..8dff5b08 --- /dev/null +++ b/unix/as.rs6000/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/aclrl.c b/unix/as.rs6000/aclrl.c new file mode 100644 index 00000000..0fc61dd4 --- /dev/null +++ b/unix/as.rs6000/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/aclrr.c b/unix/as.rs6000/aclrr.c new file mode 100644 index 00000000..78a56125 --- /dev/null +++ b/unix/as.rs6000/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/aclrs.c b/unix/as.rs6000/aclrs.c new file mode 100644 index 00000000..2dc2da7a --- /dev/null +++ b/unix/as.rs6000/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/amovc.c b/unix/as.rs6000/amovc.c new file mode 100644 index 00000000..1eecb74b --- /dev/null +++ b/unix/as.rs6000/amovc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/amovd.c b/unix/as.rs6000/amovd.c new file mode 100644 index 00000000..a56f3c09 --- /dev/null +++ b/unix/as.rs6000/amovd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/amovi.c b/unix/as.rs6000/amovi.c new file mode 100644 index 00000000..930f93ae --- /dev/null +++ b/unix/as.rs6000/amovi.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/amovl.c b/unix/as.rs6000/amovl.c new file mode 100644 index 00000000..e125c081 --- /dev/null +++ b/unix/as.rs6000/amovl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/amovr.c b/unix/as.rs6000/amovr.c new file mode 100644 index 00000000..68abfd24 --- /dev/null +++ b/unix/as.rs6000/amovr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/amovs.c b/unix/as.rs6000/amovs.c new file mode 100644 index 00000000..2864f699 --- /dev/null +++ b/unix/as.rs6000/amovs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.rs6000/bytmov.c b/unix/as.rs6000/bytmov.c new file mode 100644 index 00000000..8c5bb351 --- /dev/null +++ b/unix/as.rs6000/bytmov.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + bcopy ((char *)a + (*aoff-1), (char *)b + (*boff-1), *nbytes); +} diff --git a/unix/as.rs6000/ieee.gx b/unix/as.rs6000/ieee.gx new file mode 100644 index 00000000..3b10d02d --- /dev/null +++ b/unix/as.rs6000/ieee.gx @@ -0,0 +1,318 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[1], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[1], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[1], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemap$t (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / +$else +double fval +int ival[2] +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.rs6000/ieeed.x b/unix/as.rs6000/ieeed.x new file mode 100644 index 00000000..7634ac73 --- /dev/null +++ b/unix/as.rs6000/ieeed.x @@ -0,0 +1,289 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[1], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[1], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[1], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapd (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +double fval +int ival[2] +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.rs6000/ieeer.x b/unix/as.rs6000/ieeer.x new file mode 100644 index 00000000..a431e337 --- /dev/null +++ b/unix/as.rs6000/ieeer.x @@ -0,0 +1,289 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[1], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[1], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[1], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapr (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +real fval +int ival[1] +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.rs6000/zsvjmp.s b/unix/as.rs6000/zsvjmp.s new file mode 100644 index 00000000..38740322 --- /dev/null +++ b/unix/as.rs6000/zsvjmp.s @@ -0,0 +1,29 @@ + .toc + .extern setjmp[DS] + .extern .setjmp +.csect [PR] + .align 2 + .globl zsvjmp + .globl .zsvjmp + .csect zsvjmp[DS] +zsvjmp: + .long .zsvjmp, TOC[tc0], 0 + .csect [PR] +.zsvjmp: + st 4, 0(3) + cal 0, 0(0) + st 0, 0(4) + ai 3, 3, 4 + b .setjmp + cror 15,15,15 +LT..zsvjmp: + .long 0 + .byte 0,0,32,97,128,1,2,1 + .long 0 + .long LT..zsvjmp-.zsvjmp + .short 6 + .byte "zsvjmp" + .byte 31 +_section_.text: +.csect .data[RW] + .long _section_.text diff --git a/unix/as.rs6000/zzdebug.c b/unix/as.rs6000/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.rs6000/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.sparc/aclrb.c b/unix/as.sparc/aclrb.c new file mode 100644 index 00000000..0ad8e775 --- /dev/null +++ b/unix/as.sparc/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n); +} diff --git a/unix/as.sparc/aclrc.c b/unix/as.sparc/aclrc.c new file mode 100644 index 00000000..5f65a082 --- /dev/null +++ b/unix/as.sparc/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/aclrd.c b/unix/as.sparc/aclrd.c new file mode 100644 index 00000000..2336f5ee --- /dev/null +++ b/unix/as.sparc/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/aclri.c b/unix/as.sparc/aclri.c new file mode 100644 index 00000000..8dff5b08 --- /dev/null +++ b/unix/as.sparc/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/aclrl.c b/unix/as.sparc/aclrl.c new file mode 100644 index 00000000..0fc61dd4 --- /dev/null +++ b/unix/as.sparc/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/aclrr.c b/unix/as.sparc/aclrr.c new file mode 100644 index 00000000..78a56125 --- /dev/null +++ b/unix/as.sparc/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/aclrs.c b/unix/as.sparc/aclrs.c new file mode 100644 index 00000000..2dc2da7a --- /dev/null +++ b/unix/as.sparc/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/amovc.c b/unix/as.sparc/amovc.c new file mode 100644 index 00000000..1eecb74b --- /dev/null +++ b/unix/as.sparc/amovc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/amovd.c b/unix/as.sparc/amovd.c new file mode 100644 index 00000000..a56f3c09 --- /dev/null +++ b/unix/as.sparc/amovd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/amovi.c b/unix/as.sparc/amovi.c new file mode 100644 index 00000000..930f93ae --- /dev/null +++ b/unix/as.sparc/amovi.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/amovl.c b/unix/as.sparc/amovl.c new file mode 100644 index 00000000..e125c081 --- /dev/null +++ b/unix/as.sparc/amovl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/amovr.c b/unix/as.sparc/amovr.c new file mode 100644 index 00000000..68abfd24 --- /dev/null +++ b/unix/as.sparc/amovr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/amovs.c b/unix/as.sparc/amovs.c new file mode 100644 index 00000000..2864f699 --- /dev/null +++ b/unix/as.sparc/amovs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/aclrb.c b/unix/as.sparc/as.sparc/aclrb.c new file mode 100644 index 00000000..0ad8e775 --- /dev/null +++ b/unix/as.sparc/as.sparc/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n); +} diff --git a/unix/as.sparc/as.sparc/aclrc.c b/unix/as.sparc/as.sparc/aclrc.c new file mode 100644 index 00000000..5f65a082 --- /dev/null +++ b/unix/as.sparc/as.sparc/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/aclrd.c b/unix/as.sparc/as.sparc/aclrd.c new file mode 100644 index 00000000..2336f5ee --- /dev/null +++ b/unix/as.sparc/as.sparc/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/aclri.c b/unix/as.sparc/as.sparc/aclri.c new file mode 100644 index 00000000..8dff5b08 --- /dev/null +++ b/unix/as.sparc/as.sparc/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/aclrl.c b/unix/as.sparc/as.sparc/aclrl.c new file mode 100644 index 00000000..0fc61dd4 --- /dev/null +++ b/unix/as.sparc/as.sparc/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/aclrr.c b/unix/as.sparc/as.sparc/aclrr.c new file mode 100644 index 00000000..78a56125 --- /dev/null +++ b/unix/as.sparc/as.sparc/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/aclrs.c b/unix/as.sparc/as.sparc/aclrs.c new file mode 100644 index 00000000..2dc2da7a --- /dev/null +++ b/unix/as.sparc/as.sparc/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + bzero ((char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/amovc.c b/unix/as.sparc/as.sparc/amovc.c new file mode 100644 index 00000000..90c59c15 --- /dev/null +++ b/unix/as.sparc/as.sparc/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/amovd.c b/unix/as.sparc/as.sparc/amovd.c new file mode 100644 index 00000000..6cca4dc6 --- /dev/null +++ b/unix/as.sparc/as.sparc/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/amovi.c b/unix/as.sparc/as.sparc/amovi.c new file mode 100644 index 00000000..5cd72417 --- /dev/null +++ b/unix/as.sparc/as.sparc/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/amovl.c b/unix/as.sparc/as.sparc/amovl.c new file mode 100644 index 00000000..2d8be93b --- /dev/null +++ b/unix/as.sparc/as.sparc/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/amovr.c b/unix/as.sparc/as.sparc/amovr.c new file mode 100644 index 00000000..62981c44 --- /dev/null +++ b/unix/as.sparc/as.sparc/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/amovs.c b/unix/as.sparc/as.sparc/amovs.c new file mode 100644 index 00000000..855d2882 --- /dev/null +++ b/unix/as.sparc/as.sparc/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + bcopy ((char *)a, (char *)b, *n * sizeof(*a)); +} diff --git a/unix/as.sparc/as.sparc/bytmov.c b/unix/as.sparc/as.sparc/bytmov.c new file mode 100644 index 00000000..a473965f --- /dev/null +++ b/unix/as.sparc/as.sparc/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + bcopy ((char *)a + (*aoff-1), (char *)b + (*boff-1), *nbytes); +} diff --git a/unix/as.sparc/as.sparc/enbint.s b/unix/as.sparc/as.sparc/enbint.s new file mode 100644 index 00000000..ad73e9bf --- /dev/null +++ b/unix/as.sparc/as.sparc/enbint.s @@ -0,0 +1,20 @@ + .seg "text" + .global _ieee_enbint + +! _IEEE_ENBINT -- Enable the floating point exceptions indicated by the +! bitmask passed as the only argument. The current bitmask is returned as +! the function value. + +_ieee_enbint: + set 0x0f800000,%o4 + sll %o0,23,%o1 + st %fsr,[%sp+0x44] + ld [%sp+0x44],%o0 + and %o1,%o4,%o1 + andn %o0,%o4,%o2 + or %o1,%o2,%o1 + st %o1,[%sp+0x44] + ld [%sp+0x44],%fsr + and %o0,%o4,%o0 + retl + srl %o0,23,%o0 diff --git a/unix/as.sparc/as.sparc/ieee.gx b/unix/as.sparc/as.sparc/ieee.gx new file mode 100644 index 00000000..4a00c759 --- /dev/null +++ b/unix/as.sparc/as.sparc/ieee.gx @@ -0,0 +1,366 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.sparc/as.sparc/ieeed.x b/unix/as.sparc/as.sparc/ieeed.x new file mode 100644 index 00000000..391cf8ba --- /dev/null +++ b/unix/as.sparc/as.sparc/ieeed.x @@ -0,0 +1,335 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.sparc/as.sparc/ieeer.x b/unix/as.sparc/as.sparc/ieeer.x new file mode 100644 index 00000000..01815d30 --- /dev/null +++ b/unix/as.sparc/as.sparc/ieeer.x @@ -0,0 +1,335 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.sparc/as.sparc/oscmd.s b/unix/as.sparc/as.sparc/oscmd.s new file mode 100644 index 00000000..e7600dfc --- /dev/null +++ b/unix/as.sparc/as.sparc/oscmd.s @@ -0,0 +1,369 @@ + .seg "text" ! [internal] + .proc 4 + .global _oscmd_ +_oscmd_: +!#PROLOGUE# 0 +!#PROLOGUE# 1 + save %sp,-104,%sp + sethi %hi(VAR_SEG1+16),%l0 ! [internal] + or %l0,%lo(VAR_SEG1+16),%l0 ! [internal] + st %i1,[%fp+72] + st %i3,[%fp+80] + call _smark_,1 + mov %l0,%o0 + sethi %hi(L1D168),%o0 + add %o0,%lo(L1D168),%i3 + sethi %hi(L1D169),%o1 + add %l0,16,%o0 + add %o1,%lo(L1D169),%i4 + mov %i4,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(VAR_SEG1+32),%o2 + ld [%o2+%lo(VAR_SEG1+32)],%l5 + sethi %hi(L1D164),%o3 + add %o3,%lo(L1D164),%i5 + inc 20,%l0 ! [internal] + mov %l0,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-8,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-12,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-16,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(L1D148),%o0 + call _clstai_,1 + or %o0,%lo(L1D148),%o0 ! [internal] + cmp %o0,1 + be L77048 + nop + ld [%fp+72],%l6 + sethi %hi(_mem_-2),%o5 + or %o5,%lo(_mem_-2),%o5 ! [internal] + sll %l5,1,%o4 + add %o5,%o4,%o7 + mov %o7,%l7 + mov %l7,%o1 + mov %i4,%o2 + call _strpak_,3 + mov %i0,%o0 + ldsh [%l6],%l0 + tst %l0 + bne,a LY14 + sethi %hi(VAR_SEG1+36),%o0 + sethi %hi(VAR_SEG1+36),%l1 + ld [%l1+%lo(VAR_SEG1+36)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%i0 + add %l3,%i0,%i0 + sethi %hi(v.16),%o0 + or %o0,%lo(v.16),%o0 ! [internal] + mov %i0,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY13 + ld [%fp+80],%i1 +LY14: ! [internal] + ld [%o0+%lo(VAR_SEG1+36)],%o0 + sethi %hi(_mem_-2),%o2 + sll %o0,1,%o1 + or %o2,%lo(_mem_-2),%o2 ! [internal] + add %o2,%o1,%o3 + mov %o3,%i0 + mov %i0,%o1 + mov %i5,%o2 + call _fmapfn_,3 + mov %l6,%o0 + ld [%fp+80],%i1 +LY13: ! [internal] + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + bne,a LY12 + sethi %hi(VAR_SEG1+20),%o4 + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY11 + sethi %hi(VAR_SEG1+20),%l1 + sethi %hi(VAR_SEG1+20),%o4 +LY12: ! [internal] + ld [%o4+%lo(VAR_SEG1+20)],%o4 + sethi %hi(_mem_-2),%o7 + sll %o4,1,%o5 + or %o7,%lo(_mem_-2),%o7 ! [internal] + add %o7,%o5,%l0 + mov %l0,%i3 + sethi %hi(v.17),%o0 + or %o0,%lo(v.17),%o0 ! [internal] + mov %i3,%o1 + call _xmktep_,3 + mov %i5,%o2 + b LY10 + ldsh [%i2],%o0 +LY11: ! [internal] + ld [%l1+%lo(VAR_SEG1+20)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%l2 + add %l3,%l2,%l2 + mov %l2,%i3 + sth %g0,[%i3] + ldsh [%i2],%o0 +LY10: ! [internal] + tst %o0 + bne L77021 + sethi %hi(VAR_SEG1+28),%o1 + ld [%o1+%lo(VAR_SEG1+28)],%o1 + sethi %hi(_mem_-2),%o3 + or %o3,%lo(_mem_-2),%o3 ! [internal] + sll %o1,1,%i4 + add %o3,%i4,%i4 + sethi %hi(v.18),%o0 + or %o0,%lo(v.18),%o0 ! [internal] + mov %i4,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY9 + ldsh [%i1],%o1 +L77021: + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + be,a LY8 + sethi %hi(VAR_SEG1+28),%l2 + sethi %hi(VAR_SEG1+28),%o5 + ld [%o5+%lo(VAR_SEG1+28)],%o5 + sethi %hi(_mem_-2),%l0 + or %l0,%lo(_mem_-2),%l0 ! [internal] + sll %o5,1,%o7 + add %l0,%o7,%l1 + mov %i3,%o0 + b LY1 + mov %l1,%i4 +LY8: ! [internal] + ld [%l2+%lo(VAR_SEG1+28)],%l2 + sethi %hi(_mem_-2),%l4 + or %l4,%lo(_mem_-2),%l4 ! [internal] + sll %l2,1,%l3 + add %l4,%l3,%i4 + mov %i2,%o0 +LY1: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i4,%o1 + ldsh [%i1],%o1 +LY9: ! [internal] + tst %o1 + bne L77031 + sethi %hi(VAR_SEG1+24),%o2 + ld [%o2+%lo(VAR_SEG1+24)],%o2 + sethi %hi(_mem_-2),%o4 + sll %o2,1,%o3 + or %o4,%lo(_mem_-2),%o4 ! [internal] + add %o4,%o3,%o5 + mov %o5,%i2 + sethi %hi(v.19),%o0 + or %o0,%lo(v.19),%o0 ! [internal] + mov %i2,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY7 + sethi %hi(VAR_SEG1),%o4 +L77031: + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY6 + sethi %hi(VAR_SEG1+24),%l3 + sethi %hi(VAR_SEG1+24),%o7 + ld [%o7+%lo(VAR_SEG1+24)],%o7 + sethi %hi(_mem_-2),%l1 + or %l1,%lo(_mem_-2),%l1 ! [internal] + sll %o7,1,%i2 + mov %i3,%o0 + b LY2 + add %l1,%i2,%i2 +LY6: ! [internal] + ld [%l3+%lo(VAR_SEG1+24)],%l3 + sethi %hi(_mem_-2),%o0 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %l3,1,%l4 + add %o0,%l4,%o1 + mov %o1,%i2 + mov %i1,%o0 +LY2: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i2,%o1 + sethi %hi(VAR_SEG1),%o4 +LY7: ! [internal] + or %o4,%lo(VAR_SEG1),%o4 ! [internal] + mov %i2,%o3 + mov %i4,%o2 + mov %i0,%o1 + call _koscmd_,5 + mov %l7,%o0 + ldsh [%i3],%o3 + sethi %hi(VAR_SEG1),%o2 + ld [%o2+%lo(VAR_SEG1)],%i5 + tst %o3 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + call _xerpsh_,0 + nop + call _xfdele_,1 + mov %i3,%o0 + call _xerpop_,0 + nop + tst %o0 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(L1D54),%o0 + call _erract_,1 + or %o0,%lo(L1D54),%o0 ! [internal] + sethi %hi(_xercom_),%o4 + ld [%o4+%lo(_xercom_)],%o4 + tst %o4 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + b LY5 + sethi %hi(VAR_SEG1),%o0 ! [internal] +L77048: + call _xffluh_,1 + mov %i3,%o0 + sethi %hi(_mem_-2),%o0 ! [internal] + add %l5,1,%l1 + mov %l1,%i2 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%l3 + mov %l3,%i3 + mov 2,%i5 + inc -2,%i0 + add %i5,%i0,%i0 + add %i3,%o0,%o1 + mov %o0,%o7 + sll %l5,1,%o5 + mov 33,%l0 + sth %l0,[%o5+%o7] + mov %o1,%i3 + mov %i0,%i5 +L77049: + ldsh [%i5],%i4 + tst %i4 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + ldsh [%i5],%i0 + cmp %i4,10 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + sth %i0,[%i3] + inc %i2 + inc 2,%i5 + b L77049 + inc 2,%i3 +LY4: ! [internal] + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%i2 + mov %i2,%i5 + mov %o0,%o3 + mov 10,%o4 + sth %o4,[%i5+%o3] + add %o0,2,%o5 + sth %g0,[%i5+%o5] + mov %o0,%o1 + sethi %hi(L1D168),%o7 + add %o7,%lo(L1D168),%i5 + sll %l5,1,%l0 + add %o1,%l0,%o1 + call _putlie_,2 + mov %i5,%o0 + call _xffluh_,1 + mov %i5,%o0 + sethi %hi(L1D148),%l1 + add %l1,%lo(L1D148),%i3 + mov 0,%i5 +L77055: + sethi %hi(VAR_SEG1+4),%o1 + or %o1,%lo(VAR_SEG1+4),%o1 ! [internal] + call _getci_,2 + mov %i3,%o0 + cmp %o0,-2 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(VAR_SEG1+4),%l2 + ld [%l2+%lo(VAR_SEG1+4)],%l2 + cmp %l2,10 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + mov %i5,%o0 + sll %o0,1,%o0 + mov %o0,%o1 + sethi %hi(VAR_SEG1+4),%l3 + ld [%l3+%lo(VAR_SEG1+4)],%l3 + sll %o1,2,%o1 + add %o0,%o1,%o0 + add %l3,-48,%l4 + add %o0,%l4,%o0 + b L77055 + mov %o0,%i5 +LY3: ! [internal] + call _sfree_,1 + or %o0,%lo(VAR_SEG1+16),%o0 ! [internal] + mov %i5,%i3 + sethi %hi(VAR_SEG1),%o0 ! [internal] +LY5: ! [internal] + or %o0,%lo(VAR_SEG1),%o0 ! [internal] + st %i5,[%o0] + st %l5,[%o0+32] + ret + restore %g0,%i3,%o0 + .seg "data" ! [internal] + .common _mem_,8 + .common _xercom_,4 + .align 8 + .align 4 +L1D168: + .word 2 + .align 4 +L1D169: + .word 0x400 + .align 4 +L1D164: + .word 127 + .align 4 +L1D148: + .word 1 + .align 4 +L1D54: + .word 3 + .align 4 +v.16: + .half 0 + .align 4 +v.17: + .word 0x74006d + .word 0x700024 + .word 0x6e0075 + .word 0x6c006c + .skip 2 + .align 4 +v.18: + .skip 2 + .align 4 +v.19: + .skip 2 + .seg "bss" ! [internal] + .align 8 +VAR_SEG1: + .skip 40 diff --git a/unix/as.sparc/as.sparc/zrtadr.s b/unix/as.sparc/as.sparc/zrtadr.s new file mode 100644 index 00000000..fb94fe2b --- /dev/null +++ b/unix/as.sparc/as.sparc/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global _zrtadr_ +_zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.sparc/as.sparc/zsvjmp.s b/unix/as.sparc/as.sparc/zsvjmp.s new file mode 100644 index 00000000..9e3f9414 --- /dev/null +++ b/unix/as.sparc/as.sparc/zsvjmp.s @@ -0,0 +1,33 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + + .proc 0 +_zsvjmp_: + st %o1, [%o0] ! save &status in jmpbuf[0] + clr %o2 + st %o2, [%o1] ! zero the value of status + add %o0, 0x4, %o0 + set _setjmp, %o1 + jmp %o1 + nop + .seg "data" diff --git a/unix/as.sparc/as.sparc/zsvjmp.s.OLD b/unix/as.sparc/as.sparc/zsvjmp.s.OLD new file mode 100644 index 00000000..7f6bb7eb --- /dev/null +++ b/unix/as.sparc/as.sparc/zsvjmp.s.OLD @@ -0,0 +1,59 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + .global _zdojmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + !# The following requires a jmpbuf of length at least 6 ints. + .proc 0 +_zsvjmp_: + save %sp, -0x60, %sp + call _sigblock + clr %o0 + st %o0, [%i0 + 0x8] + st %i1, [%i0 + 0x14] + clr %o0 + st %o0, [%i1] + st %i7, [%i0] + st %fp, [%i0 + 0x4] + add %i0, 0xc, %o1 + call _sigstack + clr %o0 + ret + restore %g0, 0x0, %o0 + + .proc 0 +_zdojmp_: + save %sp, -0x40, %sp + ta 0x3 + ld [%i0 + 0x4], %fp + sub %fp, 0x60, %sp + call _sigsetmask + ld [%i0 + 0x8], %o0 + add %i0, 0xc, %o0 + call _sigstack + clr %o1 + ld [%i0 + 0x14], %o0 + ld [%i1], %i1 + st %i1, [%o0] + ld [%i0], %i7 + ret + restore %i1, 0x0, %o0 + .seg "data" diff --git a/unix/as.sparc/as.sparc/zzdebug.c b/unix/as.sparc/as.sparc/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.sparc/as.sparc/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.sparc/bytmov.c b/unix/as.sparc/bytmov.c new file mode 100644 index 00000000..8c5bb351 --- /dev/null +++ b/unix/as.sparc/bytmov.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + bcopy ((char *)a + (*aoff-1), (char *)b + (*boff-1), *nbytes); +} diff --git a/unix/as.sparc/ieee.gx b/unix/as.sparc/ieee.gx new file mode 100644 index 00000000..fb3e34a4 --- /dev/null +++ b/unix/as.sparc/ieee.gx @@ -0,0 +1,318 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemap$t (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.sparc/ieeed.x b/unix/as.sparc/ieeed.x new file mode 100644 index 00000000..081b4760 --- /dev/null +++ b/unix/as.sparc/ieeed.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapd (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.sparc/ieeer.x b/unix/as.sparc/ieeer.x new file mode 100644 index 00000000..ab4fee53 --- /dev/null +++ b/unix/as.sparc/ieeer.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapr (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.sparc/oscmd.s b/unix/as.sparc/oscmd.s new file mode 100644 index 00000000..e7600dfc --- /dev/null +++ b/unix/as.sparc/oscmd.s @@ -0,0 +1,369 @@ + .seg "text" ! [internal] + .proc 4 + .global _oscmd_ +_oscmd_: +!#PROLOGUE# 0 +!#PROLOGUE# 1 + save %sp,-104,%sp + sethi %hi(VAR_SEG1+16),%l0 ! [internal] + or %l0,%lo(VAR_SEG1+16),%l0 ! [internal] + st %i1,[%fp+72] + st %i3,[%fp+80] + call _smark_,1 + mov %l0,%o0 + sethi %hi(L1D168),%o0 + add %o0,%lo(L1D168),%i3 + sethi %hi(L1D169),%o1 + add %l0,16,%o0 + add %o1,%lo(L1D169),%i4 + mov %i4,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(VAR_SEG1+32),%o2 + ld [%o2+%lo(VAR_SEG1+32)],%l5 + sethi %hi(L1D164),%o3 + add %o3,%lo(L1D164),%i5 + inc 20,%l0 ! [internal] + mov %l0,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-8,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-12,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-16,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(L1D148),%o0 + call _clstai_,1 + or %o0,%lo(L1D148),%o0 ! [internal] + cmp %o0,1 + be L77048 + nop + ld [%fp+72],%l6 + sethi %hi(_mem_-2),%o5 + or %o5,%lo(_mem_-2),%o5 ! [internal] + sll %l5,1,%o4 + add %o5,%o4,%o7 + mov %o7,%l7 + mov %l7,%o1 + mov %i4,%o2 + call _strpak_,3 + mov %i0,%o0 + ldsh [%l6],%l0 + tst %l0 + bne,a LY14 + sethi %hi(VAR_SEG1+36),%o0 + sethi %hi(VAR_SEG1+36),%l1 + ld [%l1+%lo(VAR_SEG1+36)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%i0 + add %l3,%i0,%i0 + sethi %hi(v.16),%o0 + or %o0,%lo(v.16),%o0 ! [internal] + mov %i0,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY13 + ld [%fp+80],%i1 +LY14: ! [internal] + ld [%o0+%lo(VAR_SEG1+36)],%o0 + sethi %hi(_mem_-2),%o2 + sll %o0,1,%o1 + or %o2,%lo(_mem_-2),%o2 ! [internal] + add %o2,%o1,%o3 + mov %o3,%i0 + mov %i0,%o1 + mov %i5,%o2 + call _fmapfn_,3 + mov %l6,%o0 + ld [%fp+80],%i1 +LY13: ! [internal] + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + bne,a LY12 + sethi %hi(VAR_SEG1+20),%o4 + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY11 + sethi %hi(VAR_SEG1+20),%l1 + sethi %hi(VAR_SEG1+20),%o4 +LY12: ! [internal] + ld [%o4+%lo(VAR_SEG1+20)],%o4 + sethi %hi(_mem_-2),%o7 + sll %o4,1,%o5 + or %o7,%lo(_mem_-2),%o7 ! [internal] + add %o7,%o5,%l0 + mov %l0,%i3 + sethi %hi(v.17),%o0 + or %o0,%lo(v.17),%o0 ! [internal] + mov %i3,%o1 + call _xmktep_,3 + mov %i5,%o2 + b LY10 + ldsh [%i2],%o0 +LY11: ! [internal] + ld [%l1+%lo(VAR_SEG1+20)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%l2 + add %l3,%l2,%l2 + mov %l2,%i3 + sth %g0,[%i3] + ldsh [%i2],%o0 +LY10: ! [internal] + tst %o0 + bne L77021 + sethi %hi(VAR_SEG1+28),%o1 + ld [%o1+%lo(VAR_SEG1+28)],%o1 + sethi %hi(_mem_-2),%o3 + or %o3,%lo(_mem_-2),%o3 ! [internal] + sll %o1,1,%i4 + add %o3,%i4,%i4 + sethi %hi(v.18),%o0 + or %o0,%lo(v.18),%o0 ! [internal] + mov %i4,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY9 + ldsh [%i1],%o1 +L77021: + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + be,a LY8 + sethi %hi(VAR_SEG1+28),%l2 + sethi %hi(VAR_SEG1+28),%o5 + ld [%o5+%lo(VAR_SEG1+28)],%o5 + sethi %hi(_mem_-2),%l0 + or %l0,%lo(_mem_-2),%l0 ! [internal] + sll %o5,1,%o7 + add %l0,%o7,%l1 + mov %i3,%o0 + b LY1 + mov %l1,%i4 +LY8: ! [internal] + ld [%l2+%lo(VAR_SEG1+28)],%l2 + sethi %hi(_mem_-2),%l4 + or %l4,%lo(_mem_-2),%l4 ! [internal] + sll %l2,1,%l3 + add %l4,%l3,%i4 + mov %i2,%o0 +LY1: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i4,%o1 + ldsh [%i1],%o1 +LY9: ! [internal] + tst %o1 + bne L77031 + sethi %hi(VAR_SEG1+24),%o2 + ld [%o2+%lo(VAR_SEG1+24)],%o2 + sethi %hi(_mem_-2),%o4 + sll %o2,1,%o3 + or %o4,%lo(_mem_-2),%o4 ! [internal] + add %o4,%o3,%o5 + mov %o5,%i2 + sethi %hi(v.19),%o0 + or %o0,%lo(v.19),%o0 ! [internal] + mov %i2,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY7 + sethi %hi(VAR_SEG1),%o4 +L77031: + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY6 + sethi %hi(VAR_SEG1+24),%l3 + sethi %hi(VAR_SEG1+24),%o7 + ld [%o7+%lo(VAR_SEG1+24)],%o7 + sethi %hi(_mem_-2),%l1 + or %l1,%lo(_mem_-2),%l1 ! [internal] + sll %o7,1,%i2 + mov %i3,%o0 + b LY2 + add %l1,%i2,%i2 +LY6: ! [internal] + ld [%l3+%lo(VAR_SEG1+24)],%l3 + sethi %hi(_mem_-2),%o0 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %l3,1,%l4 + add %o0,%l4,%o1 + mov %o1,%i2 + mov %i1,%o0 +LY2: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i2,%o1 + sethi %hi(VAR_SEG1),%o4 +LY7: ! [internal] + or %o4,%lo(VAR_SEG1),%o4 ! [internal] + mov %i2,%o3 + mov %i4,%o2 + mov %i0,%o1 + call _koscmd_,5 + mov %l7,%o0 + ldsh [%i3],%o3 + sethi %hi(VAR_SEG1),%o2 + ld [%o2+%lo(VAR_SEG1)],%i5 + tst %o3 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + call _xerpsh_,0 + nop + call _xfdele_,1 + mov %i3,%o0 + call _xerpop_,0 + nop + tst %o0 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(L1D54),%o0 + call _erract_,1 + or %o0,%lo(L1D54),%o0 ! [internal] + sethi %hi(_xercom_),%o4 + ld [%o4+%lo(_xercom_)],%o4 + tst %o4 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + b LY5 + sethi %hi(VAR_SEG1),%o0 ! [internal] +L77048: + call _xffluh_,1 + mov %i3,%o0 + sethi %hi(_mem_-2),%o0 ! [internal] + add %l5,1,%l1 + mov %l1,%i2 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%l3 + mov %l3,%i3 + mov 2,%i5 + inc -2,%i0 + add %i5,%i0,%i0 + add %i3,%o0,%o1 + mov %o0,%o7 + sll %l5,1,%o5 + mov 33,%l0 + sth %l0,[%o5+%o7] + mov %o1,%i3 + mov %i0,%i5 +L77049: + ldsh [%i5],%i4 + tst %i4 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + ldsh [%i5],%i0 + cmp %i4,10 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + sth %i0,[%i3] + inc %i2 + inc 2,%i5 + b L77049 + inc 2,%i3 +LY4: ! [internal] + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%i2 + mov %i2,%i5 + mov %o0,%o3 + mov 10,%o4 + sth %o4,[%i5+%o3] + add %o0,2,%o5 + sth %g0,[%i5+%o5] + mov %o0,%o1 + sethi %hi(L1D168),%o7 + add %o7,%lo(L1D168),%i5 + sll %l5,1,%l0 + add %o1,%l0,%o1 + call _putlie_,2 + mov %i5,%o0 + call _xffluh_,1 + mov %i5,%o0 + sethi %hi(L1D148),%l1 + add %l1,%lo(L1D148),%i3 + mov 0,%i5 +L77055: + sethi %hi(VAR_SEG1+4),%o1 + or %o1,%lo(VAR_SEG1+4),%o1 ! [internal] + call _getci_,2 + mov %i3,%o0 + cmp %o0,-2 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(VAR_SEG1+4),%l2 + ld [%l2+%lo(VAR_SEG1+4)],%l2 + cmp %l2,10 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + mov %i5,%o0 + sll %o0,1,%o0 + mov %o0,%o1 + sethi %hi(VAR_SEG1+4),%l3 + ld [%l3+%lo(VAR_SEG1+4)],%l3 + sll %o1,2,%o1 + add %o0,%o1,%o0 + add %l3,-48,%l4 + add %o0,%l4,%o0 + b L77055 + mov %o0,%i5 +LY3: ! [internal] + call _sfree_,1 + or %o0,%lo(VAR_SEG1+16),%o0 ! [internal] + mov %i5,%i3 + sethi %hi(VAR_SEG1),%o0 ! [internal] +LY5: ! [internal] + or %o0,%lo(VAR_SEG1),%o0 ! [internal] + st %i5,[%o0] + st %l5,[%o0+32] + ret + restore %g0,%i3,%o0 + .seg "data" ! [internal] + .common _mem_,8 + .common _xercom_,4 + .align 8 + .align 4 +L1D168: + .word 2 + .align 4 +L1D169: + .word 0x400 + .align 4 +L1D164: + .word 127 + .align 4 +L1D148: + .word 1 + .align 4 +L1D54: + .word 3 + .align 4 +v.16: + .half 0 + .align 4 +v.17: + .word 0x74006d + .word 0x700024 + .word 0x6e0075 + .word 0x6c006c + .skip 2 + .align 4 +v.18: + .skip 2 + .align 4 +v.19: + .skip 2 + .seg "bss" ! [internal] + .align 8 +VAR_SEG1: + .skip 40 diff --git a/unix/as.sparc/zrtadr.s b/unix/as.sparc/zrtadr.s new file mode 100644 index 00000000..fb94fe2b --- /dev/null +++ b/unix/as.sparc/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global _zrtadr_ +_zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.sparc/zsvjmp.s b/unix/as.sparc/zsvjmp.s new file mode 100644 index 00000000..d9a6b81f --- /dev/null +++ b/unix/as.sparc/zsvjmp.s @@ -0,0 +1,32 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + .proc 0 +_zsvjmp_: + st %o1, [%o0] ! save &status in jmpbuf[0] + clr %o2 + st %o2, [%o1] ! zero the value of status + add %o0, 0x4, %o0 + set _setjmp, %o1 + jmp %o1 + nop + .seg "data" diff --git a/unix/as.sparc/zsvjmp.s.OLD b/unix/as.sparc/zsvjmp.s.OLD new file mode 100644 index 00000000..7f6bb7eb --- /dev/null +++ b/unix/as.sparc/zsvjmp.s.OLD @@ -0,0 +1,59 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + .global _zdojmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + !# The following requires a jmpbuf of length at least 6 ints. + .proc 0 +_zsvjmp_: + save %sp, -0x60, %sp + call _sigblock + clr %o0 + st %o0, [%i0 + 0x8] + st %i1, [%i0 + 0x14] + clr %o0 + st %o0, [%i1] + st %i7, [%i0] + st %fp, [%i0 + 0x4] + add %i0, 0xc, %o1 + call _sigstack + clr %o0 + ret + restore %g0, 0x0, %o0 + + .proc 0 +_zdojmp_: + save %sp, -0x40, %sp + ta 0x3 + ld [%i0 + 0x4], %fp + sub %fp, 0x60, %sp + call _sigsetmask + ld [%i0 + 0x8], %o0 + add %i0, 0xc, %o0 + call _sigstack + clr %o1 + ld [%i0 + 0x14], %o0 + ld [%i1], %i1 + st %i1, [%o0] + ld [%i0], %i7 + ret + restore %i1, 0x0, %o0 + .seg "data" diff --git a/unix/as.sparc/zzdebug.c b/unix/as.sparc/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.sparc/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.ssol/aclrb.c b/unix/as.ssol/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.ssol/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.ssol/aclrc.c b/unix/as.ssol/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.ssol/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrd.c b/unix/as.ssol/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.ssol/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclri.c b/unix/as.ssol/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.ssol/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrl.c b/unix/as.ssol/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.ssol/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrr.c b/unix/as.ssol/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.ssol/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/aclrs.c b/unix/as.ssol/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.ssol/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovc.c b/unix/as.ssol/amovc.c new file mode 100644 index 00000000..4cdcbe97 --- /dev/null +++ b/unix/as.ssol/amovc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovd.c b/unix/as.ssol/amovd.c new file mode 100644 index 00000000..caac4d07 --- /dev/null +++ b/unix/as.ssol/amovd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovi.c b/unix/as.ssol/amovi.c new file mode 100644 index 00000000..ff61c96d --- /dev/null +++ b/unix/as.ssol/amovi.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovl.c b/unix/as.ssol/amovl.c new file mode 100644 index 00000000..751efc7f --- /dev/null +++ b/unix/as.ssol/amovl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovr.c b/unix/as.ssol/amovr.c new file mode 100644 index 00000000..f57617bf --- /dev/null +++ b/unix/as.ssol/amovr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/amovs.c b/unix/as.ssol/amovs.c new file mode 100644 index 00000000..ba9ac5e1 --- /dev/null +++ b/unix/as.ssol/amovs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrb.c b/unix/as.ssol/as.ssol/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.ssol/as.ssol/aclrc.c b/unix/as.ssol/as.ssol/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrd.c b/unix/as.ssol/as.ssol/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclri.c b/unix/as.ssol/as.ssol/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.ssol/as.ssol/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrl.c b/unix/as.ssol/as.ssol/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrr.c b/unix/as.ssol/as.ssol/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/aclrs.c b/unix/as.ssol/as.ssol/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.ssol/as.ssol/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovc.c b/unix/as.ssol/as.ssol/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovd.c b/unix/as.ssol/as.ssol/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovi.c b/unix/as.ssol/as.ssol/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovl.c b/unix/as.ssol/as.ssol/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovr.c b/unix/as.ssol/as.ssol/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/amovs.c b/unix/as.ssol/as.ssol/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.ssol/as.ssol/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.ssol/as.ssol/bytmov.c b/unix/as.ssol/as.ssol/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.ssol/as.ssol/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.ssol/as.ssol/enbint.s b/unix/as.ssol/as.ssol/enbint.s new file mode 100644 index 00000000..ad73e9bf --- /dev/null +++ b/unix/as.ssol/as.ssol/enbint.s @@ -0,0 +1,20 @@ + .seg "text" + .global _ieee_enbint + +! _IEEE_ENBINT -- Enable the floating point exceptions indicated by the +! bitmask passed as the only argument. The current bitmask is returned as +! the function value. + +_ieee_enbint: + set 0x0f800000,%o4 + sll %o0,23,%o1 + st %fsr,[%sp+0x44] + ld [%sp+0x44],%o0 + and %o1,%o4,%o1 + andn %o0,%o4,%o2 + or %o1,%o2,%o1 + st %o1,[%sp+0x44] + ld [%sp+0x44],%fsr + and %o0,%o4,%o0 + retl + srl %o0,23,%o0 diff --git a/unix/as.ssol/as.ssol/ieee.gx b/unix/as.ssol/as.ssol/ieee.gx new file mode 100644 index 00000000..4a00c759 --- /dev/null +++ b/unix/as.ssol/as.ssol/ieee.gx @@ -0,0 +1,366 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.ssol/as.ssol/ieeed.x b/unix/as.ssol/as.ssol/ieeed.x new file mode 100644 index 00000000..391cf8ba --- /dev/null +++ b/unix/as.ssol/as.ssol/ieeed.x @@ -0,0 +1,335 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.ssol/as.ssol/ieeer.x b/unix/as.ssol/as.ssol/ieeer.x new file mode 100644 index 00000000..01815d30 --- /dev/null +++ b/unix/as.ssol/as.ssol/ieeer.x @@ -0,0 +1,335 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.ssol/as.ssol/oscmd.s b/unix/as.ssol/as.ssol/oscmd.s new file mode 100644 index 00000000..bfa82811 --- /dev/null +++ b/unix/as.ssol/as.ssol/oscmd.s @@ -0,0 +1,369 @@ + .seg "text" ! [internal] + .proc 4 + .global oscmd_ +oscmd_: +!#PROLOGUE# 0 +!#PROLOGUE# 1 + save %sp,-104,%sp + sethi %hi(VAR_SEG1+16),%l0 ! [internal] + or %l0,%lo(VAR_SEG1+16),%l0 ! [internal] + st %i1,[%fp+72] + st %i3,[%fp+80] + call _smark_,1 + mov %l0,%o0 + sethi %hi(L1D168),%o0 + add %o0,%lo(L1D168),%i3 + sethi %hi(L1D169),%o1 + add %l0,16,%o0 + add %o1,%lo(L1D169),%i4 + mov %i4,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(VAR_SEG1+32),%o2 + ld [%o2+%lo(VAR_SEG1+32)],%l5 + sethi %hi(L1D164),%o3 + add %o3,%lo(L1D164),%i5 + inc 20,%l0 ! [internal] + mov %l0,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-8,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-12,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-16,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(L1D148),%o0 + call _clstai_,1 + or %o0,%lo(L1D148),%o0 ! [internal] + cmp %o0,1 + be L77048 + nop + ld [%fp+72],%l6 + sethi %hi(_mem_-2),%o5 + or %o5,%lo(_mem_-2),%o5 ! [internal] + sll %l5,1,%o4 + add %o5,%o4,%o7 + mov %o7,%l7 + mov %l7,%o1 + mov %i4,%o2 + call _strpak_,3 + mov %i0,%o0 + ldsh [%l6],%l0 + tst %l0 + bne,a LY14 + sethi %hi(VAR_SEG1+36),%o0 + sethi %hi(VAR_SEG1+36),%l1 + ld [%l1+%lo(VAR_SEG1+36)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%i0 + add %l3,%i0,%i0 + sethi %hi(v.16),%o0 + or %o0,%lo(v.16),%o0 ! [internal] + mov %i0,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY13 + ld [%fp+80],%i1 +LY14: ! [internal] + ld [%o0+%lo(VAR_SEG1+36)],%o0 + sethi %hi(_mem_-2),%o2 + sll %o0,1,%o1 + or %o2,%lo(_mem_-2),%o2 ! [internal] + add %o2,%o1,%o3 + mov %o3,%i0 + mov %i0,%o1 + mov %i5,%o2 + call _fmapfn_,3 + mov %l6,%o0 + ld [%fp+80],%i1 +LY13: ! [internal] + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + bne,a LY12 + sethi %hi(VAR_SEG1+20),%o4 + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY11 + sethi %hi(VAR_SEG1+20),%l1 + sethi %hi(VAR_SEG1+20),%o4 +LY12: ! [internal] + ld [%o4+%lo(VAR_SEG1+20)],%o4 + sethi %hi(_mem_-2),%o7 + sll %o4,1,%o5 + or %o7,%lo(_mem_-2),%o7 ! [internal] + add %o7,%o5,%l0 + mov %l0,%i3 + sethi %hi(v.17),%o0 + or %o0,%lo(v.17),%o0 ! [internal] + mov %i3,%o1 + call _xmktep_,3 + mov %i5,%o2 + b LY10 + ldsh [%i2],%o0 +LY11: ! [internal] + ld [%l1+%lo(VAR_SEG1+20)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%l2 + add %l3,%l2,%l2 + mov %l2,%i3 + sth %g0,[%i3] + ldsh [%i2],%o0 +LY10: ! [internal] + tst %o0 + bne L77021 + sethi %hi(VAR_SEG1+28),%o1 + ld [%o1+%lo(VAR_SEG1+28)],%o1 + sethi %hi(_mem_-2),%o3 + or %o3,%lo(_mem_-2),%o3 ! [internal] + sll %o1,1,%i4 + add %o3,%i4,%i4 + sethi %hi(v.18),%o0 + or %o0,%lo(v.18),%o0 ! [internal] + mov %i4,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY9 + ldsh [%i1],%o1 +L77021: + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + be,a LY8 + sethi %hi(VAR_SEG1+28),%l2 + sethi %hi(VAR_SEG1+28),%o5 + ld [%o5+%lo(VAR_SEG1+28)],%o5 + sethi %hi(_mem_-2),%l0 + or %l0,%lo(_mem_-2),%l0 ! [internal] + sll %o5,1,%o7 + add %l0,%o7,%l1 + mov %i3,%o0 + b LY1 + mov %l1,%i4 +LY8: ! [internal] + ld [%l2+%lo(VAR_SEG1+28)],%l2 + sethi %hi(_mem_-2),%l4 + or %l4,%lo(_mem_-2),%l4 ! [internal] + sll %l2,1,%l3 + add %l4,%l3,%i4 + mov %i2,%o0 +LY1: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i4,%o1 + ldsh [%i1],%o1 +LY9: ! [internal] + tst %o1 + bne L77031 + sethi %hi(VAR_SEG1+24),%o2 + ld [%o2+%lo(VAR_SEG1+24)],%o2 + sethi %hi(_mem_-2),%o4 + sll %o2,1,%o3 + or %o4,%lo(_mem_-2),%o4 ! [internal] + add %o4,%o3,%o5 + mov %o5,%i2 + sethi %hi(v.19),%o0 + or %o0,%lo(v.19),%o0 ! [internal] + mov %i2,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY7 + sethi %hi(VAR_SEG1),%o4 +L77031: + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY6 + sethi %hi(VAR_SEG1+24),%l3 + sethi %hi(VAR_SEG1+24),%o7 + ld [%o7+%lo(VAR_SEG1+24)],%o7 + sethi %hi(_mem_-2),%l1 + or %l1,%lo(_mem_-2),%l1 ! [internal] + sll %o7,1,%i2 + mov %i3,%o0 + b LY2 + add %l1,%i2,%i2 +LY6: ! [internal] + ld [%l3+%lo(VAR_SEG1+24)],%l3 + sethi %hi(_mem_-2),%o0 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %l3,1,%l4 + add %o0,%l4,%o1 + mov %o1,%i2 + mov %i1,%o0 +LY2: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i2,%o1 + sethi %hi(VAR_SEG1),%o4 +LY7: ! [internal] + or %o4,%lo(VAR_SEG1),%o4 ! [internal] + mov %i2,%o3 + mov %i4,%o2 + mov %i0,%o1 + call _koscmd_,5 + mov %l7,%o0 + ldsh [%i3],%o3 + sethi %hi(VAR_SEG1),%o2 + ld [%o2+%lo(VAR_SEG1)],%i5 + tst %o3 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + call _xerpsh_,0 + nop + call _xfdele_,1 + mov %i3,%o0 + call _xerpop_,0 + nop + tst %o0 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(L1D54),%o0 + call _erract_,1 + or %o0,%lo(L1D54),%o0 ! [internal] + sethi %hi(_xercom_),%o4 + ld [%o4+%lo(_xercom_)],%o4 + tst %o4 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + b LY5 + sethi %hi(VAR_SEG1),%o0 ! [internal] +L77048: + call _xffluh_,1 + mov %i3,%o0 + sethi %hi(_mem_-2),%o0 ! [internal] + add %l5,1,%l1 + mov %l1,%i2 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%l3 + mov %l3,%i3 + mov 2,%i5 + inc -2,%i0 + add %i5,%i0,%i0 + add %i3,%o0,%o1 + mov %o0,%o7 + sll %l5,1,%o5 + mov 33,%l0 + sth %l0,[%o5+%o7] + mov %o1,%i3 + mov %i0,%i5 +L77049: + ldsh [%i5],%i4 + tst %i4 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + ldsh [%i5],%i0 + cmp %i4,10 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + sth %i0,[%i3] + inc %i2 + inc 2,%i5 + b L77049 + inc 2,%i3 +LY4: ! [internal] + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%i2 + mov %i2,%i5 + mov %o0,%o3 + mov 10,%o4 + sth %o4,[%i5+%o3] + add %o0,2,%o5 + sth %g0,[%i5+%o5] + mov %o0,%o1 + sethi %hi(L1D168),%o7 + add %o7,%lo(L1D168),%i5 + sll %l5,1,%l0 + add %o1,%l0,%o1 + call _putlie_,2 + mov %i5,%o0 + call _xffluh_,1 + mov %i5,%o0 + sethi %hi(L1D148),%l1 + add %l1,%lo(L1D148),%i3 + mov 0,%i5 +L77055: + sethi %hi(VAR_SEG1+4),%o1 + or %o1,%lo(VAR_SEG1+4),%o1 ! [internal] + call _getci_,2 + mov %i3,%o0 + cmp %o0,-2 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(VAR_SEG1+4),%l2 + ld [%l2+%lo(VAR_SEG1+4)],%l2 + cmp %l2,10 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + mov %i5,%o0 + sll %o0,1,%o0 + mov %o0,%o1 + sethi %hi(VAR_SEG1+4),%l3 + ld [%l3+%lo(VAR_SEG1+4)],%l3 + sll %o1,2,%o1 + add %o0,%o1,%o0 + add %l3,-48,%l4 + add %o0,%l4,%o0 + b L77055 + mov %o0,%i5 +LY3: ! [internal] + call _sfree_,1 + or %o0,%lo(VAR_SEG1+16),%o0 ! [internal] + mov %i5,%i3 + sethi %hi(VAR_SEG1),%o0 ! [internal] +LY5: ! [internal] + or %o0,%lo(VAR_SEG1),%o0 ! [internal] + st %i5,[%o0] + st %l5,[%o0+32] + ret + restore %g0,%i3,%o0 + .seg "data" ! [internal] + .common _mem_,8 + .common _xercom_,4 + .align 8 + .align 4 +L1D168: + .word 2 + .align 4 +L1D169: + .word 0x400 + .align 4 +L1D164: + .word 127 + .align 4 +L1D148: + .word 1 + .align 4 +L1D54: + .word 3 + .align 4 +v.16: + .half 0 + .align 4 +v.17: + .word 0x74006d + .word 0x700024 + .word 0x6e0075 + .word 0x6c006c + .skip 2 + .align 4 +v.18: + .skip 2 + .align 4 +v.19: + .skip 2 + .seg "bss" ! [internal] + .align 8 +VAR_SEG1: + .skip 40 diff --git a/unix/as.ssol/as.ssol/zrtadr.s b/unix/as.ssol/as.ssol/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.ssol/as.ssol/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.ssol/as.ssol/zsvjmp.s b/unix/as.ssol/as.ssol/zsvjmp.s new file mode 100644 index 00000000..b4d03439 --- /dev/null +++ b/unix/as.ssol/as.ssol/zsvjmp.s @@ -0,0 +1,32 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global zsvjmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + .proc 0 +zsvjmp_: + st %o1, [%o0] ! save &status in jmpbuf[0] + clr %o2 + st %o2, [%o1] ! zero the value of status + add %o0, 0x4, %o0 + set setjmp, %o1 + jmp %o1 + nop + .seg "data" diff --git a/unix/as.ssol/as.ssol/zsvjmp.s.OLD b/unix/as.ssol/as.ssol/zsvjmp.s.OLD new file mode 100644 index 00000000..7f6bb7eb --- /dev/null +++ b/unix/as.ssol/as.ssol/zsvjmp.s.OLD @@ -0,0 +1,59 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + .global _zdojmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + !# The following requires a jmpbuf of length at least 6 ints. + .proc 0 +_zsvjmp_: + save %sp, -0x60, %sp + call _sigblock + clr %o0 + st %o0, [%i0 + 0x8] + st %i1, [%i0 + 0x14] + clr %o0 + st %o0, [%i1] + st %i7, [%i0] + st %fp, [%i0 + 0x4] + add %i0, 0xc, %o1 + call _sigstack + clr %o0 + ret + restore %g0, 0x0, %o0 + + .proc 0 +_zdojmp_: + save %sp, -0x40, %sp + ta 0x3 + ld [%i0 + 0x4], %fp + sub %fp, 0x60, %sp + call _sigsetmask + ld [%i0 + 0x8], %o0 + add %i0, 0xc, %o0 + call _sigstack + clr %o1 + ld [%i0 + 0x14], %o0 + ld [%i1], %i1 + st %i1, [%o0] + ld [%i0], %i7 + ret + restore %i1, 0x0, %o0 + .seg "data" diff --git a/unix/as.ssol/as.ssol/zzdebug.c b/unix/as.ssol/as.ssol/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.ssol/as.ssol/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.ssol/bytmov.c b/unix/as.ssol/bytmov.c new file mode 100644 index 00000000..98a08fa4 --- /dev/null +++ b/unix/as.ssol/bytmov.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.ssol/enbint.s b/unix/as.ssol/enbint.s new file mode 100644 index 00000000..ad73e9bf --- /dev/null +++ b/unix/as.ssol/enbint.s @@ -0,0 +1,20 @@ + .seg "text" + .global _ieee_enbint + +! _IEEE_ENBINT -- Enable the floating point exceptions indicated by the +! bitmask passed as the only argument. The current bitmask is returned as +! the function value. + +_ieee_enbint: + set 0x0f800000,%o4 + sll %o0,23,%o1 + st %fsr,[%sp+0x44] + ld [%sp+0x44],%o0 + and %o1,%o4,%o1 + andn %o0,%o4,%o2 + or %o1,%o2,%o1 + st %o1,[%sp+0x44] + ld [%sp+0x44],%fsr + and %o0,%o4,%o0 + retl + srl %o0,23,%o0 diff --git a/unix/as.ssol/ieee.gx b/unix/as.ssol/ieee.gx new file mode 100644 index 00000000..fb3e34a4 --- /dev/null +++ b/unix/as.ssol/ieee.gx @@ -0,0 +1,318 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemap$t (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +% real r_quiet_nan +$else +% double precision d_quiet_nan +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + $if (datatype == r) +% ieeenn = r_quiet_NaN() + $else +% ieeenn = d_quiet_NaN() + $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.ssol/ieeed.x b/unix/as.ssol/ieeed.x new file mode 100644 index 00000000..081b4760 --- /dev/null +++ b/unix/as.ssol/ieeed.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 1 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapd (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% double precision d_quiet_nan + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = d_quiet_NaN() + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.ssol/ieeer.x b/unix/as.ssol/ieeer.x new file mode 100644 index 00000000..ab4fee53 --- /dev/null +++ b/unix/as.ssol/ieeer.x @@ -0,0 +1,287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + ieemap[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieemap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + do i = 1, nelem { + fval = native[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + do i = 1, nelem { + fval = ieee[i] + if (and (ival[IOFF], NaNmask) == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + if (mapin != NO) { + fval = x + if (and (ival[IOFF], NaNmask) == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. Setting the reserved native pseudo-NaN value +# has the side effect of enabling NaN mapping and zeroing the statistics +# counters. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + call ieemapr (YES, YES) + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEEMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieemapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +% real r_quiet_nan + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) +% ieeenn = r_quiet_NaN() + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.ssol/oscmd.s b/unix/as.ssol/oscmd.s new file mode 100644 index 00000000..bfa82811 --- /dev/null +++ b/unix/as.ssol/oscmd.s @@ -0,0 +1,369 @@ + .seg "text" ! [internal] + .proc 4 + .global oscmd_ +oscmd_: +!#PROLOGUE# 0 +!#PROLOGUE# 1 + save %sp,-104,%sp + sethi %hi(VAR_SEG1+16),%l0 ! [internal] + or %l0,%lo(VAR_SEG1+16),%l0 ! [internal] + st %i1,[%fp+72] + st %i3,[%fp+80] + call _smark_,1 + mov %l0,%o0 + sethi %hi(L1D168),%o0 + add %o0,%lo(L1D168),%i3 + sethi %hi(L1D169),%o1 + add %l0,16,%o0 + add %o1,%lo(L1D169),%i4 + mov %i4,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(VAR_SEG1+32),%o2 + ld [%o2+%lo(VAR_SEG1+32)],%l5 + sethi %hi(L1D164),%o3 + add %o3,%lo(L1D164),%i5 + inc 20,%l0 ! [internal] + mov %l0,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-8,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-12,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + add %l0,-16,%o0 + mov %i5,%o1 + call _salloc_,3 + mov %i3,%o2 + sethi %hi(L1D148),%o0 + call _clstai_,1 + or %o0,%lo(L1D148),%o0 ! [internal] + cmp %o0,1 + be L77048 + nop + ld [%fp+72],%l6 + sethi %hi(_mem_-2),%o5 + or %o5,%lo(_mem_-2),%o5 ! [internal] + sll %l5,1,%o4 + add %o5,%o4,%o7 + mov %o7,%l7 + mov %l7,%o1 + mov %i4,%o2 + call _strpak_,3 + mov %i0,%o0 + ldsh [%l6],%l0 + tst %l0 + bne,a LY14 + sethi %hi(VAR_SEG1+36),%o0 + sethi %hi(VAR_SEG1+36),%l1 + ld [%l1+%lo(VAR_SEG1+36)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%i0 + add %l3,%i0,%i0 + sethi %hi(v.16),%o0 + or %o0,%lo(v.16),%o0 ! [internal] + mov %i0,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY13 + ld [%fp+80],%i1 +LY14: ! [internal] + ld [%o0+%lo(VAR_SEG1+36)],%o0 + sethi %hi(_mem_-2),%o2 + sll %o0,1,%o1 + or %o2,%lo(_mem_-2),%o2 ! [internal] + add %o2,%o1,%o3 + mov %o3,%i0 + mov %i0,%o1 + mov %i5,%o2 + call _fmapfn_,3 + mov %l6,%o0 + ld [%fp+80],%i1 +LY13: ! [internal] + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + bne,a LY12 + sethi %hi(VAR_SEG1+20),%o4 + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY11 + sethi %hi(VAR_SEG1+20),%l1 + sethi %hi(VAR_SEG1+20),%o4 +LY12: ! [internal] + ld [%o4+%lo(VAR_SEG1+20)],%o4 + sethi %hi(_mem_-2),%o7 + sll %o4,1,%o5 + or %o7,%lo(_mem_-2),%o7 ! [internal] + add %o7,%o5,%l0 + mov %l0,%i3 + sethi %hi(v.17),%o0 + or %o0,%lo(v.17),%o0 ! [internal] + mov %i3,%o1 + call _xmktep_,3 + mov %i5,%o2 + b LY10 + ldsh [%i2],%o0 +LY11: ! [internal] + ld [%l1+%lo(VAR_SEG1+20)],%l1 + sethi %hi(_mem_-2),%l3 + or %l3,%lo(_mem_-2),%l3 ! [internal] + sll %l1,1,%l2 + add %l3,%l2,%l2 + mov %l2,%i3 + sth %g0,[%i3] + ldsh [%i2],%o0 +LY10: ! [internal] + tst %o0 + bne L77021 + sethi %hi(VAR_SEG1+28),%o1 + ld [%o1+%lo(VAR_SEG1+28)],%o1 + sethi %hi(_mem_-2),%o3 + or %o3,%lo(_mem_-2),%o3 ! [internal] + sll %o1,1,%i4 + add %o3,%i4,%i4 + sethi %hi(v.18),%o0 + or %o0,%lo(v.18),%o0 ! [internal] + mov %i4,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY9 + ldsh [%i1],%o1 +L77021: + call _fnulle_,1 + mov %i2,%o0 + tst %o0 + be,a LY8 + sethi %hi(VAR_SEG1+28),%l2 + sethi %hi(VAR_SEG1+28),%o5 + ld [%o5+%lo(VAR_SEG1+28)],%o5 + sethi %hi(_mem_-2),%l0 + or %l0,%lo(_mem_-2),%l0 ! [internal] + sll %o5,1,%o7 + add %l0,%o7,%l1 + mov %i3,%o0 + b LY1 + mov %l1,%i4 +LY8: ! [internal] + ld [%l2+%lo(VAR_SEG1+28)],%l2 + sethi %hi(_mem_-2),%l4 + or %l4,%lo(_mem_-2),%l4 ! [internal] + sll %l2,1,%l3 + add %l4,%l3,%i4 + mov %i2,%o0 +LY1: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i4,%o1 + ldsh [%i1],%o1 +LY9: ! [internal] + tst %o1 + bne L77031 + sethi %hi(VAR_SEG1+24),%o2 + ld [%o2+%lo(VAR_SEG1+24)],%o2 + sethi %hi(_mem_-2),%o4 + sll %o2,1,%o3 + or %o4,%lo(_mem_-2),%o4 ! [internal] + add %o4,%o3,%o5 + mov %o5,%i2 + sethi %hi(v.19),%o0 + or %o0,%lo(v.19),%o0 ! [internal] + mov %i2,%o1 + call _strpak_,3 + mov %i5,%o2 + b LY7 + sethi %hi(VAR_SEG1),%o4 +L77031: + call _fnulle_,1 + mov %i1,%o0 + tst %o0 + be,a LY6 + sethi %hi(VAR_SEG1+24),%l3 + sethi %hi(VAR_SEG1+24),%o7 + ld [%o7+%lo(VAR_SEG1+24)],%o7 + sethi %hi(_mem_-2),%l1 + or %l1,%lo(_mem_-2),%l1 ! [internal] + sll %o7,1,%i2 + mov %i3,%o0 + b LY2 + add %l1,%i2,%i2 +LY6: ! [internal] + ld [%l3+%lo(VAR_SEG1+24)],%l3 + sethi %hi(_mem_-2),%o0 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %l3,1,%l4 + add %o0,%l4,%o1 + mov %o1,%i2 + mov %i1,%o0 +LY2: ! [internal] + mov %i5,%o2 + call _fmapfn_,3 + mov %i2,%o1 + sethi %hi(VAR_SEG1),%o4 +LY7: ! [internal] + or %o4,%lo(VAR_SEG1),%o4 ! [internal] + mov %i2,%o3 + mov %i4,%o2 + mov %i0,%o1 + call _koscmd_,5 + mov %l7,%o0 + ldsh [%i3],%o3 + sethi %hi(VAR_SEG1),%o2 + ld [%o2+%lo(VAR_SEG1)],%i5 + tst %o3 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + call _xerpsh_,0 + nop + call _xfdele_,1 + mov %i3,%o0 + call _xerpop_,0 + nop + tst %o0 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(L1D54),%o0 + call _erract_,1 + or %o0,%lo(L1D54),%o0 ! [internal] + sethi %hi(_xercom_),%o4 + ld [%o4+%lo(_xercom_)],%o4 + tst %o4 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + b LY5 + sethi %hi(VAR_SEG1),%o0 ! [internal] +L77048: + call _xffluh_,1 + mov %i3,%o0 + sethi %hi(_mem_-2),%o0 ! [internal] + add %l5,1,%l1 + mov %l1,%i2 + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%l3 + mov %l3,%i3 + mov 2,%i5 + inc -2,%i0 + add %i5,%i0,%i0 + add %i3,%o0,%o1 + mov %o0,%o7 + sll %l5,1,%o5 + mov 33,%l0 + sth %l0,[%o5+%o7] + mov %o1,%i3 + mov %i0,%i5 +L77049: + ldsh [%i5],%i4 + tst %i4 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + ldsh [%i5],%i0 + cmp %i4,10 + be,a LY4 + sethi %hi(_mem_-2),%o0 ! [internal] + sth %i0,[%i3] + inc %i2 + inc 2,%i5 + b L77049 + inc 2,%i3 +LY4: ! [internal] + or %o0,%lo(_mem_-2),%o0 ! [internal] + sll %i2,1,%i2 + mov %i2,%i5 + mov %o0,%o3 + mov 10,%o4 + sth %o4,[%i5+%o3] + add %o0,2,%o5 + sth %g0,[%i5+%o5] + mov %o0,%o1 + sethi %hi(L1D168),%o7 + add %o7,%lo(L1D168),%i5 + sll %l5,1,%l0 + add %o1,%l0,%o1 + call _putlie_,2 + mov %i5,%o0 + call _xffluh_,1 + mov %i5,%o0 + sethi %hi(L1D148),%l1 + add %l1,%lo(L1D148),%i3 + mov 0,%i5 +L77055: + sethi %hi(VAR_SEG1+4),%o1 + or %o1,%lo(VAR_SEG1+4),%o1 ! [internal] + call _getci_,2 + mov %i3,%o0 + cmp %o0,-2 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + sethi %hi(VAR_SEG1+4),%l2 + ld [%l2+%lo(VAR_SEG1+4)],%l2 + cmp %l2,10 + be,a LY3 + sethi %hi(VAR_SEG1+16),%o0 + mov %i5,%o0 + sll %o0,1,%o0 + mov %o0,%o1 + sethi %hi(VAR_SEG1+4),%l3 + ld [%l3+%lo(VAR_SEG1+4)],%l3 + sll %o1,2,%o1 + add %o0,%o1,%o0 + add %l3,-48,%l4 + add %o0,%l4,%o0 + b L77055 + mov %o0,%i5 +LY3: ! [internal] + call _sfree_,1 + or %o0,%lo(VAR_SEG1+16),%o0 ! [internal] + mov %i5,%i3 + sethi %hi(VAR_SEG1),%o0 ! [internal] +LY5: ! [internal] + or %o0,%lo(VAR_SEG1),%o0 ! [internal] + st %i5,[%o0] + st %l5,[%o0+32] + ret + restore %g0,%i3,%o0 + .seg "data" ! [internal] + .common _mem_,8 + .common _xercom_,4 + .align 8 + .align 4 +L1D168: + .word 2 + .align 4 +L1D169: + .word 0x400 + .align 4 +L1D164: + .word 127 + .align 4 +L1D148: + .word 1 + .align 4 +L1D54: + .word 3 + .align 4 +v.16: + .half 0 + .align 4 +v.17: + .word 0x74006d + .word 0x700024 + .word 0x6e0075 + .word 0x6c006c + .skip 2 + .align 4 +v.18: + .skip 2 + .align 4 +v.19: + .skip 2 + .seg "bss" ! [internal] + .align 8 +VAR_SEG1: + .skip 40 diff --git a/unix/as.ssol/zrtadr.s b/unix/as.ssol/zrtadr.s new file mode 100644 index 00000000..22523154 --- /dev/null +++ b/unix/as.ssol/zrtadr.s @@ -0,0 +1,6 @@ + .seg "text" + .global zrtadr_ +zrtadr_: + mov %i7,%o0 + retl + nop diff --git a/unix/as.ssol/zsvjmp.s b/unix/as.ssol/zsvjmp.s new file mode 100644 index 00000000..b4d03439 --- /dev/null +++ b/unix/as.ssol/zsvjmp.s @@ -0,0 +1,32 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global zsvjmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + .proc 0 +zsvjmp_: + st %o1, [%o0] ! save &status in jmpbuf[0] + clr %o2 + st %o2, [%o1] ! zero the value of status + add %o0, 0x4, %o0 + set setjmp, %o1 + jmp %o1 + nop + .seg "data" diff --git a/unix/as.ssol/zsvjmp.s.OLD b/unix/as.ssol/zsvjmp.s.OLD new file mode 100644 index 00000000..7f6bb7eb --- /dev/null +++ b/unix/as.ssol/zsvjmp.s.OLD @@ -0,0 +1,59 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + .global _zdojmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + !# The following requires a jmpbuf of length at least 6 ints. + .proc 0 +_zsvjmp_: + save %sp, -0x60, %sp + call _sigblock + clr %o0 + st %o0, [%i0 + 0x8] + st %i1, [%i0 + 0x14] + clr %o0 + st %o0, [%i1] + st %i7, [%i0] + st %fp, [%i0 + 0x4] + add %i0, 0xc, %o1 + call _sigstack + clr %o0 + ret + restore %g0, 0x0, %o0 + + .proc 0 +_zdojmp_: + save %sp, -0x40, %sp + ta 0x3 + ld [%i0 + 0x4], %fp + sub %fp, 0x60, %sp + call _sigsetmask + ld [%i0 + 0x8], %o0 + add %i0, 0xc, %o0 + call _sigstack + clr %o1 + ld [%i0 + 0x14], %o0 + ld [%i1], %i1 + st %i1, [%o0] + ld [%i0], %i7 + ret + restore %i1, 0x0, %o0 + .seg "data" diff --git a/unix/as.ssol/zzdebug.c b/unix/as.ssol/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.ssol/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.sunos/aclrb.c b/unix/as.sunos/aclrb.c new file mode 100644 index 00000000..8c03c7a1 --- /dev/null +++ b/unix/as.sunos/aclrb.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRB (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n); +} diff --git a/unix/as.sunos/aclrc.c b/unix/as.sunos/aclrc.c new file mode 100644 index 00000000..04e0e19b --- /dev/null +++ b/unix/as.sunos/aclrc.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRC -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRC (a, n) +XCHAR *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/aclrd.c b/unix/as.sunos/aclrd.c new file mode 100644 index 00000000..0cf06b01 --- /dev/null +++ b/unix/as.sunos/aclrd.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRD -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRD (a, n) +XDOUBLE *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/aclri.c b/unix/as.sunos/aclri.c new file mode 100644 index 00000000..7d5b8ada --- /dev/null +++ b/unix/as.sunos/aclri.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRI -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRI (a, n) +XINT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/aclrl.c b/unix/as.sunos/aclrl.c new file mode 100644 index 00000000..91f2a0ef --- /dev/null +++ b/unix/as.sunos/aclrl.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRL -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRL (a, n) +XLONG *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/aclrr.c b/unix/as.sunos/aclrr.c new file mode 100644 index 00000000..0426aa73 --- /dev/null +++ b/unix/as.sunos/aclrr.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRR -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRR (a, n) +XREAL *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/aclrs.c b/unix/as.sunos/aclrs.c new file mode 100644 index 00000000..b4ff02a4 --- /dev/null +++ b/unix/as.sunos/aclrs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRS -- Clear a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +ACLRS (a, n) +XSHORT *a; +XINT *n; +{ + memset ((char *)a, 0, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/amovc.c b/unix/as.sunos/amovc.c new file mode 100644 index 00000000..ecba2573 --- /dev/null +++ b/unix/as.sunos/amovc.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVC -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVC (a, b, n) +XCHAR *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/amovd.c b/unix/as.sunos/amovd.c new file mode 100644 index 00000000..0cfa8906 --- /dev/null +++ b/unix/as.sunos/amovd.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVD -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVD (a, b, n) +XDOUBLE *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/amovi.c b/unix/as.sunos/amovi.c new file mode 100644 index 00000000..91bc2060 --- /dev/null +++ b/unix/as.sunos/amovi.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVI -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVI (a, b, n) +XINT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/amovl.c b/unix/as.sunos/amovl.c new file mode 100644 index 00000000..815fd651 --- /dev/null +++ b/unix/as.sunos/amovl.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVL -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVL (a, b, n) +XLONG *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/amovr.c b/unix/as.sunos/amovr.c new file mode 100644 index 00000000..94522ea6 --- /dev/null +++ b/unix/as.sunos/amovr.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVR -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVR (a, b, n) +XREAL *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/amovs.c b/unix/as.sunos/amovs.c new file mode 100644 index 00000000..8aa12ae7 --- /dev/null +++ b/unix/as.sunos/amovs.c @@ -0,0 +1,17 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* AMOVS -- Copy a block of memory. + * [Specially optimized for Sun/IRAF]. + */ +AMOVS (a, b, n) +XSHORT *a, *b; +XINT *n; +{ + if (a != b) + memmove ((char *)b, (char *)a, *n * sizeof(*a)); +} diff --git a/unix/as.sunos/bytmov.c b/unix/as.sunos/bytmov.c new file mode 100644 index 00000000..aa43f6d1 --- /dev/null +++ b/unix/as.sunos/bytmov.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + * [Specially optimized version for Sun/IRAF]. + */ +BYTMOV (a, aoff, b, boff, nbytes) +XCHAR *a; /* input byte array */ +XINT *aoff; /* first byte in A to be moved */ +XCHAR *b; /* output byte array */ +XINT *boff; /* first byte in B to be written */ +XINT *nbytes; /* number of bytes to move */ +{ + if ((a + *aoff) != (b + *boff)) + memmove ((char *)b + (*boff-1), (char *)a + (*aoff-1), *nbytes); +} diff --git a/unix/as.sunos/ieee.gx b/unix/as.sunos/ieee.gx new file mode 100644 index 00000000..76a16a60 --- /dev/null +++ b/unix/as.sunos/ieee.gx @@ -0,0 +1,371 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +$if (datatype == r) +real fval +int ival[1] +$else +double fval +int ival[2] +$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +$if (datatype == r) +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / +$else +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ +$endif + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/unix/as.sunos/ieeed.x b/unix/as.sunos/ieeed.x new file mode 100644 index 00000000..4bc194b1 --- /dev/null +++ b/unix/as.sunos/ieeed.x @@ -0,0 +1,338 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon +double fval +int ival[2] +% equivalence (fval, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +double fval +int ival[2] + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x /, ival(2) /-1/ + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/unix/as.sunos/ieeer.x b/unix/as.sunos/ieeer.x new file mode 100644 index 00000000..7649f73f --- /dev/null +++ b/unix/as.sunos/ieeer.x @@ -0,0 +1,338 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon +real fval +int ival[1] +% equivalence (fval, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +real fval +int ival[1] + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +% equivalence (fval, ival) +% data ival(1) / '7ff7ffff'x / + +begin + mapin = inval + mapout = outval + + # MACHDEP. + if (mapout == YES) + ieee_NaN = fval + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/unix/as.sunos/zsvjmp.s b/unix/as.sunos/zsvjmp.s new file mode 100644 index 00000000..0a345079 --- /dev/null +++ b/unix/as.sunos/zsvjmp.s @@ -0,0 +1,50 @@ + .file "zsvjmp.s" + +/ ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +/ registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +/ the registers, effecting a call in the context of the procedure which +/ originally called ZSVJMP, but with the new status code. These are Fortran +/ callable procedures. +/ +/ zsvjmp (jmp_buf, status) (returns status) +/ zdojmp (jmp_buf, status) (passes status to zsvjmp) +/ +/ These routines are directly comparable to the UNIX setjmp/longjmp, except +/ that they are Fortran callable kernel routines, i.e., trailing underscore, +/ call by reference, and no function returns. ZSVJMP requires an assembler +/ jacket routine to avoid modifying the call stack, but relies upon setjmp +/ to do the real work. ZDOJMP is implemented as a portable C routine in OS, +/ calling longjmp to do the restore. In these routines, JMP_BUF consists +/ of one longword containing the address of the STATUS variable, followed +/ by the "jmp_buf" used by setjmp/longjmp. +/ +/ This file contains the Solaris x86 version of ZSVJMP. + + .globl zsvjmp_ + .globl mem_ + .type mem_, @object + .size mem_, 0x8 + mem_ = 0 + + / The following has nothing to do with ZSVJMP, and is included here + / only because this assembler module is loaded with every process. + / This code sets the value of the symbol MEM (the VOS or Fortran Mem + / common) to zero, setting the origin for IRAF pointers to zero rather + / than some arbitrary value, and ensuring that the MEM common is + / aligned for all datatypes as well as page aligned. A further + / advantage is that references to NULL pointers are likely to cause a + / memory violation. + + / .data + / .globl mem_ + / mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx / &jmpbuf to ECX + movl 8(%esp), %eax / &status to EAX + movl %eax, (%ecx) / store &status in jmpbuf[0] + movl $0, (%eax) / zero the value of status + addl $4, %ecx / change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) / ... + jmp setjmp / let setjmp do the rest diff --git a/unix/as.sunos/zsvjmp_p.s b/unix/as.sunos/zsvjmp_p.s new file mode 100644 index 00000000..c4453ba4 --- /dev/null +++ b/unix/as.sunos/zsvjmp_p.s @@ -0,0 +1,48 @@ + .file "zsvjmp.s" + +/ ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +/ registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +/ the registers, effecting a call in the context of the procedure which +/ originally called ZSVJMP, but with the new status code. These are Fortran +/ callable procedures. +/ +/ zsvjmp (jmp_buf, status) (returns status) +/ zdojmp (jmp_buf, status) (passes status to zsvjmp) +/ +/ These routines are directly comparable to the UNIX setjmp/longjmp, except +/ that they are Fortran callable kernel routines, i.e., trailing underscore, +/ call by reference, and no function returns. ZSVJMP requires an assembler +/ jacket routine to avoid modifying the call stack, but relies upon setjmp +/ to do the real work. ZDOJMP is implemented as a portable C routine in OS, +/ calling longjmp to do the restore. In these routines, JMP_BUF consists +/ of one longword containing the address of the STATUS variable, followed +/ by the "jmp_buf" used by setjmp/longjmp. +/ +/ This file contains the Solaris x86 version of ZSVJMP. + + .globl zsvjmp_ + + / The following has nothing to do with ZSVJMP, and is included here + / only because this assembler module is loaded with every process. + / This code sets the value of the symbol MEM (the VOS or Fortran Mem + / common) to zero, setting the origin for IRAF pointers to zero rather + / than some arbitrary value, and ensuring that the MEM common is + / aligned for all datatypes as well as page aligned. A further + / advantage is that references to NULL pointers are likely to cause a + / memory violation. + + .data + .globl mem_ + .type mem_, @object + .size mem_, 0x8 + mem_ = 0 + + .text +zsvjmp_: + movl 4(%esp), %ecx / &jmpbuf to ECX + movl 8(%esp), %eax / &status to EAX + movl %eax, (%ecx) / store &status in jmpbuf[0] + movl $0, (%eax) / zero the value of status + addl $4, %ecx / change stack to point to &jmpbuf[1] + movl %ecx, 4(%esp) / ... + jmp setjmp / let setjmp do the rest diff --git a/unix/as.sunos/zz.c b/unix/as.sunos/zz.c new file mode 100644 index 00000000..68aa838b --- /dev/null +++ b/unix/as.sunos/zz.c @@ -0,0 +1,10 @@ +/* Compile with gcc -S to get demo assembler code. + */ +zsvjmp_(buf,status) +int *buf; +int *status; +{ + *status = 0; + buf[0] = *status; + setjmp (&buf[1]); +} diff --git a/unix/as.sunos/zz.s b/unix/as.sunos/zz.s new file mode 100644 index 00000000..1265b86d --- /dev/null +++ b/unix/as.sunos/zz.s @@ -0,0 +1,27 @@ + .file "zz.c" + .version "01.01" +gcc2_compiled.: +.text + .align 4 +.globl zsvjmp_ + .type zsvjmp_,@function +zsvjmp_: + pushl %ebp + movl %esp,%ebp + movl 12(%ebp),%eax + movl $0,(%eax) + movl 8(%ebp),%eax + movl 12(%ebp),%edx + movl (%edx),%ecx + movl %ecx,(%eax) + movl 8(%ebp),%eax + addl $4,%eax + pushl %eax + call setjmp + addl $4,%esp +.L1: + leave + ret +.Lfe1: + .size zsvjmp_,.Lfe1-zsvjmp_ + .ident "GCC: (GNU) 2.7.2.3" diff --git a/unix/as.sunos/zzdebug.c b/unix/as.sunos/zzdebug.c new file mode 100644 index 00000000..81247e78 --- /dev/null +++ b/unix/as.sunos/zzdebug.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* + * ZZDEBUG -- Test program for ZSVJMP/ZDOJMP. Will return "exit status 1" + * if it runs successfully. + */ + + +int jmpbuf[LEN_JUMPBUF]; +int status; + +main() +{ + zsvjmp_((char *)jmpbuf, &status); + if (status) { + printf ("exit status %d\n", status); + exit (status); + } + + a(1); + exit (0); +} + + +a(status) +int status; +{ + ZDOJMP(jmpbuf, &status); +} + + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +ZDOJMP (jmpbuf, status) +XINT *jmpbuf; +XINT *status; +{ + *((int *)jmpbuf[0]) = *status; + longjmp (&jmpbuf[1], *status); +} diff --git a/unix/as.sunos/zzz.c b/unix/as.sunos/zzz.c new file mode 100644 index 00000000..bf906de9 --- /dev/null +++ b/unix/as.sunos/zzz.c @@ -0,0 +1,5 @@ +exit_(s) +int *s; +{ + exit (*s); +} diff --git a/unix/as.vax/README b/unix/as.vax/README new file mode 100644 index 00000000..58b5c87f --- /dev/null +++ b/unix/as.vax/README @@ -0,0 +1,34 @@ +AS - Assembler Sources + +This directory contains any (non-kernel) files which it has proven +desirable to optimize in assembler. Most of these routines are not +required for the operation of the system, although considerable gains +in speed may be possible in some cases. If the autogeneration routines +cannot find a particular assembler file, the portable routine will +automatically be used instead. + +The following assembler files are required: + + zsvjmp.s (libos.a) + +The following should normally be optimized in assembler, particularly if the +machine has special memory move or bitfield instructions: + + aclr.s clear a block of memory + amov.s move a block of memory + bitpak.s write into a bit field + bitupk.s read from a bit field + bytmov.s a variant on amov.s + ishift.s bit shift, also iand, ior (used by NCAR/graphics) + +The following can be omitted without significant penalty: + + aaddks.s + aadds.s + aluir.s + aluis.s + amapr.s + amaps.s + awsur.s + awsus.s + cyboow.s diff --git a/unix/as.vax/aaddks.s b/unix/as.vax/aaddks.s new file mode 100644 index 00000000..8000beb0 --- /dev/null +++ b/unix/as.vax/aaddks.s @@ -0,0 +1,40 @@ + .data 0 + .set LWM1,0xfc0 + .data 2 + .data 1 + .data 0 + .globl _aaddks_ + .data 2 +v.2: + .space 4 + .set v.1,v.2 + + .stabs "aaddks.f",0x64,0,0,0 + .text + .globl _aaddks_ + .set LF1,12 +_aaddks_: + .word LWM1 + subl2 $LF1,sp + jbr L12 + .align 1 +L12: + moval v.1,r11 + movl *16(ap),-4(fp) + subl2 $2,4(ap) + movl *16(ap),-8(fp) + subl2 $2,12(ap) + movl *16(ap),-12(fp) + movl v.2-v.1(r11),r10 + movl 4(ap),r9 + movl 8(ap),r8 + movl 12(ap),r7 + movl -12(fp),r6 + movl $1,r10 + cmpl r6,r10 + jlss L20 +L21: + addw3 (r9)[r10],(r8),(r7)[r10] + aobleq r6,r10,L21 +L20: + ret diff --git a/unix/as.vax/aadds.s b/unix/as.vax/aadds.s new file mode 100644 index 00000000..42315155 --- /dev/null +++ b/unix/as.vax/aadds.s @@ -0,0 +1,42 @@ + .data 0 + .set LWM1,0xfc0 + .data 2 + .data 1 + .data 0 + .globl _aadds_ + .data 2 +v.2: + .space 4 + .set v.1,v.2 + + .stabs "aadds.f",0x64,0,0,0 + .text + .globl _aadds_ + .set LF1,16 +_aadds_: + .word LWM1 + subl2 $LF1,sp + jbr L12 + .align 1 +L12: + moval v.1,r11 + movl *16(ap),-4(fp) + subl2 $2,4(ap) + movl *16(ap),-8(fp) + subl2 $2,8(ap) + movl *16(ap),-12(fp) + subl2 $2,12(ap) + movl *16(ap),-16(fp) + movl v.2-v.1(r11),r10 + movl 4(ap),r9 + movl 8(ap),r8 + movl 12(ap),r7 + movl -16(fp),r6 + movl $1,r10 + cmpl r6,r10 + jlss L21 +L22: + addw3 (r9)[r10],(r8)[r10],(r7)[r10] + aobleq r6,r10,L22 +L21: + ret diff --git a/unix/as.vax/aclr.s b/unix/as.vax/aclr.s new file mode 100644 index 00000000..5cbb1617 --- /dev/null +++ b/unix/as.vax/aclr.s @@ -0,0 +1,64 @@ +# ACLR -- Zero a block of memory. + + .set MASK, 07400 + .set A, 4 + .set NPIX, 8 + +.data +LZB: + .quad 0 + .quad 0 + .quad 0 + .quad 0 + .quad 0 + .quad 0 + .quad 0 + .quad 0 + .align 2 +.text + .globl _aclrb_ # aclr_ (a, npix) + .globl _aclrc_ + .globl _aclrs_ + .globl _aclri_ + .globl _aclrl_ + .globl _aclrr_ + .globl _aclrd_ + .globl _aclrx_ +_aclrb_: + .word MASK + movl *NPIX(ap), r11 + jbr L10 +_aclrc_: +_aclrs_: + .word MASK + mull3 $2, *NPIX(ap), r11 + jbr L10 +_aclri_: +_aclrl_: +_aclrr_: + .word MASK + mull3 $4, *NPIX(ap), r11 + jbr L10 +_aclrd_: +_aclrx_: + .word MASK + mull3 $8, *NPIX(ap), r11 +L10: + jleq L20 + moval LZB, r8 + movl A(ap), r9 + ashl $-6, r11, r10 + bleq L12 + + # Clear successive 64 byte blocks. +L11: + movc3 $64, (r8), (r9) + addl2 $64, r9 + sobgtr r10, L11 +L12: + # Clear the remaining bytes. + + bicl2 $-64, r11 + movc3 r11, (r8), (r9) +L20: + ret diff --git a/unix/as.vax/aluir.s b/unix/as.vax/aluir.s new file mode 100644 index 00000000..30a37d0d --- /dev/null +++ b/unix/as.vax/aluir.s @@ -0,0 +1,54 @@ +# ALUIR -- Lookup an interpolate a vector of type real onto a real grid. +# [OBSOLETE - NO LONGER USED. 5/27/87] + + .data 0 + .align 2 + .text + .globl _aluir_ + + .set A, 4 + .set B, 8 + .set X, 12 + .set NPIX, 16 + + # ALUIR (a, b, x, npix) + # + # left = int (x[i]) + # tau = x[i] - left + # b[i] = (a[left] * (1-tau)) + (a[left+1] * tau) + # + # registers: + # r0 max_b + # r1 a + # r2 b + # r3 x + # r4 x[i], tau + # r5 left + # r6 + +_aluir_: + .word 0374 # save r2-r7 + subl3 $4, A(ap), r1 + movl B(ap), r2 + movl X(ap), r3 + mull3 $4, *NPIX(ap), r0 + addl2 r2, r0 +L1: + movf (r3)+, r4 # get X into r4 + cvtfl r4, r5 # r5 = left + cvtlf r5, r6 + subf2 r6, r4 # r4 = tau = (x[i] - left) + + movf (r1)[r5], r6 + mulf3 r4, r6, r7 + subf2 r7, r6 # r6 = (a[left] * (1-tau)) + + incl r5 + mulf3 r4, (r1)[r5], r7 # r7 = (a[left+1] * tau) + + addf3 r6, r7, (r2)+ # output result to B + + cmpl r2, r0 + blssu L1 + + ret diff --git a/unix/as.vax/aluis.s b/unix/as.vax/aluis.s new file mode 100644 index 00000000..0fe54e26 --- /dev/null +++ b/unix/as.vax/aluis.s @@ -0,0 +1,56 @@ +# ALUIS -- Lookup an interpolate a vector of type short onto a real grid. +# [OBSOLETE - NO LONGER USED. 5/27/87] + + .data 0 + .align 2 + .text + .globl _aluis_ + + .set A, 4 + .set B, 8 + .set X, 12 + .set NPIX, 16 + + # ALUIS (a, b, x, npix) + # + # left = int (x[i]) + # tau = x[i] - left + # b[i] = (a[left] * (1-tau)) + (a[left+1] * tau) + # + # registers: + # r0 max_b + # r1 a + # r2 b + # r3 x + # r4 x[i], tau + # r5 left + # r6 + +_aluis_: + .word 0374 # save r2-r7 + subl3 $2, A(ap), r1 + movl B(ap), r2 + movl X(ap), r3 + mull3 $2, *NPIX(ap), r0 + addl2 r2, r0 +L1: + movf (r3)+, r4 # get X into r4 + cvtfl r4, r5 # r5 = left + cvtlf r5, r6 + subf2 r6, r4 # r4 = tau = (x[i] - left) + + cvtwf (r1)[r5], r6 + mulf3 r4, r6, r7 + subf2 r7, r6 # r6 = (a[left] * (1-tau)) + + incl r5 + cvtwf (r1)[r5], r7 + mulf2 r4, r7 # r7 = (a[left+1] * tau) + + addf2 r6, r7 + cvtfw r7, (r2)+ # output result to B + + cmpl r2, r0 + blssu L1 + + ret diff --git a/unix/as.vax/amapr.s b/unix/as.vax/amapr.s new file mode 100644 index 00000000..5ba41092 --- /dev/null +++ b/unix/as.vax/amapr.s @@ -0,0 +1,82 @@ +# AMAPR -- Linear transformation, type real. The range of pixel values +# A1 to A2 are mapped into the range B1 to B2 using a linear transformation. +# Values less than A1 or greater than A2 are mapped into the values B1 and +# B2 upon output. + + .data 0 + + .set A, 4 + .set B, 8 + .set NPIX, 12 + .set A1, 16 + .set A2, 20 + .set B1, 24 + .set B2, 28 + + .align 2 + .globl _amapr_ + .text + + # AMAPR (a, b, npix, a1, a2, b1, b2) + # + # scalar = real (b2 - b1) / real (a2 - a1) + # minout = min (b1, b2) + # maxout = max (b1, b2) + # + # do i = 1, npix + # b[i] = max(minout, min(maxout, + # PIXEL((a[i] - a1) * scalar) + b1)) + # + # Registers: + # r0 last_a + # r1 a + # r2 b + # r3 scalar + # r4 minout + # r5 maxout + # r6 a1 + # r7 b1 + +_amapr_: + .word 01774 # save r2-r9 + movl A(ap), r1 + movl B(ap), r2 + mull3 $4, *NPIX(ap), r0 + addl2 r1, r0 + movf *A1(ap), r6 + movf *B1(ap), r7 + movf *A2(ap), r8 + movf *B2(ap), r9 + + subf3 r7, r9, r3 # r3 = (b2 - b1) / (a2 - a1) + subf3 r6, r8, r4 + divf2 r4, r3 + + cmpf r7, r9 # b1 <= b2 + bleq L1 + movf r9, r4 # no, min=b2, max=b1 + movf r7, r5 + jbr L2 +L1: movf r7, r4 # yes, min=b1, max=b2 + movf r9, r5 +L2: + subf3 r6, (r1)+, r8 # r8 = a[i] - a1 + mulf2 r3, r8 # (..) * scalar + addf2 r7, r8 # (..) + b1 + + cmpf r8, r4 # r8 < minout? + bgtr L3 + movf r4, (r2)+ + jbr L5 +L3: + cmpf r8, r5 # r8 > maxout? + blss L4 + movf r5, (r2)+ + jbr L5 +L4: + movf r8, (r2)+ # new value in range +L5: + cmpl r1, r0 + blssu L2 # loop again + + ret diff --git a/unix/as.vax/amaps.s b/unix/as.vax/amaps.s new file mode 100644 index 00000000..8f7664ea --- /dev/null +++ b/unix/as.vax/amaps.s @@ -0,0 +1,86 @@ +# AMAPS -- Linear transformation, type short. The range of pixel values +# A1 to A2 are mapped into the range B1 to B2 using a linear transformation. +# Values less than A1 or greater than A2 are mapped into the values B1 and +# B2 upon output. + + .data 0 + + .set A, 4 + .set B, 8 + .set NPIX, 12 + .set A1, 16 + .set A2, 20 + .set B1, 24 + .set B2, 28 + + .align 2 + .globl _amaps_ + .text + + # AMAPS (a, b, npix, a1, a2, b1, b2) + # + # scalar = real (b2 - b1) / real (a2 - a1) + # minout = min (b1, b2) + # maxout = max (b1, b2) + # + # do i = 1, npix + # b[i] = max(minout, min(maxout, + # PIXEL((a[i] - a1) * scalar) + b1)) + # + # Registers: + # r0 last_a + # r1 a + # r2 b + # r3 scalar + # r4 minout + # r5 maxout + # r6 a1 + # r7 b1 + +_amaps_: + .word 01774 # save r2-r9 + movl A(ap), r1 + movl B(ap), r2 + mull3 $2, *NPIX(ap), r0 + addl2 r1, r0 + movw *A1(ap), r6 + movw *B1(ap), r7 + movw *A2(ap), r8 + movw *B2(ap), r9 + + subw3 r7, r9, r3 # r3 = (b2 - b1) / (a2 - a1) + cvtwf r3, r3 + subw3 r6, r8, r4 + cvtwf r4, r4 + divf2 r4, r3 + + cmpw r7, r9 # b1 <= b2 + bleq L1 + movw r9, r4 # no, min=b2, max=b1 + movw r7, r5 + jbr L2 +L1: movw r7, r4 # yes, min=b1, max=b2 + movw r9, r5 +L2: + subw3 r6, (r1)+, r8 # r8 = a[i] - a1 + cvtwf r8, r8 + mulf2 r3, r8 # (..) * scalar + cvtfw r8, r8 + addw2 r7, r8 # (..) + b1 + + cmpw r8, r4 # r8 < minout? + bgtr L3 + movw r4, (r2)+ + jbr L5 +L3: + cmpw r8, r5 # r8 > maxout? + blss L4 + movw r5, (r2)+ + jbr L5 +L4: + movw r8, (r2)+ # new value in range +L5: + cmpl r1, r0 + blssu L2 # loop again + + ret diff --git a/unix/as.vax/amov.s b/unix/as.vax/amov.s new file mode 100644 index 00000000..61784aac --- /dev/null +++ b/unix/as.vax/amov.s @@ -0,0 +1,94 @@ +# AMOV -- Move a block of data from one area of memory to another. The +# move is carried out (using the MOVC instruction) in such a way that +# data is not destroyed, regardless of whether or not the input an output +# arrays overlap. Note that the move is not data dependent (floating +# point data is not special). + + .set MASK, 07400 + .set A, 4 + .set B, 8 + .set NPIX, 12 + .set MAXBLK, 0177777 + + .align 2 +.text + .globl _amovc_ # amov_ (a, b, npix) + .globl _amovs_ + .globl _amovi_ + .globl _amovl_ + .globl _amovr_ + .globl _amovd_ + .globl _amovx_ +_amovc_: +_amovs_: + .word MASK + movl $2, r11 # r11 = size of pixel + jbr L10 +_amovi_: +_amovl_: +_amovr_: + .word MASK + movl $4, r11 + jbr L10 +_amovd_: +_amovx_: + .word MASK + movl $8, r11 + + # Compute source and destination addresses and the number of bytes to + # be moved. If nbytes=0 or the source and destinatation are the same + # then we are done. If nbytes is greater than a single MOVC3 can + # accomodate then we must branch to the more complicated code below, + # otherwise we call MOVC3 and return. + +L10: mull3 r11, *NPIX(ap), r10 # nbytes + jleq L20 + movl A(ap), r8 # fwa of A array + movl B(ap), r9 # fwa of B array + cmpl r8, r9 + jeql L20 # A, B same array + cmpl r10, $MAXBLK # too large for single movc3? + jgtr L30 + movc3 r10, (r8), (r9) +L20: + ret +L30: + # Since the array is larger than a single MOVC3 instruction can + # accomodate we must do the move in segments of size MAXBLK. Since + # multiple moves are needed we cannot leave it up to MOVC3 to make + # sure that the move is nondestructive. If the destination is to + # the left (lower address) of the source then the move is necessarily + # nondestructive. If to the right then the move is potentially + # nondestructive, and we must solve the problem by moving the high + # segments first. + + movl $MAXBLK, r11 + cmpl r8, r9 + jlssu L50 +L40: # move high to low + cmpl r10, $MAXBLK + jgtr L41 + movl r10, r11 +L41: + movc3 r11, (r8), (r9) + addl2 r11, r8 + addl2 r11, r9 + subl2 r11, r10 + jgtr L40 + + ret +L50: # move low to high + addl2 r10, r8 + addl2 r10, r9 +L60: + cmpl r10, $MAXBLK + jgtr L61 + movl r10, r11 +L61: + subl2 r11, r8 + subl2 r11, r9 + movc3 r11, (r8), (r9) + subl2 r11, r10 + jgtr L60 + + ret diff --git a/unix/as.vax/awsur.s b/unix/as.vax/awsur.s new file mode 100644 index 00000000..a1a97e16 --- /dev/null +++ b/unix/as.vax/awsur.s @@ -0,0 +1,44 @@ +# AWSUR -- Weighted sum of two type real vectors. + + .data 0 + .globl _awsur_ + .align 2 + .text + + .set A, 4 + .set B, 8 + .set C, 12 + .set NPIX, 16 + .set W1, 20 + .set W2, 24 + + # AWSUR (a, b, c, npix, w1, w2) + # + # registers: + # r0 max_a + # r1 a + # r2 b + # r3 c + # r4 w1 (real) + # r5 w2 (real) + +_awsur_: + .word 0374 + movl A(ap), r1 + movl B(ap), r2 + movl C(ap), r3 + mull3 $4, *NPIX(ap), r0 + addl2 r1, r0 + movf *W1(ap), r4 + movf *W2(ap), r5 + + # c[i] = a[i] * w1 + b[i] * w2 +L1: + mulf3 (r1)+, r4, r6 + mulf3 (r2)+, r5, r7 + addf3 r6, r7, (r3)+ + + cmpl r1, r0 + blssu L1 + + ret diff --git a/unix/as.vax/awsus.s b/unix/as.vax/awsus.s new file mode 100644 index 00000000..5ad9bb78 --- /dev/null +++ b/unix/as.vax/awsus.s @@ -0,0 +1,47 @@ +# AWSUS -- Weighted sum of two type short vectors. + + .data 0 + .globl _awsus_ + .align 2 + .text + + .set A, 4 + .set B, 8 + .set C, 12 + .set NPIX, 16 + .set W1, 20 + .set W2, 24 + + # AWSUS (a, b, c, npix, w1, w2) + # + # registers: + # r0 max_a + # r1 a + # r2 b + # r3 c + # r4 w1 (real) + # r5 w2 (real) + +_awsus_: + .word 0374 + movl A(ap), r1 + movl B(ap), r2 + movl C(ap), r3 + mull3 $2, *NPIX(ap), r0 + addl2 r1, r0 + movf *W1(ap), r4 + movf *W2(ap), r5 + + # c[i] = a[i] * w1 + b[i] * w2 +L1: + cvtwf (r1)+, r6 + mulf2 r4, r6 + cvtwf (r2)+, r7 + mulf2 r5, r7 + addf2 r6, r7 + cvtfw r7, (r3)+ + + cmpl r1, r0 + blssu L1 + + ret diff --git a/unix/as.vax/bitfields.s b/unix/as.vax/bitfields.s new file mode 100644 index 00000000..5e28cd3d --- /dev/null +++ b/unix/as.vax/bitfields.s @@ -0,0 +1,42 @@ +# BITFIELDS -- Routines for inserting and extracting bitfields into integers. + +# BITPAK -- Pack an integer into a bitfield of an array. Set all nbits +# bits regardless of the value of the integer. + + .text + .align 1 + .globl _bitpak_ + + # bitpak (intval, array, offset, nbits) + .set INTVAL, 4 + .set ARRAY, 8 + .set OFFSET, 12 # one-indexed bit offset + .set NBITS, 16 + +_bitpak_: + .word 0x0 + + subl3 $1, *OFFSET(ap), r1 + insv *INTVAL(ap), r1, *NBITS(ap), *ARRAY(ap) + ret + .data + +# BITUPK -- Unpack a bitfield from an array and return as the function +# value, an integer. Do not sign extend. + + .text + .align 1 + .globl _bitupk_ + + # bitupk (array, offset, nbits) + .set ARRAY, 4 + .set OFFSET, 8 # one-indexed bit offset + .set NBITS, 12 + +_bitupk_: + .word 0x0 + + subl3 $1, *OFFSET(ap), r1 + extzv r1, *NBITS(ap), *ARRAY(ap), r0 + ret + .data diff --git a/unix/as.vax/bytmov.s b/unix/as.vax/bytmov.s new file mode 100644 index 00000000..64acc299 --- /dev/null +++ b/unix/as.vax/bytmov.s @@ -0,0 +1,80 @@ +# BYTMOV -- Move a block of data from one area of memory to another. The +# move is carried out (using the MOVC instruction) in such a way that +# data is not destroyed, regardless of whether or not the input and output +# arrays overlap. + + .set MASK, 07400 + + # bytmov (a, aoff, b, boff, nbytes) + .set A, 4 + .set AOFF, 8 + .set B, 12 + .set BOFF, 16 + .set NBYTES, 20 + .set MAXBLK, 0177777 + + .align 2 +.text + .globl _bytmov_ +_bytmov_: + .word MASK + + # Compute source and destination addresses and the number of bytes to + # be moved. If nbytes=0 or the source and destinatation are the same + # then we are done. If nbytes is greater than a single MOVC3 can + # accomodate then we must branch to the more complicated code below, + # otherwise we call MOVC3 and return. + + movl *NBYTES(ap), r10 # nbytes + jleq L20 + addl3 A(ap), *AOFF(ap), r8 # fwa of A array + decl r8 # allow for one-indexing + addl3 B(ap), *BOFF(ap), r9 # fwa of B array + decl r9 # allow for one-indexing + cmpl r8, r9 + jeql L20 # A, B same array + cmpl r10, $MAXBLK # too large for single movc3? + jgtr L30 + movc3 r10, (r8), (r9) +L20: + ret +L30: + # Since the array is larger than a single MOVC3 instruction can + # accomodate we must do the move in segments of size MAXBLK. Since + # multiple moves are needed we cannot leave it up to MOVC3 to make + # sure that the move is nondestructive. If the destination is to + # the left (lower address) of the source then the move is necessarily + # nondestructive. If to the right then the move is potentially + # nondestructive, and we must solve the problem by moving the high + # segments first. + + movl $MAXBLK, r11 + cmpl r8, r9 + jlssu L50 +L40: # move high to low + cmpl r10, $MAXBLK + jgtr L41 + movl r10, r11 +L41: + movc3 r11, (r8), (r9) + addl2 r11, r8 + addl2 r11, r9 + subl2 r11, r10 + jgtr L40 + + ret +L50: # move low to high + addl2 r10, r8 + addl2 r10, r9 +L60: + cmpl r10, $MAXBLK + jgtr L61 + movl r10, r11 +L61: + subl2 r11, r8 + subl2 r11, r9 + movc3 r11, (r8), (r9) + subl2 r11, r10 + jgtr L60 + + ret diff --git a/unix/as.vax/cyboow.s b/unix/as.vax/cyboow.s new file mode 100644 index 00000000..cafec5a2 --- /dev/null +++ b/unix/as.vax/cyboow.s @@ -0,0 +1,93 @@ +# CYBOOW, CYBOEW -- Order the bits in an odd or even indexed 60-bit Cyber word. +# The operation may not be performed in-place. The offsets and sizes of the +# bit segments which must be moved are as follows: +# +# --> Odd Words <-- --> Even Words <-- +# [from] [to] [nbits] +# 1 53 8 -3 57 4 +# 9 45 8 5 49 8 +# 17 37 8 13 41 8 +# 25 29 8 21 33 8 +# 33 21 8 29 25 8 +# 41 13 8 37 17 8 +# 49 5 8 45 9 8 +# 61 1 4 53 1 8 +# +# Input bit-offsets must be a multiple of the Cyber word size, i.e., 1, 61, +# 121, etc. An output word may begin at any bit-offset. + +.globl _cyboow_ +.globl _cyboew_ + + .set IN, 4 + .set INBIT, 8 + .set OUT, 12 + .set OUTBIT, 16 + + .data + .align 2 +W: .long 0 # temp space for output word + .long 0 + + .text + .align 1 + + +# CYBOOW -- Order odd cyber word. After swapping the first 8 bytes of IN the +# ordered 60-bit Cyber word is in bits 5-64 of the temporary storage area at W. + +_cyboow_: # (in, inbit, out, outbit) + .word 0x4 + + subl3 $1, *INBIT(ap), r0 # bit offset into IN + ashl $-3, r0, r0 + addl2 IN(ap), r0 # input base address + + addl3 $8, $W, r1 # swap bytes into W temporary + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + + movl OUT(ap), r0 # output base address + subl3 $1, *OUTBIT(ap), r1 # bit offset into OUT + extzv $4, $30, W, r2 + insv r2, r1, $30, (r0) # put first 30 bits + extzv $34, $30, W, r2 + addl2 $30, r1 + insv r2, r1, $30, (r0) # put second 30 bits + ret + +# CYBOEW -- Order even cyber word. After swapping the 8 bytes the ordered +# Cyber word will be found in bits 1-60 of the temporary storage area at W. + +_cyboew_: # (in, inbit, out, outbit) + .word 0x4 + subl3 $5, *INBIT(ap), r0 # bit offset into IN + ashl $-3, r0, r0 + addl2 IN(ap), r0 # input base address + + addl3 $8, $W, r1 # swap bytes into W temporary + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + movb (r0)+, -(r1) + + movl OUT(ap), r0 # output base address + subl3 $1, *OUTBIT(ap), r1 # bit offset into OUT + movl W, r2 + insv r2, r1, $32, (r0) # put first 32 bits + extzv $32, $30, W, r2 + addl2 $32, r1 + insv r2, r1, $28, (r0) # put remaining 28 bits + + ret + .data diff --git a/unix/as.vax/ieeed.s b/unix/as.vax/ieeed.s new file mode 100644 index 00000000..ec550592 --- /dev/null +++ b/unix/as.vax/ieeed.s @@ -0,0 +1,182 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +# +# IEEED.S -- IEEE double to VAX double floating conversions. +# +# ieepakd (x) # scalar, vax->ieee +# ieeupkd (x) # scalar, ieee->vax +# ieevpakd (native, ieee, nelem) # vector, vax->ieee +# ieevupkd (ieee, native, nelem) # vector, ieee->vax +# ieesnand (NaN) # set VAX NaN value +# ieegnand (NaN) # get VAX NaN value +# ieemapd (mapin, mapout) # enable NaN mapping +# ieestatd (nin, nout) # get num NaN values mapped +# ieezstatd () # zero NaN counters +# +# These routines convert between the VAX and IEEE double floating formats, +# operating upon a single value or an array of values. +/- zero is converted +# to zero. When converting IEEE to VAX, underflow maps to zero, and exponent +# overflow and NaN input values map to the value set by IEESNAND (default 0). +# These routines are functionally equivalent to the semi-portable versions of +# the IRAF ieee/native floating conversion routines in osb$ieeed.x. +# TODO - Add a function callback option for processing NaN values. + + .data +vaxnan: .quad 0 +nanin: .long 0 +nanout: .long 0 +mapin: .long 1 # enable input NaN mapping by default for VAX +mapout: .long 0 + + .text + .align 1 + .globl _ieepad_ + .globl _ieevpd_ + .globl _ieeupd_ + .globl _ieevud_ + .globl _ieesnd_ + .globl _ieegnd_ + .globl _ieemad_ + .globl _ieestd_ + .globl _ieezsd_ + +_ieepad_: # IEEPAKD (X) + .word 0x3c + movl 4(ap), r4 # data addr -> r4 + movl r4, r5 # output clobbers input + jsb cvt_vax_ieee # convert value + ret +_ieevpd_: # IEEVPAKD (VAX, IEEE, NELEM) + .word 0x7c + movl 4(ap), r4 # input vector -> r4 + movl 8(ap), r5 # output vector -> r5 + movl *12(ap), r6 # loop counter +L1: jsb cvt_vax_ieee # convert one value + sobgtr r6, L1 # loop + ret +_ieeupd_: # IEEUPKD (X) + .word 0x3c + movl 4(ap), r4 # data addr -> r4 + movl r4, r5 # output clobbers input + jsb cvt_ieee_vax # convert value + ret +_ieevud_: # IEEVUPKD (IEEE, VAX, NELEM) + .word 0x7c + movl 4(ap), r4 # input vector -> r4 + movl 8(ap), r5 # output vector -> r5 + movl *12(ap), r6 # loop counter +L2: jsb cvt_ieee_vax # convert one value + sobgtr r6, L2 # loop + ret +_ieesnd_: # IEESNAND (VAXNAN) + .word 0x0 + movq *4(ap), vaxnan + clrl nanin + clrl nanout + ret +_ieegnd_: # IEEGNAND (VAXNAN) + .word 0x0 + movq vaxnan, *4(ap) + ret +_ieemad_: # IEEMAPD (MAPIN, MAPOUT) + .word 0x0 + movl *4(ap), mapin + movl *8(ap), mapout + ret +_ieestd_: # IEESTATD (NIN, NOUT) + .word 0x0 + movl nanin, *4(ap) + movl nanout, *8(ap) + ret +_ieezsd_: # IEEZSTATD () + .word 0x0 + clrl nanin + clrl nanout + ret + +cvt_vax_ieee: # R4=in, R5=out + movl (r4)+, r1 # get vax double + movl (r4)+, r0 # get vax double + + tstl mapout # map NaNs on output? + beql L4 # no, just output value + cmpl r0, vaxnan # yes, check if reserved value + bneq L4 # no, just output value + cmpl r1, vaxnan+4 # yes, check if reserved value + bneq L4 # no, just output value + clrl r0 # generate IEEE NaN value + clrl r1 # generate IEEE NaN value + insv $2047, $20, $11, r1 # insert NaN exponent (2047) + incl nanout # increment counter + jbr L5 +L4: + rotl $16, r0, r0 # swap words -> r0 + rotl $16, r1, r1 # swap words -> r1 + extzv $23, $8, r1, r2 # 8 bit exponent -> r2 + beql L6 # branch if zero exponent + extzv $2, $1, r0, r3 # get round bit -> r3 + ashq $-3, r0, r0 # shift 64 data bits by 3 + addw2 $(1024-130), r2 # adjust exponent bias + insv r2, $20, $11, r1 # insert new exponent + blbc r3, L5 # branch if round bit clear + incl r0 # round low longword + adwc $0, r1 # carry to high longword +L5: + movl sp, r3 # r3 points to input byte + pushl r1 # push r1 on stack + pushl r0 # push r0 on stack + movb -(r3), (r5)+ # output quadword, swapped + movb -(r3), (r5)+ + movb -(r3), (r5)+ + movb -(r3), (r5)+ + movb -(r3), (r5)+ + movb -(r3), (r5)+ + movb -(r3), (r5)+ + movb -(r3), (r5)+ + addl2 $8, sp # pop stack + rsb # all done +L6: + clrl r0 # return all 64 bits zero + clrl r1 + jbr L5 + +cvt_ieee_vax: # R4=in, R5=out + movb (r4)+, -(sp) # byte swap quadword onto stack + movb (r4)+, -(sp) + movb (r4)+, -(sp) + movb (r4)+, -(sp) + movb (r4)+, -(sp) + movb (r4)+, -(sp) + movb (r4)+, -(sp) + movb (r4)+, -(sp) + + movl (sp)+, r0 # pop low bits + movl (sp)+, r1 # pop high bits + extzv $20, $11, r1, r2 # exponent -> r2 + beql L10 # zero exponent + tstl mapin # map NaNs on input? + beql L9 # no, don't check value + cmpl r2, $2047 # NaN double has exponent 2047 + beql L11 # yes, output vaxnan +L9: + extzv $31, $1, r1, r3 # save sign bit + ashq $3, r0, r0 # shift 64 bits left 3 bits + subw2 $(1024-130), r2 # adjust exponent bias + bleq L10 # return zero if underflow + cmpw r2, $256 # compare with max VAX exponent + bgeq L11 # return VAX-NaN if overflow + insv r2, $23, $8, r1 # insert VAX-D exponent + insv r3, $31, $1, r1 # restore sign bit + + rotl $16, r1, (r5)+ # output VAX double + rotl $16, r0, (r5)+ # output VAX double + rsb +L10: + clrl (r5)+ # return all 64 bits zero + clrl (r5)+ + rsb +L11: + moval vaxnan, r3 # return VAX equiv. of NaN + movl (r3)+, (r5)+ + movl (r3)+, (r5)+ + incl nanin + rsb diff --git a/unix/as.vax/ieeer.s b/unix/as.vax/ieeer.s new file mode 100644 index 00000000..789712aa --- /dev/null +++ b/unix/as.vax/ieeer.s @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +# +# IEEER.S -- IEEE real to VAX single precision floating conversions. +# +# ieepakr (x) # scalar, vax->ieee +# ieeupkr (x) # scalar, ieee->vax +# ieevpakr (native, ieee, nelem) # vector, vax->ieee +# ieevupkr (ieee, native, nelem) # vector, ieee->vax +# ieesnanr (NaN) # set VAX NaN value +# ieegnanr (NaN) # get VAX NaN value +# ieemapr (mapin, mapout) # enable NaN mapping +# ieestatr (nin, nout) # get num NaN values mapped +# ieezstatr () # zero NaN counters +# +# These routines convert between the VAX and IEEE real floating formats, +# operating upon a single value or an array of values. +/- zero is converted +# to zero. When converting IEEE to VAX, underflow maps to zero, and exponent +# overflow and NaN input values map to the value set by IEESNANR (default 0). +# These routines are functionally equivalent to the semi-portable versions of +# the IRAF ieee/native floating conversion routines in osb$ieeer.x. +# TODO - Add a function callback option for processing NaN values. + + .data +vaxnan: .long 0 +nanin: .long 0 +nanout: .long 0 +mapin: .long 1 # enable input NaN mapping by default for VAX +mapout: .long 0 + + .text + .align 1 + .globl _ieepar_ + .globl _ieevpr_ + .globl _ieeupr_ + .globl _ieevur_ + .globl _ieesnr_ + .globl _ieegnr_ + .globl _ieemar_ + .globl _ieestr_ + .globl _ieezsr_ + +_ieepar_: # IEEPAKR (X) + .word 0x0c + movl 4(ap), r2 # data addr -> r2 + movl r2, r3 # output clobbers input + jsb cvt_vax_ieee # convert value + ret +_ieevpr_: # IEEVPAKR (VAX, IEEE, NELEM) + .word 0x1c + movl 4(ap), r2 # input vector -> r2 + movl 8(ap), r3 # output vector -> r3 + movl *12(ap), r4 # loop counter +L1: jsb cvt_vax_ieee # convert one value + sobgtr r4, L1 # loop + ret +_ieeupr_: # IEEUPKR (X) + .word 0x0c + movl 4(ap), r2 # data addr -> r2 + movl r2, r3 # output clobbers input + jsb cvt_ieee_vax # convert value + ret +_ieevur_: # IEEVUPKR (IEEE, VAX, NELEM) + .word 0x1c + movl 4(ap), r2 # input vector -> r2 + movl 8(ap), r3 # output vector -> r3 + movl *12(ap), r4 # loop counter +L2: jsb cvt_ieee_vax # convert one value + sobgtr r4, L2 # loop + ret +_ieesnr_: # IEESNANR (VAXNAN) + .word 0x0 + movl *4(ap), vaxnan + clrl nanin + clrl nanout + ret +_ieegnr_: # IEEGNANR (VAXNAN) + .word 0x0 + movl vaxnan, *4(ap) + ret +_ieemar_: # IEEMAPR (MAPIN, MAPOUT) + .word 0x0 + movl *4(ap), mapin + movl *8(ap), mapout + ret +_ieestr_: # IEESTATR (NIN, NOUT) + .word 0x0 + movl nanin, *4(ap) + movl nanout, *8(ap) + ret +_ieezsr_: # IEEZSTATR () + .word 0x0 + clrl nanin + clrl nanout + ret + +cvt_vax_ieee: # R2=in, R3=out + movl (r2)+, r0 # vax value -> r0 + + tstl mapout # map NaNs on output? + beql L4 # no, just output value + cmpl r0, vaxnan # yes, check if reserved value + bneq L4 # no, just output value + clrl r0 # generate IEEE NaN value + insv $255, $23, $8, r0 # insert NaN exponent (255) + incl nanout # increment counter + jbr L5 +L4: + rotl $16, r0, r0 # swap words -> r0 + extzv $23, $8, r0, r1 # 8 bit exponent -> r1 + beql L6 # branch if zero exponent + subw2 $2, r1 # adjust exponent bias + bleq L6 # return zero if underflow + insv r1, $23, $8, r0 # insert new exponent +L5: + movl sp, r1 # r3 points to input byte + pushl r0 # push r0 on stack + movb -(r1), (r3)+ # output longword, swapped + movb -(r1), (r3)+ + movb -(r1), (r3)+ + movb -(r1), (r3)+ + tstl (sp)+ # pop stack + rsb # all done +L6: + clrl r0 # return all 32 bits zero + jbr L5 + +cvt_ieee_vax: # R2=in, R3=out + movb (r2)+, -(sp) # byte swap longword onto stack + movb (r2)+, -(sp) + movb (r2)+, -(sp) + movb (r2)+, -(sp) + movl (sp)+, r0 # pop swapped value -> r0 + extzv $23, $8, r0, r1 # exponent -> r1 + beql L10 # zero exponent + tstl mapin # map NaNs on input? + beql L9 # no, don't check value + cmpl r1, $255 # NaN has exponent 255 + beql L11 # yes, output vaxnan +L9: + addw2 $2, r1 # adjust exponent bias + cmpw r1, $256 # compare with max VAX exponent + bgeq L11 # return VAX-NaN if overflow + insv r1, $23, $8, r0 # insert VAX-D exponent + rotl $16, r0, (r3)+ # output VAX value + rsb +L10: + clrl (r3)+ # return all 32 bits zero + rsb +L11: + moval vaxnan, r1 # return VAX equiv. of NaN + movl (r1)+, (r3)+ + incl nanin + rsb diff --git a/unix/as.vax/ishift.s b/unix/as.vax/ishift.s new file mode 100644 index 00000000..1319556f --- /dev/null +++ b/unix/as.vax/ishift.s @@ -0,0 +1,57 @@ +# IAND, IOR, ISHIFT -- Bitwise boolean integer functions for the NCAR +# package. The shift function must rotate the bits left and around +# if the nbits to shift argument is positive. + + .data # Bitwise boolean AND + .text + .align 1 + .globl _iand_ +_iand_: + .word L12 + jbr L14 +L15: + mcoml *8(ap),r0 + bicl3 r0,*4(ap),r0 + ret + ret + .set L12,0x0 +L14: + jbr L15 + + + .data # Bitwise boolean OR + .text + .align 1 + .globl _ior_ +_ior_: + .word L17 + jbr L19 +L20: + bisl3 *8(ap),*4(ap),r0 + ret + ret + .set L17,0x0 +L19: + jbr L20 + + + .data # Bitwise SHIFT + .text + .align 1 + .globl _ishift_ +_ishift_: + .word L22 + jbr L24 +L25: + movl *8(ap),r11 + jlss L26 + rotl r11,*4(ap),r0 # left rotate longword + ret +L26: + ashl r11,*4(ap),r0 # right shift with sign extension + ret + ret + .set L22,0x800 +L24: + jbr L25 + .data diff --git a/unix/as.vax/zsvjmp.s b/unix/as.vax/zsvjmp.s new file mode 100644 index 00000000..f4664dac --- /dev/null +++ b/unix/as.vax/zsvjmp.s @@ -0,0 +1,35 @@ +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. + + .globl _zsvjmp_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the Mem common) to zero, + # setting the origin for IRAF pointers to zero rather than some + # arbitrary value, and ensuring that the MEM common is aligned for + # all datatypes as well as page aligned. A further advantage is that + # references to NULL pointers will cause a memory violation. + + .globl _mem_ + .set _mem_, 0 + + .set JMPBUF, 4 + .set STATUS, 8 + + # The strategy here is to build on the services provided by the C + # setjmp/longjmp. Note that we cannot do this by writing a C function + # which calls setjmp, because the procedure which calls setjmp cannot + # return before the longjmp is executed (we want to return to the caller # of the routine containing the setjmp call, not the routine itself). + + .align 1 +_zsvjmp_: # CALL ZSVJMP (JMPBUF, STATUS) + .word 0x0 + movl STATUS(ap),*JMPBUF(ap) # jmp_buf[0] = addr of status variable + clrl *STATUS(ap) # return zero status + addl2 $4, JMPBUF(ap) # skip first cell of jmp_buf + movl $1, (ap) # SETJMP (JMP_BUF) + jmp _setjmp+2 # let setjmp do the rest. diff --git a/unix/as.vax/zsvjmp.s.ORIG b/unix/as.vax/zsvjmp.s.ORIG new file mode 100644 index 00000000..59911970 --- /dev/null +++ b/unix/as.vax/zsvjmp.s.ORIG @@ -0,0 +1,55 @@ +# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +# the registers, effecting a call in the context of the procedure which +# originally called ZSVJMP, but with the new status code. These are Fortran +# callable procedures. + + .globl _zsvjmp_ + .globl _zdojmp_ + + # The following has nothing to do with ZSVJMP, and is included here + # only because this assembler module is loaded with every process. + # This code sets the value of the symbol MEM (the Mem common) to zero, + # setting the origin for IRAF pointers to zero rather than some + # arbitrary value, and ensuring that the MEM common is aligned for + # all datatypes as well as page aligned. A further advantage is that + # references to NULL pointers will cause a memory violation. + + .globl _mem_ + .set _mem_, 0 + + .set JMPBUF, 4 + .set STATUS, 8 + + .align 1 +_zsvjmp_: # set up jump + .word 0x0 + movl JMPBUF(ap), r0 + movl STATUS(ap), (r0)+ # save address of status variable + movq r6, (r0)+ + movq r8, (r0)+ + movq r10, (r0)+ + movq 8(fp), (r0)+ # ap, fp + movab 12(ap), (r0)+ # sp + movl 16(fp), (r0) # saved pc + clrl *STATUS(ap) + clrl r0 + ret + + .align 1 +_zdojmp_: # do jump (return again from zsvjmp) + .word 0x0 + movl JMPBUF(ap), r1 + movl (r1)+, r0 # get address of status variable + movl *STATUS(ap), (r0) # put new status there + movq (r1)+, r6 + movq (r1)+, r8 + movq (r1)+, r10 + movq (r1)+, r12 + movl (r1)+, sp + tstl (r0) # must not return status=0 + bneq L1 + movzbl $1, (r0) +L1: + movl (r0), r0 + jmp *(r1) diff --git a/unix/bin b/unix/bin new file mode 120000 index 00000000..715871b3 --- /dev/null +++ b/unix/bin @@ -0,0 +1 @@ +bin.generic \ No newline at end of file diff --git a/unix/bin.cygwin/arch_includes/fio.h b/unix/bin.cygwin/arch_includes/fio.h new file mode 100644 index 00000000..4d9e8f49 --- /dev/null +++ b/unix/bin.cygwin/arch_includes/fio.h @@ -0,0 +1,146 @@ +# FIO.H -- FIO definitions. + +# Logical seek: adjust i/o pointer to the seek offset. If the buffer was +# being written into when the seek occurs, adjust ITOP and OTOP to mark +# the end of the good data in the buffer, then set IOP to new offset. + +define (UPDATE_IOP, if (bufptr[$1] != NULL && otop[$1] == buftop[$1]) { itop[$1] = min(buftop[$1], max(itop[$1], iop[$1])) ; otop[$1] = itop[$1] }) +define (LSEEK, {UPDATE_IOP($1);iop[$1]=($2-boffset[$1]+bufptr[$1])}) +define LNOTE (boffset[$1]+iop[$1]-bufptr[$1]) +define BUF_MODIFIED (otop[$1] > bufptr[$1]) + +define INACTIVE 0 +define READ_IN_PROGRESS 1 +define WRITE_IN_PROGRESS 2 + + +# File descriptor structure (dynamically allocated part) + +define SZ_FFNAME 255 +define LEN_FIODES (20+LEN_CHANDES+256) + +define FCHAN Memi[$1] # os channnel +define FMODE Memi[$1+1] # mode of access +define FTYPE Memi[$1+2] # binary or text +define FDEV Memi[$1+3] # device index +define FBUFSIZE Memi[$1+4] # buffer size +define FIRSTBUFOFF Memi[$1+5] # offset of first file buffer +define FNBUFS Memi[$1+6] # number of buffers +define FLOCBUF Memi[$1+7] # zlocva of aread buffer +define FPBBUFSIZE Memi[$1+8] # size pushback buffer +define FPBBUF Memi[$1+9] # ptr to pushback buffer +define FPBTOP Memi[$1+10] # ptr to top of pbbuf +define FPBIOP Memi[$1+11] # iop into pbbuf +define FPBSP Memi[$1+12] # pbbuf stack pointer +define FILSTAT Memi[$1+13] # channel status +define FNCHARS Memi[$1+14] # nchars last i/o +define FNBYTES Memi[$1+15] # nbytes last rec read +define FBUFMODE Memi[$1+16] # i/o mode for buffer +define FFIOMODE Memi[$1+17] # i/o mode for file +define FCD Memi[$1+18] # ptr to chan descr. + # (open) +define FLCD ($1+20) # local storage for cd +define FNAME Memc[P2C($1+20+LEN_CHANDES)] # filename + +# Channel descriptor (stored in fd if file not multiply open). The DEVPAR +# (device parameter) fields are reserved for use with special devices and +# are not used by FIO. + +define LEN_CHANDES (10+256) +define FREFCNT Memi[FCD($1)] # chan reference count +define FCIOMODE Memi[FCD($1)+1] # chan i/o mode +define FCLOSEFD Memi[FCD($1)+2] # close chan when inactive +define FAFD Memi[FCD($1)+3] # active fd +define FBLKSIZE Memi[FCD($1)+4] # device block size +define FOPTBUFSIZE Memi[FCD($1)+5] # "optimum" buffer size +define FMAXBUFSIZE Memi[FCD($1)+6] # maximum buffer size +define FDEVOPEN Memi[FCD($1)+7] # device zopen proc +define FILSZ_PTR FCD($1)+8 +define FILSIZE Meml[FILSZ_PTR($1)] # file size, chars +define FPKOSFN Memc[P2C(FCD($1)+10)] # packed osfn of file + + +# Flags + +define FF_FLUSHNL 1B # flush each line to output device +define FF_READ 2B # read perm on file +define FF_WRITE 4B # write perm on file +define FF_EOF 10B # at EOF +define FF_ERR 20B # i/o error +define FF_KEEP 40B # keep file open after task quits? +define FF_FLUSH 100B # write each line to z buffer +define FF_RAW 200B # raw i/o when reading a text device +define FF_NDELAY 400B # nonblocking i/o +define FF_PUSHBACK 1000B # data is pushed back into input + + +# Device table entry points + +define LEN_DTE 7 # length of device table entry +define TX_DRIVER 1 # index into devtbl of textfile driver +define BF_DRIVER 8 # index of binary file driver +define TY_DRIVER 15 # index of terminal driver +define PR_DRIVER 22 # index of IPC driver +define SF_DRIVER 29 # index of static file driver +define STD_DRIVER ($1 <= 29) # is device code that of a std driver? + +define ZGETTX zdev[FDEV($1)] # text files +define ZPUTTX zdev[FDEV($1)+1] +define ZFLSTX zdev[FDEV($1)+2] +define ZSTTTX zdev[FDEV($1)+3] +define ZCLSTX zdev[FDEV($1)+4] +define ZSEKTX zdev[FDEV($1)+5] +define ZNOTTX zdev[FDEV($1)+6] + +define ZARDBF zdev[FDEV($1)] # binary files +define ZAWRBF zdev[FDEV($1)+1] +define ZAWTBF zdev[FDEV($1)+2] +define ZSTTBF zdev[FDEV($1)+3] +define ZCLSBF zdev[FDEV($1)+4] + + +# File status codes (ZFSTTX, ZFSTTB). FIO makes a distinction between the +# device block size, which establishes the alignment restrictions for +# asynchronous reads and writes, and the "optimal" buffer size, the default +# buffer size supplied by the device z-routines, which defines the minimum +# buffer size for efficient sequential access to the device. + +define FSTT_BLKSIZE 1 # block size, bytes +define FSTT_FILSIZE 2 # file size, bytes +define FSTT_OPTBUFSIZE 3 # optimum buffer size, bytes +define FSTT_MAXBUFSIZE 4 # optimum buffer size, bytes + +define REMOVE_PROTECTION 0 # for ZFPROT +define SET_PROTECTION 1 +define QUERY_PROTECTION 2 + +define STRING_FILE (-1) # open a string as a file +define SZ_SPOOLBUF 4096 # def. initial size of a spool buffer + + +# Filename Mapping definitions. + +define SZ_VFNFN 127 # max size ROOT or EXTN in VFN +define SZ_OSDIR 255 # max chars in V_OSDIR field + +define VFN_READ 1 # VFN access modes for VFNOPEN +define VFN_WRITE 2 +define VFN_UNMAP 3 + +define VFN_NOUPDATE 0 # update flag for VFNCLOSE +define VFN_UPDATE 1 + + +# Terminal driver escape sequences. + +define LEN_RAWCMD 5 # +1 for iomode character (N|B) +define RAWOFF "\033-rAw" # raw mode off +define RAWON "\033+rAw" # raw mode on + +define LEN_SETREDRAW 6 # 5 char escape sequence + code +define SETREDRAW "\033=rDw" # set/enable screen redraw code + + +# Magtape driver global definitions. + +define LEN_MTDEVPOS 5 diff --git a/unix/bin.cygwin/arch_includes/pllseg.h b/unix/bin.cygwin/arch_includes/pllseg.h new file mode 100644 index 00000000..c2bc1811 --- /dev/null +++ b/unix/bin.cygwin/arch_includes/pllseg.h @@ -0,0 +1,62 @@ +# PLLSEG.H -- Macros for sequentially reading segments of a line list. +# +# pll_init (ll, descriptor) +# npix = pll_nleft (descriptor) +# val = pll_getseg (ll, descriptor, npix, value) +# +# pll_init Initialize descriptor for sequential i/o from the linelist LL. +# pll_nleft Number of pixels left in the current line segment of constant +# value. Zero is returned at the EOL. +# pll_getseg Read NPIX pixels from the current segment, advancing to the +# next segment automatically when the the current segment is +# exhausted. +# +# The descriptor is an integer array, the contents of which are hidden from +# the application using these macros. This package uses the internal +# procedure PLL_NEXTSEG, which is included in PL package library. + +# Range list i/o descriptor. +define LEN_PLLDES 7 +define ld_nleft $1[1] +define ld_value $1[2] +define ld_x $1[3] +define ld_ip $1[4] +define ld_hi $1[5] +define ld_next_nleft $1[6] +define ld_next_value $1[7] + +# PLL_NLEFT -- Number of pixels left in the current segment. +define pll_nleft ld_nleft($1) + +## PLL_INIT -- Initialize the linelist descriptor. +#define (pll_init, { # $1=ll $2=des +# # ld_x($2) = 1 +# ld_hi($2) = 1 +# if (LL_OLDFORMAT($1)) +# ld_ip($2) = OLL_FIRST +# else +# ld_ip($2) = LL_FIRST($1) +# ld_next_nleft($2) = 0 +# ld_nleft($2) = 0 +# call pll_nextseg ($1, $2) +#}) + +define (pll_init, {ld_hi($2)=1;if(LL_OLDFORMAT($1)){ld_ip($2)=OLL_FIRST;}else{ld_ip($2)=LL_FIRST($1);}ld_next_nleft($2)=0;ld_nleft($2)=0;call pll_nextseg($1,$2);}) + +# +## PLL_GETSEG -- Read pixels from the current segment. +#define (pll_getseg, { # $1=ll $2=des $3=npix $4=value +# $4 = ld_value($2) +# # ld_x($2) = ld_x($2) + $3 +# ld_nleft($2) = ld_nleft($2) - $3 +# if (ld_nleft($2) <= 0) +# if (ld_next_nleft($2) > 0) { +# ld_nleft($2) = ld_next_nleft($2) +# ld_value($2) = ld_next_value($2) +# ld_next_nleft($2) = 0 +# } else +# call pll_nextseg ($1, $2) +#}) + +define (pll_getseg, {$4=ld_value($2);ld_nleft($2)=ld_nleft($2)-$3;if(ld_nleft($2)<=0){if(ld_next_nleft($2)>0){ld_nleft($2)=ld_next_nleft($2);ld_value($2)=ld_next_value($2);ld_next_nleft($2)=0;}else{call pll_nextseg($1,$2);}}}) + diff --git a/unix/bin.cygwin/arch_includes/plrseg.h b/unix/bin.cygwin/arch_includes/plrseg.h new file mode 100644 index 00000000..2f32a9ab --- /dev/null +++ b/unix/bin.cygwin/arch_includes/plrseg.h @@ -0,0 +1,68 @@ +# PLRSEG.H -- Macros for sequentially reading segments of a range list. +# +# plr_init (rl, descriptor) +# npix = plr_nleft (descriptor) +# val = plr_getseg (rl, descriptor, npix, value) +# +# plr_init Initialize descriptor for sequential i/o from the rangelist RL. +# plr_nleft Number of pixels left in the current line segment of constant +# value. Zero is returned at the EOL. +# plr_getseg Read NPIX pixels from the current segment, advancing to the +# next segment automatically when the the current segment is +# exhausted. +# +# The descriptor is an integer array, the contents of which are hidden from +# the application using these macros. + +# Range list i/o descriptor. +define LEN_PLRDES 4 +define rd_nleft $1[1] +define rd_value $1[2] +define rd_x $1[3] +define rd_rn $1[4] + +# PLR_NLEFT -- Number of pixels left in the current segment. +define plr_nleft rd_nleft($1) + +# PLR_INIT -- Initialize the rangelist descriptor. +#define (plr_init, { # $1=rl $2=des +# rd_x($2) = 1 +# rd_rn($2) = RL_FIRST +# plr_nextseg ($1, $2) +#}) + +# PLR_GETSEG -- Read pixels from the current segment. +#define (plr_getseg, { # $1=rl $2=des $3=npix $4=value +# $4 = rd_value($2) +# rd_x($2) = rd_x($2) + $3 +# rd_nleft($2) = rd_nleft($2) - $3 +# if (rd_nleft($2) <= 0) +# plr_nextseg ($1, $2) +#}) + +# PLR_NEXTSEG -- Set up the next segment (internal routine). +#define (plr_nextseg, { # $1=rl $2=des +# if (rd_rn($2) <= RL_LEN($1)) { +# if ($1[1,rd_rn($2)] > rd_x($2)) { +# rd_value($2) = 0 +# rd_nleft($2) = $1[1,rd_x($2)] - rd_x($2) +# } else { +# rd_value($2) = $1[3,rd_rn($2)] +# rd_nleft($2) = $1[2,rd_rn($2)] +# rd_rn($2) = rd_rn($2) + 1 +# } +# } else if (rd_x($2) <= RL_AXLEN($1)) { +# rd_value($2) = 0 +# rd_nleft($2) = RL_AXLEN($1) - rd_x($2) + 1 +# } +#}) + + +# PLR_INIT -- Initialize the rangelist descriptor. +define (plr_init, {rd_x($2)=1;rd_rn($2)=RL_FIRST;plr_nextseg($1,$2);}) + +# PLR_GETSEG -- Read pixels from the current segment. +define (plr_getseg, {$4=rd_value($2);rd_x($2)=rd_x($2)+$3;rd_nleft($2)=rd_nleft($2)-$3;if(rd_nleft($2) <= 0){plr_nextseg($1,$2)}}) + +# PLR_NEXTSEG -- Set up the next segment (internal routine). +define (plr_nextseg, {if(rd_rn($2)<=RL_LEN($1)){if($1[1,rd_rn($2)]>rd_x($2)){rd_value($2)=0;rd_nleft($2)=$1[1,rd_x($2)]-rd_x($2);}else{rd_value($2)=$1[3,rd_rn($2)];rd_nleft($2)=$1[2,rd_rn($2)];rd_rn($2)=rd_rn($2)+1;}}else if(rd_x($2)<=RL_AXLEN($1)){rd_value($2)=0;rd_nleft($2)=RL_AXLEN($1)-rd_x($2)+1;}}) diff --git a/unix/bin.cygwin/f2c.e.exe b/unix/bin.cygwin/f2c.e.exe new file mode 100755 index 00000000..d6bfb29b Binary files /dev/null and b/unix/bin.cygwin/f2c.e.exe differ diff --git a/unix/bin.cygwin/f2c.h b/unix/bin.cygwin/f2c.h new file mode 100644 index 00000000..6af1cdc0 --- /dev/null +++ b/unix/bin.cygwin/f2c.h @@ -0,0 +1,228 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +/* +typedef long int integer; +typedef long int logical; +*/ +typedef int integer; +typedef int logical; + +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/bin.cygwin/fio.h b/unix/bin.cygwin/fio.h new file mode 100644 index 00000000..4d9e8f49 --- /dev/null +++ b/unix/bin.cygwin/fio.h @@ -0,0 +1,146 @@ +# FIO.H -- FIO definitions. + +# Logical seek: adjust i/o pointer to the seek offset. If the buffer was +# being written into when the seek occurs, adjust ITOP and OTOP to mark +# the end of the good data in the buffer, then set IOP to new offset. + +define (UPDATE_IOP, if (bufptr[$1] != NULL && otop[$1] == buftop[$1]) { itop[$1] = min(buftop[$1], max(itop[$1], iop[$1])) ; otop[$1] = itop[$1] }) +define (LSEEK, {UPDATE_IOP($1);iop[$1]=($2-boffset[$1]+bufptr[$1])}) +define LNOTE (boffset[$1]+iop[$1]-bufptr[$1]) +define BUF_MODIFIED (otop[$1] > bufptr[$1]) + +define INACTIVE 0 +define READ_IN_PROGRESS 1 +define WRITE_IN_PROGRESS 2 + + +# File descriptor structure (dynamically allocated part) + +define SZ_FFNAME 255 +define LEN_FIODES (20+LEN_CHANDES+256) + +define FCHAN Memi[$1] # os channnel +define FMODE Memi[$1+1] # mode of access +define FTYPE Memi[$1+2] # binary or text +define FDEV Memi[$1+3] # device index +define FBUFSIZE Memi[$1+4] # buffer size +define FIRSTBUFOFF Memi[$1+5] # offset of first file buffer +define FNBUFS Memi[$1+6] # number of buffers +define FLOCBUF Memi[$1+7] # zlocva of aread buffer +define FPBBUFSIZE Memi[$1+8] # size pushback buffer +define FPBBUF Memi[$1+9] # ptr to pushback buffer +define FPBTOP Memi[$1+10] # ptr to top of pbbuf +define FPBIOP Memi[$1+11] # iop into pbbuf +define FPBSP Memi[$1+12] # pbbuf stack pointer +define FILSTAT Memi[$1+13] # channel status +define FNCHARS Memi[$1+14] # nchars last i/o +define FNBYTES Memi[$1+15] # nbytes last rec read +define FBUFMODE Memi[$1+16] # i/o mode for buffer +define FFIOMODE Memi[$1+17] # i/o mode for file +define FCD Memi[$1+18] # ptr to chan descr. + # (open) +define FLCD ($1+20) # local storage for cd +define FNAME Memc[P2C($1+20+LEN_CHANDES)] # filename + +# Channel descriptor (stored in fd if file not multiply open). The DEVPAR +# (device parameter) fields are reserved for use with special devices and +# are not used by FIO. + +define LEN_CHANDES (10+256) +define FREFCNT Memi[FCD($1)] # chan reference count +define FCIOMODE Memi[FCD($1)+1] # chan i/o mode +define FCLOSEFD Memi[FCD($1)+2] # close chan when inactive +define FAFD Memi[FCD($1)+3] # active fd +define FBLKSIZE Memi[FCD($1)+4] # device block size +define FOPTBUFSIZE Memi[FCD($1)+5] # "optimum" buffer size +define FMAXBUFSIZE Memi[FCD($1)+6] # maximum buffer size +define FDEVOPEN Memi[FCD($1)+7] # device zopen proc +define FILSZ_PTR FCD($1)+8 +define FILSIZE Meml[FILSZ_PTR($1)] # file size, chars +define FPKOSFN Memc[P2C(FCD($1)+10)] # packed osfn of file + + +# Flags + +define FF_FLUSHNL 1B # flush each line to output device +define FF_READ 2B # read perm on file +define FF_WRITE 4B # write perm on file +define FF_EOF 10B # at EOF +define FF_ERR 20B # i/o error +define FF_KEEP 40B # keep file open after task quits? +define FF_FLUSH 100B # write each line to z buffer +define FF_RAW 200B # raw i/o when reading a text device +define FF_NDELAY 400B # nonblocking i/o +define FF_PUSHBACK 1000B # data is pushed back into input + + +# Device table entry points + +define LEN_DTE 7 # length of device table entry +define TX_DRIVER 1 # index into devtbl of textfile driver +define BF_DRIVER 8 # index of binary file driver +define TY_DRIVER 15 # index of terminal driver +define PR_DRIVER 22 # index of IPC driver +define SF_DRIVER 29 # index of static file driver +define STD_DRIVER ($1 <= 29) # is device code that of a std driver? + +define ZGETTX zdev[FDEV($1)] # text files +define ZPUTTX zdev[FDEV($1)+1] +define ZFLSTX zdev[FDEV($1)+2] +define ZSTTTX zdev[FDEV($1)+3] +define ZCLSTX zdev[FDEV($1)+4] +define ZSEKTX zdev[FDEV($1)+5] +define ZNOTTX zdev[FDEV($1)+6] + +define ZARDBF zdev[FDEV($1)] # binary files +define ZAWRBF zdev[FDEV($1)+1] +define ZAWTBF zdev[FDEV($1)+2] +define ZSTTBF zdev[FDEV($1)+3] +define ZCLSBF zdev[FDEV($1)+4] + + +# File status codes (ZFSTTX, ZFSTTB). FIO makes a distinction between the +# device block size, which establishes the alignment restrictions for +# asynchronous reads and writes, and the "optimal" buffer size, the default +# buffer size supplied by the device z-routines, which defines the minimum +# buffer size for efficient sequential access to the device. + +define FSTT_BLKSIZE 1 # block size, bytes +define FSTT_FILSIZE 2 # file size, bytes +define FSTT_OPTBUFSIZE 3 # optimum buffer size, bytes +define FSTT_MAXBUFSIZE 4 # optimum buffer size, bytes + +define REMOVE_PROTECTION 0 # for ZFPROT +define SET_PROTECTION 1 +define QUERY_PROTECTION 2 + +define STRING_FILE (-1) # open a string as a file +define SZ_SPOOLBUF 4096 # def. initial size of a spool buffer + + +# Filename Mapping definitions. + +define SZ_VFNFN 127 # max size ROOT or EXTN in VFN +define SZ_OSDIR 255 # max chars in V_OSDIR field + +define VFN_READ 1 # VFN access modes for VFNOPEN +define VFN_WRITE 2 +define VFN_UNMAP 3 + +define VFN_NOUPDATE 0 # update flag for VFNCLOSE +define VFN_UPDATE 1 + + +# Terminal driver escape sequences. + +define LEN_RAWCMD 5 # +1 for iomode character (N|B) +define RAWOFF "\033-rAw" # raw mode off +define RAWON "\033+rAw" # raw mode on + +define LEN_SETREDRAW 6 # 5 char escape sequence + code +define SETREDRAW "\033=rDw" # set/enable screen redraw code + + +# Magtape driver global definitions. + +define LEN_MTDEVPOS 5 diff --git a/unix/bin.cygwin/libf2c.a b/unix/bin.cygwin/libf2c.a new file mode 100644 index 00000000..58bcc126 Binary files /dev/null and b/unix/bin.cygwin/libf2c.a differ diff --git a/unix/bin.cygwin/pllseg.h b/unix/bin.cygwin/pllseg.h new file mode 100644 index 00000000..c2bc1811 --- /dev/null +++ b/unix/bin.cygwin/pllseg.h @@ -0,0 +1,62 @@ +# PLLSEG.H -- Macros for sequentially reading segments of a line list. +# +# pll_init (ll, descriptor) +# npix = pll_nleft (descriptor) +# val = pll_getseg (ll, descriptor, npix, value) +# +# pll_init Initialize descriptor for sequential i/o from the linelist LL. +# pll_nleft Number of pixels left in the current line segment of constant +# value. Zero is returned at the EOL. +# pll_getseg Read NPIX pixels from the current segment, advancing to the +# next segment automatically when the the current segment is +# exhausted. +# +# The descriptor is an integer array, the contents of which are hidden from +# the application using these macros. This package uses the internal +# procedure PLL_NEXTSEG, which is included in PL package library. + +# Range list i/o descriptor. +define LEN_PLLDES 7 +define ld_nleft $1[1] +define ld_value $1[2] +define ld_x $1[3] +define ld_ip $1[4] +define ld_hi $1[5] +define ld_next_nleft $1[6] +define ld_next_value $1[7] + +# PLL_NLEFT -- Number of pixels left in the current segment. +define pll_nleft ld_nleft($1) + +## PLL_INIT -- Initialize the linelist descriptor. +#define (pll_init, { # $1=ll $2=des +# # ld_x($2) = 1 +# ld_hi($2) = 1 +# if (LL_OLDFORMAT($1)) +# ld_ip($2) = OLL_FIRST +# else +# ld_ip($2) = LL_FIRST($1) +# ld_next_nleft($2) = 0 +# ld_nleft($2) = 0 +# call pll_nextseg ($1, $2) +#}) + +define (pll_init, {ld_hi($2)=1;if(LL_OLDFORMAT($1)){ld_ip($2)=OLL_FIRST;}else{ld_ip($2)=LL_FIRST($1);}ld_next_nleft($2)=0;ld_nleft($2)=0;call pll_nextseg($1,$2);}) + +# +## PLL_GETSEG -- Read pixels from the current segment. +#define (pll_getseg, { # $1=ll $2=des $3=npix $4=value +# $4 = ld_value($2) +# # ld_x($2) = ld_x($2) + $3 +# ld_nleft($2) = ld_nleft($2) - $3 +# if (ld_nleft($2) <= 0) +# if (ld_next_nleft($2) > 0) { +# ld_nleft($2) = ld_next_nleft($2) +# ld_value($2) = ld_next_value($2) +# ld_next_nleft($2) = 0 +# } else +# call pll_nextseg ($1, $2) +#}) + +define (pll_getseg, {$4=ld_value($2);ld_nleft($2)=ld_nleft($2)-$3;if(ld_nleft($2)<=0){if(ld_next_nleft($2)>0){ld_nleft($2)=ld_next_nleft($2);ld_value($2)=ld_next_value($2);ld_next_nleft($2)=0;}else{call pll_nextseg($1,$2);}}}) + diff --git a/unix/bin.cygwin/plrseg.h b/unix/bin.cygwin/plrseg.h new file mode 100644 index 00000000..2f32a9ab --- /dev/null +++ b/unix/bin.cygwin/plrseg.h @@ -0,0 +1,68 @@ +# PLRSEG.H -- Macros for sequentially reading segments of a range list. +# +# plr_init (rl, descriptor) +# npix = plr_nleft (descriptor) +# val = plr_getseg (rl, descriptor, npix, value) +# +# plr_init Initialize descriptor for sequential i/o from the rangelist RL. +# plr_nleft Number of pixels left in the current line segment of constant +# value. Zero is returned at the EOL. +# plr_getseg Read NPIX pixels from the current segment, advancing to the +# next segment automatically when the the current segment is +# exhausted. +# +# The descriptor is an integer array, the contents of which are hidden from +# the application using these macros. + +# Range list i/o descriptor. +define LEN_PLRDES 4 +define rd_nleft $1[1] +define rd_value $1[2] +define rd_x $1[3] +define rd_rn $1[4] + +# PLR_NLEFT -- Number of pixels left in the current segment. +define plr_nleft rd_nleft($1) + +# PLR_INIT -- Initialize the rangelist descriptor. +#define (plr_init, { # $1=rl $2=des +# rd_x($2) = 1 +# rd_rn($2) = RL_FIRST +# plr_nextseg ($1, $2) +#}) + +# PLR_GETSEG -- Read pixels from the current segment. +#define (plr_getseg, { # $1=rl $2=des $3=npix $4=value +# $4 = rd_value($2) +# rd_x($2) = rd_x($2) + $3 +# rd_nleft($2) = rd_nleft($2) - $3 +# if (rd_nleft($2) <= 0) +# plr_nextseg ($1, $2) +#}) + +# PLR_NEXTSEG -- Set up the next segment (internal routine). +#define (plr_nextseg, { # $1=rl $2=des +# if (rd_rn($2) <= RL_LEN($1)) { +# if ($1[1,rd_rn($2)] > rd_x($2)) { +# rd_value($2) = 0 +# rd_nleft($2) = $1[1,rd_x($2)] - rd_x($2) +# } else { +# rd_value($2) = $1[3,rd_rn($2)] +# rd_nleft($2) = $1[2,rd_rn($2)] +# rd_rn($2) = rd_rn($2) + 1 +# } +# } else if (rd_x($2) <= RL_AXLEN($1)) { +# rd_value($2) = 0 +# rd_nleft($2) = RL_AXLEN($1) - rd_x($2) + 1 +# } +#}) + + +# PLR_INIT -- Initialize the rangelist descriptor. +define (plr_init, {rd_x($2)=1;rd_rn($2)=RL_FIRST;plr_nextseg($1,$2);}) + +# PLR_GETSEG -- Read pixels from the current segment. +define (plr_getseg, {$4=rd_value($2);rd_x($2)=rd_x($2)+$3;rd_nleft($2)=rd_nleft($2)-$3;if(rd_nleft($2) <= 0){plr_nextseg($1,$2)}}) + +# PLR_NEXTSEG -- Set up the next segment (internal routine). +define (plr_nextseg, {if(rd_rn($2)<=RL_LEN($1)){if($1[1,rd_rn($2)]>rd_x($2)){rd_value($2)=0;rd_nleft($2)=$1[1,rd_x($2)]-rd_x($2);}else{rd_value($2)=$1[3,rd_rn($2)];rd_nleft($2)=$1[2,rd_rn($2)];rd_rn($2)=rd_rn($2)+1;}}else if(rd_x($2)<=RL_AXLEN($1)){rd_value($2)=0;rd_nleft($2)=RL_AXLEN($1)-rd_x($2)+1;}}) diff --git a/unix/bin.freebsd/README b/unix/bin.freebsd/README new file mode 100644 index 00000000..842caaf7 --- /dev/null +++ b/unix/bin.freebsd/README @@ -0,0 +1,12 @@ +BIN.FREEBSD + +This directory contains host-specific binaries for the FreeBSD version +of IRAF. These are generated automatically in an HSI bootstrap, which is +performed by the "reboot" command in $iraf/unix. + +An exception to the above are the F2C files in this directory. The F2C +executable, library, and include file, which are manually copied in from +the host system. These are installed here as IRAF requires them but they +are not typically installed on Linux systems these days. IRAF XC uses +the f77.sh script in HLIB to compiler Fortran files. This script is +tailored to use the version of F2C installed here in HBIN. diff --git a/unix/bin.freebsd/f2c.1.gz b/unix/bin.freebsd/f2c.1.gz new file mode 100644 index 00000000..e9f69f4a Binary files /dev/null and b/unix/bin.freebsd/f2c.1.gz differ diff --git a/unix/bin.freebsd/f2c.e b/unix/bin.freebsd/f2c.e new file mode 100755 index 00000000..fea9886b Binary files /dev/null and b/unix/bin.freebsd/f2c.e differ diff --git a/unix/bin.freebsd/f2c.h b/unix/bin.freebsd/f2c.h new file mode 100644 index 00000000..61f72aff --- /dev/null +++ b/unix/bin.freebsd/f2c.h @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#if 0 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef int flag; +typedef int ftnlen; +typedef int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/bin.freebsd/libf2c.a b/unix/bin.freebsd/libf2c.a new file mode 100644 index 00000000..e9f95b51 Binary files /dev/null and b/unix/bin.freebsd/libf2c.a differ diff --git a/unix/bin.linux/alloc.e b/unix/bin.linux/alloc.e new file mode 100755 index 00000000..9bd59215 Binary files /dev/null and b/unix/bin.linux/alloc.e differ diff --git a/unix/bin.linux/f2c.1 b/unix/bin.linux/f2c.1 new file mode 100644 index 00000000..3bdbc8b8 --- /dev/null +++ b/unix/bin.linux/f2c.1 @@ -0,0 +1,222 @@ + + F2C(1) UNIX System V F2C(1) + + NAME + f2c - Convert Fortran 77 to C or C++ + + SYNOPSIS + f2c [ option ... ] file ... + + DESCRIPTION + F2c converts Fortran 77 source code in files with names end- + ing in `.f' or `.F' to C (or C++) source files in the cur- + rent directory, with `.c' substituted for the final `.f' or + `.F'. If no Fortran files are named, f2c reads Fortran from + standard input and writes C on standard output. File names + that end with `.p' or `.P' are taken to be prototype files, + as produced by option `-P', and are read first. + + The following options have the same meaning as in f77(1). + + -C Compile code to check that subscripts are within + declared array bounds. + + -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long + int. Assume the default libF77 and libI77: allow only + INTEGER*4 (and no LOGICAL) variables in INQUIREs. + Option `-I4' confirms the default rendering of INTEGER + as long int. + + -Idir + Look for a non-absolute include file first in the + directory of the current input file, then in directo- + ries specified by -I options (one directory per + option). Options -I2 and -I4 have precedence, so, + e.g., a directory named 2 should be specified by -I./2 + . + + -onetrip + Compile DO loops that are performed at least once if + reached. (Fortran 77 DO loops are not performed at all + if the upper limit is smaller than the lower limit.) + + -U Honor the case of variable and external names. Fortran + keywords must be in lower case. + + -u Make the default type of a variable `undefined' rather + than using the default Fortran rules. + + -w Suppress all warning messages, or, if the option is + `-w66', just Fortran 66 compatibility warnings. + + The following options are peculiar to f2c. + + -A Produce ANSI C (default, starting 20020621). For old- + style C, use option -K. + + Page 1 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + -a Make local variables automatic rather than static + unless they appear in a DATA, EQUIVALENCE, NAMELIST, or + SAVE statement. + + -C++ Output C++ code. + + -c Include original Fortran source as comments. + + -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and + cdsqrt as synonyms for the double complex intrinsics + zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, + nor dreal as a synonym for dble. + + -ddir + Write `.c' files in directory dir instead of the cur- + rent directory. + + -E Declare uninitialized COMMON to be Extern (overridably + defined in f2c.h as extern). + + -ec Place uninitialized COMMON blocks in separate files: + COMMON /ABC/ appears in file abc_com.c. Option `-e1c' + bundles the separate files into the output file, with + comments that give an unbundling sed(1) script. + + -ext Complain about f77(1) extensions. + + -f Assume free-format input: accept text after column 72 + and do not pad fixed-format lines shorter than 72 char- + acters with blanks. + + -72 Treat text appearing after column 72 as an error. + + -g Include original Fortran line numbers in #line lines. + + -h Emulate Fortran 66's treatment of Hollerith: try to + align character strings on word (or, if the option is + `-hd', on double-word) boundaries. + + -i2 Similar to -I2, but assume a modified libF77 and libI77 + (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- + ables may be assigned by INQUIRE and array lengths are + stored in short ints. + + -i90 Do not recognize the Fortran 90 bit-manipulation + intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, + ishft, and ishftc. + + -kr Use temporary values to enforce Fortran expression + evaluation where K&R (first edition) parenthesization + rules allow rearrangement. If the option is `-krd', + use double precision temporaries even for single- + + Page 2 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + precision operands. + + -P Write a file.P of ANSI (or C++) prototypes for defini- + tions in each input file.f or file.F. When reading + Fortran from standard input, write prototypes at the + beginning of standard output. Option -Ps implies -P + and gives exit status 4 if rerunning f2c may change + prototypes or declarations. + + -p Supply preprocessor definitions to make common-block + members look like local variables. + + -R Do not promote REAL functions and operations to DOUBLE + PRECISION. Option `-!R' confirms the default, which + imitates f77. + + -r Cast REAL arguments of intrinsic functions and values + of REAL functions (including intrinsics) to REAL. + + -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE + COMPLEX. + + -s Preserve multidimensional subscripts. Suppressed by + option `-C' . + + -Tdir + Put temporary files in directory dir. + + -trapuv + Dynamically initialize local variables, except those + appearing in SAVE or DATA statements, with values that + may help find references to uninitialized variables. + For example, with IEEE arithmetic, initialize local + floating-point variables to signaling NaNs. + + -w8 Suppress warnings when COMMON or EQUIVALENCE forces + odd-word alignment of doubles. + + -Wn Assume n characters/word (default 4) when initializing + numeric variables with character data. + + -z Do not implicitly recognize DOUBLE COMPLEX. + + -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, + \f, \n, \r, \t, \v) in character strings. + + -!c Inhibit C output, but produce -P output. + + -!I Reject include statements. + + -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', + permit INTEGER*8 but do not promote integer constants + + Page 3 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + to INTEGER*8 when they involve more than 32 bits. + + -!it Don't infer types of untyped EXTERNAL procedures from + use as parameters to previously defined or prototyped + procedures. + + -!P Do not attempt to infer ANSI or C++ prototypes from + usage. + + The resulting C invokes the support routines of f77; object + code should be loaded by f77 or with ld(1) or cc(1) options + -lF77 -lI77 -lm. Calling conventions are those of f77: see + the reference below. + + FILES + file.[fF] input file + + *.c output file + + /usr/include/f2c.h + header file + + /usr/lib/libF77.aintrinsic function library + + /usr/lib/libI77.aFortran I/O library + + /lib/libc.a C library, see section 3 + + SEE ALSO + S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 + Compiler', UNIX Time Sharing System Programmer's Manual, + Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. + + DIAGNOSTICS + The diagnostics produced by f2c are intended to be self- + explanatory. + + BUGS + Floating-point constant expressions are simplified in the + floating-point arithmetic of the machine running f2c, so + they are typically accurate to at most 16 or 17 decimal + places. + Untypable EXTERNAL functions are declared int. + There is no notation for INTEGER*8 constants. + Some intrinsic functions do not yet work with INTEGER*8 . + + Page 4 (printed 6/21/02) + diff --git a/unix/bin.linux/f2c.1.gz b/unix/bin.linux/f2c.1.gz new file mode 100644 index 00000000..7890e601 Binary files /dev/null and b/unix/bin.linux/f2c.1.gz differ diff --git a/unix/bin.linux/f2c.e b/unix/bin.linux/f2c.e new file mode 100755 index 00000000..1474c939 Binary files /dev/null and b/unix/bin.linux/f2c.e differ diff --git a/unix/bin.linux/f2c.h b/unix/bin.linux/f2c.h new file mode 100644 index 00000000..5e942164 --- /dev/null +++ b/unix/bin.linux/f2c.h @@ -0,0 +1,252 @@ +/* f2c.h -- Standard Fortran to C header file. */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + + +/* For ILP64 +*/ +#define INTEGER_STAR_8 +typedef long integer; +typedef long logical; +typedef unsigned long int uinteger; +/* typedef double real; */ + + +/* For ILP32 +typedef int integer; +typedef int logical; +typedef unsigned int uinteger; +*/ +typedef float real; +typedef short int shortint; + + +typedef char *address; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long longint; /* system-dependent */ +typedef unsigned long ulongint; /* system-dependent */ + +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#ifndef abs +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#endif +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +/*typedef doublereal E_f; // real function with -R not specified */ +typedef real E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif + + + +/* +#ifndef BLD_KERNEL +#include "/iraf/iraf/unix/hlib/libc/kproto.h" +#include "/iraf/iraf/unix/hlib/libc/vosproto.h" +#endif +*/ diff --git a/unix/bin.linux/generic.e b/unix/bin.linux/generic.e new file mode 100755 index 00000000..0ad43636 Binary files /dev/null and b/unix/bin.linux/generic.e differ diff --git a/unix/bin.linux/iraf.h b/unix/bin.linux/iraf.h new file mode 120000 index 00000000..cea9b321 --- /dev/null +++ b/unix/bin.linux/iraf.h @@ -0,0 +1 @@ +../hlib/iraf32.h \ No newline at end of file diff --git a/unix/bin.linux/libboot.a b/unix/bin.linux/libboot.a new file mode 100644 index 00000000..0f5896c7 Binary files /dev/null and b/unix/bin.linux/libboot.a differ diff --git a/unix/bin.linux/libf2c.a b/unix/bin.linux/libf2c.a new file mode 100644 index 00000000..3dc0fc72 Binary files /dev/null and b/unix/bin.linux/libf2c.a differ diff --git a/unix/bin.linux/libos.a b/unix/bin.linux/libos.a new file mode 100644 index 00000000..6bdb40b5 Binary files /dev/null and b/unix/bin.linux/libos.a differ diff --git a/unix/bin.linux/mach.h b/unix/bin.linux/mach.h new file mode 120000 index 00000000..16d34714 --- /dev/null +++ b/unix/bin.linux/mach.h @@ -0,0 +1 @@ +../hlib/mach32.h \ No newline at end of file diff --git a/unix/bin.linux/mkpkg.e b/unix/bin.linux/mkpkg.e new file mode 100755 index 00000000..d463a9dd Binary files /dev/null and b/unix/bin.linux/mkpkg.e differ diff --git a/unix/bin.linux/rmbin.e b/unix/bin.linux/rmbin.e new file mode 100755 index 00000000..60cf0b72 Binary files /dev/null and b/unix/bin.linux/rmbin.e differ diff --git a/unix/bin.linux/rmfiles.e b/unix/bin.linux/rmfiles.e new file mode 100755 index 00000000..f97a5f03 Binary files /dev/null and b/unix/bin.linux/rmfiles.e differ diff --git a/unix/bin.linux/rpp.e b/unix/bin.linux/rpp.e new file mode 100755 index 00000000..7eb3d897 Binary files /dev/null and b/unix/bin.linux/rpp.e differ diff --git a/unix/bin.linux/rtar.e b/unix/bin.linux/rtar.e new file mode 100755 index 00000000..51d80668 Binary files /dev/null and b/unix/bin.linux/rtar.e differ diff --git a/unix/bin.linux/sgi2gif.e b/unix/bin.linux/sgi2gif.e new file mode 100755 index 00000000..8fbd2503 Binary files /dev/null and b/unix/bin.linux/sgi2gif.e differ diff --git a/unix/bin.linux/sgi2svg.e b/unix/bin.linux/sgi2svg.e new file mode 100755 index 00000000..b7edead4 Binary files /dev/null and b/unix/bin.linux/sgi2svg.e differ diff --git a/unix/bin.linux/sgi2uapl.e b/unix/bin.linux/sgi2uapl.e new file mode 100755 index 00000000..6626ed96 Binary files /dev/null and b/unix/bin.linux/sgi2uapl.e differ diff --git a/unix/bin.linux/sgi2ueps.e b/unix/bin.linux/sgi2ueps.e new file mode 100755 index 00000000..25bded87 Binary files /dev/null and b/unix/bin.linux/sgi2ueps.e differ diff --git a/unix/bin.linux/sgi2uhpgl.e b/unix/bin.linux/sgi2uhpgl.e new file mode 100755 index 00000000..281ee551 Binary files /dev/null and b/unix/bin.linux/sgi2uhpgl.e differ diff --git a/unix/bin.linux/sgi2uhplj.e b/unix/bin.linux/sgi2uhplj.e new file mode 100755 index 00000000..13a98d1c Binary files /dev/null and b/unix/bin.linux/sgi2uhplj.e differ diff --git a/unix/bin.linux/sgi2uimp.e b/unix/bin.linux/sgi2uimp.e new file mode 100755 index 00000000..5cb56d53 Binary files /dev/null and b/unix/bin.linux/sgi2uimp.e differ diff --git a/unix/bin.linux/sgi2uptx.e b/unix/bin.linux/sgi2uptx.e new file mode 100755 index 00000000..61e39453 Binary files /dev/null and b/unix/bin.linux/sgi2uptx.e differ diff --git a/unix/bin.linux/sgi2uqms.e b/unix/bin.linux/sgi2uqms.e new file mode 100755 index 00000000..d3a71f68 Binary files /dev/null and b/unix/bin.linux/sgi2uqms.e differ diff --git a/unix/bin.linux/sgi2xbm.e b/unix/bin.linux/sgi2xbm.e new file mode 100755 index 00000000..f510766e Binary files /dev/null and b/unix/bin.linux/sgi2xbm.e differ diff --git a/unix/bin.linux/sgidispatch.e b/unix/bin.linux/sgidispatch.e new file mode 100755 index 00000000..25e8185f Binary files /dev/null and b/unix/bin.linux/sgidispatch.e differ diff --git a/unix/bin.linux/wtar.e b/unix/bin.linux/wtar.e new file mode 100755 index 00000000..aae2e97c Binary files /dev/null and b/unix/bin.linux/wtar.e differ diff --git a/unix/bin.linux/xc.e b/unix/bin.linux/xc.e new file mode 100755 index 00000000..0fda128f Binary files /dev/null and b/unix/bin.linux/xc.e differ diff --git a/unix/bin.linux/xpp.e b/unix/bin.linux/xpp.e new file mode 100755 index 00000000..a361e40d Binary files /dev/null and b/unix/bin.linux/xpp.e differ diff --git a/unix/bin.linux/xyacc.e b/unix/bin.linux/xyacc.e new file mode 100755 index 00000000..bbdc680d Binary files /dev/null and b/unix/bin.linux/xyacc.e differ diff --git a/unix/bin.linux64/alloc.e b/unix/bin.linux64/alloc.e new file mode 100755 index 00000000..2b4f1049 Binary files /dev/null and b/unix/bin.linux64/alloc.e differ diff --git a/unix/bin.linux64/f2c.1 b/unix/bin.linux64/f2c.1 new file mode 100644 index 00000000..3bdbc8b8 --- /dev/null +++ b/unix/bin.linux64/f2c.1 @@ -0,0 +1,222 @@ + + F2C(1) UNIX System V F2C(1) + + NAME + f2c - Convert Fortran 77 to C or C++ + + SYNOPSIS + f2c [ option ... ] file ... + + DESCRIPTION + F2c converts Fortran 77 source code in files with names end- + ing in `.f' or `.F' to C (or C++) source files in the cur- + rent directory, with `.c' substituted for the final `.f' or + `.F'. If no Fortran files are named, f2c reads Fortran from + standard input and writes C on standard output. File names + that end with `.p' or `.P' are taken to be prototype files, + as produced by option `-P', and are read first. + + The following options have the same meaning as in f77(1). + + -C Compile code to check that subscripts are within + declared array bounds. + + -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long + int. Assume the default libF77 and libI77: allow only + INTEGER*4 (and no LOGICAL) variables in INQUIREs. + Option `-I4' confirms the default rendering of INTEGER + as long int. + + -Idir + Look for a non-absolute include file first in the + directory of the current input file, then in directo- + ries specified by -I options (one directory per + option). Options -I2 and -I4 have precedence, so, + e.g., a directory named 2 should be specified by -I./2 + . + + -onetrip + Compile DO loops that are performed at least once if + reached. (Fortran 77 DO loops are not performed at all + if the upper limit is smaller than the lower limit.) + + -U Honor the case of variable and external names. Fortran + keywords must be in lower case. + + -u Make the default type of a variable `undefined' rather + than using the default Fortran rules. + + -w Suppress all warning messages, or, if the option is + `-w66', just Fortran 66 compatibility warnings. + + The following options are peculiar to f2c. + + -A Produce ANSI C (default, starting 20020621). For old- + style C, use option -K. + + Page 1 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + -a Make local variables automatic rather than static + unless they appear in a DATA, EQUIVALENCE, NAMELIST, or + SAVE statement. + + -C++ Output C++ code. + + -c Include original Fortran source as comments. + + -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and + cdsqrt as synonyms for the double complex intrinsics + zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, + nor dreal as a synonym for dble. + + -ddir + Write `.c' files in directory dir instead of the cur- + rent directory. + + -E Declare uninitialized COMMON to be Extern (overridably + defined in f2c.h as extern). + + -ec Place uninitialized COMMON blocks in separate files: + COMMON /ABC/ appears in file abc_com.c. Option `-e1c' + bundles the separate files into the output file, with + comments that give an unbundling sed(1) script. + + -ext Complain about f77(1) extensions. + + -f Assume free-format input: accept text after column 72 + and do not pad fixed-format lines shorter than 72 char- + acters with blanks. + + -72 Treat text appearing after column 72 as an error. + + -g Include original Fortran line numbers in #line lines. + + -h Emulate Fortran 66's treatment of Hollerith: try to + align character strings on word (or, if the option is + `-hd', on double-word) boundaries. + + -i2 Similar to -I2, but assume a modified libF77 and libI77 + (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- + ables may be assigned by INQUIRE and array lengths are + stored in short ints. + + -i90 Do not recognize the Fortran 90 bit-manipulation + intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, + ishft, and ishftc. + + -kr Use temporary values to enforce Fortran expression + evaluation where K&R (first edition) parenthesization + rules allow rearrangement. If the option is `-krd', + use double precision temporaries even for single- + + Page 2 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + precision operands. + + -P Write a file.P of ANSI (or C++) prototypes for defini- + tions in each input file.f or file.F. When reading + Fortran from standard input, write prototypes at the + beginning of standard output. Option -Ps implies -P + and gives exit status 4 if rerunning f2c may change + prototypes or declarations. + + -p Supply preprocessor definitions to make common-block + members look like local variables. + + -R Do not promote REAL functions and operations to DOUBLE + PRECISION. Option `-!R' confirms the default, which + imitates f77. + + -r Cast REAL arguments of intrinsic functions and values + of REAL functions (including intrinsics) to REAL. + + -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE + COMPLEX. + + -s Preserve multidimensional subscripts. Suppressed by + option `-C' . + + -Tdir + Put temporary files in directory dir. + + -trapuv + Dynamically initialize local variables, except those + appearing in SAVE or DATA statements, with values that + may help find references to uninitialized variables. + For example, with IEEE arithmetic, initialize local + floating-point variables to signaling NaNs. + + -w8 Suppress warnings when COMMON or EQUIVALENCE forces + odd-word alignment of doubles. + + -Wn Assume n characters/word (default 4) when initializing + numeric variables with character data. + + -z Do not implicitly recognize DOUBLE COMPLEX. + + -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, + \f, \n, \r, \t, \v) in character strings. + + -!c Inhibit C output, but produce -P output. + + -!I Reject include statements. + + -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', + permit INTEGER*8 but do not promote integer constants + + Page 3 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + to INTEGER*8 when they involve more than 32 bits. + + -!it Don't infer types of untyped EXTERNAL procedures from + use as parameters to previously defined or prototyped + procedures. + + -!P Do not attempt to infer ANSI or C++ prototypes from + usage. + + The resulting C invokes the support routines of f77; object + code should be loaded by f77 or with ld(1) or cc(1) options + -lF77 -lI77 -lm. Calling conventions are those of f77: see + the reference below. + + FILES + file.[fF] input file + + *.c output file + + /usr/include/f2c.h + header file + + /usr/lib/libF77.aintrinsic function library + + /usr/lib/libI77.aFortran I/O library + + /lib/libc.a C library, see section 3 + + SEE ALSO + S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 + Compiler', UNIX Time Sharing System Programmer's Manual, + Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. + + DIAGNOSTICS + The diagnostics produced by f2c are intended to be self- + explanatory. + + BUGS + Floating-point constant expressions are simplified in the + floating-point arithmetic of the machine running f2c, so + they are typically accurate to at most 16 or 17 decimal + places. + Untypable EXTERNAL functions are declared int. + There is no notation for INTEGER*8 constants. + Some intrinsic functions do not yet work with INTEGER*8 . + + Page 4 (printed 6/21/02) + diff --git a/unix/bin.linux64/f2c.1.gz b/unix/bin.linux64/f2c.1.gz new file mode 100644 index 00000000..7890e601 Binary files /dev/null and b/unix/bin.linux64/f2c.1.gz differ diff --git a/unix/bin.linux64/f2c.e b/unix/bin.linux64/f2c.e new file mode 100755 index 00000000..1625f1f3 Binary files /dev/null and b/unix/bin.linux64/f2c.e differ diff --git a/unix/bin.linux64/f2c.h b/unix/bin.linux64/f2c.h new file mode 100644 index 00000000..5e942164 --- /dev/null +++ b/unix/bin.linux64/f2c.h @@ -0,0 +1,252 @@ +/* f2c.h -- Standard Fortran to C header file. */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + + +/* For ILP64 +*/ +#define INTEGER_STAR_8 +typedef long integer; +typedef long logical; +typedef unsigned long int uinteger; +/* typedef double real; */ + + +/* For ILP32 +typedef int integer; +typedef int logical; +typedef unsigned int uinteger; +*/ +typedef float real; +typedef short int shortint; + + +typedef char *address; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long longint; /* system-dependent */ +typedef unsigned long ulongint; /* system-dependent */ + +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#ifndef abs +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#endif +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +/*typedef doublereal E_f; // real function with -R not specified */ +typedef real E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif + + + +/* +#ifndef BLD_KERNEL +#include "/iraf/iraf/unix/hlib/libc/kproto.h" +#include "/iraf/iraf/unix/hlib/libc/vosproto.h" +#endif +*/ diff --git a/unix/bin.linux64/generic.e b/unix/bin.linux64/generic.e new file mode 100755 index 00000000..3956e71e Binary files /dev/null and b/unix/bin.linux64/generic.e differ diff --git a/unix/bin.linux64/iraf.h b/unix/bin.linux64/iraf.h new file mode 120000 index 00000000..678a23a1 --- /dev/null +++ b/unix/bin.linux64/iraf.h @@ -0,0 +1 @@ +../hlib/iraf64.h \ No newline at end of file diff --git a/unix/bin.linux64/libboot.a b/unix/bin.linux64/libboot.a new file mode 100644 index 00000000..19b13ed4 Binary files /dev/null and b/unix/bin.linux64/libboot.a differ diff --git a/unix/bin.linux64/libf2c.a b/unix/bin.linux64/libf2c.a new file mode 100644 index 00000000..553791cc Binary files /dev/null and b/unix/bin.linux64/libf2c.a differ diff --git a/unix/bin.linux64/libos.a b/unix/bin.linux64/libos.a new file mode 100644 index 00000000..67156571 Binary files /dev/null and b/unix/bin.linux64/libos.a differ diff --git a/unix/bin.linux64/mach.h b/unix/bin.linux64/mach.h new file mode 120000 index 00000000..8aac4992 --- /dev/null +++ b/unix/bin.linux64/mach.h @@ -0,0 +1 @@ +../hlib/mach64.h \ No newline at end of file diff --git a/unix/bin.linux64/mkpkg.e b/unix/bin.linux64/mkpkg.e new file mode 100755 index 00000000..ff7c73e7 Binary files /dev/null and b/unix/bin.linux64/mkpkg.e differ diff --git a/unix/bin.linux64/rmbin.e b/unix/bin.linux64/rmbin.e new file mode 100755 index 00000000..3a9616ae Binary files /dev/null and b/unix/bin.linux64/rmbin.e differ diff --git a/unix/bin.linux64/rmfiles.e b/unix/bin.linux64/rmfiles.e new file mode 100755 index 00000000..d8061020 Binary files /dev/null and b/unix/bin.linux64/rmfiles.e differ diff --git a/unix/bin.linux64/rpp.e b/unix/bin.linux64/rpp.e new file mode 100755 index 00000000..e409b5b6 Binary files /dev/null and b/unix/bin.linux64/rpp.e differ diff --git a/unix/bin.linux64/rtar.e b/unix/bin.linux64/rtar.e new file mode 100755 index 00000000..9b569c2f Binary files /dev/null and b/unix/bin.linux64/rtar.e differ diff --git a/unix/bin.linux64/sgi2gif.e b/unix/bin.linux64/sgi2gif.e new file mode 100755 index 00000000..7a2b0fdc Binary files /dev/null and b/unix/bin.linux64/sgi2gif.e differ diff --git a/unix/bin.linux64/sgi2svg.e b/unix/bin.linux64/sgi2svg.e new file mode 100755 index 00000000..fa29b6a2 Binary files /dev/null and b/unix/bin.linux64/sgi2svg.e differ diff --git a/unix/bin.linux64/sgi2uapl.e b/unix/bin.linux64/sgi2uapl.e new file mode 100755 index 00000000..477bc2f6 Binary files /dev/null and b/unix/bin.linux64/sgi2uapl.e differ diff --git a/unix/bin.linux64/sgi2ueps.e b/unix/bin.linux64/sgi2ueps.e new file mode 100755 index 00000000..ce512dbc Binary files /dev/null and b/unix/bin.linux64/sgi2ueps.e differ diff --git a/unix/bin.linux64/sgi2uhpgl.e b/unix/bin.linux64/sgi2uhpgl.e new file mode 100755 index 00000000..33e0288f Binary files /dev/null and b/unix/bin.linux64/sgi2uhpgl.e differ diff --git a/unix/bin.linux64/sgi2uhplj.e b/unix/bin.linux64/sgi2uhplj.e new file mode 100755 index 00000000..679fc706 Binary files /dev/null and b/unix/bin.linux64/sgi2uhplj.e differ diff --git a/unix/bin.linux64/sgi2uimp.e b/unix/bin.linux64/sgi2uimp.e new file mode 100755 index 00000000..d11ca305 Binary files /dev/null and b/unix/bin.linux64/sgi2uimp.e differ diff --git a/unix/bin.linux64/sgi2uptx.e b/unix/bin.linux64/sgi2uptx.e new file mode 100755 index 00000000..86f8964d Binary files /dev/null and b/unix/bin.linux64/sgi2uptx.e differ diff --git a/unix/bin.linux64/sgi2uqms.e b/unix/bin.linux64/sgi2uqms.e new file mode 100755 index 00000000..1b3cbf97 Binary files /dev/null and b/unix/bin.linux64/sgi2uqms.e differ diff --git a/unix/bin.linux64/sgi2xbm.e b/unix/bin.linux64/sgi2xbm.e new file mode 100755 index 00000000..50683751 Binary files /dev/null and b/unix/bin.linux64/sgi2xbm.e differ diff --git a/unix/bin.linux64/sgidispatch.e b/unix/bin.linux64/sgidispatch.e new file mode 100755 index 00000000..66f43052 Binary files /dev/null and b/unix/bin.linux64/sgidispatch.e differ diff --git a/unix/bin.linux64/wtar.e b/unix/bin.linux64/wtar.e new file mode 100755 index 00000000..1c428791 Binary files /dev/null and b/unix/bin.linux64/wtar.e differ diff --git a/unix/bin.linux64/xc.e b/unix/bin.linux64/xc.e new file mode 100755 index 00000000..0f31875e Binary files /dev/null and b/unix/bin.linux64/xc.e differ diff --git a/unix/bin.linux64/xpp.e b/unix/bin.linux64/xpp.e new file mode 100755 index 00000000..f4fb2af1 Binary files /dev/null and b/unix/bin.linux64/xpp.e differ diff --git a/unix/bin.linux64/xyacc.e b/unix/bin.linux64/xyacc.e new file mode 100755 index 00000000..cfacff11 Binary files /dev/null and b/unix/bin.linux64/xyacc.e differ diff --git a/unix/bin.macintel/alloc.e b/unix/bin.macintel/alloc.e new file mode 100755 index 00000000..7adcd8a8 Binary files /dev/null and b/unix/bin.macintel/alloc.e differ diff --git a/unix/bin.macintel/f2c.1 b/unix/bin.macintel/f2c.1 new file mode 100644 index 00000000..3bdbc8b8 --- /dev/null +++ b/unix/bin.macintel/f2c.1 @@ -0,0 +1,222 @@ + + F2C(1) UNIX System V F2C(1) + + NAME + f2c - Convert Fortran 77 to C or C++ + + SYNOPSIS + f2c [ option ... ] file ... + + DESCRIPTION + F2c converts Fortran 77 source code in files with names end- + ing in `.f' or `.F' to C (or C++) source files in the cur- + rent directory, with `.c' substituted for the final `.f' or + `.F'. If no Fortran files are named, f2c reads Fortran from + standard input and writes C on standard output. File names + that end with `.p' or `.P' are taken to be prototype files, + as produced by option `-P', and are read first. + + The following options have the same meaning as in f77(1). + + -C Compile code to check that subscripts are within + declared array bounds. + + -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long + int. Assume the default libF77 and libI77: allow only + INTEGER*4 (and no LOGICAL) variables in INQUIREs. + Option `-I4' confirms the default rendering of INTEGER + as long int. + + -Idir + Look for a non-absolute include file first in the + directory of the current input file, then in directo- + ries specified by -I options (one directory per + option). Options -I2 and -I4 have precedence, so, + e.g., a directory named 2 should be specified by -I./2 + . + + -onetrip + Compile DO loops that are performed at least once if + reached. (Fortran 77 DO loops are not performed at all + if the upper limit is smaller than the lower limit.) + + -U Honor the case of variable and external names. Fortran + keywords must be in lower case. + + -u Make the default type of a variable `undefined' rather + than using the default Fortran rules. + + -w Suppress all warning messages, or, if the option is + `-w66', just Fortran 66 compatibility warnings. + + The following options are peculiar to f2c. + + -A Produce ANSI C (default, starting 20020621). For old- + style C, use option -K. + + Page 1 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + -a Make local variables automatic rather than static + unless they appear in a DATA, EQUIVALENCE, NAMELIST, or + SAVE statement. + + -C++ Output C++ code. + + -c Include original Fortran source as comments. + + -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and + cdsqrt as synonyms for the double complex intrinsics + zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, + nor dreal as a synonym for dble. + + -ddir + Write `.c' files in directory dir instead of the cur- + rent directory. + + -E Declare uninitialized COMMON to be Extern (overridably + defined in f2c.h as extern). + + -ec Place uninitialized COMMON blocks in separate files: + COMMON /ABC/ appears in file abc_com.c. Option `-e1c' + bundles the separate files into the output file, with + comments that give an unbundling sed(1) script. + + -ext Complain about f77(1) extensions. + + -f Assume free-format input: accept text after column 72 + and do not pad fixed-format lines shorter than 72 char- + acters with blanks. + + -72 Treat text appearing after column 72 as an error. + + -g Include original Fortran line numbers in #line lines. + + -h Emulate Fortran 66's treatment of Hollerith: try to + align character strings on word (or, if the option is + `-hd', on double-word) boundaries. + + -i2 Similar to -I2, but assume a modified libF77 and libI77 + (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- + ables may be assigned by INQUIRE and array lengths are + stored in short ints. + + -i90 Do not recognize the Fortran 90 bit-manipulation + intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, + ishft, and ishftc. + + -kr Use temporary values to enforce Fortran expression + evaluation where K&R (first edition) parenthesization + rules allow rearrangement. If the option is `-krd', + use double precision temporaries even for single- + + Page 2 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + precision operands. + + -P Write a file.P of ANSI (or C++) prototypes for defini- + tions in each input file.f or file.F. When reading + Fortran from standard input, write prototypes at the + beginning of standard output. Option -Ps implies -P + and gives exit status 4 if rerunning f2c may change + prototypes or declarations. + + -p Supply preprocessor definitions to make common-block + members look like local variables. + + -R Do not promote REAL functions and operations to DOUBLE + PRECISION. Option `-!R' confirms the default, which + imitates f77. + + -r Cast REAL arguments of intrinsic functions and values + of REAL functions (including intrinsics) to REAL. + + -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE + COMPLEX. + + -s Preserve multidimensional subscripts. Suppressed by + option `-C' . + + -Tdir + Put temporary files in directory dir. + + -trapuv + Dynamically initialize local variables, except those + appearing in SAVE or DATA statements, with values that + may help find references to uninitialized variables. + For example, with IEEE arithmetic, initialize local + floating-point variables to signaling NaNs. + + -w8 Suppress warnings when COMMON or EQUIVALENCE forces + odd-word alignment of doubles. + + -Wn Assume n characters/word (default 4) when initializing + numeric variables with character data. + + -z Do not implicitly recognize DOUBLE COMPLEX. + + -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, + \f, \n, \r, \t, \v) in character strings. + + -!c Inhibit C output, but produce -P output. + + -!I Reject include statements. + + -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', + permit INTEGER*8 but do not promote integer constants + + Page 3 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + to INTEGER*8 when they involve more than 32 bits. + + -!it Don't infer types of untyped EXTERNAL procedures from + use as parameters to previously defined or prototyped + procedures. + + -!P Do not attempt to infer ANSI or C++ prototypes from + usage. + + The resulting C invokes the support routines of f77; object + code should be loaded by f77 or with ld(1) or cc(1) options + -lF77 -lI77 -lm. Calling conventions are those of f77: see + the reference below. + + FILES + file.[fF] input file + + *.c output file + + /usr/include/f2c.h + header file + + /usr/lib/libF77.aintrinsic function library + + /usr/lib/libI77.aFortran I/O library + + /lib/libc.a C library, see section 3 + + SEE ALSO + S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 + Compiler', UNIX Time Sharing System Programmer's Manual, + Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. + + DIAGNOSTICS + The diagnostics produced by f2c are intended to be self- + explanatory. + + BUGS + Floating-point constant expressions are simplified in the + floating-point arithmetic of the machine running f2c, so + they are typically accurate to at most 16 or 17 decimal + places. + Untypable EXTERNAL functions are declared int. + There is no notation for INTEGER*8 constants. + Some intrinsic functions do not yet work with INTEGER*8 . + + Page 4 (printed 6/21/02) + diff --git a/unix/bin.macintel/f2c.e b/unix/bin.macintel/f2c.e new file mode 100755 index 00000000..0c5baf51 Binary files /dev/null and b/unix/bin.macintel/f2c.e differ diff --git a/unix/bin.macintel/f2c.h b/unix/bin.macintel/f2c.h new file mode 100644 index 00000000..32568059 --- /dev/null +++ b/unix/bin.macintel/f2c.h @@ -0,0 +1,252 @@ +/* f2c.h -- Standard Fortran to C header file. */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + + +/* For ILP64 +*/ +#define INTEGER_STAR_8 +typedef long int integer; +typedef long int logical; +typedef unsigned long int uinteger; +/* typedef double real; */ + + +/* For ILP32 +typedef int integer; +typedef int logical; +typedef unsigned int uinteger; +*/ +typedef float real; +typedef short int shortint; + + +typedef char *address; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long longint; /* system-dependent */ +typedef unsigned long ulongint; /* system-dependent */ + +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#ifndef abs +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#endif +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +/*typedef doublereal E_f; // real function with -R not specified */ +typedef real E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif + + + +/* +#ifndef BLD_KERNEL +#include "/iraf/iraf/unix/hlib/libc/kproto.h" +#include "/iraf/iraf/unix/hlib/libc/vosproto.h" +#endif +*/ diff --git a/unix/bin.macintel/generic.e b/unix/bin.macintel/generic.e new file mode 100755 index 00000000..63aa6f63 Binary files /dev/null and b/unix/bin.macintel/generic.e differ diff --git a/unix/bin.macintel/iraf.h b/unix/bin.macintel/iraf.h new file mode 120000 index 00000000..678a23a1 --- /dev/null +++ b/unix/bin.macintel/iraf.h @@ -0,0 +1 @@ +../hlib/iraf64.h \ No newline at end of file diff --git a/unix/bin.macintel/libboot.a b/unix/bin.macintel/libboot.a new file mode 100644 index 00000000..3fe11cb8 Binary files /dev/null and b/unix/bin.macintel/libboot.a differ diff --git a/unix/bin.macintel/libf2c.a b/unix/bin.macintel/libf2c.a new file mode 100644 index 00000000..ffe3fdb5 Binary files /dev/null and b/unix/bin.macintel/libf2c.a differ diff --git a/unix/bin.macintel/libos.a b/unix/bin.macintel/libos.a new file mode 100644 index 00000000..798cc1cd Binary files /dev/null and b/unix/bin.macintel/libos.a differ diff --git a/unix/bin.macintel/mach.h b/unix/bin.macintel/mach.h new file mode 120000 index 00000000..8aac4992 --- /dev/null +++ b/unix/bin.macintel/mach.h @@ -0,0 +1 @@ +../hlib/mach64.h \ No newline at end of file diff --git a/unix/bin.macintel/mkpkg.e b/unix/bin.macintel/mkpkg.e new file mode 100755 index 00000000..c8a7b4b5 Binary files /dev/null and b/unix/bin.macintel/mkpkg.e differ diff --git a/unix/bin.macintel/rmbin.e b/unix/bin.macintel/rmbin.e new file mode 100755 index 00000000..fe3c0c1c Binary files /dev/null and b/unix/bin.macintel/rmbin.e differ diff --git a/unix/bin.macintel/rmfiles.e b/unix/bin.macintel/rmfiles.e new file mode 100755 index 00000000..33e9c5d7 Binary files /dev/null and b/unix/bin.macintel/rmfiles.e differ diff --git a/unix/bin.macintel/rpp.e b/unix/bin.macintel/rpp.e new file mode 100755 index 00000000..7d50b96a Binary files /dev/null and b/unix/bin.macintel/rpp.e differ diff --git a/unix/bin.macintel/rtar.e b/unix/bin.macintel/rtar.e new file mode 100755 index 00000000..65b9220f Binary files /dev/null and b/unix/bin.macintel/rtar.e differ diff --git a/unix/bin.macintel/sgi2gif.e b/unix/bin.macintel/sgi2gif.e new file mode 100755 index 00000000..2802da40 Binary files /dev/null and b/unix/bin.macintel/sgi2gif.e differ diff --git a/unix/bin.macintel/sgi2svg.e b/unix/bin.macintel/sgi2svg.e new file mode 100755 index 00000000..eb8b68cb Binary files /dev/null and b/unix/bin.macintel/sgi2svg.e differ diff --git a/unix/bin.macintel/sgi2uapl.e b/unix/bin.macintel/sgi2uapl.e new file mode 100755 index 00000000..3a28e740 Binary files /dev/null and b/unix/bin.macintel/sgi2uapl.e differ diff --git a/unix/bin.macintel/sgi2ueps.e b/unix/bin.macintel/sgi2ueps.e new file mode 100755 index 00000000..1e408b75 Binary files /dev/null and b/unix/bin.macintel/sgi2ueps.e differ diff --git a/unix/bin.macintel/sgi2uhpgl.e b/unix/bin.macintel/sgi2uhpgl.e new file mode 100755 index 00000000..2da829d5 Binary files /dev/null and b/unix/bin.macintel/sgi2uhpgl.e differ diff --git a/unix/bin.macintel/sgi2uhplj.e b/unix/bin.macintel/sgi2uhplj.e new file mode 100755 index 00000000..6654eacf Binary files /dev/null and b/unix/bin.macintel/sgi2uhplj.e differ diff --git a/unix/bin.macintel/sgi2uimp.e b/unix/bin.macintel/sgi2uimp.e new file mode 100755 index 00000000..acf513ec Binary files /dev/null and b/unix/bin.macintel/sgi2uimp.e differ diff --git a/unix/bin.macintel/sgi2uptx.e b/unix/bin.macintel/sgi2uptx.e new file mode 100755 index 00000000..1a799f09 Binary files /dev/null and b/unix/bin.macintel/sgi2uptx.e differ diff --git a/unix/bin.macintel/sgi2uqms.e b/unix/bin.macintel/sgi2uqms.e new file mode 100755 index 00000000..13b251af Binary files /dev/null and b/unix/bin.macintel/sgi2uqms.e differ diff --git a/unix/bin.macintel/sgi2xbm.e b/unix/bin.macintel/sgi2xbm.e new file mode 100755 index 00000000..a11640e9 Binary files /dev/null and b/unix/bin.macintel/sgi2xbm.e differ diff --git a/unix/bin.macintel/sgidispatch.e b/unix/bin.macintel/sgidispatch.e new file mode 100755 index 00000000..bc49d671 Binary files /dev/null and b/unix/bin.macintel/sgidispatch.e differ diff --git a/unix/bin.macintel/wtar.e b/unix/bin.macintel/wtar.e new file mode 100755 index 00000000..435597d3 Binary files /dev/null and b/unix/bin.macintel/wtar.e differ diff --git a/unix/bin.macintel/xc.e b/unix/bin.macintel/xc.e new file mode 100755 index 00000000..05a02a2a Binary files /dev/null and b/unix/bin.macintel/xc.e differ diff --git a/unix/bin.macintel/xpp.e b/unix/bin.macintel/xpp.e new file mode 100755 index 00000000..1073bb0e Binary files /dev/null and b/unix/bin.macintel/xpp.e differ diff --git a/unix/bin.macintel/xyacc.e b/unix/bin.macintel/xyacc.e new file mode 100755 index 00000000..ce2a8a1a Binary files /dev/null and b/unix/bin.macintel/xyacc.e differ diff --git a/unix/bin.macosx/alloc.e b/unix/bin.macosx/alloc.e new file mode 100755 index 00000000..dc324a05 Binary files /dev/null and b/unix/bin.macosx/alloc.e differ diff --git a/unix/bin.macosx/f2c.1.gz b/unix/bin.macosx/f2c.1.gz new file mode 100644 index 00000000..7890e601 Binary files /dev/null and b/unix/bin.macosx/f2c.1.gz differ diff --git a/unix/bin.macosx/f2c.e b/unix/bin.macosx/f2c.e new file mode 100755 index 00000000..54a8c4f7 Binary files /dev/null and b/unix/bin.macosx/f2c.e differ diff --git a/unix/bin.macosx/f2c.h b/unix/bin.macosx/f2c.h new file mode 100644 index 00000000..6af1cdc0 --- /dev/null +++ b/unix/bin.macosx/f2c.h @@ -0,0 +1,228 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +/* +typedef long int integer; +typedef long int logical; +*/ +typedef int integer; +typedef int logical; + +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/bin.macosx/generic.e b/unix/bin.macosx/generic.e new file mode 100755 index 00000000..58bede5c Binary files /dev/null and b/unix/bin.macosx/generic.e differ diff --git a/unix/bin.macosx/iraf.h b/unix/bin.macosx/iraf.h new file mode 120000 index 00000000..cea9b321 --- /dev/null +++ b/unix/bin.macosx/iraf.h @@ -0,0 +1 @@ +../hlib/iraf32.h \ No newline at end of file diff --git a/unix/bin.macosx/libboot.a b/unix/bin.macosx/libboot.a new file mode 100644 index 00000000..ee1243b5 Binary files /dev/null and b/unix/bin.macosx/libboot.a differ diff --git a/unix/bin.macosx/libf2c.a b/unix/bin.macosx/libf2c.a new file mode 100644 index 00000000..f9a37168 Binary files /dev/null and b/unix/bin.macosx/libf2c.a differ diff --git a/unix/bin.macosx/libos.a b/unix/bin.macosx/libos.a new file mode 100644 index 00000000..39e78905 Binary files /dev/null and b/unix/bin.macosx/libos.a differ diff --git a/unix/bin.macosx/mach.h b/unix/bin.macosx/mach.h new file mode 120000 index 00000000..16d34714 --- /dev/null +++ b/unix/bin.macosx/mach.h @@ -0,0 +1 @@ +../hlib/mach32.h \ No newline at end of file diff --git a/unix/bin.macosx/mkpkg.e b/unix/bin.macosx/mkpkg.e new file mode 100755 index 00000000..6b589bf8 Binary files /dev/null and b/unix/bin.macosx/mkpkg.e differ diff --git a/unix/bin.macosx/rmbin.e b/unix/bin.macosx/rmbin.e new file mode 100755 index 00000000..296b6660 Binary files /dev/null and b/unix/bin.macosx/rmbin.e differ diff --git a/unix/bin.macosx/rmfiles.e b/unix/bin.macosx/rmfiles.e new file mode 100755 index 00000000..09022b26 Binary files /dev/null and b/unix/bin.macosx/rmfiles.e differ diff --git a/unix/bin.macosx/rpp.e b/unix/bin.macosx/rpp.e new file mode 100755 index 00000000..64648547 Binary files /dev/null and b/unix/bin.macosx/rpp.e differ diff --git a/unix/bin.macosx/rtar.e b/unix/bin.macosx/rtar.e new file mode 100755 index 00000000..73a102ca Binary files /dev/null and b/unix/bin.macosx/rtar.e differ diff --git a/unix/bin.macosx/sgi2gif.e b/unix/bin.macosx/sgi2gif.e new file mode 100755 index 00000000..419db3a4 Binary files /dev/null and b/unix/bin.macosx/sgi2gif.e differ diff --git a/unix/bin.macosx/sgi2svg.e b/unix/bin.macosx/sgi2svg.e new file mode 100755 index 00000000..8fe2b5ee Binary files /dev/null and b/unix/bin.macosx/sgi2svg.e differ diff --git a/unix/bin.macosx/sgi2uapl.e b/unix/bin.macosx/sgi2uapl.e new file mode 100755 index 00000000..cbf87df6 Binary files /dev/null and b/unix/bin.macosx/sgi2uapl.e differ diff --git a/unix/bin.macosx/sgi2ueps.e b/unix/bin.macosx/sgi2ueps.e new file mode 100755 index 00000000..332437a8 Binary files /dev/null and b/unix/bin.macosx/sgi2ueps.e differ diff --git a/unix/bin.macosx/sgi2uhpgl.e b/unix/bin.macosx/sgi2uhpgl.e new file mode 100755 index 00000000..aadf019d Binary files /dev/null and b/unix/bin.macosx/sgi2uhpgl.e differ diff --git a/unix/bin.macosx/sgi2uhplj.e b/unix/bin.macosx/sgi2uhplj.e new file mode 100755 index 00000000..fdc1a6b6 Binary files /dev/null and b/unix/bin.macosx/sgi2uhplj.e differ diff --git a/unix/bin.macosx/sgi2uimp.e b/unix/bin.macosx/sgi2uimp.e new file mode 100755 index 00000000..6044f421 Binary files /dev/null and b/unix/bin.macosx/sgi2uimp.e differ diff --git a/unix/bin.macosx/sgi2uptx.e b/unix/bin.macosx/sgi2uptx.e new file mode 100755 index 00000000..9a5d4635 Binary files /dev/null and b/unix/bin.macosx/sgi2uptx.e differ diff --git a/unix/bin.macosx/sgi2uqms.e b/unix/bin.macosx/sgi2uqms.e new file mode 100755 index 00000000..a55b4d27 Binary files /dev/null and b/unix/bin.macosx/sgi2uqms.e differ diff --git a/unix/bin.macosx/sgi2xbm.e b/unix/bin.macosx/sgi2xbm.e new file mode 100755 index 00000000..0f1a2e6d Binary files /dev/null and b/unix/bin.macosx/sgi2xbm.e differ diff --git a/unix/bin.macosx/sgidispatch.e b/unix/bin.macosx/sgidispatch.e new file mode 100755 index 00000000..cd69ae11 Binary files /dev/null and b/unix/bin.macosx/sgidispatch.e differ diff --git a/unix/bin.macosx/wtar.e b/unix/bin.macosx/wtar.e new file mode 100755 index 00000000..4c5161f3 Binary files /dev/null and b/unix/bin.macosx/wtar.e differ diff --git a/unix/bin.macosx/xc.e b/unix/bin.macosx/xc.e new file mode 100755 index 00000000..b665bac1 Binary files /dev/null and b/unix/bin.macosx/xc.e differ diff --git a/unix/bin.macosx/xpp.e b/unix/bin.macosx/xpp.e new file mode 100755 index 00000000..321bc878 Binary files /dev/null and b/unix/bin.macosx/xpp.e differ diff --git a/unix/bin.macosx/xyacc.e b/unix/bin.macosx/xyacc.e new file mode 100755 index 00000000..6e017f23 Binary files /dev/null and b/unix/bin.macosx/xyacc.e differ diff --git a/unix/bin.redhat b/unix/bin.redhat new file mode 120000 index 00000000..13471433 --- /dev/null +++ b/unix/bin.redhat @@ -0,0 +1 @@ +bin.linux \ No newline at end of file diff --git a/unix/bin.sunos/README b/unix/bin.sunos/README new file mode 100644 index 00000000..53fbe549 --- /dev/null +++ b/unix/bin.sunos/README @@ -0,0 +1,12 @@ +BIN.LINUX + +This directory contains host-specific binaries for the Solaris x86 version +of IRAF. These are generated automatically in an HSI bootstrap, which is +performed by the "reboot" command in $iraf/unix. + +An exception to the above are the F2C files in this directory. The F2C +executable, library, and include file, which are manually copied in from the +host system. These are installed here as IRAF requires them but they are +not typically installed on Solarix x86 systems. IRAF XC uses the f77.sh +script in HLIB to compiler Fortran files. This script is tailored to use +the version of F2C installed here in HBIN. diff --git a/unix/bin.sunos/f2c.1.gz b/unix/bin.sunos/f2c.1.gz new file mode 100644 index 00000000..a85181fb Binary files /dev/null and b/unix/bin.sunos/f2c.1.gz differ diff --git a/unix/bin.sunos/f2c.h b/unix/bin.sunos/f2c.h new file mode 100644 index 00000000..2d78743c --- /dev/null +++ b/unix/bin.sunos/f2c.h @@ -0,0 +1,229 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +/* +typedef long int integer; +typedef long int logical; +*/ +typedef int integer; +typedef int logical; + + +typedef unsigned long uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#if 0 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/boot/README b/unix/boot/README new file mode 100644 index 00000000..cbba59ef --- /dev/null +++ b/unix/boot/README @@ -0,0 +1,19 @@ +BOOT -- Bootstrap utilities for building and maintaining IRAF. The utilities +in this package are implemented at the host system level, sometimes with +assistance from the iraf kernel or other libraries. All utilites are host +system callable, regardless of how they are implemented. + +Major directories: + + mkpkg - package/library maintenance utility + spp - compiler for the SPP language + rmbin - seek out and destroy all binaries in a directory tree + rtar - tar file reader + wtar - tar file writer + bootlib - system interface for the bootstrap utilities + +Others: + + xyacc - SPP/Yacc + generic - generic preprocessor + vfn - old boot-boot version of vfn2osfn (not currently used) diff --git a/unix/boot/bootProto.h b/unix/boot/bootProto.h new file mode 100644 index 00000000..388c2fd5 --- /dev/null +++ b/unix/boot/bootProto.h @@ -0,0 +1,53 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + + +void BYTMOV (XCHAR *a, XINT *aoff, XCHAR *b, XINT *boff, XINT *nbytes); + +void loadpkgenv (char *pkg); +void _envinit (void); +void loadenv (char *osfn); + +#ifdef NO_OS_INDEX +char *index (char *str, int ch); +char *rindex (char *str, int ch); +#endif + +int os_access (char *fname, int mode, int type); +void os_amovb (char *a, char *b, int nbytes); +int os_chdir (char *dir); +void os_close (int fd); +int os_cmd (char *cmd); +int os_createdir (char *dirname, int mode); +int os_createfile (char *fname, int mode, int type); +int os_delete (char *fname); +int os_diropen (char *dirname); +int os_dirclose (int chan); +int os_gfdir (int chan, char *fname, int maxch); +int os_fcopy (char *oldfile, char *newfile); +long os_fdate (char *fname); +int os_filetype (char *fname); +char *osfn2vfn (char *osfn); +int os_fpathname (char *vfn, char *osfn, int maxch); +char *os_getenv (char *envvar); +void os_getowner (char *fname, int *uid, int *gid); +int os_open (char *vfn, int mode, int type); +void os_putenv (char *name, char *value); +int os_read (int fd, char *buf, int nbytes); +int os_setfmode (char *fname, int mode); +int os_setowner (char *fname, int uid, int gid); +int os_setmtime (char *fname, long mtime); +char *os_strpak (XCHAR *sppstr, char *cstr, int maxch); +XCHAR *os_strupk (char *str, XCHAR *outstr, int maxch); +char *os_subdir (char *dir, char *subdir); +int os_symlink (char *fname, char *valbuf, int maxch); +int os_sysfile (char *sysfile, char *fname, int maxch); +char *os_irafpath (char *sysfile); +long os_utime (long iraf_time); +long os_itime (long unix_time); +int os_write (int fd, char *buf, int nbytes); +char *vfn2osfn (char *vfn, int new); diff --git a/unix/boot/bootlib/README b/unix/boot/bootlib/README new file mode 100644 index 00000000..b934f681 --- /dev/null +++ b/unix/boot/bootlib/README @@ -0,0 +1,53 @@ +BOOTLIB -- C callable file primitives used by the bootstrap utilities. + +This is a somewhat adhoc interface consisting of a collection of low level +functions required by the bootstrap utilities. As far as possible these +use the iraf kernel, but occasionally non-kernel facilities are required or +desirable. The purpose of this interface is to isolate the machine dependence +of the bootstrap utilities from the bulk of the code, making it easier to +maintain IRAF on different hosts, as well as to make it easier to port IRAF +to a new host. No attempt has been made to specify this interface carefully; +it is not necessary since only a limited number of programs use the routines. + +Partial list of functions (grows sporadically): + + char * vfn2osfn (vfn, mode) # Map filenames + char * osfn2vfn (osfn) + + fd = os_diropen (dir) # Read directories + os_dirclose (fd) + os_gfdir (fd, fname, maxch) + + bool os_access (fname, mode, type) # General file + os_chdir (dir) + os_close (fd) + os_cmd (cmd) + os_close (fd + os_createdir (dirname, mode) + os_createfile (fname, mode, type) + os_delete (fname) + os_fcopy (oldfile, newfile) + os_fpathname (vfn, pathname, maxch) + long os_fdate (file) + char * os_getenv (ennvar) + fd = os_open (fname, mode, type) + os_setfmode (fname, mode) + os_setowner (fname, uid, gid) + os_setmtime (fname, mtime) + os_sysfile (fname, outstr, maxch) + os_read (fd, buf, nbytes) + os_write (fd, buf, nbytes) + + fd = tape_open (fname, mode) # Tape or disk file + tape_close (fd) + tape_read (fd, buf, nbytes) + tape_write (fd, buf, nbytes) + + +Tasks which use this library must also use the kernel library (libos.a). +Tasks which use full filename mapping will also need libsys.a and libvops.a, +however the system can be bootstrapped with simpler filename mapping and +then the utilities relinked with full filename mapping, once the system +libraries have been generated. Note that no VOS level i/o is used (only +kernel level i/o functions are used), hence an IRAF main is not required +to initialize the VOS i/o system. diff --git a/unix/boot/bootlib/_bytmov.c b/unix/boot/bootlib/_bytmov.c new file mode 100644 index 00000000..849d8e52 --- /dev/null +++ b/unix/boot/bootlib/_bytmov.c @@ -0,0 +1,41 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BYTMOV -- Byte move from array "a" to array "b". The move must be + * nondestructive, allowing a byte array to be shifted left or right a + * few bytes, hence comparison of the addresses of the arrays is necessary + * to determine if they overlap. + */ +void +BYTMOV ( + XCHAR *a, /* input byte array */ + XINT *aoff, /* first byte in A to be moved */ + XCHAR *b, /* output byte array */ + XINT *boff, /* first byte in B to be written */ + XINT *nbytes /* number of bytes to move */ +) +{ + register char *ip, *op; + register int n = *nbytes; + char *ap, *bp; + + ap = (char *)a + (*aoff - 1); + bp = (char *)b + (*boff - 1); + + /* If the two arrays are the same return immediately. If the move is + * to the left then copy left to right, else copy right to left. + */ + if (ap == bp) { + return; + } else if (bp < ap) { + for (ip=ap, op=bp; --n >= 0; ) + *op++ = *ip++; + } else { + for (ip = &ap[n], op = &bp[n]; --n >= 0; ) + *--op = *--ip; + } +} diff --git a/unix/boot/bootlib/bootlib.h b/unix/boot/bootlib/bootlib.h new file mode 100644 index 00000000..b1bbbc7a --- /dev/null +++ b/unix/boot/bootlib/bootlib.h @@ -0,0 +1,36 @@ +#include +#include +#define import_spp +#define NOKNET +#define import_knames +#include + +#define SZ_FBUF 512 /* File i/o buffer size */ + +#ifdef VMS +#define rindex strrchr +struct timeval { + long tv_sec; + long tv_usec; +}; +#else +#include +#endif + + +# ifdef FINIT +int bdebug = 0; /* print debug stuff */ +int osfiletype; /* type of single output file */ +XCHAR text[SZ_FBUF]; /* output text line if textfile */ +XCHAR *txop; /* next char in output buf */ +# else +extern int bdebug; +extern int osfiletype; +extern XCHAR text[]; +extern XCHAR *txop; +# endif + +char *vfn2osfn(); +char *osfn2vfn(); +char *os_strpak(); +XCHAR *os_strupk(); diff --git a/unix/boot/bootlib/envinit.c b/unix/boot/bootlib/envinit.c new file mode 100644 index 00000000..e70a8d86 --- /dev/null +++ b/unix/boot/bootlib/envinit.c @@ -0,0 +1,269 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_spp +#define import_xnames +#include + +#define isspace(c) ((c)==' '||(c)=='\t'||(c)=='\n') +#define SETENV "zzsetenv.def" +#define SZ_VALUE SZ_COMMAND +#define MAXLEV 8 +#define PKGLIBS "pkglibs" +#define IRAFARCH "IRAFARCH" +#define ARCH "arch" + +extern char *_os_getenv (char *envvar, char *outstr, int maxch); +extern char *os_getenv (char *envvar); +extern char *os_strpak (XCHAR *sppstr, char *cstr, int maxch); +extern char *vfn2osfn (char *vfn, int new); +extern XCHAR *os_strupk (char *str, XCHAR *outstr, int maxch); +extern void os_putenv (char *name, char *value); +extern int bdebug; + +void _envinit (void); +void loadenv (char *osfn); + + + +/* LOADPKGENV -- Load the environment definitions for the named package. + * [e.g., loadpkgenv ("noao")]. This assumes that the root directory of + * the named package is already defined, and that this directory contains + * a subdirectory lib containing the file zzsetenv.def. If none of these + * assumptions are true, call loadenv(osfn) with the host filename of the + * file to be loaded. + */ +void +loadpkgenv (char *pkg) +{ + char vfn[SZ_PATHNAME+1]; + char pkglibs[SZ_COMMAND+1]; + char newlibs[SZ_COMMAND+1]; + + /* Initialize the default IRAF environment. */ + _envinit(); + + /* If no package name is given or the IRAF environment is being + * loaded we are done. + */ + if (!pkg || strcmp(pkg,"iraf")==0) + return; + + strcpy (vfn, pkg); + strcat (vfn, "$lib/"); + strcat (vfn, SETENV); + + /* Load the package environment. The new values are added to the + * environment in the conventional way except for the value of + * "pkglibs". As each package environment is loaded we want to + * add the newly defined package libraries to the current list + * of package libraries, otherwise the most recent package environment + * overrides the earlier ones. It is still possible that user + * defined environment variables will be redefined but there is + * little we can do about that; "pkglibs" is special though since + * it is a part of the loadpkgenv facility. + */ + _os_getenv (PKGLIBS, pkglibs, SZ_COMMAND); + loadenv (vfn2osfn (vfn, 0)); + _os_getenv (PKGLIBS, newlibs, SZ_COMMAND); + + if (strlen(newlibs) > 0 && strcmp (newlibs, pkglibs)) { + char *ip, *op; + char *otop; + + /* Find the end of the current pkglibs file list. */ + for (ip=op=pkglibs; *ip; ip++) + if (!isspace(*ip)) + op = ip + 1; + + /* Concatenate the new files list segment. */ + if (op > pkglibs) + *op++ = ','; + for (ip=newlibs, otop=pkglibs+SZ_COMMAND; *ip && op < otop; ip++) + if (!isspace(*ip)) + *op++ = *ip; + + /* Blank fill to the next SZ_LINE increment to optimize resets. */ + while (op < otop && ((op-pkglibs) % SZ_LINE)) + *op++ = ' '; + *op++ = EOS; + + /* Reset the stored value in the environment. */ + os_putenv (PKGLIBS, pkglibs); + } +} + + +#ifdef NOVOS +void _envinit (void) {} +void loadenv (char *osfn) { printf ("HSI is compiled NOVOS\n"); } +#else + +/* ENVINIT -- Initialize the VOS environment list by scanning the file + * hlib$zzsetenv.def. HLIB is defined in terms of HOST which is sufficiently + * well known to have a value before the environment list is loaded. + */ +void +_envinit (void) +{ + static int initialized = 0; + char osfn[SZ_PATHNAME+1], *hlib; + char irafarch[SZ_PATHNAME+1]; + + extern void ENVINIT(), ENVRESET(); + + + if (initialized++) + return; + + if ( (hlib = os_getenv ("hlib")) ) { + strcpy (osfn, hlib); + strcat (osfn, SETENV); + } else { + fprintf (stderr, "cannot translate logical name `hlib'"); + fflush (stderr); + } + + ENVINIT(); + loadenv (osfn); + + /* If the variable "IRAFARCH" is defined and "arch" is not, add + * a definition for the latter. "arch" is used to construct + * pathnames but the HSI architecture support requires only that + * IRAFARCH be predefined. + */ + if (_os_getenv (IRAFARCH, irafarch, SZ_PATHNAME)) + if (!_os_getenv (ARCH, osfn, SZ_PATHNAME)) { + XCHAR x_name[SZ_PATHNAME+1]; + XCHAR x_value[SZ_PATHNAME+1]; + + sprintf (osfn, ".%s", irafarch); + os_strupk (ARCH, x_name, SZ_PATHNAME); + os_strupk (osfn, x_value, SZ_PATHNAME); + ENVRESET (x_name, x_value); + } +} + + +/* LOADENV -- Load environment definitions from the named host file. + */ +void +loadenv (char *osfn) +{ + register char *ip; + register XCHAR *op; + + char lbuf[SZ_LINE+1]; + char pkname[SZ_FNAME+1], old_value[SZ_VALUE+1]; + XCHAR name[SZ_FNAME+1], value[SZ_VALUE+1]; + FILE *fp, *sv_fp[MAXLEV]; + int lev=0; + + extern void ENVRESET(); + + + if ((fp = fopen (osfn, "r")) == NULL) { + printf ("envinit: cannot open `%s'\n", osfn); + fflush (stdout); + return; + } + + for (;;) { + /* Get next line from input file. */ + if (fgets (lbuf, SZ_LINE, fp) == NULL) { + /* End of file. */ + if (lev > 0) { + fclose (fp); + fp = sv_fp[--lev]; + continue; + } else + break; + + } else { + /* Skip comments and blank lines. */ + for (ip=lbuf; isspace(*ip); ip++) + ; + if (strncmp (lbuf, "set", 3) != 0) { + if (strncmp (lbuf, "reset", 5) != 0) + continue; + else + ip += 5; + } else + ip += 3; + + /* Check for @file inclusion. */ + while (isspace(*ip)) + ip++; + + if (*ip == '@') { + sv_fp[lev++] = fp; + if (lev >= MAXLEV) { + printf ("envinit: nesting too deep\n"); + fflush (stdout); + break; + + } else { + char *fname; + fname = ++ip; + + while (*ip) + if (isspace(*ip)) { + *ip = '\0'; + break; + } else + ip++; + + if ((fp = fopen (vfn2osfn(fname,0), "r")) == NULL) { + printf ("envinit: cannot open `%s'\n", fname); + fflush (stdout); + break; + } + } + continue; + } + + /* fall through */ + } + + /* Extract name field. */ + for (op=name; *ip && *ip != '=' && !isspace(*ip); op++) + *op = *ip++; + *op = XEOS; + + /* Extract value field; may be quoted. Newline may be escaped + * to break a long value string over several lines of the input + * file. + */ + for (; *ip && (*ip == '=' || *ip == '"' || isspace (*ip)); ip++) + ; + for (op=value; *ip && *ip != '"' && *ip != '\n'; op++) + if (*ip == '\\' && *(ip+1) == '\n') { +again: if (fgets (lbuf, SZ_LINE, fp) == NULL) + break; + for (ip=lbuf; isspace(*ip); ip++) + ; + if (*ip == '#') + goto again; + } else + *op = *ip++; + *op = XEOS; + + /* Allow the user to override the values of environment variables + * by defining them in their host environment. Once again, + * "pkglibs" requires special treatment as we want to permit + * redefinitions to allow concatenation in loadpkgenv(). + */ + os_strpak (name, pkname, SZ_FNAME); + if (strcmp (pkname, PKGLIBS) && + _os_getenv (pkname, old_value, SZ_VALUE)) { + if (bdebug) + printf ("%s = %s\n", pkname, old_value); + } else + ENVRESET (name, value); + } + + fclose (fp); +} +#endif diff --git a/unix/boot/bootlib/index.c b/unix/boot/bootlib/index.c new file mode 100644 index 00000000..e3387060 --- /dev/null +++ b/unix/boot/bootlib/index.c @@ -0,0 +1,39 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#ifdef LINUX +#define NOINDEX +#endif +#ifdef MACOSX +/* The following effectively disables the local version. */ +#define index strindex +#endif + +/* index and rindex are provided by most systems and are redundantly defined + * here only in case they are missing (we probably should be using the more + * modern strchr etc. but that is another thing). Linux (slackware at least) + * defines these in the same libc.a object module as strchr etc. (this is a + * bug), which causes a library conflict. Hence on Linux systems we omit + * these functions. + */ +#ifndef NOINDEX + +/* INDEX -- Return pointer to the first occurrence of a character in a string, + * or null if the char is not found. + */ +char * +index ( char *str, int ch) +{ + register char *ip; + register int cch; + + for (ip=str; (cch = *ip); ip++) + if (cch == ch) + return (ip); + + return (NULL); +} + +#endif diff --git a/unix/boot/bootlib/kproto32.h b/unix/boot/bootlib/kproto32.h new file mode 100644 index 00000000..e407cff5 --- /dev/null +++ b/unix/boot/bootlib/kproto32.h @@ -0,0 +1,80 @@ +/* _bytmov.c */ +extern void bytmov_(short *a, int *aoff, short *b, int *boff, int *nbytes); +/* envinit.c */ +extern void loadpkgenv(char *pkg); +extern void _envinit(void); +extern void loadenv(char *osfn); +/* index.c */ +/* osaccess.c */ +extern int os_access(char *fname, int mode, int type); +/* osamovb.c */ +extern void os_amovb(char *a, char *b, int nbytes); +/* oschdir.c */ +extern int os_chdir(char *dir); +/* osclose.c */ +extern void os_close(int fd); +/* oscmd.c */ +extern int os_cmd(char *cmd); +/* oscreatedir.c */ +extern int os_createdir(char *dirname, int mode); +/* oscrfile.c */ +extern int os_createfile(char *fname, int mode, int type); +/* osdelete.c */ +extern int os_delete(char *fname); +/* osdir.c */ +extern int os_diropen(char *dirname); +extern int os_dirclose(int chan); +extern int os_gfdir(int chan, char *fname, int maxch); +/* osfcopy.c */ +extern int os_fcopy(char *oldfile, char *newfile); +/* osfdate.c */ +extern long os_fdate(char *fname); +/* osfiletype.c */ +extern int os_filetype(char *fname); +/* osfn2vfn.c */ +extern char *osfn2vfn(char *osfn); +/* osfpathname.c */ +extern int os_fpathname(char *vfn, char *osfn, int maxch); +/* osgetenv.c */ +extern char *os_getenv(char *envvar); +extern char *_os_getenv(char *envvar, char *outstr, int maxch); +/* osgetowner.c */ +extern void os_getowner(char *fname, int *uid, int *gid); +/* osopen.c */ +extern int os_open(char *vfn, int mode, int type); +/* osputenv.c */ +extern void os_putenv(char *name, char *value); +/* osread.c */ +extern int os_read(int fd, char *buf, int nbytes); +/* ossetfmode.c */ +extern int os_setfmode(char *fname, int mode); +/* ossetowner.c */ +extern int os_setowner(char *fname, int uid, int gid); +/* ossettime.c */ +extern int os_setmtime(char *fname, long mtime); +/* osstrpak.c */ +extern char *os_strpak(short *sppstr, char *cstr, int maxch); +/* osstrupk.c */ +extern short *os_strupk(char *str, short *outstr, int maxch); +/* ossubdir.c */ +extern char *os_subdir(char *dir, char *subdir); +/* ossymlink.c */ +extern int os_symlink(char *fname, char *valbuf, int maxch); +/* ossysfile.c */ +extern int os_sysfile(char *sysfile, char *fname, int maxch); +/* ostime.c */ +extern long os_utime(long iraf_time); +extern long os_itime(long unix_time); +/* oswrite.c */ +extern int os_write(int fd, char *buf, int nbytes); +/* rindex.c */ +/* tape.c */ +extern int tape_open(char *fname, int mode); +extern int tape_close(int fd); +extern int tape_read(int fd, char *buf, int maxbytes); +extern int tape_write(int fd, char *buf, int nbytes); +/* vfn2osfn.c */ +extern char *vfn2osfn(char *vfn, int new); +extern int kigets_(void); +extern void kisend_(void); +extern void kirece_(void); diff --git a/unix/boot/bootlib/kproto64.h b/unix/boot/bootlib/kproto64.h new file mode 100644 index 00000000..5335919c --- /dev/null +++ b/unix/boot/bootlib/kproto64.h @@ -0,0 +1,80 @@ +/* _bytmov.c */ +extern void bytmov_(short *a, long *aoff, short *b, long *boff, long *nbytes); +/* envinit.c */ +extern void loadpkgenv(char *pkg); +extern void _envinit(void); +extern void loadenv(char *osfn); +/* index.c */ +/* osaccess.c */ +extern int os_access(char *fname, int mode, int type); +/* osamovb.c */ +extern void os_amovb(char *a, char *b, int nbytes); +/* oschdir.c */ +extern int os_chdir(char *dir); +/* osclose.c */ +extern void os_close(int fd); +/* oscmd.c */ +extern int os_cmd(char *cmd); +/* oscreatedir.c */ +extern int os_createdir(char *dirname, int mode); +/* oscrfile.c */ +extern int os_createfile(char *fname, int mode, int type); +/* osdelete.c */ +extern int os_delete(char *fname); +/* osdir.c */ +extern int os_diropen(char *dirname); +extern int os_dirclose(int chan); +extern int os_gfdir(int chan, char *fname, int maxch); +/* osfcopy.c */ +extern int os_fcopy(char *oldfile, char *newfile); +/* osfdate.c */ +extern long os_fdate(char *fname); +/* osfiletype.c */ +extern int os_filetype(char *fname); +/* osfn2vfn.c */ +extern char *osfn2vfn(char *osfn); +/* osfpathname.c */ +extern int os_fpathname(char *vfn, char *osfn, int maxch); +/* osgetenv.c */ +extern char *os_getenv(char *envvar); +extern char *_os_getenv(char *envvar, char *outstr, int maxch); +/* osgetowner.c */ +extern void os_getowner(char *fname, int *uid, int *gid); +/* osopen.c */ +extern int os_open(char *vfn, int mode, int type); +/* osputenv.c */ +extern void os_putenv(char *name, char *value); +/* osread.c */ +extern int os_read(int fd, char *buf, int nbytes); +/* ossetfmode.c */ +extern int os_setfmode(char *fname, int mode); +/* ossetowner.c */ +extern int os_setowner(char *fname, int uid, int gid); +/* ossettime.c */ +extern int os_setmtime(char *fname, long mtime); +/* osstrpak.c */ +extern char *os_strpak(short *sppstr, char *cstr, int maxch); +/* osstrupk.c */ +extern short *os_strupk(char *str, short *outstr, int maxch); +/* ossubdir.c */ +extern char *os_subdir(char *dir, char *subdir); +/* ossymlink.c */ +extern int os_symlink(char *fname, char *valbuf, int maxch); +/* ossysfile.c */ +extern int os_sysfile(char *sysfile, char *fname, int maxch); +/* ostime.c */ +extern long os_utime(long iraf_time); +extern long os_itime(long unix_time); +/* oswrite.c */ +extern int os_write(int fd, char *buf, int nbytes); +/* rindex.c */ +/* tape.c */ +extern int tape_open(char *fname, int mode); +extern int tape_close(int fd); +extern int tape_read(int fd, char *buf, int maxbytes); +extern int tape_write(int fd, char *buf, int nbytes); +/* vfn2osfn.c */ +extern char *vfn2osfn(char *vfn, int new); +extern int kigets_(void); +extern void kisend_(void); +extern void kirece_(void); diff --git a/unix/boot/bootlib/mkpkg b/unix/boot/bootlib/mkpkg new file mode 100644 index 00000000..5b4f9ba1 --- /dev/null +++ b/unix/boot/bootlib/mkpkg @@ -0,0 +1,49 @@ +# Update the BOOTLIB library. The Makefile is used to bootstrap the library, +# but once MKPKG is up it is easier to maintain the library with MKPKG. + +$checkout libboot.a hlib$ +$update libboot.a +$checkin libboot.a hlib$ +$exit + +libboot.a: + $set XFLAGS = "-c $(HSI_XF)" + $iffile (as$bytmov.s) as$bytmov.s $else _bytmov.c $endif + osamovb.c + + index.c + rindex.c + envinit.c + + osaccess.c bootlib.h + oschdir.c bootlib.h + osclose.c bootlib.h + oscmd.c bootlib.h + oscreatedir.c bootlib.h + oscrfile.c bootlib.h + osdelete.c bootlib.h + osdir.c bootlib.h + osfcopy.c bootlib.h + osfdate.c bootlib.h + osfiletype.c + osfpathname.c bootlib.h + osgetenv.c bootlib.h + osgetowner.c bootlib.h + osopen.c + osputenv.c bootlib.h + osread.c + ossetfmode.c bootlib.h + ossetowner.c bootlib.h + ossettime.c bootlib.h + osstrpak.c + osstrupk.c + ossymlink.c + ossubdir.c bootlib.h + ossysfile.c bootlib.h + ostime.c + oswrite.c bootlib.h + + vfn2osfn.c bootlib.h + osfn2vfn.c bootlib.h + tape.c + ; diff --git a/unix/boot/bootlib/mkpkg.sh b/unix/boot/bootlib/mkpkg.sh new file mode 100644 index 00000000..6f37c67e --- /dev/null +++ b/unix/boot/bootlib/mkpkg.sh @@ -0,0 +1,16 @@ +# Make the bootstrap utilities library (bootlib). + +if test -f ../../as/bytmov.s; then\ + $CC -c $HSI_CF ../../as/bytmov.s -o bytmov.o;\ +else\ + $CC -c $HSI_CF _bytmov.c;\ +fi + +# $CC -c $HSI_CF [a-z]*.c +for i in [a-z]*.c ;\ +do $CC -c $HSI_CF $i ;\ +done + +ar rv libboot.a *.o; rm *.o +$RANLIB libboot.a +mv -f libboot.a ../../bin diff --git a/unix/boot/bootlib/osaccess.c b/unix/boot/bootlib/osaccess.c new file mode 100644 index 00000000..0c6861e7 --- /dev/null +++ b/unix/boot/bootlib/osaccess.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + +/* OS_ACCESS -- Determine if file is accessible with the given access mode + * and type. Returns YES (1) or NO (0). + */ +int +os_access ( + char *fname, + int mode, + int type +) +{ + PKCHAR osfn[SZ_PATHNAME+1]; + XINT status, xmode=mode, xtype=type; + + extern int ZFACSS(); + + + strcpy ((char *)osfn, vfn2osfn(fname,0)); + ZFACSS (osfn, &xmode, &xtype, &status); + + return (status); +} diff --git a/unix/boot/bootlib/osamovb.c b/unix/boot/bootlib/osamovb.c new file mode 100644 index 00000000..71b1d2d0 --- /dev/null +++ b/unix/boot/bootlib/osamovb.c @@ -0,0 +1,34 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + + +/* OS_AMOVB -- Memory to memory copy using BYTMOV. + */ +void +os_amovb ( + char *a, + char *b, + int nbytes +) +{ + XCHAR *a_wp, *b_wp; + XINT a_off, b_off; + + extern void BYTMOV(); + + + a_wp = (XCHAR *)a; + b_wp = (XCHAR *)b; + + /* The following offsets can be something other than one if the + * buffers are not word aligned. + */ + a_off = a - (char *)a_wp + 1; + b_off = b - (char *)b_wp + 1; + + BYTMOV (a_wp, &a_off, b_wp, &b_off, &nbytes); +} diff --git a/unix/boot/bootlib/oschdir.c b/unix/boot/bootlib/oschdir.c new file mode 100644 index 00000000..497f1576 --- /dev/null +++ b/unix/boot/bootlib/oschdir.c @@ -0,0 +1,43 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "bootlib.h" + + +extern int os_fpathname (char *vfn, char *osfn, int maxch); + + + +/* OS_CHDIR -- Change the current default directory. Note that the kernel + * procedure ZFCHDR should only be called with the full pathname of a + * directory. + */ +int +os_chdir (char *dir) +{ + XCHAR dpath[SZ_PATHNAME+1]; + XCHAR osdir[SZ_PATHNAME+1]; + XINT sz_dpath, sz_osdir, status, x_maxch=SZ_PATHNAME; + + extern int ZFXDIR(), ZFGCWD(), ZFSUBD(), ZFCHDR(); + + + sz_dpath = os_fpathname (dir, (char *)dpath, SZ_PATHNAME); + os_strupk ((char *)dpath, osdir, SZ_PATHNAME); + ZFXDIR (osdir, osdir, &x_maxch, &sz_osdir); + + if (sz_osdir <= 0) { + /* Dir is a subdirectory, not a full pathname. Note that this + * only works for an immediate subdirectory, and does not work + * for paths relative to the cwd. + */ + ZFGCWD (osdir, &x_maxch, &sz_osdir); + os_strupk ((char *)osdir, osdir, SZ_PATHNAME); + os_strupk (dir, dpath, SZ_PATHNAME); + ZFSUBD (osdir, &x_maxch, dpath, &sz_osdir); + os_strpak (osdir, (char *)dpath, SZ_PATHNAME); + } + + ZFCHDR (dpath, &status); + return (status); +} diff --git a/unix/boot/bootlib/osclose.c b/unix/boot/bootlib/osclose.c new file mode 100644 index 00000000..f9be512c --- /dev/null +++ b/unix/boot/bootlib/osclose.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include /* for close() */ +#include "bootlib.h" + + +/* OS_CLOSE -- Close a file created (opened) by OSCREATE. If writing to a + * text file flush any incomplete (non newline terminated) output line. + */ +void +os_close (int fd) +{ + XINT junk, xfd=fd; + XINT nchars; + + extern int ZPUTTX(), ZCLSTX(); + + + if (osfiletype == BINARY_FILE) + close (fd); + else { + if (txop > text) { + nchars = txop - text; + ZPUTTX (&xfd, text, &nchars, &junk); + } + ZCLSTX (&xfd, &junk); + } +} diff --git a/unix/boot/bootlib/oscmd.c b/unix/boot/bootlib/oscmd.c new file mode 100644 index 00000000..0f9c9755 --- /dev/null +++ b/unix/boot/bootlib/oscmd.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + +#define SZ_CMD 2048 + +/* OS_CMD -- Send a command to the host system. + */ +int +os_cmd (char *cmd) +{ + PKCHAR x_cmd[SZ_CMD+1]; + PKCHAR nullstr[1]; + XINT status; + extern int ZOSCMD(); + + + strncpy ((char *)x_cmd, cmd, SZ_CMD); + nullstr[0] = 0; + + /* Terminate the parent process if the OS command is interrupted. + */ + ZOSCMD (x_cmd, nullstr, nullstr, nullstr, &status); + return (status); +} diff --git a/unix/boot/bootlib/oscreatedir.c b/unix/boot/bootlib/oscreatedir.c new file mode 100644 index 00000000..517d0eed --- /dev/null +++ b/unix/boot/bootlib/oscreatedir.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include /* for mkdir() */ +#include "bootlib.h" + +/* OS_CREATEDIR -- Create a new subdirectory. + */ +int +os_createdir ( + char *dirname, + int mode +) +{ + if (bdebug) + fprintf (stderr, "createdir '%s'\n", dirname); + return (mkdir (vfn2osfn(dirname,1), mode)); +} diff --git a/unix/boot/bootlib/oscrfile.c b/unix/boot/bootlib/oscrfile.c new file mode 100644 index 00000000..28eec304 --- /dev/null +++ b/unix/boot/bootlib/oscrfile.c @@ -0,0 +1,36 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + + +/* OS_CREATEFILE -- Open a new file for writing. Create the file with the + * given mode bits. + */ +int +os_createfile ( + char *fname, + int mode, + int type +) +{ + static XINT xmode = NEW_FILE; + PKCHAR *osfn = (PKCHAR *) vfn2osfn (fname, 1); + XINT chan; + extern int ZOPNTX(); + + + if (bdebug) + fprintf (stderr, "create %s file `%s' -> `%s'\n", + type == TEXT_FILE ? "text" : "binary", fname, (char *)osfn); + osfiletype = type; + + if (type == BINARY_FILE) + return (creat ((char *)osfn, mode)); + else { + ZOPNTX (osfn, &xmode, &chan); + txop = text; + return (chan == XERR ? ERR : chan); + } +} diff --git a/unix/boot/bootlib/osdelete.c b/unix/boot/bootlib/osdelete.c new file mode 100644 index 00000000..a56a72e6 --- /dev/null +++ b/unix/boot/bootlib/osdelete.c @@ -0,0 +1,19 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "bootlib.h" + + +/* OS_DELETE -- Delete a file. + */ +int +os_delete (char *fname) +{ + XINT status; + + extern int ZFDELE(); + + + ZFDELE ((PKCHAR *)vfn2osfn (fname, 0), &status); + return (status); +} diff --git a/unix/boot/bootlib/osdir.c b/unix/boot/bootlib/osdir.c new file mode 100644 index 00000000..d3807302 --- /dev/null +++ b/unix/boot/bootlib/osdir.c @@ -0,0 +1,93 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + + +/* + * OS_DIR -- A package for accessing a directory as a list of files. + */ + +#ifndef NOVOS + +/* OS_DIROPEN -- Open the directory. + */ +int +os_diropen (char *dirname) +{ + PKCHAR osfn[SZ_PATHNAME+1]; + XINT chan; + + extern int ZOPDIR(); + + + strcpy ((char *)osfn, dirname); + ZOPDIR (osfn, &chan); + + return (chan); +} + + +/* OS_DIRCLOSE -- Close the directory. + */ +int +os_dirclose (int chan) +{ + XINT x_chan=chan, status; + + extern int ZCLDIR(); + + + ZCLDIR (&x_chan, &status); + return (status); +} + + +/* OS_GFDIR -- Get the next filename from the directory. + */ +int +os_gfdir ( + int chan, + char *fname, + int maxch +) +{ + PKCHAR osfn[SZ_PATHNAME+1]; + XINT x_chan=chan, x_maxch=maxch, status; + + extern int ZGFDIR(); + + for (;;) { + ZGFDIR (&x_chan, osfn, &x_maxch, &status); + if (status > 0) { + /* Omit the self referential directory files "." and ".." + * or recursion may result. + */ + if (strcmp ((char *)osfn, ".") == 0) + continue; + if (strcmp ((char *)osfn, "..") == 0) + continue; + + strncpy (fname, osfn2vfn ((char *)osfn), maxch); + return (status); + + } else { + /* End of directory. + */ + *fname = EOS; + return (0); + } + } +} + +#else +/* NOVOS bootsrap. Just stub these out until we re-boostrap using the + * VOS libs, which provide zopdir. + */ + +int os_dirclose (int chan) { return (-1); } +int os_diropen (char *dirname) { return (-1); } +int os_gfdir (int chan, char *fname, int maxch) { return (0); } + +#endif diff --git a/unix/boot/bootlib/osfcopy.c b/unix/boot/bootlib/osfcopy.c new file mode 100644 index 00000000..037d6eff --- /dev/null +++ b/unix/boot/bootlib/osfcopy.c @@ -0,0 +1,84 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include "bootlib.h" + +extern int os_access (char *fname, int mode, int type); + + +/* OS_FCOPY -- Copy a file. Used by RTAR to resolve links. + */ +int +os_fcopy ( + char *oldfile, + char *newfile +) +{ + XCHAR buf[SZ_FBUF]; + XINT status, junk, maxch = SZ_FBUF, mode = 0, in, out, n, nw; + + extern int ZOPNTX(), ZGETTX(), ZCLSTX(), ZPUTTX(); + + + if (os_access (oldfile,0,0) == NO) + return (ERR); + + if (os_access (oldfile, 0, TEXT_FILE) == YES) { + if (bdebug) + fprintf (stderr, "copy text file '%s' -> '%s'\n", + oldfile, newfile); + + mode = READ_ONLY; + ZOPNTX ((PKCHAR *)vfn2osfn(oldfile,0), &mode, &in); + if (in == XERR) + return (ERR); + + mode = NEW_FILE; + ZOPNTX ((PKCHAR *)vfn2osfn(newfile,1), &mode, &out); + if (out == XERR) { + ZCLSTX (&in, &status); + return (ERR); + } + + while (ZGETTX (&in, buf, &maxch, &n), n != XEOF) { + if (n != XERR) + ZPUTTX (&out, buf, &n, &status); + if (n == XERR || status == XERR) { + ZCLSTX (&in, &junk); + ZCLSTX (&out, &junk); + return (ERR); + } + } + + ZCLSTX (&in, &status); + ZCLSTX (&out, &status); + + return (status); + + } else { + if (bdebug) + fprintf (stderr, "copy binary file `%s' -> `%s'\n", + oldfile, newfile); + + if ((in = open (vfn2osfn(oldfile,0), 0)) == ERR) + return (ERR); + if ((out = creat (vfn2osfn(newfile,1), 0644)) == ERR) { + close (in); + return (ERR); + } + + while ((n = read (in, (char *)buf, SZ_FBUF)) > 0) + nw = write (out, (char *)buf, n); + + close (in); + close (out); + if (n < 0) + return (ERR); + } + + return (ERR); +} diff --git a/unix/boot/bootlib/osfdate.c b/unix/boot/bootlib/osfdate.c new file mode 100644 index 00000000..900b2a9d --- /dev/null +++ b/unix/boot/bootlib/osfdate.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include "bootlib.h" + + +/* FDATE -- Get the date of last modification of a file. [MACHDEP] + */ +long +os_fdate (char *fname) +{ + struct stat buf; + + if (stat (vfn2osfn(fname,0), &buf) == ERR) + return (0); + else + return (buf.st_mtime); +} diff --git a/unix/boot/bootlib/osfiletype.c b/unix/boot/bootlib/osfiletype.c new file mode 100644 index 00000000..d211cc99 --- /dev/null +++ b/unix/boot/bootlib/osfiletype.c @@ -0,0 +1,116 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_spp +#include + +/* + * OS_FILETYPE -- Determine whether the named file is a text file, a binary + * file, or a directory. The filename extensions used to speed up the test + * are portable provided osfn2vfn() is called to map the OSFN before we are + * called. + */ + +char *binextn[] = { /* Known binary file extensions */ + ".o", + ".e", + ".a", + ".so", + ".pyc", + NULL +}; + +char *srcextn[] = { /* Known source file extensions */ + ".x", + ".h", + ".f", + ".f77", + ".f90", + ".s", + ".c", + ".cpp", + ".hlp", + ".mip", + ".imh", + ".pix", + ".gki", + ".vdm", + ".fits", + ".fit", + ".ftz", + ".pl", + ".gif", + ".jpeg", + ".jpg", + ".tiff", + ".tif", + ".png", + ".gz", + ".tar", + ".jar", + ".java", + ".py", + ".pdf", + ".ps", + ".hqx", + ".std", + NULL +}; + +extern int os_access (char *fname, int mode, int type); + + + +/* OS_FILETYPE -- Determine the type of a file. If the file has one of the + * known source file extensions we assume it is a text file; if it has a well + * known binary file extension we assume it is a binary file; otherwise we call + * os_access to determine the file type. + */ +int +os_filetype ( + char *fname /* name of file to be examined */ +) +{ + register char *ip, *ep; + register int ch, i; + char *extn; + + + /* Get filename extension. + */ + extn = NULL; + for (ip=fname; (ch = *ip); ip++) + if (ch == '.') + extn = ip; + + /* If the filename has a extension, check the list of known text and + * binary file extensions to see if we can make a quick determination + * of the file type. + */ + if (extn) { + ch = *(extn + 1); + + /* Known source file extension? */ + for (i=0; (ep = srcextn[i]); i++) + if (*(ep+1) == ch) + if (strcasecmp (ep, extn) == 0) + return (TEXT_FILE); + + /* Known binary file extension? */ + for (i=0; (ep = binextn[i]); i++) + if (*(ep+1) == ch) + if (strcasecmp (ep, extn) == 0) + return (BINARY_FILE); + } + + /* Call ACCESS to determine the file type. + */ + if (os_access (fname, READ_ONLY, DIRECTORY_FILE) == YES) + return (DIRECTORY_FILE); + else if (os_access (fname, 0, TEXT_FILE) == YES) + return (TEXT_FILE); + else + return (BINARY_FILE); +} diff --git a/unix/boot/bootlib/osfn2vfn.c b/unix/boot/bootlib/osfn2vfn.c new file mode 100644 index 00000000..c16ccf03 --- /dev/null +++ b/unix/boot/bootlib/osfn2vfn.c @@ -0,0 +1,81 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define NOLIBCNAMES +#define import_spp +#define import_libc +#define import_xnames +#define import_knames +#include +#include "bootlib.h" + + +static char vfn[SZ_PATHNAME+1]; + +#ifdef NOVOS + +/* OSFN2VFN -- Convert a local-directory OS filename into a virtual filename. + * On UNIX this is a no-op since escape sequence encoding is not needed and + * the IRAF file extensions are the same as UNIX. + */ +char * +osfn2vfn ( + char *osfn /* input OS filename */ +) +{ + strcpy (vfn, osfn); /* [MACHDEP */ + return (vfn); +} + +#else + +/* OSFN2VFN -- Convert a local-directory OS filename into a virtual filename. + * Undo the escape sequence encoding and map the OS filename extension into + * the IRAF one. No attempt is made to map OS directory names into IRAF + * logical directory names; this is a local directory operation only. + */ +char *osfn2vfn (osfn) +char *osfn; /* input OS filename */ +{ + XCHAR x_osfn[SZ_PATHNAME+1]; + XCHAR x_vfn[SZ_PATHNAME+1]; + XINT x_maxch = SZ_PATHNAME; + XINT x_mode, vp, nchars; + + extern void _envinit(); + + + _envinit(); + + os_strupk ("./", x_vfn, SZ_PATHNAME); + x_mode = VFN_UNMAP; + iferr (vp = VFNOPEN (x_vfn, (integer *)&x_mode)) { + vp = 0; + goto err_; + } + + strcpy ((char *)x_osfn, osfn); + iferr (nchars = VFNUNMAP ((integer *)&vp, x_osfn, x_vfn, + (integer *)&x_maxch)) + goto err_; + if (nchars < 0) + goto err_; + + x_mode = VFN_NOUPDATE; + VFNCLOSE ((integer *)&vp, (integer *)&x_mode); + + os_strpak (x_vfn, vfn, SZ_PATHNAME); + return (vfn); + +err_: + fprintf (stderr, "cannot unmap filename `%s'\n", osfn); + if (vp > 0) + VFNCLOSE ((integer *)&vp, (integer *)&x_mode); + + strcpy (vfn, osfn); + return (vfn); +} + +#endif diff --git a/unix/boot/bootlib/osfpathname.c b/unix/boot/bootlib/osfpathname.c new file mode 100644 index 00000000..17fdba61 --- /dev/null +++ b/unix/boot/bootlib/osfpathname.c @@ -0,0 +1,41 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "bootlib.h" + + +/* OS_FPATHNAME -- Map a VFN (virtual filename) into a pathname (filename + * specification which is independent of the current directory). + */ +int +os_fpathname ( + char *vfn, /* virtual filename */ + char *osfn, /* OS filename */ + int maxch +) +{ + XCHAR x_vfn[SZ_PATHNAME+1]; + XCHAR x_osfn[SZ_PATHNAME+1]; + XINT x_maxch = SZ_PATHNAME, x_nchars; + + extern int ZFGCWD(), ZFSUBD(), ZFPATH(); + + + if (vfn[0]) + os_strupk (vfn2osfn(vfn,0), x_vfn, x_maxch); + else + x_vfn[0] = 0; + + if (vfn[0] == '.' && (vfn[1] == EOS || vfn[2] == EOS)) { + ZFGCWD (x_osfn, &x_maxch, &x_nchars); + os_strupk ((char *)x_osfn, x_osfn, x_maxch); + if (vfn[1] == '.') { + os_strupk (vfn, x_vfn, x_maxch); + ZFSUBD (x_osfn, &x_maxch, x_vfn, &x_nchars); + } + } else + ZFPATH (x_vfn, x_osfn, &x_maxch, &x_nchars); + + os_strpak (x_osfn, osfn, maxch); + return (x_nchars); +} diff --git a/unix/boot/bootlib/osgetenv.c b/unix/boot/bootlib/osgetenv.c new file mode 100644 index 00000000..3ccfb403 --- /dev/null +++ b/unix/boot/bootlib/osgetenv.c @@ -0,0 +1,127 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_xnames +#include "bootlib.h" + + +char *_os_getenv(); + + +/* OS_GETENV -- Return the value of the named environment variable. Null is + * returned if the named variable is not found. + */ +char * +os_getenv (char *envvar) +{ + static char irafdir[SZ_PATHNAME+1] = ""; + static char hostdir[SZ_PATHNAME+1] = ""; + static char valstr[SZ_COMMAND+1]; + static char errmsg[] = "environment variable `%s' not found\n"; + extern char *os_subdir(); + char *vp; + + + /* Try the standard environment first. */ + memset (valstr, 0, SZ_COMMAND+1); + if ( (vp = _os_getenv (envvar, valstr, SZ_COMMAND)) ) + return (vp); + + /* The following maps certain well-known IRAF logical directories + * even if there is no regular (VOS) environment facility. + */ + if (irafdir[0] == EOS) + if (_os_getenv ("iraf", irafdir, SZ_PATHNAME) == NULL) { + fprintf (stderr, errmsg, "iraf"); + return (NULL); + } + if (hostdir[0] == EOS) + if (_os_getenv ("host", hostdir, SZ_PATHNAME) == NULL) { + fprintf (stderr, errmsg, "host"); + return (NULL); + } + + /* Map the names of the well known IRAF logical directories which + * are defined portably in terms of iraf$ or host$. + */ + if ( strcmp (envvar, "lib") == 0) /* iraf/. */ + strcpy (valstr, os_subdir (irafdir, "lib")); + else if (strcmp (envvar, "bin") == 0) + strcpy (valstr, os_subdir (irafdir, "bin")); + else if (strcmp (envvar, "dev") == 0) + strcpy (valstr, os_subdir (irafdir, "dev")); + else if (strcmp (envvar, "pkg") == 0) + strcpy (valstr, os_subdir (irafdir, "pkg")); + else if (strcmp (envvar, "sys") == 0) + strcpy (valstr, os_subdir (irafdir, "sys")); + else if (strcmp (envvar, "math") == 0) + strcpy (valstr, os_subdir (irafdir, "math")); + else if (strcmp (envvar, "hlib") == 0) /* host/. */ + strcpy (valstr, os_subdir (hostdir, "hlib")); + else if (strcmp (envvar, "as") == 0) + strcpy (valstr, os_subdir (hostdir, "as")); + else + return (NULL); + + return (valstr); +} + + +#ifdef NOVOS +/* _OS_GETENV -- Fetch the value of the named environment variable from the + * host environment. + */ +char * +_os_getenv ( + char *envvar, /* name of environment variable */ + char *outstr, /* receives value */ + int maxch +) +{ + PKCHAR symbol[SZ_FNAME+1]; + PKCHAR value[SZ_COMMAND+1]; + XINT x_maxch = SZ_COMMAND, status=1; + + strcpy ((char *)symbol, envvar); + ZGTENV (symbol, value, &x_maxch, &status); + + if (status < 0) { + outstr[0] = EOS; + return (NULL); + } else { + strncpy (outstr, (char *)value, maxch); + outstr[maxch] = EOS; + return (outstr); + } +} + +#else +/* _OS_GETENV -- Fetch the value of the named environment variable from the + * host environment. + */ +char * +_os_getenv ( + char *envvar, /* name of environment variable */ + char *outstr, /* receives value */ + int maxch +) +{ + XCHAR x_symbol[SZ_FNAME+1]; + XCHAR x_value[SZ_COMMAND+1]; + XINT x_maxch = SZ_COMMAND, status=1; + extern XINT ENVFIND(); + + + os_strupk (envvar, x_symbol, SZ_FNAME); + status = ENVFIND (x_symbol, x_value, &x_maxch); + + if (status <= 0) { + outstr[0] = EOS; + return (NULL); + } else { + os_strpak (x_value, outstr, maxch); + return (outstr); + } +} +#endif diff --git a/unix/boot/bootlib/osgetowner.c b/unix/boot/bootlib/osgetowner.c new file mode 100644 index 00000000..489997c1 --- /dev/null +++ b/unix/boot/bootlib/osgetowner.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include "bootlib.h" + + +/* OS_GETOWNER -- Get the user and group identifications for a file. This is + * not a required function and is expected to rarely work when transporting + * files to a host at a different site. Nonetheless it is useful when moving + * files between compatible hosts at a single site, so we make use of it in + * case it works. It is sufficient to merely set uid and gid to 0 and return. + */ +void +os_getowner ( + char *fname, + int *uid, + int *gid +) +{ + struct stat fi; + + if (stat (vfn2osfn(fname,0), &fi) != -1) { + *uid = fi.st_uid; + *gid = fi.st_gid; + } +} diff --git a/unix/boot/bootlib/osopen.c b/unix/boot/bootlib/osopen.c new file mode 100644 index 00000000..42b3cdeb --- /dev/null +++ b/unix/boot/bootlib/osopen.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + +extern int os_createfile (char *fname, int mode, int type); + + +/* OS_OPEN -- Open or create a host system file for reading or writing (text + * and binary disk files only). + */ +int +os_open ( + char *vfn, /* file to be opened */ + int mode, /* access mode 0=R, 1=W, 2=RW */ + int type /* file type */ +) +{ + extern char *vfn2osfn(); + + if (mode == 0) { + osfiletype = BINARY_FILE; + return (open (vfn2osfn (vfn, 0), 0)); + } else if (mode == 1) { + return (os_createfile (vfn, mode, type)); + } else + return (-1); +} diff --git a/unix/boot/bootlib/osproto.h b/unix/boot/bootlib/osproto.h new file mode 100644 index 00000000..0be822d7 --- /dev/null +++ b/unix/boot/bootlib/osproto.h @@ -0,0 +1,136 @@ +extern int zdvall_(short *aliases, int *allflg, int *status); +extern int zdvown_(short *device, short *owner, int *maxch, int *status); +extern int zawset_(int *best_size, int *new_size, int *old_size, int *max_size); +extern int zcall0_(int *proc); +extern int zcall1_(int *proc, void *arg1); +extern int zcall2_(int *proc, void *arg1, void *arg2); +extern int zcall3_(int *proc, void *arg1, void *arg2, void *arg3); +extern int zcall4_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zcall5_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zcall6_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zcall7_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zcall8_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zcall9_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zcalla_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +extern void zdojmp_(int *jmpbuf, int *status); +extern int zfacss_(short *fname, int *mode, int *type, int *status); +extern int zfaloc_(short *fname, int *nbytes, int *status); +extern int zfchdr_(short *newdir, int *status); +extern int zfdele_(short *fname, int *status); +extern int zfgcwd_(short *outstr, int *maxch, int *status); +extern int zfinfo_(short *fname, int *finfo_struct, int *status); +extern int zopnbf_(short *osfn, int *mode, int *chan); +extern int zclsbf_(int *fd, int *status); +extern int zardbf_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrbf_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtbf_(int *fd, int *status); +extern int zsttbf_(int *fd, int *param, int *lvalue); +extern int zopnks_(short *x_server, int *mode, int *chan); +extern int zclsks_(int *chan, int *status); +extern int zardks_(int *chan, short *buf, int *totbytes, int *loffset); +extern int zawrks_(int *chan, short *buf, int *totbytes, int *loffset); +extern int zawtks_(int *chan, int *status); +extern int zsttks_(int *chan, int *param, int *lvalue); +extern int zopnlp_(short *printer, int *mode, int *chan); +extern int zclslp_(int *chan, int *status); +extern int zardlp_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrlp_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtlp_(int *chan, int *status); +extern int zsttlp_(int *chan, int *param, int *lvalue); +extern int zzopmt_(short *device, int *acmode, short *devcap, int *devpos, int *newfile, int *chan); +extern int zzclmt_(int *chan, int *devpos, int *o_status); +extern int zzrdmt_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zzwrmt_(int *chan, short *buf, int *nbytes, int *offset); +extern int zzwtmt_(int *chan, int *devpos, int *o_status); +extern int zzstmt_(int *chan, int *param, int *lvalue); +extern int zzrwmt_(short *device, short *devcap, int *o_status); +extern int zopnnd_(short *pk_osfn, int *mode, int *chan); +extern int zclsnd_(int *fd, int *status); +extern int zardnd_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrnd_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtnd_(int *fd, int *status); +extern int zsttnd_(int *fd, int *param, int *lvalue); +extern int zopnpl_(short *plotter, int *mode, int *chan); +extern int zclspl_(int *chan, int *status); +extern int zardpl_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrpl_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtpl_(int *chan, int *status); +extern int zsttpl_(int *chan, int *param, int *lvalue); +extern int zopcpr_(short *osfn, int *inchan, int *outchan, int *pid); +extern int zclcpr_(int *pid, int *exit_status); +extern int zardpr_(int *chan, short *buf, int *maxbytes, int *loffset); +extern int zawrpr_(int *chan, short *buf, int *nbytes, int *loffset); +extern int zawtpr_(int *chan, int *status); +extern int zsttpr_(int *chan, int *param, int *lvalue); +extern int zopnsf_(short *osfn, int *mode, int *chan); +extern int zclssf_(int *fd, int *status); +extern int zardsf_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrsf_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtsf_(int *fd, int *status); +extern int zsttsf_(int *fd, int *param, int *lvalue); +extern int zopntx_(short *osfn, int *mode, int *chan); +extern int zclstx_(int *fd, int *status); +extern int zflstx_(int *fd, int *status); +extern int zgettx_(int *fd, short *buf, int *maxchars, int *status); +extern int znottx_(int *fd, int *offset); +extern int zputtx_(int *fd, short *buf, int *nchars, int *status); +extern int zsektx_(int *fd, int *znottx_offset, int *status); +extern int zstttx_(int *fd, int *param, int *value); +extern int zopnty_(short *osfn, int *mode, int *chan); +extern int zclsty_(int *fd, int *status); +extern int zflsty_(int *fd, int *status); +extern int zgetty_(int *fd, short *buf, int *maxchars, int *status); +extern int znotty_(int *fd, int *offset); +extern int zputty_(int *fd, short *buf, int *nchars, int *status); +extern int zsekty_(int *fd, int *znotty_offset, int *status); +extern int zsttty_(int *fd, int *param, int *value); +extern int zfmkcp_(short *osfn, short *new_osfn, int *status); +extern int zfmkdr_(short *newdir, int *status); +extern int zfnbrk_(short *vfn, int *uroot_offset, int *uextn_offset); +extern int zfpath_(short *osfn, short *pathname, int *maxch, int *nchars); +extern int zfpoll_(int *pfds, int *nfds, int *timeout, int *npoll, int *status); +extern int zfprot_(short *fname, int *action, int *status); +extern int zfrnam_(short *oldname, short *newname, int *status); +extern int zfrmdr_(short *dir, int *status); +extern int zfsubd_(short *osdir, int *maxch, short *subdir, int *nchars); +extern int zfunc0_(int *proc); +extern int zfunc1_(int *proc, void *arg1); +extern int zfunc2_(int *proc, void *arg1, void *arg2); +extern int zfunc3_(int *proc, void *arg1, void *arg2, void *arg3); +extern int zfunc4_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zfunc5_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zfunc6_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zfunc7_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zfunc8_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zfunc9_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zfunca_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +extern int zfutim_(short *fname, int *atime, int *mtime, int *status); +extern int zfxdir_(short *osfn, short *osdir, int *maxch, int *nchars); +extern int zgcmdl_(short *cmd, int *maxch, int *status); +extern int zghost_(short *outstr, int *maxch); +extern int zgmtco_(int *gmtcor); +extern int zgtenv_(short *envvar, short *outstr, int *maxch, int *status); +extern int zgtime_(int *clock_time, int *cpu_time); +extern int zgtpid_(int *pid); +extern int zintpr_(int *pid, int *exception, int *status); +extern int zlocpr_(PFI proc, int *o_epa); +extern int zlocva_(short *variable, int *location); +extern int zmaloc_(int *buf, int *nbytes, int *status); +extern int zmfree_(int *buf, int *status); +extern int zopdir_(short *fname, int *chan); +extern int zcldir_(int *chan, int *status); +extern int zgfdir_(int *chan, short *outstr, int *maxch, int *status); +extern int zopdpr_(short *osfn, short *bkgfile, short *queue, int *jobcode); +extern int zcldpr_(int *jobcode, int *killflag, int *exit_status); +extern int zoscmd_(short *oscmd, short *stdin_file, short *stdout_file, short *stderr_file, int *status); +extern int zpanic_(int *errcode, short *errmsg); +extern int zraloc_(int *buf, int *nbytes, int *status); +extern int zwmsec_(int *msec); +extern int zxwhen_(int *sig_code, int *epa, int *old_epa); +extern int zxgmes_(int *os_exception, short *errmsg, int *maxch); +extern int zzepro_(void); +extern int zzpstr_(short *s1, short *s2); +extern int zzlstr_(short *s1, short *s2); +extern int zzsetk_(char *ospn, char *osbfn, int prtype, int isatty, int in, int out); +extern int zzstrt_(void); +extern int zzstop_(void); diff --git a/unix/boot/bootlib/osputenv.c b/unix/boot/bootlib/osputenv.c new file mode 100644 index 00000000..40599a85 --- /dev/null +++ b/unix/boot/bootlib/osputenv.c @@ -0,0 +1,72 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_xnames +#include "bootlib.h" + +#define SZ_VALUE SZ_COMMAND + +#ifdef NOVOS +/* OS_PUTENV -- Set the value of the named environment variable. + */ +void +os_putenv ( + char *name, + char *value +) +{ + char buf[SZ_VALUE], *env; + + sprintf (buf, "%s=%s", name, value); + if ( (env = (char *) malloc (strlen(buf) + 1)) ) { + strcpy (env, buf); +#ifdef ultrix + putenv (env); /* must keep env around. */ +#else +#ifdef vax + setenv (name, value, 1); +#else + putenv (env); /* must keep env around. */ +#endif +#endif + } +} + +#else +/* OS_PUTENV -- Set the value of the named environment variable. + */ +void +os_putenv ( + char *name, + char *value +) +{ + XCHAR x_name[SZ_FNAME+1]; + XCHAR x_value[SZ_VALUE+1]; + char buf[SZ_VALUE], *env; + extern void ENVRESET(); + + + /* Set the VOS environment. */ + os_strupk (name, x_name, SZ_FNAME); + os_strupk (value, x_value, SZ_VALUE); + ENVRESET (x_name, x_value); + + /* Set the HOST environment. */ + sprintf (buf, "%s=%s", name, value); + if ( (env = (char *) malloc (strlen(buf) + 1)) ) { + strcpy (env, buf); +#ifdef ultrix + putenv (env); +#else +#ifdef vax + setenv (name, value, 1); +#else + putenv (env); /* must keep env around. */ +#endif +#endif + } +} +#endif diff --git a/unix/boot/bootlib/osread.c b/unix/boot/bootlib/osread.c new file mode 100644 index 00000000..b7d731d2 --- /dev/null +++ b/unix/boot/bootlib/osread.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + + +/* OS_READ -- Read from a disk file. We can use the UNIX procedures for + * reading both binary and text files. + */ +int +os_read ( + int fd, /* input file */ + char *buf, /* output buffer */ + int nbytes /* max bytes to read */ +) +{ + return (read (fd, buf, nbytes)); +} diff --git a/unix/boot/bootlib/ossetfmode.c b/unix/boot/bootlib/ossetfmode.c new file mode 100644 index 00000000..be2f7c5f --- /dev/null +++ b/unix/boot/bootlib/ossetfmode.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + + +/* OS_SETFMODE -- Set the file mode bits. This is an important function on + * any system and should be implemented. + */ +int +os_setfmode ( + char *fname, + int mode +) +{ + return (chmod (vfn2osfn(fname,0), mode)); +} diff --git a/unix/boot/bootlib/ossetowner.c b/unix/boot/bootlib/ossetowner.c new file mode 100644 index 00000000..e6d78261 --- /dev/null +++ b/unix/boot/bootlib/ossetowner.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + +/* OS_SETOWNER -- Set the user and group identifications for the file. This is + * not a required function and is expected to rarely work when transporting + * files to a host at a different site. Nonetheless it is useful when moving + * files between compatible hosts at a single site, so we make use of it in + * case it works. + */ +int +os_setowner ( + char *fname, + int uid, + int gid +) +{ + return (chown (vfn2osfn(fname,0), uid, gid)); +} diff --git a/unix/boot/bootlib/ossettime.c b/unix/boot/bootlib/ossettime.c new file mode 100644 index 00000000..4c7d8694 --- /dev/null +++ b/unix/boot/bootlib/ossettime.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + + +/* OS_SETMTIME -- Set the modification (update) time of a file. Should only + * be called when the named file is closed. This is a desirable but + * nonessential function to implement. + */ +int +os_setmtime ( + char *fname, + long mtime +) +{ + struct timeval tvp[2]; + + tvp[0].tv_sec = tvp[1].tv_sec = mtime; + tvp[0].tv_usec = tvp[1].tv_usec = 0L; + + return (utimes (vfn2osfn(fname,0), tvp)); +} diff --git a/unix/boot/bootlib/osstrpak.c b/unix/boot/bootlib/osstrpak.c new file mode 100644 index 00000000..01b6cf1a --- /dev/null +++ b/unix/boot/bootlib/osstrpak.c @@ -0,0 +1,34 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#include + + +/* OS_STRPAK -- Pack an SPP string (type XCHAR) into a C string in a user + * supplied buffer. Return a pointer to the output buffer. + * + * N.B.: This routine should be used in preference to STRPAK in C code + * since the output string is of type char*, rather than XCHAR*. + */ +char * +os_strpak ( + XCHAR *sppstr, /* SPP string */ + char *cstr, /* C string */ + int maxch /* max chars out, excl EOS */ +) +{ + register XCHAR *ip = sppstr; + register char *op = cstr; + register int n = maxch; + + + while ( (*op++ = *ip++) ) { + if (--n <= 0) { + *op = EOS; + break; + } + } + + return (cstr); +} diff --git a/unix/boot/bootlib/osstrupk.c b/unix/boot/bootlib/osstrupk.c new file mode 100644 index 00000000..e0617089 --- /dev/null +++ b/unix/boot/bootlib/osstrupk.c @@ -0,0 +1,44 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#include +#define import_spp +#include + +/* OS_STRUPK -- Unpack a C string into an SPP string. This procedure should + * be called from C in preference to the SPP procedure STRUPK because the + * input string is declared to be of type char, rather than as an XCHAR + * array containing packed chars as in STRUPK. The output string is however + * of type XCHAR since it is expected to be passed to an SPP procedure. A + * pointer to the output string is returned as the function value for use + * in argument lists. + */ +XCHAR * +os_strupk ( + char *str, /* C string */ + XCHAR *outstr, /* SPP string */ + int maxch /* max chars out, excl EOS */ +) +{ + register char *ip = str; + register XCHAR *op = outstr; + register int n = maxch; + + + /* Is is necessary to determine the length of the string in order to + * be able to unpack the string in place, i.e., from right to left. + */ + if (maxch) { + if (sizeof(char) != sizeof(XCHAR) || str != (char *)outstr) { + n = min (n, strlen(ip)); + op[n] = XEOS; + + while (--n >= 0) + op[n] = ip[n]; + } + } + + return (outstr); +} diff --git a/unix/boot/bootlib/ossubdir.c b/unix/boot/bootlib/ossubdir.c new file mode 100644 index 00000000..4330aaad --- /dev/null +++ b/unix/boot/bootlib/ossubdir.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "bootlib.h" + + +/* OS_SUBDIR -- Fold a subdirectory name into a directory pathname and return + * a pointer to the pathname of the subdirectory. + */ +char * +os_subdir ( + char *dir, /* OS pathname of directory */ + char *subdir /* name of subdirectory */ +) +{ + static XCHAR x_path[SZ_PATHNAME+1]; + XCHAR x_subdir[SZ_FNAME+1]; + XINT x_maxch = SZ_PATHNAME, x_nchars; + extern int ZFSUBD(); + + + os_strupk (dir, x_path, SZ_PATHNAME); + os_strupk (subdir, x_subdir, SZ_FNAME); + + ZFSUBD (x_path, &x_maxch, x_subdir, &x_nchars); + + if (x_nchars > 0) + return (os_strpak (x_path, (char *)x_path, SZ_PATHNAME)); + else + return (NULL); +} diff --git a/unix/boot/bootlib/ossymlink.c b/unix/boot/bootlib/ossymlink.c new file mode 100644 index 00000000..991b8359 --- /dev/null +++ b/unix/boot/bootlib/ossymlink.c @@ -0,0 +1,35 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#ifndef VMS +#include +#include +#endif + +/* OS_SYMLINK -- Determine if a file is a symbolic link. + */ +int +os_symlink ( + char *fname, /* file to be tested */ + char *valbuf, /* buffer to receive link path, else NULL */ + int maxch +) +{ +#ifndef VMS + struct stat fi; + int n; + + if (lstat (fname, &fi) == 0) + if ((fi.st_mode & S_IFMT) == S_IFLNK) { + if (valbuf && maxch) + if ((n = readlink (fname, valbuf, maxch)) > 0) + valbuf[n] = '\0'; + return (1); + } +#endif + + return (0); +} diff --git a/unix/boot/bootlib/ossysfile.c b/unix/boot/bootlib/ossysfile.c new file mode 100644 index 00000000..2d4f23be --- /dev/null +++ b/unix/boot/bootlib/ossysfile.c @@ -0,0 +1,113 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + +/* Uncomment the following if the kernel for this machine does not need + * or provide its own custom irafpath function, used if it can not be easily + * determine in advance what directories need to be searched. + */ +/* #define STANDALONE */ + +#ifdef STANDALONE +#define irafpath os_irafpath +#endif + +char *irafpath(); +char *os_getenv(); +extern int os_access (char *fname, int mode, int type); + + +/* OS_SYSFILE -- Return the pathname of a system library file. The library + * search order is + * + * IRAFULIB libraries, if any + * HSI system libraries (lib, hlib, hbin, etc.) + * pkglibs applications libraries, if any + * + * Hence, the IRAFULIB mechanism may be used to make use of custom copies + * of system files (libraries or global include files), whereas the `pkglibs' + * mechanism is provided to extend the system library search path to include + * applications specified libraries. These are intended to be the global + * libraries of installed layered packages, rather than private user libraries + * (the IRAFULIB mechanism is better for the latter). + */ +int +os_sysfile ( + char *sysfile, /* filename from include statement */ + char *fname, /* receives filename */ + int maxch +) +{ + register char *ip, *op; + char *files, *ip_save; + + + /* Search the standard system libraries and exit if the named + * file is found. + */ + strncpy (fname, irafpath(sysfile), maxch); + fname[maxch-1] = EOS; + if (strcmp (fname, sysfile) != 0) + return (strlen (fname)); + + /* Search the designated package libraries, if any. + */ + if ( (files = os_getenv ("pkglibs")) ) { + for (ip=files; *ip; ) { + /* Get the next library name from the list. */ + while (isspace(*ip) || *ip == ',') + ip++; + for (op=fname; *ip && !isspace(*ip) && *ip != ','; op++) + *op = *ip++; + *op = EOS; + + /* Append the target filename. */ + for (ip_save=ip, (ip=sysfile); (*op++ = *ip++); ) + ; + ip = ip_save; + + /* Exit if the file exists. */ + if (os_access (fname, 0, 0)) + return (strlen (fname)); + } + } + + return (ERR); +} + + +#ifdef STANDALONE +static char *libs[] = { "iraf$lib/", "host$hlib/", "" }; + +/* OS_IRAFPATH -- Portable version of the kernel irafpath() function, used + * if only the standard directories LIB and HLIB need to be searched. + */ +char * +os_irafpath (sysfile) +char *sysfile; /* filename from include statement */ +{ + register char *ip, *op; + register int n; + static char outfname[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + int i; + + strcpy (outfname, sysfile); + + for (i=0; libs[i][0] != EOS; i++) { + strcpy (fname, libs[i]); + strcat (fname, sysfile); + if (os_access (fname, 0,0) == YES) { + n = SZ_PATHNAME; + for (ip=fname, op=outfname; --n >= 0 && (*op = *ip++); op++) + ; + *op = EOS; + break; + } + } + + return (outfname); +} +#endif diff --git a/unix/boot/bootlib/ostime.c b/unix/boot/bootlib/ostime.c new file mode 100644 index 00000000..8ae97df7 --- /dev/null +++ b/unix/boot/bootlib/ostime.c @@ -0,0 +1,113 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#ifdef SYSV +#include +#else +#include +#include +#endif + +#ifdef MACOSX +#include +#endif + +#define SECONDS_1970_TO_1980 315532800L +static long os_timezone(); + + +/* OS_UTIME -- Convert IRAF time (local standard, epoch 1980) to UNIX time + * (greenwich mean time, epoch 1970). [MACHDEP] + * + * NOTE: If this is difficult to implement on your system, you can probably + * forget about the correction to Greenwich (e.g., 7 hours) and that for + * daylight savings time (1 hour), and file times will come out a bit off + * but it probably won't matter. + */ +long +os_utime (long iraf_time) +{ + struct tm *localtime(); + time_t time_var, lst; +#ifdef AUX + long lstl; +#endif + + lst = (time_t)iraf_time; + + /* Add minutes westward from GMT */ + time_var = lst + os_timezone(); + + /* Correct for daylight savings time, if in effect */ +#ifdef AUX + lstl = (long)lst; + if (localtime(&lstl)->tm_isdst) +#else + if (localtime(&lst)->tm_isdst) +#endif + time_var += 60L * 60L; + + return ((long)time_var + SECONDS_1970_TO_1980); +} + + +/* OS_ITIME -- Convert UNIX time (gmt, epoch 1970) to IRAF time (lst, epoch + * 1980). [MACHDEP] + */ +long +os_itime (long unix_time) +{ + struct tm *localtime(); + time_t time_var, gmt; +#ifdef AUX + long gmtl; +#endif + + gmt = (time_t)unix_time; + + /* Subtract minutes westward from GMT */ + time_var = gmt - os_timezone(); + + /* Correct for daylight savings time, if in effect */ +#ifdef AUX + gmtl = (long)gmt; + if (localtime(&gmtl)->tm_isdst) +#else + if (localtime(&gmt)->tm_isdst) +#endif + time_var -= 60L * 60L; + + return ((long)time_var - SECONDS_1970_TO_1980); +} + + +/* OS_GTIMEZONE -- Get the local timezone, measured in seconds westward + * from Greenwich, ignoring daylight savings time if in effect. + */ +static long +os_timezone() +{ +#ifdef CYGWIN + extern long _timezone; + return (_timezone); +#else +#if defined(SOLARIS) && defined(X86) + extern long timezone; + return (timezone); + +#else +#if defined(SYSV) || defined(MACOSX) + struct tm *tm; + time_t clock; + clock = time(NULL); + tm = gmtime (&clock); + return (-(tm->tm_gmtoff)); +#else + struct timeb time_info; + ftime (&time_info); + return (time_info.timezone * 60); +#endif +#endif +#endif +} diff --git a/unix/boot/bootlib/oswrite.c b/unix/boot/bootlib/oswrite.c new file mode 100644 index 00000000..3c59f8cd --- /dev/null +++ b/unix/boot/bootlib/oswrite.c @@ -0,0 +1,49 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "bootlib.h" + +/* OS_WRITE -- Write to the output file. If the output file is a text file + * we must convert the binary input (text) stream to the record structured + * stream required by the host. + */ +int +os_write ( + int fd, /* output file */ + char *buf, /* data to be written */ + int nbytes /* num bytes to be written */ +) +{ + register char *ip; + register XCHAR *op, *otop; + register int ch, n; + XINT nchars, status, xfd=fd; + extern int ZPUTTX(); + + + if (osfiletype == BINARY_FILE) + return (write (fd, buf, nbytes)); + + n = nbytes; + ip = buf; + op = txop; + otop = &text[SZ_FBUF]; + + /* Accumulate an output line of text and pass it on to the system when + * newline is seen or when the output buffer fills (unlikely). + */ + while (--n >= 0) { + *op++ = ch = *ip++; + if (ch == '\n' || op >= otop) { + nchars = op - text; + ZPUTTX (&xfd, text, &nchars, &status); + op = txop = text; + if (status == XERR) + return (ERR); + } + } + + txop = op; + return (nbytes); +} diff --git a/unix/boot/bootlib/rindex.c b/unix/boot/bootlib/rindex.c new file mode 100644 index 00000000..9a2a99f2 --- /dev/null +++ b/unix/boot/bootlib/rindex.c @@ -0,0 +1,33 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#ifdef LINUX +#define NOINDEX +#endif +#ifdef MACOSX +/* The following effectively disables the local version. */ +#define rindex strrindex +#endif + +#ifndef NOINDEX + +/* RINDEX -- Return pointer to the last occurrence of a character in a string, + * or null if the char is not found. + */ +char * +rindex (str, ch) +char *str; +register int ch; +{ + register char *ip; + register int cch; + char *last; + + for (ip=str, last=0; (cch = *ip); ip++) + if (cch == ch) + last = ip; + + return (last); +} + +#endif diff --git a/unix/boot/bootlib/tape.c b/unix/boot/bootlib/tape.c new file mode 100644 index 00000000..6d949f72 --- /dev/null +++ b/unix/boot/bootlib/tape.c @@ -0,0 +1,271 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define NOKNET +#define import_spp +#define import_finfo +#define import_knames +#include + +/* + * TAPE.C -- Generalized binary file i/o to a tape drive or other devices. + * + * fd = tape_open (fname, mode) + * tape_close (fd) + * nb = tape_read (fd, buf, maxbytes) + * nb = tape_write (fd, buf, nbytes) + * + * Only one "tape" file can be open at a time (unless all open files are of + * the same type). Since we call ZZRDMT and ZZWRMT directly, only blocked + * output is permitted (there is no internal buffering). Only sequential + * output is permitted to disk (there is no seek entry point). + * + * NOTE - For the IRAF V2.10 version of this utility, only host device names + * are permitted. The IRAF device names "mta", "mtb", etc are not supported + * as the tapefile file is not read. + */ + +#define TF_STDIN 0 +#define TF_STDOUT 1 +#define TF_BINARY 2 +#define TF_TAPE 3 + +#define R 0 +#define W 1 +#define RW 2 + +/* Tape position structure (V2.10). */ +struct mtpos { + int filno; /* current file (1=first) */ + int recno; /* current record (1=first) */ + int nfiles; /* number of files on tape */ + int tapeused; /* total tape used (Kb) */ + int pflags; /* i/o status bitflags (output) */ +}; + +/* MTPOS bitflags. */ +#define MF_ERR 0001 /* i/o error occurred in last operation */ +#define MF_EOF 0002 /* a tape mark was seen in the last operation */ +#define MF_EOT 0004 /* end of tape seen in the last operation */ +#define MF_EOR 0010 /* a record advance occurred in the last operation */ + +static int ftype; +static XINT acmode; +static int ateof; +static XLONG offset = 0; + +static int os_mtname (char *fname, char *osdev); + +extern int ZZOPMT(), ZOPNBF(), ZCLSBF(), ZZCLMT(); +extern int ZARDBF(), ZAWTBF(), ZZRDMT(), ZZWTMT(), ZAWRBF(), ZZWRMT(); + + + +/* TAPE_OPEN -- Open the named file, which need not actually be a tape device. + */ +int +tape_open ( + char *fname, /* file or device to be opened */ + int mode /* access mode */ +) +{ + PKCHAR osfn[SZ_PATHNAME+1]; + XINT chan; + extern char *vfn2osfn(); + + + if (strcmp (fname, "stdin") == 0) { + ftype = TF_STDIN; + if (mode != R) + chan = ERR; + else + chan = 1; /* arbitrary */ + + } else if (strcmp (fname, "stdout") == 0) { + ftype = TF_STDOUT; + if (mode != W) + chan = ERR; + else + chan = 1; /* arbitrary */ + + } else if (os_mtname (fname, (char *)osfn)) { + /* Open a magtape device. Only host device names are permitted. + * Try to open without moving the tape (newfile=0). + */ + register int *op; + struct mtpos devpos; + int nwords = sizeof(devpos) / sizeof(int); + XINT newfile = 0; + char *tapecap = ":np"; + + for (op = (int *)&devpos; --nwords >= 0; ) + *op++ = 0; + ftype = TF_TAPE; + if (mode == R) + acmode = READ_ONLY; + else + acmode = WRITE_ONLY; + + ZZOPMT (osfn, &acmode, (PKCHAR *)tapecap, (XINT *)&devpos, + &newfile, &chan); + + } else { + /* Open a binary disk file. + */ + ftype = TF_BINARY; + offset = 1; + + strcpy ((char *)osfn, vfn2osfn (fname, 0)); + if (mode == R) + acmode = READ_ONLY; + else if (mode == W) + acmode = NEW_FILE; + else + acmode = READ_WRITE; + + ZOPNBF (osfn, &acmode, &chan); + } + + ateof = 0; + + return (chan == XERR ? ERR : chan); +} + + +/* TAPE_CLOSE -- Close a file opened with tape_open. + */ +int +tape_close (int fd) +{ + struct mtpos devpos; + XINT x_fd=fd, status; + + if (ftype == TF_BINARY) + ZCLSBF (&x_fd, &status); + else if (ftype == TF_TAPE) + ZZCLMT (&x_fd, (XINT *)&devpos, &status); + else + status = XOK; + + return (status == XERR ? ERR : OK); +} + + +/* TAPE_READ -- Read from a file opened with tape_open. + */ +int +tape_read ( + int fd, /* input file */ + char *buf, /* output buffer */ + int maxbytes /* max bytes to read */ +) +{ + struct mtpos devpos; + XINT x_fd=fd, x_maxbytes=maxbytes, status; + + if (ateof) + return (0); + + if (ftype == TF_STDIN) { + status = read (0, buf, maxbytes); + } else if (ftype == TF_BINARY) { + ZARDBF (&x_fd, (XCHAR *)buf, &x_maxbytes, &offset); + ZAWTBF (&x_fd, &status); + if (status > 0) + offset += status; + } else if (ftype == TF_TAPE){ + ZZRDMT (&x_fd, (XCHAR *)buf, &x_maxbytes, &offset); + ZZWTMT (&x_fd, (XINT *)&devpos, &status); + if (devpos.pflags & MF_EOF) + ateof++; + } else + status = XERR; + + return (status == XERR ? ERR : status); +} + + +/* TAPE_WRITE -- Write to a file opened with tape_open. + */ +int +tape_write ( + int fd, /* output file */ + char *buf, /* input bufferr */ + int nbytes /* nbytes to write */ +) +{ + struct mtpos devpos; + XINT x_fd=fd, x_nbytes=nbytes, status; + + if (ftype == TF_STDOUT) { + status = write (1, buf, nbytes); + } else if (ftype == TF_BINARY) { + ZAWRBF (&x_fd, (XCHAR *)buf, &x_nbytes, &offset); + ZAWTBF (&x_fd, &status); + if (status > 0) + offset += status; + } else if (ftype == TF_TAPE) { + ZZWRMT (&x_fd, (XCHAR *)buf, &x_nbytes, &offset); + ZZWTMT (&x_fd, (XINT *)&devpos, &status); + } else + status = XERR; + + return (status == XERR ? ERR : status); +} + + +/* OS_MTNAME -- Parse a filename to determine if the file is a magtape + * device or something else. A nonzero return indicates that the device + * is a tape. + */ +static int +os_mtname ( + char *fname, /* filename e.g., "foo.tar" or "mua0:". */ + char *osdev /* receives host system drive name */ +) +{ +#ifdef VMS + register char *ip; + char drive[SZ_FNAME+1]; +#endif + + /* Ignore any "mt." prefix. This is for backwards compatibility, + * to permit old-style names like "mt.MUA0:". + */ + if (!strncmp (fname, "mt.", 3) || !strncmp (fname, "MT.", 3)) + fname += 3; + +#ifdef VMS + /* Resolve a possible logical device name. */ + if (strchr (fname, '[')) + strcpy (drive, fname); + else + _tranlog (fname, drive); + + /* If the resolved name ends with a colon it is a device name, + * which we assume to be a tape device. + */ + for (ip=drive; *ip; ip++) + ; + if (*(ip-1) == ':') { + strcpy (osdev, drive); + return (1); + } +#else + /* For unix systems we assume anything beginning with /dev is a + * tape device. + */ + if (strncmp (fname, "/dev/", 5) == 0) { + strcpy (osdev, fname); + return (1); + } +#endif + + strcpy (osdev, fname); + return (0); +} diff --git a/unix/boot/bootlib/vfn2osfn.c b/unix/boot/bootlib/vfn2osfn.c new file mode 100644 index 00000000..c93d2090 --- /dev/null +++ b/unix/boot/bootlib/vfn2osfn.c @@ -0,0 +1,147 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define NOLIBCNAMES +#define import_spp +#define import_libc +#define import_xnames +#define import_knames +#include + +#define FINIT +#include "bootlib.h" + +static PKCHAR pk_osfn[SZ_PATHNAME+1]; +static char *osfn = (char *)pk_osfn; +extern char *os_getenv(); + + +#ifdef NOVOS + +/* VFN2OSFN -- Map an IRAF virtual filename into an OS filename. This is + * a simplified version for UNIX which does not use the VOS. This version + * should also be almost sufficient to compile the system libraries when + * starting from scratch on a new machine, since the filenames in the system + * directories are simple and the full generality of the FIO filename mapping + * code is not required (extension mapping is about all that is required). + * Only the well-known system logical directories are recognized in this + * version, however ZGTENV is called to replace logical directories, and + * this in turn references the host system environment, so one can bootstrap + * things by using the host environment facilities. + */ +char * +vfn2osfn ( + char *vfn, /* input IRAF virtual filename */ + int new /* new file */ +) +{ + register char *ip, *op; + char fname[SZ_PATHNAME+1], *ldir; + + /* Recursively expand logical directories, but don't do anything + * about subdirectories, extensions, etc. This is all that is + * needed for UNIX. + */ + for (ip=vfn, op=fname; (*op = *ip++); op++) + if (*op == '$') { + *op = EOS; + if ( (ldir = os_getenv (fname)) ) + strcpy (fname, ldir); + strcat (fname, ip); + return (vfn2osfn (fname, 0)); + } + + /* Copy filename to the output string. Fix up the "//" sequences + * that occur because IRAF likes the / at the end of logical directory + * names. + */ + for (ip=fname, op=osfn; (*op = *ip++); op++) + if (*op == '/' && op > osfn && *(op-1) == '/') + --op; + + return (osfn); +} + + +#else + +/* VFN2OSFN -- Map an IRAF virtual filename into an OS filename. This is + * the portable version using the VOS (libsys.a+libvops.a+libos.a) to do the + * mapping. The system libraries must have been built before we can do this, + * of course. + */ +char * +vfn2osfn ( + char *vfn, /* input IRAF virtual filename */ + int new /* new file */ +) +{ + register char *ip; + register XCHAR *op; + register int n = SZ_PATHNAME; + XINT vp, mode, maxch = SZ_PATHNAME; + PKCHAR upkvfn[SZ_PATHNAME+1]; + int err; + + extern void _envinit(); + + + + /* Copy the input filename into local storage before calling envinit, + * below, to avoid any chance of overwriting the input string in a + * recursive call to vfn2osfn by envinit. + */ + for (ip=vfn, op=upkvfn; --n >= 0 && (*op++ = *ip++) != (XCHAR)EOS; ) + ; + *(op-1) = XEOS; + mode = new ? VFN_WRITE : VFN_READ; + + /* Nasty beast that can call vsn2osfn recursively. */ + _envinit(); + + err = 0; + iferr (vp = VFNOPEN (upkvfn, (integer *)&mode)) { + fprintf (stderr, "Warning: cannot open vfn `%s' for %s\n", + vfn, mode == VFN_WRITE ? "writing" : "reading"); + err++; + } + + if (new) { + if (!err) + iferr (VFNADD ((integer *)&vp, pk_osfn, (integer *)&maxch)) + fprintf (stderr, "Warning: cannot add filename `%s'\n",vfn); + } else { + if (!err) + iferr (VFNMAP ((integer *)&vp, pk_osfn, (integer *)&maxch)) + fprintf (stderr, "Warning: cannot map filename `%s'\n",vfn); + } + + mode = (mode == VFN_WRITE) ? VFN_UPDATE : VFN_NOUPDATE; + if (!err) { + iferr (VFNCLOSE ((integer *)&vp, (integer *)&mode)) + fprintf (stderr, "Warning: error closing mapping file\n"); + } else + *osfn = EOS; + + return (osfn); +} + + +/* + * KISTUB -- Stub out selected KI (kernel network interface) routines. This + * is done when VOS filename mapping is in use to avoid linking in a lot of + * objects that will never be used, since the HSI does not use networking. + */ +int KI_GETHOSTS() { return (0); } +void KI_SEND(){} +void KI_RECEIVE(){} +#endif + +#ifdef SUNOS +/* Stub out the following too, since there is no floating point in the HSI. */ +ieee_flags(){} +ieee_handler(){} +abrupt_underflow_(){} +#endif diff --git a/unix/boot/generic.new/README b/unix/boot/generic.new/README new file mode 100644 index 00000000..98a1d23a --- /dev/null +++ b/unix/boot/generic.new/README @@ -0,0 +1,3 @@ +GENERIC -- The generic preprocessor is a simple task used to process generic + code into type specific code. A different copy of the code is output + for each datatype. diff --git a/unix/boot/generic.new/chario.c b/unix/boot/generic.new/chario.c new file mode 100644 index 00000000..09b46e40 --- /dev/null +++ b/unix/boot/generic.new/chario.c @@ -0,0 +1,188 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + + +/* + * OS Character I/O. This set of routines are provided as a workaround in + * the event that the host system cannot execute FTELL/FSEEK reliably (VMS/C + * could not). The idea here is to keep track of the character offset from + * the beginning of the file. K_FTELL returns the character offset. K_FSEEK + * rewinds the file and reads characters forward to the indicated offset. + * K_GETC keeps a count of the file position. (the k_ stands for kludge). + */ + +extern int debug; + +struct context { + FILE *fp; /* file descriptor */ + long fpos; /* saved file pointer */ + char fname[512]; /* file being scanned */ +}; + +FILE * +k_fopen (fname, mode) +char *fname; +char *mode; +{ + register struct context *cx; + register FILE *fp; + + if ((fp = fopen (fname, mode)) == NULL) + return (NULL); + + cx = (struct context *) malloc (sizeof(struct context)); + strcpy (cx->fname, fname); + cx->fpos = 0; + cx->fp = fp; + + return ((FILE *)cx); +} + + +int +k_fclose (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + int status; + + status = fclose (cx->fp); + free (cx); + + return (status); +} + +#ifdef vms + +int +k_getc (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + register int ch; + + cx->fpos++; + if (debug > 3) { + if ((ch = getc (cx->fp)) > 0) + printf ("%5d %03o %c\n", cx->fpos, ch, ch > 040 ? ch : 040); + return (ch); + } else + return (getc (cx->fp)); +} + +char * +k_fgets (obuf, maxch, cx_i) +char *obuf; +int maxch; +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + register int ch, n; + register char *op; + + for (op=obuf, n=maxch; --n >= 0; ) + if ((ch = k_getc(cx)) < 0) + return (NULL); + else { + *op++ = ch; + if (ch == '\n') + break; + } + + return (obuf); +} + +seek +k_fseek (cx_i, offset, type) +FILE *cx_i; +long offset; +int type; +{ + register struct context *cx = (struct context *)cx_i; + register FILE *fp = cx->fp; + register int ch; + + if (debug > 1) + printf ("seek (%s, %ld, %d)\n", cx->fname, offset, type); + + if (type == 0) { + fseek (fp, 0L, 0); + cx->fpos = 0; + + while (cx->fpos < offset && (ch = getc(fp)) != EOF) { + if (debug > 1) + fputc (ch, stdout); + cx->fpos++; + } + + if (debug > 1) + printf ("[]\n"); + + return (0); + } + + if (fseek (fp, offset, type) == -1) + return (-1); + else { + cx->fpos = ftell (fp); + return (0); + } +} + +long +k_ftell (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + + if (debug > 1) { + printf ("ftell returns %d\n", cx->fpos); + fflush (stdout); + } + + return (cx->fpos); +} + +#else + +int +k_getc (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + return (getc (cx->fp)); +} + +char * +k_fgets (op, maxch, cx_i) +char *op; +int maxch; +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + return (fgets (op, maxch, cx->fp)); +} + +int +k_fseek (cx_i, offset, type) +FILE *cx_i; +long offset; +int type; +{ + register struct context *cx = (struct context *)cx_i; + return (fseek (cx->fp, offset, type)); +} + +int +k_ftell (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + return (ftell (cx->fp)); +} + +#endif diff --git a/unix/boot/generic.new/chario.o b/unix/boot/generic.new/chario.o new file mode 100644 index 00000000..33fd2d1d Binary files /dev/null and b/unix/boot/generic.new/chario.o differ diff --git a/unix/boot/generic.new/generic.c b/unix/boot/generic.new/generic.c new file mode 100644 index 00000000..07d19885 --- /dev/null +++ b/unix/boot/generic.new/generic.c @@ -0,0 +1,892 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#define import_spp +#include + +/* + * GENERIC -- This filter takes a file containing a generic operator as input + * and generates as output either a set of files, one for each of the data + * types in the generic family, or a single file wherein the generic section + * has been duplicated for each case. + */ + +#define input lex_input +#define unput lex_unput +extern char yytext[]; +extern int yyleng; +extern FILE *yyin; +extern FILE *yyout; + +#define MAXFILES 512 +#define MAXNEST 50 +#define OK 0 +#define SZ_FORSTK 20 + +/* $FOR contstruct descriptor. + */ +struct _for { + char f_prevtype; /* type before $for */ + char f_types[20]; /* "csilrdx" */ + char *f_curtype; /* pointer into f_types */ + long f_fpos; /* seek offset of $FOR */ +}; + +struct _for forstk[SZ_FORSTK]; +int forlev; +char *type_string; +char xtype_string[SZ_FNAME+1]; +char type_char; +int pass_output = 1; +int clobber = NO; + +extern long k_ftell (FILE *cx_i); +extern FILE *k_fopen (char *fname, char *mode); +extern int k_fseek (FILE *cx_i, long offset, int type); +extern int k_fclose (FILE *cx_i); + +extern int yylex (void); +extern int lex_input (void); +extern void lex_unput (int ch); + + +char *make_typed_filename (char *template, char type_char); +void set_type_string (char ch); +void copy_line (void); +void copy_string (void); +void copy_comment (void); +void make_float (char type_ch); +void output_indef (char ch); +void output_upper (char *s); +void pass_through (void); +void do_for (void); +void do_endfor (void); +void do_if (void); +void do_else (void); +void do_endif (void); + +int evaluate_expr (void); +int parse_relational (int *size1, int *size2, int *op); + +int relop (void); +int gsize (char ch); +char nextch (void); +char gch (void); +void uch (char ch); + +void output (char ch); +void outstr (char *s); + + + + +/** + * GENERIC: e.g., generic [-k] [-t csilrdx] file + */ +int main (int argc, char *argv[]) +{ + char *files[MAXFILES], *s, **p, *ip; + char fname[SZ_FNAME], *extension; + char *types = "i", *t; + char *prefix = ""; + char genfname[SZ_FNAME+1]; + char template[SZ_FNAME+1]; + char input_file[SZ_FNAME+1]; + char *index(), *rindex(); + int n, nfiles; + FILE *fp; + + genfname[0] = EOS; + nfiles = 0; + + for (p = &argv[1]; *p != NULL; p++) { + s = *p; + if (s[0] == '-') { + switch (s[1]) { + case 'k': + clobber = YES; + break; + case 't': + if (*(p+1) != NULL) + types = *++p; + break; + case 'o': + if (*(p+1) != NULL) + strcpy (genfname, *++p); + break; + case 'p': + if (*(p+1) != NULL) + prefix = *++p; + break; + } + } else { + files[nfiles++] = s; + if (genfname[0] != EOS && nfiles > 1) { + fprintf (stderr, + "Cannot process multiple files with '-o' flag\n"); + exit (OSOK+1); + } + } + } + + for (n=0; n < nfiles; n++) { + strcpy (input_file, files[n]); + yyin = k_fopen (input_file, "r"); + if (yyin == NULL) { + fprintf (stderr, "Cannot open input file '%s'\n", input_file); + continue; + } + + /* Set pointer to the filename extension string. If the file name + * has an extension, lop it off by overwriting the '.' with EOS. + * The first character of the extension of a generic file is + * normally a 'g', e.g., ".gx" or ".gc", but we want to generate + * a ".x" or ".c" file, so lop off any leading g in the extension. + */ + if ((extension = rindex (input_file, '.')) != NULL) { + *extension++ = EOS; + if (*extension == 'g') + extension++; + } else + extension = ""; + + for (t=types; *t != EOS; t++) { + /* Make output file name */ + strcpy (fname, prefix); + + /* Expand a template of the form "chars$tchars" into the root + * name of the new file, replacing the $t by the type char. + * If using input filename as the root, add "$t"; otherwise, + * check whether or not the generic filename string has a + * "$t" in it, and add one at end if it does not. + */ + if (genfname[0] == EOS) { + strcpy (template, input_file); + strcat (template, "$t"); + + } else { + strcpy (template, genfname); + + for (ip=index(genfname,'$'); ip != NULL; + ip = index(ip,'$')) { + + if (*(ip+1) == '$') + ip += 2; + else if (*(ip+1) == 't') + break; + } + + if (ip == NULL && strlen(types) > 1) + strcat (ip, "$t"); + } + + if (genfname[0] == EOS || strlen (types) > 1) + strcat (fname, make_typed_filename (template, *t)); + else + strcat (fname, template); + + /* If the user supplied the output filename template, we + * assume that it already contains an extension. + */ + if (genfname[0] == EOS) { + strcat (fname, "."); + strcat (fname, extension); + } + + if (access(fname,0) == 0) { + if (clobber == NO) { + fprintf (stderr, "File `%s' already exists\n", fname); + continue; + } else + unlink (fname); + } + if ((fp = fopen (fname, "w")) == NULL) { + fprintf (stderr, "Cannot open file `%s'\n", fname); + continue; + } + + yyout = fp; + set_type_string (*t); + type_char = *t; + forlev = -1; + + yylex(); /* do it */ + + fclose (fp); + k_fseek (yyin,0L,0); + } + + k_fclose (yyin); + } + + exit (OSOK); +} + + +/* MAKE_TYPED_FILENAME -- Make a copy of a filename string, substituting + * the given type suffix character for the every sequence "$t" found in the + * input string. The output string is retained in an internal static buffer. + * Any sequence "$$" is converted into a single "$". + */ +char * +make_typed_filename (char *template, char type_char) +{ + register char *ip, *op; + char ch; + static char fname[SZ_FNAME+1]; + + if (isupper (type_char)) + ch = tolower (type_char); + else + ch = type_char; + + for (ip=template, op=fname; *ip != EOS; ) + if (*ip == '$' && *(ip+1) == '$') { + *op++ = '$'; + ip += 2; + } else if (*ip == '$' && *(ip+1) == 't') { + *op++ = ch; + ip += 2; + } else + *op++ = *ip++; + + return (fname); +} + + +/* SET_TYPE_STRING -- Given the type suffix character, set the external + * array "type_string" to the name of the corresponding SPP datatype. + */ +void +set_type_string (char ch) +{ + char *ip, *op; + + switch (ch) { + case 'B': + type_string = "ubyte"; /* unsigned byte */ + break; + case 'U': + type_string = "ushort"; + break; + case 'b': + type_string = "bool"; + break; + case 'c': + type_string = "char"; + break; + case 's': + type_string = "short"; + break; + case 'i': + type_string = "int"; + break; + case 'l': + type_string = "long"; + break; + case 'r': + type_string = "real"; + break; + case 'd': + type_string = "double"; + break; + case 'x': + type_string = "complex"; + break; + case 'p': + type_string = "pointer"; + break; + default: + fprintf (stderr, "Unknown type suffix char `%c'\n", ch); + } + + op = xtype_string; + *op++ = 'X'; + for (ip=type_string; *ip != EOS; ip++) + *op++ = toupper (*ip); + *op++ = EOS; +} + + +/* COPY_LINE -- Output whatever is in the yylex token buffer, followed by the + * remainder of the line from which the token was extracted. + */ +void +copy_line (void) +{ + char ch; + + outstr(yytext); + while ((ch = input()) != '\n') + output(ch); + unput(ch); +} + + +/* COPY_STRING -- Called when the opening quote of a string is seen in the + * input. Copy the opening quote followed by all input characters until the + * end of string is seen. + */ +void +copy_string (void) +{ + char ch; + + outstr(yytext); + for (;;) { + switch (ch = input()) { + case '"': + output(ch); + return; + case '\\': + output(ch); + if ((ch = input()) != '\n') + output(ch); + else + unput(ch); + break; + case '\n': + unput(ch); + return; + default: + output(ch); + } + } +} + + +/* COPY_COMMENT -- Copy a C style comment to the output file. + */ +void +copy_comment (void) +{ + char ch; + int flag = 0; + + outstr (yytext); + + while ((ch = input()) != EOF) { + output (ch); + switch (ch) { + case '*': + flag = 1; + break; + case '/': + if (flag == 1) + return; + else + flag = 0; + break; + default: + flag = 0; + break; + } + } +} + + +/* MAKE_FLOAT -- Called when a n$f is seen in the input to convert a numeric + * constant to the form appropriate for the indicated datatype, e.g., "0", + * "0.", "0.0D0", etc. + */ +void +make_float (char type_ch) +{ + char *p; + + for (p=yytext; *p != '$'; p++) + ; + *p = EOS; + + if (type_ch == 'x') { + output ('('); + outstr (yytext); + outstr (".0,"); + outstr (yytext); + outstr (".0)"); + } else { + outstr (yytext); + switch (type_ch) { + case 'r': + outstr (".0"); + break; + case 'd': + outstr (".0D0"); + break; + } + } +} + + +/* OUTPUT_INDEF -- Output the INDEF string for the indicated datatype. + */ +void +output_indef (char ch) /* output INDEF, INDEFS, INDEFL, etc. */ +{ + outstr(yytext); + + switch (ch) { + case 's': + output ('S'); + break; + case 'i': + output ('I'); + break; + case 'l': + output ('L'); + break; + case 'r': + output ('R'); + break; + case 'd': + output ('D'); + break; + case 'x': + output ('X'); + break; + } +} + + +/* OUTPUT_UPPER -- Output the name of the current datatype (INT, REAL, etc.) + * in upper case. + */ +void +output_upper (char *s) +{ + char ch, *p; + + outstr(s); + for (p=type_string; (ch = *p) != EOS; p++) + output(toupper(ch)); +} + + +/* PASS_THROUGH -- Used to pass text on to the output without modification. + * The text is delimited as "$/ (text) /" in the input file. The delimited + * section may enclose newlines. + */ +void +pass_through (void) +{ + char ch; + + while ((ch = input()) != '/') + output(ch); +} + + +/* DO_FOR -- Process a "$FOR (types)" statement. The sequence of statements + * bracketed by $for ... $endfor will be processed and output (to a single + * output stream) for each datatype named in the for predicate. + */ +void +do_for (void) +{ + register char *op; + register int ch; + register struct _for *fp; + char types[20]; + + if (++forlev + 1 >= SZ_FORSTK) { + fprintf (stderr, "$for statements nested too deeply\n"); + exit (OSOK+1); + } + + /* Extract list of types. + */ + while ((ch = input()) != '(') + if (ch == EOF || ch == '\n') { + fprintf (stderr, "$for must have () delimited list of types\n"); + strcpy (types, "i"); + goto init_; + } + + for (op=types; (ch = input()) != ')'; op++) + if (ch == EOF || ch == '\n') { + fprintf (stderr, "missing right paren in $for statement\n"); + break; + } else + *op = ch; + + *op = EOS; + if (op == types) { + fprintf (stderr, "null typelist in $for statement\n"); + strcpy (types, "i"); + } + +init_: + fp = &forstk[forlev]; + fp->f_prevtype = type_char; + strcpy (fp->f_types, types); + fp->f_curtype = fp->f_types; + fp->f_fpos = k_ftell (yyin); + + type_char = *(fp->f_curtype)++; + set_type_string (type_char); +} + + +/* DO_ENDFOR -- Called to process a $ENDFOR. Set the next datatype and seek + * back to the line following the matching $FOR statement. When the type list + * is exhausted pop the $for stack and continue normal processing. + */ +void +do_endfor (void) +{ + register struct _for *fp; + + if (forlev < 0) { + fprintf (stderr, "$endfor with no matching $for\n"); + return; + } + + fp = &forstk[forlev]; + if ((type_char = *(fp->f_curtype)++) != EOS) { + set_type_string (type_char); + k_fseek (yyin, fp->f_fpos, 0); + } else { + type_char = fp->f_prevtype; + set_type_string (type_char); + --forlev; + } +} + + +/* + * Conditional Compilation + * ------------------------- + */ + +#define TRUE 1 +#define FALSE 0 +#define EQ 0 +#define NE 1 +#define LE 2 +#define LT 3 +#define GE 4 +#define GT 5 + +char expr_buf[80], *expr; +int level = 0; + +struct if_stack { + int oldstate; + int active; +} stk[MAXNEST]; + + +/* DO_IF -- Process a $IF statement. Evaluate the predicate and push a + * pass or stop output flag on the if stack. + */ +void +do_if (void) +{ + char ch; + int expr_value; + struct if_stack *p; + + level += 1; + p = &stk[level]; + p->oldstate = pass_output; + p->active = (pass_output == TRUE); + + if ((expr_value = evaluate_expr()) == ERR) + expr_value = FALSE; + + if ((ch = input()) != '\n') + unput(ch); + + if (p->active == FALSE) + return; + else if (expr_value == FALSE) + pass_output = FALSE; +} + + +/* DO_ELSE -- Process a $ELSE statement. Toggle the pass/stop output flag + * on top of the if stack. + */ +void +do_else (void) +{ + char ch; + + if (level == 0) + fprintf (stderr, "Unmatched $else statement\n"); + else if (stk[level].active) /* toggle pass_output */ + pass_output = (pass_output == FALSE); + + if ((ch = input()) != '\n') + unput(ch); +} + + +/* DO_ENDIF -- Process a $ENDIF statement. Pop the if stack. + */ +void +do_endif (void) /* $endif statement */ +{ + char ch; + + if (level == 0) + fprintf (stderr, "Too many $endif statements\n"); + else + pass_output = stk[level--].oldstate; + + if ((ch = input()) != '\n') + unput(ch); +} + + +/* EVALUATE_EXPR -- Kludge to evaluate boolean expressions in $if statements. + * Two kinds of expressions are permitted: (datatype relop chars), or + * (sizeof(char) relop sizeof(char)), where relop = (==, !=, <= etc.). + * + * Examples: $if (datatype != dx) + * (code to be compiled if type not d or x) + * + * $if (sizeof(i) <= sizeof(r)) + * (code to be compiled if size int <= real) + */ +int +evaluate_expr (void) +{ + char ch=0, *p, *index(); + int lpar, size1, size2, op; + + + /* Advance to start of expression (discard '(') */ + if (nextch() != '(') + goto err; + else + input(); + + /* Extract expression string into buffer */ + expr = expr_buf; + nextch(); + + for (p=expr_buf, lpar=1; lpar > 0 && (*p = input()) != EOF; p++) + switch (ch = *p) { + case '(': + lpar++; + break; + case ')': + if (--lpar == 0) + *p = EOS; + break; + case '\n': + goto err; + } + + /* Is current type in set or not in set */ + if (strncmp (expr,"datatype",8) == 0) { + expr += 8; + switch (relop()) { + case EQ: + return (index(expr,type_char) != NULL); + case NE: + return (index(expr,type_char) == NULL); + default: + goto err; + } + + /* Compare sizes of two data types */ + } else if (strncmp(expr,"sizeof",6) == 0) { + if (parse_relational (&size1, &size2, &op) == ERR) { + ch = 0; + goto err; + } + switch (op) { + case EQ: + return (size1 == size2); + case NE: + return (size1 != size2); + case LE: + return (size1 <= size2); + case LT: + return (size1 < size2); + case GE: + return (size1 >= size2); + case GT: + return (size1 > size2); + } + + /* only "type" and "sizeof" are implemented */ + } else { +err: fprintf (stderr, "Syntax error in $if statement\n"); + if (ch != '\n') { + /* skip rest of line */ + while ((ch = input()) != '\n') + ; + unput(ch); + } + } + + return (ERR); +} + + +/* PARSE_RELATIONAL -- Parse "sizeof(t1) relop sizeof(t2)" (via brute force...) */ +int +parse_relational (int *size1, int *size2, int *op) +{ + expr += 6; /* ... (t1) */ + + if (gch() != '(') + return (ERR); + if ((*size1 = gsize(gch())) == ERR) + return (ERR); + if (gch() != ')') + return (ERR); /* relop */ + if ((*op = relop()) == ERR) + return (ERR); + + uch (gch()); /* skip whitespace */ + + if (strncmp(expr,"sizeof",6) != 0) /* sizeof(t2) */ + return (ERR); + + expr += 6; + + if (gch() != '(') + return (ERR); + if ((*size2 = gsize(gch())) == ERR) + return (ERR); + if (gch() != ')') + return (ERR); + + return (OK); +} + + +/* RELOP -- Return a code for the next relational operator token in the input + * stream. + */ +int +relop (void) +{ + char ch; + + + switch (gch()) { + case '!': + if (gch() == '=') + return (NE); + return (ERR); + case '=': + if (gch() == '=') + return (EQ); + return (ERR); + case '<': + if ((ch = gch()) == '=') + return (LE); + uch(ch); + return (LT); + case '>': + if ((ch = gch()) == '=') + return (GE); + uch(ch); + return (GT); + default: + return (ERR); + } +} + + +/* GSIZE -- Return the size of a datatype given its character code. + */ +int +gsize (char ch) +{ + switch (ch) { + case 'B': + return (sizeof(XUBYTE)); + case 'U': + return (sizeof(XUSHORT)); + case 't': + return (gsize(type_char)); + case 'c': + return (sizeof(XCHAR)); + case 's': + return (sizeof(XSHORT)); + case 'i': + return (sizeof(XINT)); + case 'l': + return (sizeof(XLONG)); + case 'r': + return (sizeof(XREAL)); + case 'd': + return (sizeof(XDOUBLE)); + case 'x': + return (sizeof(XCOMPLEX)); + case 'p': + return (sizeof(XPOINTER)); + default: + return (ERR); + } +} + + +/* NEXTCH -- Advance to next non-whitespace character. + */ +char +nextch (void) +{ + char ch; + + for (ch=input(); ch == ' ' || ch == '\t'; ch=input()) + ; + unput (ch); + return (ch); +} + + +/* GCH -- Get next nonwhite char from expression buffer. + */ +char +gch (void) +{ + while (*expr == ' ' || *expr == '\t') + expr++; + + if (*expr != EOS) + return (*expr++); + else + return (EOS); +} + + +/* UCH -- Put char back into expression buffer. + */ +void +uch (char ch) +{ + *--expr = ch; +} + + +/* OUTPUT -- Write a single character to the output file, if output is + * currently enabled (else throw it away). + */ +void +output (char ch) +{ + if (pass_output) + putc (ch, yyout); +} + + +/* OUTSTR -- Output a string. + */ +void +outstr (char *s) +{ + if (pass_output) + fputs (s, yyout); +} diff --git a/unix/boot/generic.new/generic.e b/unix/boot/generic.new/generic.e new file mode 100755 index 00000000..dfab2707 Binary files /dev/null and b/unix/boot/generic.new/generic.e differ diff --git a/unix/boot/generic.new/generic.hlp b/unix/boot/generic.new/generic.hlp new file mode 100644 index 00000000..eda8ceb2 --- /dev/null +++ b/unix/boot/generic.new/generic.hlp @@ -0,0 +1,245 @@ +.help generic Feb86 softools +.ih +NAME +generic -- generic preprocessor +.ih +USAGE +generic [-k] [-o ofile] [-p prefix] [-t types] files +.ih +PARAMETERS +.ls 4 -k +Allow the output files generated by \fIgeneric\fR to clobber any existing +files. +.le +.ls 4 -o ofile +The name of the output file. If this option is selected, only a single +file can be processed. +.le +.ls 4 -p prefix +A prefix to be prepended to the output filenames. This is useful when +the output files are to be placed in a different directory. +.le +.ls 4 -t types +The datatypes for which output is desired. One output file will be generated +for each type specified, with \fIgeneric\fR automatically generating the +output filename by appending the type character to the root filename of +the input file. The \fItype\fR string is some subset of [ubscilrdx], +where the type characters are as follows. +.ls +.nf +u - C unsigned short +b - C byte (char) +c - SPP character +s - SPP short +i - SPP int +l - SPP long +r - SPP real +d - SPP double +x - SPP complex +.fi +.le + +This option cannot be used in combination with the -o option, and should +not be used when generic code is expanded inline, rather than written into +multiple output files. +.le +.ls 4 files +The input file or files to be processed. Generic input files should have +the extension ".gx" or ".gc", although this is not required. Only a single +input file can be given if the -o option is specified. +.le +.ih +DESCRIPTION +The generic preprocessor is used to translate generic source code (code +written to work for any datatype) into type dependent source code, +suitable for compilation and insertion into a library. The generic source +is translated for each datatype, producing a type dependent copy of the +source code for each datatype. There are two primary modes of operation: + +.ls +.ls [1] +The generic source is embedded in a normal file, bracketed by \fI$for\fR and +\fI$endfor\fR directives. There is one input file and one somewhat larger +output file, with the generic code in the input file being replaced in the +output file by several copies of the enclosed source, one for each datatype. +This mode is most commonly used for modules to be linked in their entirety +into an applications package. The "-o" parameter is used to specify +the output filename. +.le +.ls [2] +The entire input file is generic. There may be multiple input files, and +for each input file N output files are generated, one for each datatype +specified with the "-t" parameter. The output filenames are automatically +generated by appending the type character to the root filename of the +input file. This mode is most commonly used for object libraries. +.le +.le + + +The generic preprocessor operates by token replacement (currently using a +UNIX \fILex\fR lexical analyzer). The input stream is broken up into a +stream of tokens. Each token is examined to see if it is in the following +list, and the indicated action is taken if the token is matched. The generic +preprocessor directives have the form "$NAME", where $ marks a \fIgeneric\fR +directive, and where NAME is the name of the directive. +.ls 10 PIXEL +Replaced by the current type name, e.g., "int", "real", etc. +.le +.ls 10 XPIXEL +Replaced by the current type name in upper case, preceded by an X, +e.g., "XINT", "XREAL", etc. This is used for generic C procedures meant +to be called from SPP or Fortran. +.le +.ls 10 INDEF +Replaced by the numeric constant denoting indefinite for the current +datatype. +.le +.ls 10 INDEF[SILRDX] +These strings are \fInot\fR replaced, since the "INDEF" in this case is +not generic. +.le +.ls 10 SZ_PIXEL +Replaced by "SZ_INT", "SZ_REAL", etc. +.le +.ls 10 TY_PIXEL +Replaced by "TY_INT", "TY_REAL", etc. +.le +.ls 10 $PIXEL +Replaced by the string "PIXEL". This is used in doubly generic sources, +where the first pass translates $PIXEL to PIXEL, and the second to the +actual type string. +.le +.ls 10 $INDEF +Replaced by the string "INDEF". +.le +.ls 10 $t +Replaced by one of the characters [ubcsilrdx]. +.le +.ls 10 $T +Replaced by one of the characters [UBCSILRDX]. +.le +.ls 10 $/.../ +Replaced by the string "...", i.e., whatever is within the // delimiters. +Used to disable generic preprocessing of arbitrary text. +.le +.ls 10 [0-9]+("$f"|"$F") +Replaced by the corresponding real or double constant. For example, +"1$f" translates as "1.0" for type real, but as "1.0D0" for type double. +.le + +.ls 10 $if (expression) +The conditional preprocessing facility. If the $IF tests false the code +which follows is skipped over, and is not copied to the output file. +Control transfers to the matching $ELSE or $ENDIF. The following may be +used in the boolean expression: + +.nf +"datatype" denotes the current type +ubcsilrdx any subset of these characters denotes + the corresponding datatype +sizeof() the size of the specified type, + e.g., for comparisons + +!= == the relational operators + > < >= <= + + +Examples: + + $if (datatype != dx) + (code to be compiled if type not d or x) + + $if (sizeof(i) <= sizeof(r)) + (code to be compiled if size int <= real) +.fi + +$IF constructs may be nested. The directive may appear anywhere on +a line. +.le + +.ls 10 $else +Marks the else clause of a $IF. +.le +.ls 10 $endif +Marks the end of a $IF. One is required for every $IF. +.le +.ls 10 $for (types) +For each of the listed types, output a translated copy of the code between +the $FOR and the matching $ENDFOR. Nesting is permitted. + +.nf +Example: + $for (silrd) + (any amount of generic code) + $endfor +.fi +.le +.ls 10 $endfor +Marks the end of a $FOR statement. +.le +.ls 10 $$ +Replaced by a single $. +.le +.ls 10 /*...*/ +C comments are not preprocessed. +.le +.ls 10 "..." +Quoted strings are not preprocessed. +.le +.ls 10 #...(EOL) +SPP comments are not preprocessed. +.le +.ls 10 %...(EOL) +SPP Fortran escapes are not preprocessed. +.le +.ih +EXAMPLES +1. Translate the generic source "aadd.gx" to produce the six output files +"aadds.x", "aaddi.x", etc., in the subdirectory "ak", clobbering any +existing files therein. The \fIgeneric\fR task is a bootstrap utility +written in C and is implemented as a CL foreign task, hence the UNIX +command syntax. + + cl> generic -k -p ak/ -t silrdx aadd.gx + +2. Perform an inline transformation ($FOR directive) of the source file +"imsum.gx", producing the single file "imsum.x" as output. + + cl> generic -k -o imsum.x imsum.gx + +3. The following is a simple example of a typical generic source file. +For additional examples, see the ".gx" sources in the VOPS, IMIO, IMAGES +and other directories. + +.nf +# ALIM -- Compute the limits (minimum and maximum values) of a vector. +# (this is a copy of the file vops$alim.gx). + +procedure alim$t (a, npix, minval, maxval) + +PIXEL a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + $if (datatype == x) + if (abs(value) < abs(minval)) + minval = value + else if (abs(value) > abs(maxval)) + maxval = value + $else + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + $endif + } +end +.fi +.ih +SEE ALSO +xc, xyacc diff --git a/unix/boot/generic.new/generic.o b/unix/boot/generic.new/generic.o new file mode 100644 index 00000000..6ea439d3 Binary files /dev/null and b/unix/boot/generic.new/generic.o differ diff --git a/unix/boot/generic.new/lex.sed b/unix/boot/generic.new/lex.sed new file mode 100644 index 00000000..56df4751 --- /dev/null +++ b/unix/boot/generic.new/lex.sed @@ -0,0 +1,7 @@ +/int nstr; extern int yyprevious;/a\ +if (yyin==NULL) yyin = stdin;\ +if (yyout==NULL) yyout = stdout; +/{stdin}/c\ +FILE *yyin, *yyout; +s/"stdio.h"// +s/getc/k_getc/ diff --git a/unix/boot/generic.new/lexyy.c b/unix/boot/generic.new/lexyy.c new file mode 100644 index 00000000..4540bd3c --- /dev/null +++ b/unix/boot/generic.new/lexyy.c @@ -0,0 +1,2045 @@ + +#line 3 "lex.yy.c" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 +#define YY_FLEX_SUBMINOR_VERSION 35 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include +#include +#include +#include + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have . Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +typedef uint64_t flex_uint64_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; +#endif /* ! C99 */ + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#endif /* ! FLEXINT_H */ + +#ifdef __cplusplus + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +/* C99 requires __STDC__ to be defined as 1. */ +#if defined (__STDC__) + +#define YY_USE_CONST + +#endif /* defined (__STDC__) */ +#endif /* ! __cplusplus */ + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN (yy_start) = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START (((yy_start) - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart(yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#define YY_BUF_SIZE 16384 +#endif + +/* The state buf must be large enough to hold one state per character in the main buffer. + */ +#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +extern yy_size_t yyleng; + +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + + #define YY_LESS_LINENO(n) + +/* Return all but the first "n" matched characters back to the input stream. */ +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + *yy_cp = (yy_hold_char); \ + YY_RESTORE_YY_MORE_OFFSET \ + (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, (yytext_ptr) ) + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + yy_size_t yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use k_getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +/* Stack of input buffers. */ +static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ +static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ +static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + * + * Returns the top of the stack, or NULL. + */ +#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ + ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ + : NULL) + +/* Same as previous macro, but useful when we know that the buffer stack is not + * NULL or when we need an lvalue. For internal use only. + */ +#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; +static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */ +yy_size_t yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 0; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart (FILE *input_file ); +void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE yy_create_buffer (FILE *file,int size ); +void yy_delete_buffer (YY_BUFFER_STATE b ); +void yy_flush_buffer (YY_BUFFER_STATE b ); +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ); +void yypop_buffer_state (void ); + +static void yyensure_buffer_stack (void ); +static void yy_load_buffer_state (void ); +static void yy_init_buffer (YY_BUFFER_STATE b,FILE *file ); + +#define YY_FLUSH_BUFFER yy_flush_buffer(YY_CURRENT_BUFFER ) + +YY_BUFFER_STATE yy_scan_buffer (char *base,yy_size_t size ); +YY_BUFFER_STATE yy_scan_string (yyconst char *yy_str ); +YY_BUFFER_STATE yy_scan_bytes (yyconst char *bytes,yy_size_t len ); + +void *yyalloc (yy_size_t ); +void *yyrealloc (void *,yy_size_t ); +void yyfree (void * ); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! YY_CURRENT_BUFFER ){ \ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! YY_CURRENT_BUFFER ){\ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) + +/* Begin user sect3 */ + +typedef unsigned char YY_CHAR; + +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; + +typedef int yy_state_type; + +extern int yylineno; + +int yylineno = 1; + +extern char *yytext; +#define yytext_ptr yytext + +static yy_state_type yy_get_previous_state (void ); +static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); +static int yy_get_next_buffer (void ); +static void yy_fatal_error (yyconst char msg[] ); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + (yytext_ptr) = yy_bp; \ + yyleng = (yy_size_t) (yy_cp - yy_bp); \ + (yy_hold_char) = *yy_cp; \ + *yy_cp = '\0'; \ + (yy_c_buf_p) = yy_cp; + +#define YY_NUM_RULES 33 +#define YY_END_OF_BUFFER 34 +/* This struct is not used in this scanner, + but its presence is necessary. */ +struct yy_trans_info + { + flex_int32_t yy_verify; + flex_int32_t yy_nxt; + }; +static yyconst flex_int16_t yy_accept[122] = + { 0, + 0, 0, 34, 33, 33, 26, 31, 33, 33, 33, + 33, 33, 33, 33, 33, 33, 31, 32, 0, 0, + 24, 12, 0, 0, 0, 0, 11, 0, 0, 0, + 10, 25, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 19, 0, 0, + 0, 0, 0, 14, 13, 0, 0, 0, 0, 0, + 0, 0, 0, 27, 0, 0, 0, 22, 0, 0, + 0, 0, 17, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 20, 0, 0, 0, 0, 15, 0, 0, + 0, 3, 1, 0, 0, 0, 28, 0, 0, 0, + + 21, 8, 7, 0, 16, 9, 4, 0, 0, 2, + 29, 0, 23, 18, 0, 0, 0, 5, 6, 30, + 0 + } ; + +static yyconst flex_int32_t yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 1, 3, 4, 5, 6, 1, 1, 1, + 1, 7, 1, 1, 1, 1, 8, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 1, 1, 1, + 1, 1, 1, 1, 10, 10, 10, 11, 12, 13, + 10, 10, 14, 10, 10, 15, 10, 16, 17, 18, + 10, 19, 20, 21, 10, 10, 10, 22, 23, 24, + 1, 1, 1, 1, 25, 1, 1, 1, 26, 27, + + 28, 29, 1, 1, 30, 1, 1, 31, 1, 32, + 33, 1, 1, 34, 35, 36, 37, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst flex_int32_t yy_meta[38] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1 + } ; + +static yyconst flex_int16_t yy_base[123] = + { 0, + 0, 34, 194, 195, 37, 195, 195, 38, 186, 36, + 174, 31, 30, 36, 35, 173, 27, 195, 59, 63, + 195, 195, 47, 173, 56, 175, 195, 39, 155, 158, + 195, 195, 52, 73, 168, 65, 62, 66, 69, 71, + 72, 66, 70, 172, 164, 172, 163, 195, 170, 158, + 144, 151, 143, 195, 195, 82, 83, 91, 158, 157, + 88, 139, 146, 195, 146, 159, 94, 195, 158, 157, + 140, 82, 195, 101, 102, 99, 104, 107, 111, 139, + 136, 134, 195, 147, 150, 149, 146, 195, 127, 130, + 109, 119, 140, 110, 113, 125, 195, 128, 119, 136, + + 195, 195, 195, 120, 195, 135, 134, 124, 132, 133, + 195, 120, 195, 195, 130, 131, 98, 98, 87, 195, + 195, 83 + } ; + +static yyconst flex_int16_t yy_def[123] = + { 0, + 121, 1, 121, 121, 121, 121, 121, 121, 121, 121, + 122, 122, 122, 122, 122, 122, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 122, 122, 122, 122, 122, 122, + 122, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 122, 122, 122, 122, 122, + 122, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 122, 122, 122, 122, 122, 122, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 122, 122, 122, 122, 122, 122, 121, 121, 121, 121, + + 121, 121, 121, 121, 121, 122, 122, 122, 122, 122, + 121, 121, 121, 121, 122, 122, 121, 122, 122, 121, + 0, 121 + } ; + +static yyconst flex_int16_t yy_nxt[233] = + { 0, + 4, 5, 6, 7, 8, 4, 4, 9, 10, 11, + 11, 11, 11, 12, 11, 11, 11, 13, 11, 14, + 15, 16, 11, 11, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 17, 19, 18, + 33, 20, 21, 38, 34, 22, 37, 36, 36, 23, + 24, 25, 36, 36, 42, 26, 43, 40, 27, 39, + 19, 45, 46, 20, 55, 28, 29, 30, 48, 51, + 52, 49, 57, 31, 23, 24, 44, 33, 56, 36, + 55, 34, 36, 36, 35, 61, 36, 58, 36, 36, + 28, 29, 30, 59, 75, 60, 62, 63, 64, 36, + + 36, 65, 76, 74, 36, 36, 84, 85, 36, 79, + 89, 90, 91, 93, 92, 36, 36, 94, 36, 36, + 95, 36, 96, 106, 36, 120, 36, 36, 36, 107, + 36, 108, 107, 107, 109, 115, 36, 107, 107, 110, + 107, 36, 36, 116, 118, 119, 117, 36, 36, 36, + 36, 36, 36, 114, 113, 112, 111, 36, 105, 104, + 103, 102, 101, 100, 99, 98, 97, 88, 87, 86, + 83, 82, 81, 80, 78, 77, 73, 72, 71, 70, + 69, 68, 67, 66, 48, 36, 54, 53, 50, 47, + 41, 36, 32, 121, 3, 121, 121, 121, 121, 121, + + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121 + } ; + +static yyconst flex_int16_t yy_chk[233] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 2, 5, 2, + 10, 5, 8, 13, 10, 8, 12, 13, 12, 8, + 8, 8, 15, 14, 17, 8, 17, 15, 8, 14, + 19, 23, 23, 19, 33, 8, 8, 8, 25, 28, + 28, 25, 37, 8, 20, 20, 20, 34, 36, 37, + 33, 34, 36, 38, 122, 41, 39, 38, 40, 41, + 20, 20, 20, 39, 57, 40, 42, 42, 43, 56, + + 57, 43, 58, 56, 119, 61, 67, 67, 58, 61, + 72, 72, 74, 76, 75, 118, 76, 77, 74, 75, + 78, 77, 79, 91, 78, 117, 91, 94, 79, 92, + 95, 94, 92, 92, 95, 108, 92, 92, 92, 96, + 92, 108, 96, 109, 115, 116, 112, 115, 116, 109, + 110, 107, 106, 104, 100, 99, 98, 93, 90, 89, + 87, 86, 85, 84, 82, 81, 80, 71, 70, 69, + 66, 65, 63, 62, 60, 59, 53, 52, 51, 50, + 49, 47, 46, 45, 44, 35, 30, 29, 26, 24, + 16, 11, 9, 3, 121, 121, 121, 121, 121, 121, + + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +extern int yy_flex_debug; +int yy_flex_debug = 0; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *yytext; +#line 1 "tok.l" +#line 2 "tok.l" + +#include + +/* + * GENERIC -- This filter takes a file containing a generic operator as input + * and generates as output either a set of files, one for each of the data + * types in the generic family, or a single file wherein the generic section + * has been duplicated for each case. + */ + +#undef output +extern char *type_string; +extern char xtype_string[]; +extern char type_char; + +extern void copy_line (void); +extern void copy_string (void); +extern void copy_comment (void); +extern void make_float (char type_ch); +extern void pass_through (void); +extern void do_for (void); +extern void do_endfor (void); +extern void do_if (void); +extern void do_else (void); +extern void do_endif (void); + +extern void output_indef (char ch); +extern void output_upper (char *s); +extern void output (char ch); +extern void outstr (char *s); +extern int k_getc (FILE *cx_i); /* NOTE: lex.sed changes this to k_getc() */ + + + +#line 577 "lex.yy.c" + +#define INITIAL 0 + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +static int yy_init_globals (void ); + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int yylex_destroy (void ); + +int yyget_debug (void ); + +void yyset_debug (int debug_flag ); + +YY_EXTRA_TYPE yyget_extra (void ); + +void yyset_extra (YY_EXTRA_TYPE user_defined ); + +FILE *yyget_in (void ); + +void yyset_in (FILE * in_str ); + +FILE *yyget_out (void ); + +void yyset_out (FILE * out_str ); + +yy_size_t yyget_leng (void ); + +char *yyget_text (void ); + +int yyget_lineno (void ); + +void yyset_lineno (int line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap (void ); +#else +extern int yywrap (void ); +#endif +#endif + + static void yyunput (int c,char *buf_ptr ); + +#ifndef yytext_ptr +static void yy_flex_strncpy (char *,yyconst char *,int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * ); +#endif + +#ifndef YY_NO_INPUT + +#ifdef __cplusplus +static int yyinput (void ); +#else +static int input (void ); +#endif + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ + { \ + int c = '*'; \ + yy_size_t n; \ + for ( n = 0; n < max_size && \ + (c = k_getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else \ + { \ + errno=0; \ + while ( (result = fread(buf, 1, max_size, yyin))==0 && ferror(yyin)) \ + { \ + if( errno != EINTR) \ + { \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + break; \ + } \ + errno=0; \ + clearerr(yyin); \ + } \ + }\ +\ + +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* end tables serialization structures and prototypes */ + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int yylex (void); + +#define YY_DECL int yylex (void) +#endif /* !YY_DECL */ + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + if ( yyleng > 0 ) \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = \ + (yytext[yyleng - 1] == '\n'); \ + YY_USER_ACTION + +/** The main scanner function which does all the work. + */ +YY_DECL +{ + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 40 "tok.l" + + +#line 765 "lex.yy.c" + + if ( !(yy_init) ) + { + (yy_init) = 1; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! (yy_start) ) + (yy_start) = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! YY_CURRENT_BUFFER ) { + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_load_buffer_state( ); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = (yy_c_buf_p); + + /* Support of yytext. */ + *yy_cp = (yy_hold_char); + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 122 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 195 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + +do_action: /* This label is used only to access EOF actions. */ + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = (yy_hold_char); + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + goto yy_find_action; + +case 1: +YY_RULE_SETUP +#line 42 "tok.l" +outstr (type_string); + YY_BREAK +case 2: +YY_RULE_SETUP +#line 43 "tok.l" +outstr (xtype_string); + YY_BREAK +case 3: +YY_RULE_SETUP +#line 44 "tok.l" +output_indef (type_char); + YY_BREAK +case 4: +YY_RULE_SETUP +#line 45 "tok.l" +ECHO; + YY_BREAK +case 5: +YY_RULE_SETUP +#line 46 "tok.l" +output_upper ("SZ_"); + YY_BREAK +case 6: +YY_RULE_SETUP +#line 47 "tok.l" +output_upper ("TY_"); + YY_BREAK +case 7: +YY_RULE_SETUP +#line 48 "tok.l" +outstr ("PIXEL"); + YY_BREAK +case 8: +YY_RULE_SETUP +#line 49 "tok.l" +outstr ("INDEF"); + YY_BREAK +case 9: +YY_RULE_SETUP +#line 51 "tok.l" +{ + yytext[strlen(yytext)-5] = '\0'; + output_upper (yytext); + } + YY_BREAK +case 10: +YY_RULE_SETUP +#line 56 "tok.l" +{ if (isupper (type_char)) + output (tolower (type_char)); + else + output (type_char); + } + YY_BREAK +case 11: +YY_RULE_SETUP +#line 61 "tok.l" +{ if (islower (type_char)) + output (toupper (type_char)); + else + output (type_char); + } + YY_BREAK +case 12: +YY_RULE_SETUP +#line 67 "tok.l" +pass_through(); + YY_BREAK +case 13: +YY_RULE_SETUP +#line 68 "tok.l" +make_float (type_char); + YY_BREAK +case 14: +YY_RULE_SETUP +#line 70 "tok.l" +do_if(); + YY_BREAK +case 15: +YY_RULE_SETUP +#line 71 "tok.l" +do_else(); + YY_BREAK +case 16: +YY_RULE_SETUP +#line 72 "tok.l" +do_endif(); + YY_BREAK +case 17: +YY_RULE_SETUP +#line 73 "tok.l" +do_for(); + YY_BREAK +case 18: +YY_RULE_SETUP +#line 74 "tok.l" +do_endfor(); + YY_BREAK +case 19: +YY_RULE_SETUP +#line 75 "tok.l" +do_if(); + YY_BREAK +case 20: +YY_RULE_SETUP +#line 76 "tok.l" +do_else(); + YY_BREAK +case 21: +YY_RULE_SETUP +#line 77 "tok.l" +do_endif(); + YY_BREAK +case 22: +YY_RULE_SETUP +#line 78 "tok.l" +do_for(); + YY_BREAK +case 23: +YY_RULE_SETUP +#line 79 "tok.l" +do_endfor(); + YY_BREAK +case 24: +YY_RULE_SETUP +#line 81 "tok.l" +output ('$'); + YY_BREAK +case 25: +YY_RULE_SETUP +#line 82 "tok.l" +copy_comment(); + YY_BREAK +case 26: +YY_RULE_SETUP +#line 83 "tok.l" +copy_string(); + YY_BREAK +case 27: +YY_RULE_SETUP +#line 85 "tok.l" +ECHO; + YY_BREAK +case 28: +YY_RULE_SETUP +#line 86 "tok.l" +ECHO; + YY_BREAK +case 29: +YY_RULE_SETUP +#line 87 "tok.l" +ECHO; + YY_BREAK +case 30: +YY_RULE_SETUP +#line 88 "tok.l" +ECHO; + YY_BREAK +case 31: +YY_RULE_SETUP +#line 90 "tok.l" +copy_line(); + YY_BREAK +case 32: +YY_RULE_SETUP +#line 91 "tok.l" +copy_line(); + YY_BREAK +case 33: +YY_RULE_SETUP +#line 93 "tok.l" +ECHO; + YY_BREAK +#line 1025 "lex.yy.c" +case YY_STATE_EOF(INITIAL): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = (yy_hold_char); + YY_RESTORE_YY_MORE_OFFSET + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between YY_CURRENT_BUFFER and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + YY_CURRENT_BUFFER_LVALUE->yy_input_file = yyin; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++(yy_c_buf_p); + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = (yy_c_buf_p); + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_END_OF_FILE: + { + (yy_did_buffer_switch_on_eof) = 0; + + if ( yywrap( ) ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = + (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + (yy_c_buf_p) = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ +} /* end of yylex */ + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ +static int yy_get_next_buffer (void) +{ + register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; + register char *source = (yytext_ptr); + register int number_to_move, i; + int ret_val; + + if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; + + else + { + yy_size_t num_to_read = + YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = YY_CURRENT_BUFFER; + + int yy_c_buf_p_offset = + (int) ((yy_c_buf_p) - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + yy_size_t new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + yyrealloc((void *) b->yy_ch_buf,b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + (yy_c_buf_p) = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - + number_to_move - 1; + + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), + (yy_n_chars), num_to_read ); + + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + if ( (yy_n_chars) == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart(yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { + /* Extend the array by 50%, plus the number we really need. */ + yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) yyrealloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); + if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); + } + + (yy_n_chars) += number_to_move; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; + + (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; + + return ret_val; +} + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + + static yy_state_type yy_get_previous_state (void) +{ + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); + + for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 122 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; +} + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) +{ + register int yy_is_jam; + register char *yy_cp = (yy_c_buf_p); + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 122 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 121); + + return yy_is_jam ? 0 : yy_current_state; +} + + static void yyunput (int c, register char * yy_bp ) +{ + register char *yy_cp; + + yy_cp = (yy_c_buf_p); + + /* undo effects of setting up yytext */ + *yy_cp = (yy_hold_char); + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register yy_size_t number_to_move = (yy_n_chars) + 2; + register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; + register char *source = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; + + while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + (yytext_ptr) = yy_bp; + (yy_hold_char) = *yy_cp; + (yy_c_buf_p) = yy_cp; +} + +#ifndef YY_NO_INPUT +#ifdef __cplusplus + static int yyinput (void) +#else + static int input (void) +#endif + +{ + int c; + + *(yy_c_buf_p) = (yy_hold_char); + + if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + /* This was really a NUL. */ + *(yy_c_buf_p) = '\0'; + + else + { /* need more input */ + yy_size_t offset = (yy_c_buf_p) - (yytext_ptr); + ++(yy_c_buf_p); + + switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart(yyin ); + + /*FALLTHROUGH*/ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap( ) ) + return 0; + + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = (yytext_ptr) + offset; + break; + } + } + } + + c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ + *(yy_c_buf_p) = '\0'; /* preserve yytext */ + (yy_hold_char) = *++(yy_c_buf_p); + + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = (c == '\n'); + + return c; +} +#endif /* ifndef YY_NO_INPUT */ + +/** Immediately switch to a different input stream. + * @param input_file A readable stream. + * + * @note This function does not reset the start condition to @c INITIAL . + */ + void yyrestart (FILE * input_file ) +{ + + if ( ! YY_CURRENT_BUFFER ){ + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_init_buffer(YY_CURRENT_BUFFER,input_file ); + yy_load_buffer_state( ); +} + +/** Switch to a different input buffer. + * @param new_buffer The new input buffer. + * + */ + void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ) +{ + + /* TODO. We should be able to replace this entire function body + * with + * yypop_buffer_state(); + * yypush_buffer_state(new_buffer); + */ + yyensure_buffer_stack (); + if ( YY_CURRENT_BUFFER == new_buffer ) + return; + + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + YY_CURRENT_BUFFER_LVALUE = new_buffer; + yy_load_buffer_state( ); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + (yy_did_buffer_switch_on_eof) = 1; +} + +static void yy_load_buffer_state (void) +{ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; + yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file; + (yy_hold_char) = *(yy_c_buf_p); +} + +/** Allocate and initialize an input buffer state. + * @param file A readable stream. + * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. + * + * @return the allocated buffer state. + */ + YY_BUFFER_STATE yy_create_buffer (FILE * file, int size ) +{ + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yyalloc(b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer(b,file ); + + return b; +} + +/** Destroy the buffer. + * @param b a buffer created with yy_create_buffer() + * + */ + void yy_delete_buffer (YY_BUFFER_STATE b ) +{ + + if ( ! b ) + return; + + if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ + YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yyfree((void *) b->yy_ch_buf ); + + yyfree((void *) b ); +} + +#ifndef __cplusplus +extern int isatty (int ); +#endif /* __cplusplus */ + +/* Initializes or reinitializes a buffer. + * This function is sometimes called more than once on the same buffer, + * such as during a yyrestart() or at EOF. + */ + static void yy_init_buffer (YY_BUFFER_STATE b, FILE * file ) + +{ + int oerrno = errno; + + yy_flush_buffer(b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + + /* If b is the current buffer, then yy_init_buffer was _probably_ + * called from yyrestart() or through yy_get_next_buffer. + * In that case, we don't want to reset the lineno or column. + */ + if (b != YY_CURRENT_BUFFER){ + b->yy_bs_lineno = 1; + b->yy_bs_column = 0; + } + + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; + + errno = oerrno; +} + +/** Discard all buffered characters. On the next scan, YY_INPUT will be called. + * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. + * + */ + void yy_flush_buffer (YY_BUFFER_STATE b ) +{ + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == YY_CURRENT_BUFFER ) + yy_load_buffer_state( ); +} + +/** Pushes the new state onto the stack. The new state becomes + * the current state. This function will allocate the stack + * if necessary. + * @param new_buffer The new state. + * + */ +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ) +{ + if (new_buffer == NULL) + return; + + yyensure_buffer_stack(); + + /* This block is copied from yy_switch_to_buffer. */ + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + /* Only push if top exists. Otherwise, replace top. */ + if (YY_CURRENT_BUFFER) + (yy_buffer_stack_top)++; + YY_CURRENT_BUFFER_LVALUE = new_buffer; + + /* copied from yy_switch_to_buffer. */ + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; +} + +/** Removes and deletes the top of the stack, if present. + * The next element becomes the new top. + * + */ +void yypop_buffer_state (void) +{ + if (!YY_CURRENT_BUFFER) + return; + + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + if ((yy_buffer_stack_top) > 0) + --(yy_buffer_stack_top); + + if (YY_CURRENT_BUFFER) { + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; + } +} + +/* Allocates the stack if it does not exist. + * Guarantees space for at least one push. + */ +static void yyensure_buffer_stack (void) +{ + yy_size_t num_to_alloc; + + if (!(yy_buffer_stack)) { + + /* First allocation is just for 2 elements, since we don't know if this + * scanner will even need a stack. We use 2 instead of 1 to avoid an + * immediate realloc on the next call. + */ + num_to_alloc = 1; + (yy_buffer_stack) = (struct yy_buffer_state**)yyalloc + (num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); + + (yy_buffer_stack_max) = num_to_alloc; + (yy_buffer_stack_top) = 0; + return; + } + + if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ + + /* Increase the buffer to prepare for a possible push. */ + int grow_size = 8 /* arbitrary grow size */; + + num_to_alloc = (yy_buffer_stack_max) + grow_size; + (yy_buffer_stack) = (struct yy_buffer_state**)yyrealloc + ((yy_buffer_stack), + num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + /* zero only the new slots.*/ + memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); + (yy_buffer_stack_max) = num_to_alloc; + } +} + +/** Setup the input buffer state to scan directly from a user-specified character buffer. + * @param base the character buffer + * @param size the size in bytes of the character buffer + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_buffer (char * base, yy_size_t size ) +{ + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer(b ); + + return b; +} + +/** Setup the input buffer state to scan a string. The next call to yylex() will + * scan from a @e copy of @a str. + * @param yystr a NUL-terminated string to scan + * + * @return the newly allocated buffer state object. + * @note If you want to scan bytes that may contain NUL values, then use + * yy_scan_bytes() instead. + */ +YY_BUFFER_STATE yy_scan_string (yyconst char * yystr ) +{ + + return yy_scan_bytes(yystr,strlen(yystr) ); +} + +/** Setup the input buffer state to scan the given bytes. The next call to yylex() will + * scan from a @e copy of @a bytes. + * @param bytes the byte buffer to scan + * @param len the number of bytes in the buffer pointed to by @a bytes. + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len ) +{ + YY_BUFFER_STATE b; + char *buf; + yy_size_t n, i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = _yybytes_len + 2; + buf = (char *) yyalloc(n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < _yybytes_len; ++i ) + buf[i] = yybytes[i]; + + buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer(buf,n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; +} + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +static void yy_fatal_error (yyconst char* msg ) +{ + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); +} + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + yytext[yyleng] = (yy_hold_char); \ + (yy_c_buf_p) = yytext + yyless_macro_arg; \ + (yy_hold_char) = *(yy_c_buf_p); \ + *(yy_c_buf_p) = '\0'; \ + yyleng = yyless_macro_arg; \ + } \ + while ( 0 ) + +/* Accessor methods (get/set functions) to struct members. */ + +/** Get the current line number. + * + */ +int yyget_lineno (void) +{ + + return yylineno; +} + +/** Get the input stream. + * + */ +FILE *yyget_in (void) +{ + return yyin; +} + +/** Get the output stream. + * + */ +FILE *yyget_out (void) +{ + return yyout; +} + +/** Get the length of the current token. + * + */ +yy_size_t yyget_leng (void) +{ + return yyleng; +} + +/** Get the current token. + * + */ + +char *yyget_text (void) +{ + return yytext; +} + +/** Set the current line number. + * @param line_number + * + */ +void yyset_lineno (int line_number ) +{ + + yylineno = line_number; +} + +/** Set the input stream. This does not discard the current + * input buffer. + * @param in_str A readable stream. + * + * @see yy_switch_to_buffer + */ +void yyset_in (FILE * in_str ) +{ + yyin = in_str ; +} + +void yyset_out (FILE * out_str ) +{ + yyout = out_str ; +} + +int yyget_debug (void) +{ + return yy_flex_debug; +} + +void yyset_debug (int bdebug ) +{ + yy_flex_debug = bdebug ; +} + +static int yy_init_globals (void) +{ + /* Initialization is the same as for the non-reentrant scanner. + * This function is called from yylex_destroy(), so don't allocate here. + */ + + (yy_buffer_stack) = 0; + (yy_buffer_stack_top) = 0; + (yy_buffer_stack_max) = 0; + (yy_c_buf_p) = (char *) 0; + (yy_init) = 0; + (yy_start) = 0; + +/* Defined in main.c */ +#ifdef YY_STDINIT + yyin = stdin; + yyout = stdout; +#else + yyin = (FILE *) 0; + yyout = (FILE *) 0; +#endif + + /* For future reference: Set errno on error, since we are called by + * yylex_init() + */ + return 0; +} + +/* yylex_destroy is for both reentrant and non-reentrant scanners. */ +int yylex_destroy (void) +{ + + /* Pop the buffer stack, destroying each element. */ + while(YY_CURRENT_BUFFER){ + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + yypop_buffer_state(); + } + + /* Destroy the stack itself. */ + yyfree((yy_buffer_stack) ); + (yy_buffer_stack) = NULL; + + /* Reset the globals. This is important in a non-reentrant scanner so the next time + * yylex() is called, initialization will occur. */ + yy_init_globals( ); + + return 0; +} + +/* + * Internal utility routines. + */ + +#ifndef yytext_ptr +static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) +{ + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; +} +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * s ) +{ + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; +} +#endif + +void *yyalloc (yy_size_t size ) +{ + return (void *) malloc( size ); +} + +void *yyrealloc (void * ptr, yy_size_t size ) +{ + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); +} + +void yyfree (void * ptr ) +{ + free( (char *) ptr ); /* see yyrealloc() for (char *) cast */ +} + +#define YYTABLES_NAME "yytables" + +#line 93 "tok.l" + + + + +/* LEX_INPUT -- Make input() callable as a function from the .c code. + */ +int +lex_input (void) +{ + return (input()); +} + + +/* LEX_UNPUT -- Make unput() callable as a function from the .c code. + */ +void +lex_unput (int ch) +{ + unput (ch); +} + diff --git a/unix/boot/generic.new/lexyy.o b/unix/boot/generic.new/lexyy.o new file mode 100644 index 00000000..9f67f4cf Binary files /dev/null and b/unix/boot/generic.new/lexyy.o differ diff --git a/unix/boot/generic.new/mkpkg.sh b/unix/boot/generic.new/mkpkg.sh new file mode 100644 index 00000000..45389d35 --- /dev/null +++ b/unix/boot/generic.new/mkpkg.sh @@ -0,0 +1,18 @@ +# Bootstrap the generic preprocessor. The -lln library is not used to avoid +# the enternal dependency. The sed script is used to edit certain nonportable +# constructs in the LEX code, and the filename lex.yy.c is changed to lexyy.c +# for portability reasons. + +find tok.l -newer lexyy.c -exec rm lexyy.c \; +if test -f lexyy.c; then\ + $CC -c $HSI_CF lexyy.c;\ +else\ + lex tok.l;\ + sed -f lex.sed lex.yy.c > lexyy.c; rm lex.yy.c;\ + $CC -c $HSI_CF lexyy.c;\ +fi + +$CC -c $HSI_CF generic.c chario.c yywrap.c +$CC $HSI_LF generic.o lexyy.o chario.o yywrap.o $HSI_LIBS -o generic.e +mv -f generic.e ../../hlib +rm *.o diff --git a/unix/boot/generic.new/tok.l b/unix/boot/generic.new/tok.l new file mode 100644 index 00000000..c9bedf29 --- /dev/null +++ b/unix/boot/generic.new/tok.l @@ -0,0 +1,111 @@ +%{ + +#include + +/* + * GENERIC -- This filter takes a file containing a generic operator as input + * and generates as output either a set of files, one for each of the data + * types in the generic family, or a single file wherein the generic section + * has been duplicated for each case. + */ + +#undef output +extern char *type_string; +extern char xtype_string[]; +extern char type_char; + +extern void copy_line (void); +extern void copy_string (void); +extern void copy_comment (void); +extern void make_float (char type_ch); +extern void pass_through (void); +extern void do_for (void); +extern void do_endfor (void); +extern void do_if (void); +extern void do_else (void); +extern void do_endif (void); + +extern void output_indef (char ch); +extern void output_upper (char *s); +extern void output (char ch); +extern void outstr (char *s); +extern int getc (FILE *cx_i); /* NOTE: lex.sed changes this to k_getc() */ + + + +%} + +W [ \t] + +%% + +PIXEL outstr (type_string); +XPIXEL outstr (xtype_string); +INDEF output_indef (type_char); +INDEF(S|I|L|R|D|X) ECHO; +SZ_PIXEL output_upper ("SZ_"); +TY_PIXEL output_upper ("TY_"); +$PIXEL outstr ("PIXEL"); +$INDEF outstr ("INDEF"); + +[A-Z][A-Z_]*PIXEL { + yytext[strlen(yytext)-5] = '\0'; + output_upper (yytext); + } + +"$t" { if (isupper (type_char)) + output (tolower (type_char)); + else + output (type_char); + } +"$T" { if (islower (type_char)) + output (toupper (type_char)); + else + output (type_char); + } + +"$/" pass_through(); +[0-9]+("$f"|"$F") make_float (type_char); + +{W}*"$if" do_if(); +{W}*"$else" do_else(); +{W}*"$endif" do_endif(); +{W}*"$for" do_for(); +{W}*"$endfor" do_endfor(); +{W}*"$IF" do_if(); +{W}*"$ELSE" do_else(); +{W}*"$ENDIF" do_endif(); +{W}*"$FOR" do_for(); +{W}*"$ENDFOR" do_endfor(); + +"$$" output ('$'); +"/*" copy_comment(); +\" copy_string(); + +^\#if ECHO; +^\#else ECHO; +^\#endif ECHO; +^\#include ECHO; + +\# copy_line(); +^\% copy_line(); + +%% + + +/* LEX_INPUT -- Make input() callable as a function from the .c code. + */ +int +lex_input (void) +{ + return (input()); +} + + +/* LEX_UNPUT -- Make unput() callable as a function from the .c code. + */ +void +lex_unput (int ch) +{ + unput (ch); +} diff --git a/unix/boot/generic.new/yywrap.c b/unix/boot/generic.new/yywrap.c new file mode 100644 index 00000000..627dff08 --- /dev/null +++ b/unix/boot/generic.new/yywrap.c @@ -0,0 +1,10 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* YYWRAP -- Called by lex when end of file is seen. + */ +int +yywrap() +{ + return (1); +} diff --git a/unix/boot/generic.new/yywrap.o b/unix/boot/generic.new/yywrap.o new file mode 100644 index 00000000..16875620 Binary files /dev/null and b/unix/boot/generic.new/yywrap.o differ diff --git a/unix/boot/generic.new/z b/unix/boot/generic.new/z new file mode 100644 index 00000000..c850dbe8 --- /dev/null +++ b/unix/boot/generic.new/z @@ -0,0 +1,16 @@ +# Bootstrap the generic preprocessor. The -lln library is not used to avoid +# the enternal dependency. The sed script is used to edit certain nonportable +# constructs in the LEX code, and the filename lex.yy.c is changed to lexyy.c +# for portability reasons. + +find tok.l -newer lexyy.c -exec rm lexyy.c \; +if test -f lexyy.c; then\ + $CC -c $HSI_CF lexyy.c;\ +else\ + lex tok.l;\ + sed -f lex.sed lex.yy.c > lexyy.c; rm lex.yy.c;\ + $CC -c $HSI_CF lexyy.c;\ +fi + +$CC -c -g $HSI_CF generic.c chario.c yywrap.c +$CC $HSI_LF generic.o lexyy.o chario.o yywrap.o $HSI_LIBS -o generic.e diff --git a/unix/boot/generic/README b/unix/boot/generic/README new file mode 100644 index 00000000..98a1d23a --- /dev/null +++ b/unix/boot/generic/README @@ -0,0 +1,3 @@ +GENERIC -- The generic preprocessor is a simple task used to process generic + code into type specific code. A different copy of the code is output + for each datatype. diff --git a/unix/boot/generic/chario.c b/unix/boot/generic/chario.c new file mode 100644 index 00000000..09b46e40 --- /dev/null +++ b/unix/boot/generic/chario.c @@ -0,0 +1,188 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + + +/* + * OS Character I/O. This set of routines are provided as a workaround in + * the event that the host system cannot execute FTELL/FSEEK reliably (VMS/C + * could not). The idea here is to keep track of the character offset from + * the beginning of the file. K_FTELL returns the character offset. K_FSEEK + * rewinds the file and reads characters forward to the indicated offset. + * K_GETC keeps a count of the file position. (the k_ stands for kludge). + */ + +extern int debug; + +struct context { + FILE *fp; /* file descriptor */ + long fpos; /* saved file pointer */ + char fname[512]; /* file being scanned */ +}; + +FILE * +k_fopen (fname, mode) +char *fname; +char *mode; +{ + register struct context *cx; + register FILE *fp; + + if ((fp = fopen (fname, mode)) == NULL) + return (NULL); + + cx = (struct context *) malloc (sizeof(struct context)); + strcpy (cx->fname, fname); + cx->fpos = 0; + cx->fp = fp; + + return ((FILE *)cx); +} + + +int +k_fclose (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + int status; + + status = fclose (cx->fp); + free (cx); + + return (status); +} + +#ifdef vms + +int +k_getc (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + register int ch; + + cx->fpos++; + if (debug > 3) { + if ((ch = getc (cx->fp)) > 0) + printf ("%5d %03o %c\n", cx->fpos, ch, ch > 040 ? ch : 040); + return (ch); + } else + return (getc (cx->fp)); +} + +char * +k_fgets (obuf, maxch, cx_i) +char *obuf; +int maxch; +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + register int ch, n; + register char *op; + + for (op=obuf, n=maxch; --n >= 0; ) + if ((ch = k_getc(cx)) < 0) + return (NULL); + else { + *op++ = ch; + if (ch == '\n') + break; + } + + return (obuf); +} + +seek +k_fseek (cx_i, offset, type) +FILE *cx_i; +long offset; +int type; +{ + register struct context *cx = (struct context *)cx_i; + register FILE *fp = cx->fp; + register int ch; + + if (debug > 1) + printf ("seek (%s, %ld, %d)\n", cx->fname, offset, type); + + if (type == 0) { + fseek (fp, 0L, 0); + cx->fpos = 0; + + while (cx->fpos < offset && (ch = getc(fp)) != EOF) { + if (debug > 1) + fputc (ch, stdout); + cx->fpos++; + } + + if (debug > 1) + printf ("[]\n"); + + return (0); + } + + if (fseek (fp, offset, type) == -1) + return (-1); + else { + cx->fpos = ftell (fp); + return (0); + } +} + +long +k_ftell (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + + if (debug > 1) { + printf ("ftell returns %d\n", cx->fpos); + fflush (stdout); + } + + return (cx->fpos); +} + +#else + +int +k_getc (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + return (getc (cx->fp)); +} + +char * +k_fgets (op, maxch, cx_i) +char *op; +int maxch; +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + return (fgets (op, maxch, cx->fp)); +} + +int +k_fseek (cx_i, offset, type) +FILE *cx_i; +long offset; +int type; +{ + register struct context *cx = (struct context *)cx_i; + return (fseek (cx->fp, offset, type)); +} + +int +k_ftell (cx_i) +FILE *cx_i; +{ + register struct context *cx = (struct context *)cx_i; + return (ftell (cx->fp)); +} + +#endif diff --git a/unix/boot/generic/generic.c b/unix/boot/generic/generic.c new file mode 100644 index 00000000..07d19885 --- /dev/null +++ b/unix/boot/generic/generic.c @@ -0,0 +1,892 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#define import_spp +#include + +/* + * GENERIC -- This filter takes a file containing a generic operator as input + * and generates as output either a set of files, one for each of the data + * types in the generic family, or a single file wherein the generic section + * has been duplicated for each case. + */ + +#define input lex_input +#define unput lex_unput +extern char yytext[]; +extern int yyleng; +extern FILE *yyin; +extern FILE *yyout; + +#define MAXFILES 512 +#define MAXNEST 50 +#define OK 0 +#define SZ_FORSTK 20 + +/* $FOR contstruct descriptor. + */ +struct _for { + char f_prevtype; /* type before $for */ + char f_types[20]; /* "csilrdx" */ + char *f_curtype; /* pointer into f_types */ + long f_fpos; /* seek offset of $FOR */ +}; + +struct _for forstk[SZ_FORSTK]; +int forlev; +char *type_string; +char xtype_string[SZ_FNAME+1]; +char type_char; +int pass_output = 1; +int clobber = NO; + +extern long k_ftell (FILE *cx_i); +extern FILE *k_fopen (char *fname, char *mode); +extern int k_fseek (FILE *cx_i, long offset, int type); +extern int k_fclose (FILE *cx_i); + +extern int yylex (void); +extern int lex_input (void); +extern void lex_unput (int ch); + + +char *make_typed_filename (char *template, char type_char); +void set_type_string (char ch); +void copy_line (void); +void copy_string (void); +void copy_comment (void); +void make_float (char type_ch); +void output_indef (char ch); +void output_upper (char *s); +void pass_through (void); +void do_for (void); +void do_endfor (void); +void do_if (void); +void do_else (void); +void do_endif (void); + +int evaluate_expr (void); +int parse_relational (int *size1, int *size2, int *op); + +int relop (void); +int gsize (char ch); +char nextch (void); +char gch (void); +void uch (char ch); + +void output (char ch); +void outstr (char *s); + + + + +/** + * GENERIC: e.g., generic [-k] [-t csilrdx] file + */ +int main (int argc, char *argv[]) +{ + char *files[MAXFILES], *s, **p, *ip; + char fname[SZ_FNAME], *extension; + char *types = "i", *t; + char *prefix = ""; + char genfname[SZ_FNAME+1]; + char template[SZ_FNAME+1]; + char input_file[SZ_FNAME+1]; + char *index(), *rindex(); + int n, nfiles; + FILE *fp; + + genfname[0] = EOS; + nfiles = 0; + + for (p = &argv[1]; *p != NULL; p++) { + s = *p; + if (s[0] == '-') { + switch (s[1]) { + case 'k': + clobber = YES; + break; + case 't': + if (*(p+1) != NULL) + types = *++p; + break; + case 'o': + if (*(p+1) != NULL) + strcpy (genfname, *++p); + break; + case 'p': + if (*(p+1) != NULL) + prefix = *++p; + break; + } + } else { + files[nfiles++] = s; + if (genfname[0] != EOS && nfiles > 1) { + fprintf (stderr, + "Cannot process multiple files with '-o' flag\n"); + exit (OSOK+1); + } + } + } + + for (n=0; n < nfiles; n++) { + strcpy (input_file, files[n]); + yyin = k_fopen (input_file, "r"); + if (yyin == NULL) { + fprintf (stderr, "Cannot open input file '%s'\n", input_file); + continue; + } + + /* Set pointer to the filename extension string. If the file name + * has an extension, lop it off by overwriting the '.' with EOS. + * The first character of the extension of a generic file is + * normally a 'g', e.g., ".gx" or ".gc", but we want to generate + * a ".x" or ".c" file, so lop off any leading g in the extension. + */ + if ((extension = rindex (input_file, '.')) != NULL) { + *extension++ = EOS; + if (*extension == 'g') + extension++; + } else + extension = ""; + + for (t=types; *t != EOS; t++) { + /* Make output file name */ + strcpy (fname, prefix); + + /* Expand a template of the form "chars$tchars" into the root + * name of the new file, replacing the $t by the type char. + * If using input filename as the root, add "$t"; otherwise, + * check whether or not the generic filename string has a + * "$t" in it, and add one at end if it does not. + */ + if (genfname[0] == EOS) { + strcpy (template, input_file); + strcat (template, "$t"); + + } else { + strcpy (template, genfname); + + for (ip=index(genfname,'$'); ip != NULL; + ip = index(ip,'$')) { + + if (*(ip+1) == '$') + ip += 2; + else if (*(ip+1) == 't') + break; + } + + if (ip == NULL && strlen(types) > 1) + strcat (ip, "$t"); + } + + if (genfname[0] == EOS || strlen (types) > 1) + strcat (fname, make_typed_filename (template, *t)); + else + strcat (fname, template); + + /* If the user supplied the output filename template, we + * assume that it already contains an extension. + */ + if (genfname[0] == EOS) { + strcat (fname, "."); + strcat (fname, extension); + } + + if (access(fname,0) == 0) { + if (clobber == NO) { + fprintf (stderr, "File `%s' already exists\n", fname); + continue; + } else + unlink (fname); + } + if ((fp = fopen (fname, "w")) == NULL) { + fprintf (stderr, "Cannot open file `%s'\n", fname); + continue; + } + + yyout = fp; + set_type_string (*t); + type_char = *t; + forlev = -1; + + yylex(); /* do it */ + + fclose (fp); + k_fseek (yyin,0L,0); + } + + k_fclose (yyin); + } + + exit (OSOK); +} + + +/* MAKE_TYPED_FILENAME -- Make a copy of a filename string, substituting + * the given type suffix character for the every sequence "$t" found in the + * input string. The output string is retained in an internal static buffer. + * Any sequence "$$" is converted into a single "$". + */ +char * +make_typed_filename (char *template, char type_char) +{ + register char *ip, *op; + char ch; + static char fname[SZ_FNAME+1]; + + if (isupper (type_char)) + ch = tolower (type_char); + else + ch = type_char; + + for (ip=template, op=fname; *ip != EOS; ) + if (*ip == '$' && *(ip+1) == '$') { + *op++ = '$'; + ip += 2; + } else if (*ip == '$' && *(ip+1) == 't') { + *op++ = ch; + ip += 2; + } else + *op++ = *ip++; + + return (fname); +} + + +/* SET_TYPE_STRING -- Given the type suffix character, set the external + * array "type_string" to the name of the corresponding SPP datatype. + */ +void +set_type_string (char ch) +{ + char *ip, *op; + + switch (ch) { + case 'B': + type_string = "ubyte"; /* unsigned byte */ + break; + case 'U': + type_string = "ushort"; + break; + case 'b': + type_string = "bool"; + break; + case 'c': + type_string = "char"; + break; + case 's': + type_string = "short"; + break; + case 'i': + type_string = "int"; + break; + case 'l': + type_string = "long"; + break; + case 'r': + type_string = "real"; + break; + case 'd': + type_string = "double"; + break; + case 'x': + type_string = "complex"; + break; + case 'p': + type_string = "pointer"; + break; + default: + fprintf (stderr, "Unknown type suffix char `%c'\n", ch); + } + + op = xtype_string; + *op++ = 'X'; + for (ip=type_string; *ip != EOS; ip++) + *op++ = toupper (*ip); + *op++ = EOS; +} + + +/* COPY_LINE -- Output whatever is in the yylex token buffer, followed by the + * remainder of the line from which the token was extracted. + */ +void +copy_line (void) +{ + char ch; + + outstr(yytext); + while ((ch = input()) != '\n') + output(ch); + unput(ch); +} + + +/* COPY_STRING -- Called when the opening quote of a string is seen in the + * input. Copy the opening quote followed by all input characters until the + * end of string is seen. + */ +void +copy_string (void) +{ + char ch; + + outstr(yytext); + for (;;) { + switch (ch = input()) { + case '"': + output(ch); + return; + case '\\': + output(ch); + if ((ch = input()) != '\n') + output(ch); + else + unput(ch); + break; + case '\n': + unput(ch); + return; + default: + output(ch); + } + } +} + + +/* COPY_COMMENT -- Copy a C style comment to the output file. + */ +void +copy_comment (void) +{ + char ch; + int flag = 0; + + outstr (yytext); + + while ((ch = input()) != EOF) { + output (ch); + switch (ch) { + case '*': + flag = 1; + break; + case '/': + if (flag == 1) + return; + else + flag = 0; + break; + default: + flag = 0; + break; + } + } +} + + +/* MAKE_FLOAT -- Called when a n$f is seen in the input to convert a numeric + * constant to the form appropriate for the indicated datatype, e.g., "0", + * "0.", "0.0D0", etc. + */ +void +make_float (char type_ch) +{ + char *p; + + for (p=yytext; *p != '$'; p++) + ; + *p = EOS; + + if (type_ch == 'x') { + output ('('); + outstr (yytext); + outstr (".0,"); + outstr (yytext); + outstr (".0)"); + } else { + outstr (yytext); + switch (type_ch) { + case 'r': + outstr (".0"); + break; + case 'd': + outstr (".0D0"); + break; + } + } +} + + +/* OUTPUT_INDEF -- Output the INDEF string for the indicated datatype. + */ +void +output_indef (char ch) /* output INDEF, INDEFS, INDEFL, etc. */ +{ + outstr(yytext); + + switch (ch) { + case 's': + output ('S'); + break; + case 'i': + output ('I'); + break; + case 'l': + output ('L'); + break; + case 'r': + output ('R'); + break; + case 'd': + output ('D'); + break; + case 'x': + output ('X'); + break; + } +} + + +/* OUTPUT_UPPER -- Output the name of the current datatype (INT, REAL, etc.) + * in upper case. + */ +void +output_upper (char *s) +{ + char ch, *p; + + outstr(s); + for (p=type_string; (ch = *p) != EOS; p++) + output(toupper(ch)); +} + + +/* PASS_THROUGH -- Used to pass text on to the output without modification. + * The text is delimited as "$/ (text) /" in the input file. The delimited + * section may enclose newlines. + */ +void +pass_through (void) +{ + char ch; + + while ((ch = input()) != '/') + output(ch); +} + + +/* DO_FOR -- Process a "$FOR (types)" statement. The sequence of statements + * bracketed by $for ... $endfor will be processed and output (to a single + * output stream) for each datatype named in the for predicate. + */ +void +do_for (void) +{ + register char *op; + register int ch; + register struct _for *fp; + char types[20]; + + if (++forlev + 1 >= SZ_FORSTK) { + fprintf (stderr, "$for statements nested too deeply\n"); + exit (OSOK+1); + } + + /* Extract list of types. + */ + while ((ch = input()) != '(') + if (ch == EOF || ch == '\n') { + fprintf (stderr, "$for must have () delimited list of types\n"); + strcpy (types, "i"); + goto init_; + } + + for (op=types; (ch = input()) != ')'; op++) + if (ch == EOF || ch == '\n') { + fprintf (stderr, "missing right paren in $for statement\n"); + break; + } else + *op = ch; + + *op = EOS; + if (op == types) { + fprintf (stderr, "null typelist in $for statement\n"); + strcpy (types, "i"); + } + +init_: + fp = &forstk[forlev]; + fp->f_prevtype = type_char; + strcpy (fp->f_types, types); + fp->f_curtype = fp->f_types; + fp->f_fpos = k_ftell (yyin); + + type_char = *(fp->f_curtype)++; + set_type_string (type_char); +} + + +/* DO_ENDFOR -- Called to process a $ENDFOR. Set the next datatype and seek + * back to the line following the matching $FOR statement. When the type list + * is exhausted pop the $for stack and continue normal processing. + */ +void +do_endfor (void) +{ + register struct _for *fp; + + if (forlev < 0) { + fprintf (stderr, "$endfor with no matching $for\n"); + return; + } + + fp = &forstk[forlev]; + if ((type_char = *(fp->f_curtype)++) != EOS) { + set_type_string (type_char); + k_fseek (yyin, fp->f_fpos, 0); + } else { + type_char = fp->f_prevtype; + set_type_string (type_char); + --forlev; + } +} + + +/* + * Conditional Compilation + * ------------------------- + */ + +#define TRUE 1 +#define FALSE 0 +#define EQ 0 +#define NE 1 +#define LE 2 +#define LT 3 +#define GE 4 +#define GT 5 + +char expr_buf[80], *expr; +int level = 0; + +struct if_stack { + int oldstate; + int active; +} stk[MAXNEST]; + + +/* DO_IF -- Process a $IF statement. Evaluate the predicate and push a + * pass or stop output flag on the if stack. + */ +void +do_if (void) +{ + char ch; + int expr_value; + struct if_stack *p; + + level += 1; + p = &stk[level]; + p->oldstate = pass_output; + p->active = (pass_output == TRUE); + + if ((expr_value = evaluate_expr()) == ERR) + expr_value = FALSE; + + if ((ch = input()) != '\n') + unput(ch); + + if (p->active == FALSE) + return; + else if (expr_value == FALSE) + pass_output = FALSE; +} + + +/* DO_ELSE -- Process a $ELSE statement. Toggle the pass/stop output flag + * on top of the if stack. + */ +void +do_else (void) +{ + char ch; + + if (level == 0) + fprintf (stderr, "Unmatched $else statement\n"); + else if (stk[level].active) /* toggle pass_output */ + pass_output = (pass_output == FALSE); + + if ((ch = input()) != '\n') + unput(ch); +} + + +/* DO_ENDIF -- Process a $ENDIF statement. Pop the if stack. + */ +void +do_endif (void) /* $endif statement */ +{ + char ch; + + if (level == 0) + fprintf (stderr, "Too many $endif statements\n"); + else + pass_output = stk[level--].oldstate; + + if ((ch = input()) != '\n') + unput(ch); +} + + +/* EVALUATE_EXPR -- Kludge to evaluate boolean expressions in $if statements. + * Two kinds of expressions are permitted: (datatype relop chars), or + * (sizeof(char) relop sizeof(char)), where relop = (==, !=, <= etc.). + * + * Examples: $if (datatype != dx) + * (code to be compiled if type not d or x) + * + * $if (sizeof(i) <= sizeof(r)) + * (code to be compiled if size int <= real) + */ +int +evaluate_expr (void) +{ + char ch=0, *p, *index(); + int lpar, size1, size2, op; + + + /* Advance to start of expression (discard '(') */ + if (nextch() != '(') + goto err; + else + input(); + + /* Extract expression string into buffer */ + expr = expr_buf; + nextch(); + + for (p=expr_buf, lpar=1; lpar > 0 && (*p = input()) != EOF; p++) + switch (ch = *p) { + case '(': + lpar++; + break; + case ')': + if (--lpar == 0) + *p = EOS; + break; + case '\n': + goto err; + } + + /* Is current type in set or not in set */ + if (strncmp (expr,"datatype",8) == 0) { + expr += 8; + switch (relop()) { + case EQ: + return (index(expr,type_char) != NULL); + case NE: + return (index(expr,type_char) == NULL); + default: + goto err; + } + + /* Compare sizes of two data types */ + } else if (strncmp(expr,"sizeof",6) == 0) { + if (parse_relational (&size1, &size2, &op) == ERR) { + ch = 0; + goto err; + } + switch (op) { + case EQ: + return (size1 == size2); + case NE: + return (size1 != size2); + case LE: + return (size1 <= size2); + case LT: + return (size1 < size2); + case GE: + return (size1 >= size2); + case GT: + return (size1 > size2); + } + + /* only "type" and "sizeof" are implemented */ + } else { +err: fprintf (stderr, "Syntax error in $if statement\n"); + if (ch != '\n') { + /* skip rest of line */ + while ((ch = input()) != '\n') + ; + unput(ch); + } + } + + return (ERR); +} + + +/* PARSE_RELATIONAL -- Parse "sizeof(t1) relop sizeof(t2)" (via brute force...) */ +int +parse_relational (int *size1, int *size2, int *op) +{ + expr += 6; /* ... (t1) */ + + if (gch() != '(') + return (ERR); + if ((*size1 = gsize(gch())) == ERR) + return (ERR); + if (gch() != ')') + return (ERR); /* relop */ + if ((*op = relop()) == ERR) + return (ERR); + + uch (gch()); /* skip whitespace */ + + if (strncmp(expr,"sizeof",6) != 0) /* sizeof(t2) */ + return (ERR); + + expr += 6; + + if (gch() != '(') + return (ERR); + if ((*size2 = gsize(gch())) == ERR) + return (ERR); + if (gch() != ')') + return (ERR); + + return (OK); +} + + +/* RELOP -- Return a code for the next relational operator token in the input + * stream. + */ +int +relop (void) +{ + char ch; + + + switch (gch()) { + case '!': + if (gch() == '=') + return (NE); + return (ERR); + case '=': + if (gch() == '=') + return (EQ); + return (ERR); + case '<': + if ((ch = gch()) == '=') + return (LE); + uch(ch); + return (LT); + case '>': + if ((ch = gch()) == '=') + return (GE); + uch(ch); + return (GT); + default: + return (ERR); + } +} + + +/* GSIZE -- Return the size of a datatype given its character code. + */ +int +gsize (char ch) +{ + switch (ch) { + case 'B': + return (sizeof(XUBYTE)); + case 'U': + return (sizeof(XUSHORT)); + case 't': + return (gsize(type_char)); + case 'c': + return (sizeof(XCHAR)); + case 's': + return (sizeof(XSHORT)); + case 'i': + return (sizeof(XINT)); + case 'l': + return (sizeof(XLONG)); + case 'r': + return (sizeof(XREAL)); + case 'd': + return (sizeof(XDOUBLE)); + case 'x': + return (sizeof(XCOMPLEX)); + case 'p': + return (sizeof(XPOINTER)); + default: + return (ERR); + } +} + + +/* NEXTCH -- Advance to next non-whitespace character. + */ +char +nextch (void) +{ + char ch; + + for (ch=input(); ch == ' ' || ch == '\t'; ch=input()) + ; + unput (ch); + return (ch); +} + + +/* GCH -- Get next nonwhite char from expression buffer. + */ +char +gch (void) +{ + while (*expr == ' ' || *expr == '\t') + expr++; + + if (*expr != EOS) + return (*expr++); + else + return (EOS); +} + + +/* UCH -- Put char back into expression buffer. + */ +void +uch (char ch) +{ + *--expr = ch; +} + + +/* OUTPUT -- Write a single character to the output file, if output is + * currently enabled (else throw it away). + */ +void +output (char ch) +{ + if (pass_output) + putc (ch, yyout); +} + + +/* OUTSTR -- Output a string. + */ +void +outstr (char *s) +{ + if (pass_output) + fputs (s, yyout); +} diff --git a/unix/boot/generic/generic.hlp b/unix/boot/generic/generic.hlp new file mode 100644 index 00000000..eda8ceb2 --- /dev/null +++ b/unix/boot/generic/generic.hlp @@ -0,0 +1,245 @@ +.help generic Feb86 softools +.ih +NAME +generic -- generic preprocessor +.ih +USAGE +generic [-k] [-o ofile] [-p prefix] [-t types] files +.ih +PARAMETERS +.ls 4 -k +Allow the output files generated by \fIgeneric\fR to clobber any existing +files. +.le +.ls 4 -o ofile +The name of the output file. If this option is selected, only a single +file can be processed. +.le +.ls 4 -p prefix +A prefix to be prepended to the output filenames. This is useful when +the output files are to be placed in a different directory. +.le +.ls 4 -t types +The datatypes for which output is desired. One output file will be generated +for each type specified, with \fIgeneric\fR automatically generating the +output filename by appending the type character to the root filename of +the input file. The \fItype\fR string is some subset of [ubscilrdx], +where the type characters are as follows. +.ls +.nf +u - C unsigned short +b - C byte (char) +c - SPP character +s - SPP short +i - SPP int +l - SPP long +r - SPP real +d - SPP double +x - SPP complex +.fi +.le + +This option cannot be used in combination with the -o option, and should +not be used when generic code is expanded inline, rather than written into +multiple output files. +.le +.ls 4 files +The input file or files to be processed. Generic input files should have +the extension ".gx" or ".gc", although this is not required. Only a single +input file can be given if the -o option is specified. +.le +.ih +DESCRIPTION +The generic preprocessor is used to translate generic source code (code +written to work for any datatype) into type dependent source code, +suitable for compilation and insertion into a library. The generic source +is translated for each datatype, producing a type dependent copy of the +source code for each datatype. There are two primary modes of operation: + +.ls +.ls [1] +The generic source is embedded in a normal file, bracketed by \fI$for\fR and +\fI$endfor\fR directives. There is one input file and one somewhat larger +output file, with the generic code in the input file being replaced in the +output file by several copies of the enclosed source, one for each datatype. +This mode is most commonly used for modules to be linked in their entirety +into an applications package. The "-o" parameter is used to specify +the output filename. +.le +.ls [2] +The entire input file is generic. There may be multiple input files, and +for each input file N output files are generated, one for each datatype +specified with the "-t" parameter. The output filenames are automatically +generated by appending the type character to the root filename of the +input file. This mode is most commonly used for object libraries. +.le +.le + + +The generic preprocessor operates by token replacement (currently using a +UNIX \fILex\fR lexical analyzer). The input stream is broken up into a +stream of tokens. Each token is examined to see if it is in the following +list, and the indicated action is taken if the token is matched. The generic +preprocessor directives have the form "$NAME", where $ marks a \fIgeneric\fR +directive, and where NAME is the name of the directive. +.ls 10 PIXEL +Replaced by the current type name, e.g., "int", "real", etc. +.le +.ls 10 XPIXEL +Replaced by the current type name in upper case, preceded by an X, +e.g., "XINT", "XREAL", etc. This is used for generic C procedures meant +to be called from SPP or Fortran. +.le +.ls 10 INDEF +Replaced by the numeric constant denoting indefinite for the current +datatype. +.le +.ls 10 INDEF[SILRDX] +These strings are \fInot\fR replaced, since the "INDEF" in this case is +not generic. +.le +.ls 10 SZ_PIXEL +Replaced by "SZ_INT", "SZ_REAL", etc. +.le +.ls 10 TY_PIXEL +Replaced by "TY_INT", "TY_REAL", etc. +.le +.ls 10 $PIXEL +Replaced by the string "PIXEL". This is used in doubly generic sources, +where the first pass translates $PIXEL to PIXEL, and the second to the +actual type string. +.le +.ls 10 $INDEF +Replaced by the string "INDEF". +.le +.ls 10 $t +Replaced by one of the characters [ubcsilrdx]. +.le +.ls 10 $T +Replaced by one of the characters [UBCSILRDX]. +.le +.ls 10 $/.../ +Replaced by the string "...", i.e., whatever is within the // delimiters. +Used to disable generic preprocessing of arbitrary text. +.le +.ls 10 [0-9]+("$f"|"$F") +Replaced by the corresponding real or double constant. For example, +"1$f" translates as "1.0" for type real, but as "1.0D0" for type double. +.le + +.ls 10 $if (expression) +The conditional preprocessing facility. If the $IF tests false the code +which follows is skipped over, and is not copied to the output file. +Control transfers to the matching $ELSE or $ENDIF. The following may be +used in the boolean expression: + +.nf +"datatype" denotes the current type +ubcsilrdx any subset of these characters denotes + the corresponding datatype +sizeof() the size of the specified type, + e.g., for comparisons + +!= == the relational operators + > < >= <= + + +Examples: + + $if (datatype != dx) + (code to be compiled if type not d or x) + + $if (sizeof(i) <= sizeof(r)) + (code to be compiled if size int <= real) +.fi + +$IF constructs may be nested. The directive may appear anywhere on +a line. +.le + +.ls 10 $else +Marks the else clause of a $IF. +.le +.ls 10 $endif +Marks the end of a $IF. One is required for every $IF. +.le +.ls 10 $for (types) +For each of the listed types, output a translated copy of the code between +the $FOR and the matching $ENDFOR. Nesting is permitted. + +.nf +Example: + $for (silrd) + (any amount of generic code) + $endfor +.fi +.le +.ls 10 $endfor +Marks the end of a $FOR statement. +.le +.ls 10 $$ +Replaced by a single $. +.le +.ls 10 /*...*/ +C comments are not preprocessed. +.le +.ls 10 "..." +Quoted strings are not preprocessed. +.le +.ls 10 #...(EOL) +SPP comments are not preprocessed. +.le +.ls 10 %...(EOL) +SPP Fortran escapes are not preprocessed. +.le +.ih +EXAMPLES +1. Translate the generic source "aadd.gx" to produce the six output files +"aadds.x", "aaddi.x", etc., in the subdirectory "ak", clobbering any +existing files therein. The \fIgeneric\fR task is a bootstrap utility +written in C and is implemented as a CL foreign task, hence the UNIX +command syntax. + + cl> generic -k -p ak/ -t silrdx aadd.gx + +2. Perform an inline transformation ($FOR directive) of the source file +"imsum.gx", producing the single file "imsum.x" as output. + + cl> generic -k -o imsum.x imsum.gx + +3. The following is a simple example of a typical generic source file. +For additional examples, see the ".gx" sources in the VOPS, IMIO, IMAGES +and other directories. + +.nf +# ALIM -- Compute the limits (minimum and maximum values) of a vector. +# (this is a copy of the file vops$alim.gx). + +procedure alim$t (a, npix, minval, maxval) + +PIXEL a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + $if (datatype == x) + if (abs(value) < abs(minval)) + minval = value + else if (abs(value) > abs(maxval)) + maxval = value + $else + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + $endif + } +end +.fi +.ih +SEE ALSO +xc, xyacc diff --git a/unix/boot/generic/lex.sed b/unix/boot/generic/lex.sed new file mode 100644 index 00000000..56df4751 --- /dev/null +++ b/unix/boot/generic/lex.sed @@ -0,0 +1,7 @@ +/int nstr; extern int yyprevious;/a\ +if (yyin==NULL) yyin = stdin;\ +if (yyout==NULL) yyout = stdout; +/{stdin}/c\ +FILE *yyin, *yyout; +s/"stdio.h"// +s/getc/k_getc/ diff --git a/unix/boot/generic/lexyy.c b/unix/boot/generic/lexyy.c new file mode 100644 index 00000000..6cda8553 --- /dev/null +++ b/unix/boot/generic/lexyy.c @@ -0,0 +1,679 @@ +# include +# 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):k_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, *yyout; +extern int yylineno; +struct yysvf { + struct yywork *yystoff; + struct yysvf *yyother; + int *yystops;}; +struct yysvf *yyestate; +extern struct yysvf yysvec[], *yybgin; + +#include + +/* + * GENERIC -- This filter takes a file containing a generic operator as input + * and generates as output either a set of files, one for each of the data + * types in the generic family, or a single file wherein the generic section + * has been duplicated for each case. + */ + +#undef output +extern char *type_string; +extern char xtype_string[]; +extern char type_char; + +# define YYNEWLINE 10 +yylex(){ +int nstr; extern int yyprevious; +if (yyin==NULL) yyin = stdin; +if (yyout==NULL) yyout = stdout; +while((nstr = yylook()) >= 0) +yyfussy: switch(nstr){ +case 0: +if(yywrap()) return(0); break; +case 1: + outstr (type_string); +break; +case 2: + outstr (xtype_string); +break; +case 3: + output_indef (type_char); +break; +case 4: + ECHO; +break; +case 5: + output_upper ("SZ_"); +break; +case 6: + output_upper ("TY_"); +break; +case 7: + outstr ("PIXEL"); +break; +case 8: + outstr ("INDEF"); +break; +case 9: + { + yytext[strlen(yytext)-5] = '\0'; + output_upper (yytext); + } +break; +case 10: + { if (isupper (type_char)) + output (tolower (type_char)); + else + output (type_char); + } +break; +case 11: + { if (islower (type_char)) + output (toupper (type_char)); + else + output (type_char); + } +break; +case 12: + pass_through(); +break; +case 13: + make_float (type_char); +break; +case 14: + do_if(); +break; +case 15: + do_else(); +break; +case 16: + do_endif(); +break; +case 17: + do_for(); +break; +case 18: + do_endfor(); +break; +case 19: + do_if(); +break; +case 20: + do_else(); +break; +case 21: + do_endif(); +break; +case 22: + do_for(); +break; +case 23: + do_endfor(); +break; +case 24: + output ('$'); +break; +case 25: + copy_comment(); +break; +case 26: + copy_string(); +break; +case 27: + ECHO; +break; +case 28: + ECHO; +break; +case 29: + ECHO; +break; +case 30: + ECHO; +break; +case 31: + copy_line(); +break; +case 32: + copy_line(); +break; +case -1: +break; +default: +fprintf(yyout,"bad switch yylook %d",nstr); +} return(0); } +/* end of yylex */ + + +/* LEX_INPUT -- Make input() callable as a function from the .c code. + */ +lex_input() +{ + return (input()); +} + + +/* LEX_UNPUT -- Make unput() callable as a function from the .c code. + */ +lex_unput (ch) +int ch; +{ + unput (ch); +} +int yyvstop[] = { +0, + +26, +0, + +31, +0, + +31, +0, + +32, +0, + +24, +0, + +12, +0, + +11, +0, + +10, +0, + +25, +0, + +19, +0, + +14, +0, + +13, +0, + +27, +0, + +22, +0, + +17, +0, + +20, +0, + +15, +0, + +3, +0, + +1, +0, + +28, +0, + +21, +0, + +8, +0, + +7, +0, + +16, +0, + +9, +0, + +4, +0, + +2, +9, +0, + +29, +0, + +23, +0, + +18, +0, + +5, +9, +0, + +6, +9, +0, + +30, +0, +0}; +# define YYTYPE char +struct yywork { YYTYPE verify, advance; } yycrank[] = { +0,0, 0,0, 0,0, 0,0, +0,0, 0,0, 0,0, 0,0, +0,0, 0,0, 1,3, 0,0, +0,0, 0,0, 0,0, 0,0, +3,3, 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, 1,3, 0,0, 1,4, +1,5, 1,6, 2,15, 3,3, +2,16, 0,0, 0,0, 3,17, +7,29, 0,0, 0,0, 0,0, +1,7, 1,8, 1,8, 1,8, +1,8, 1,8, 1,8, 1,8, +1,8, 1,8, 1,8, 0,0, +0,0, 0,0, 0,0, 0,0, +0,0, 0,0, 1,9, 1,9, +1,9, 1,9, 1,9, 1,9, +1,9, 1,9, 1,10, 1,9, +1,9, 1,9, 1,9, 1,9, +1,9, 1,11, 1,9, 1,9, +1,12, 1,13, 1,9, 1,9, +1,9, 1,14, 1,9, 1,9, +6,18, 8,30, 10,32, 11,33, +12,34, 13,35, 14,36, 20,40, +21,42, 20,41, 23,45, 6,19, +27,49, 8,8, 8,8, 8,8, +8,8, 8,8, 8,8, 8,8, +8,8, 8,8, 8,8, 15,37, +17,20, 17,21, 26,48, 15,38, +17,39, 25,46, 22,43, 25,47, +30,50, 6,20, 6,21, 31,51, +32,52, 6,22, 22,44, 33,53, +34,54, 35,55, 36,56, 37,57, +6,23, 37,58, 38,59, 39,43, +6,24, 40,61, 41,62, 42,63, +44,64, 45,65, 38,60, 46,66, +17,25, 17,26, 47,67, 48,68, +17,27, 51,69, 52,70, 53,71, +30,50, 6,25, 6,26, 54,72, +55,73, 6,27, 56,74, 57,75, +58,76, 60,77, 61,78, 62,79, +64,81, 65,82, 62,80, 66,83, +6,28, 9,9, 9,9, 9,9, +9,9, 9,9, 9,9, 9,9, +9,9, 9,9, 9,9, 9,9, +9,9, 9,9, 9,9, 9,9, +9,31, 9,9, 9,9, 9,9, +9,9, 9,9, 9,9, 9,9, +9,9, 9,9, 9,9, 67,84, +69,86, 70,87, 67,85, 9,9, +71,88, 72,89, 73,90, 74,91, +75,92, 76,93, 77,94, 79,95, +80,96, 81,97, 82,98, 84,99, +85,100, 86,101, 87,102, 89,103, +90,104, 91,105, 93,106, 87,102, +94,107, 95,108, 87,102, 99,109, +103,110, 104,111, 107,112, 110,113, +87,102, 87,102, 111,114, 112,115, +0,0, 0,0, 87,102, 0,0, +0,0}; +struct yysvf yysvec[] = { +0, 0, 0, +yycrank+1, 0, 0, +yycrank+3, yysvec+1, 0, +yycrank+7, 0, 0, +yycrank+0, 0, yyvstop+1, +yycrank+0, 0, yyvstop+3, +yycrank+56, 0, 0, +yycrank+2, 0, 0, +yycrank+57, 0, 0, +yycrank+108, 0, 0, +yycrank+16, yysvec+9, 0, +yycrank+22, yysvec+9, 0, +yycrank+6, yysvec+9, 0, +yycrank+8, yysvec+9, 0, +yycrank+18, yysvec+9, 0, +yycrank+14, 0, yyvstop+5, +yycrank+0, 0, yyvstop+7, +yycrank+47, 0, 0, +yycrank+0, 0, yyvstop+9, +yycrank+0, 0, yyvstop+11, +yycrank+23, 0, 0, +yycrank+21, 0, 0, +yycrank+52, 0, 0, +yycrank+29, 0, 0, +yycrank+0, 0, yyvstop+13, +yycrank+13, 0, 0, +yycrank+7, 0, 0, +yycrank+2, 0, 0, +yycrank+0, 0, yyvstop+15, +yycrank+0, 0, yyvstop+17, +yycrank+54, 0, 0, +yycrank+54, yysvec+9, 0, +yycrank+60, yysvec+9, 0, +yycrank+43, yysvec+9, 0, +yycrank+37, yysvec+9, 0, +yycrank+38, yysvec+9, 0, +yycrank+61, yysvec+9, 0, +yycrank+27, 0, 0, +yycrank+36, 0, 0, +yycrank+69, 0, 0, +yycrank+58, 0, 0, +yycrank+74, 0, 0, +yycrank+61, 0, 0, +yycrank+0, 0, yyvstop+19, +yycrank+76, 0, 0, +yycrank+57, 0, 0, +yycrank+32, 0, 0, +yycrank+50, 0, 0, +yycrank+37, 0, 0, +yycrank+0, 0, yyvstop+21, +yycrank+0, 0, yyvstop+23, +yycrank+65, yysvec+9, 0, +yycrank+85, yysvec+9, 0, +yycrank+86, yysvec+9, 0, +yycrank+79, yysvec+9, 0, +yycrank+80, yysvec+9, 0, +yycrank+74, yysvec+9, 0, +yycrank+48, 0, 0, +yycrank+64, 0, 0, +yycrank+0, 0, yyvstop+25, +yycrank+66, 0, 0, +yycrank+97, 0, 0, +yycrank+97, 0, 0, +yycrank+0, 0, yyvstop+27, +yycrank+99, 0, 0, +yycrank+100, 0, 0, +yycrank+70, 0, 0, +yycrank+97, 0, 0, +yycrank+0, 0, yyvstop+29, +yycrank+131, yysvec+9, 0, +yycrank+131, yysvec+9, 0, +yycrank+128, yysvec+9, 0, +yycrank+132, yysvec+9, 0, +yycrank+133, yysvec+9, 0, +yycrank+138, yysvec+9, 0, +yycrank+107, 0, 0, +yycrank+104, 0, 0, +yycrank+102, 0, 0, +yycrank+0, 0, yyvstop+31, +yycrank+132, 0, 0, +yycrank+142, 0, 0, +yycrank+143, 0, 0, +yycrank+138, 0, 0, +yycrank+0, 0, yyvstop+33, +yycrank+104, 0, 0, +yycrank+114, 0, 0, +yycrank+141, yysvec+9, 0, +yycrank+150, yysvec+9, yyvstop+35, +yycrank+0, yysvec+9, yyvstop+37, +yycrank+131, yysvec+9, 0, +yycrank+132, yysvec+9, 0, +yycrank+145, yysvec+9, 0, +yycrank+0, 0, yyvstop+39, +yycrank+120, 0, 0, +yycrank+107, 0, 0, +yycrank+143, 0, 0, +yycrank+0, 0, yyvstop+41, +yycrank+0, 0, yyvstop+43, +yycrank+0, 0, yyvstop+45, +yycrank+113, 0, 0, +yycrank+0, 0, yyvstop+47, +yycrank+0, yysvec+9, yyvstop+49, +yycrank+0, yysvec+9, yyvstop+51, +yycrank+159, yysvec+9, 0, +yycrank+160, yysvec+9, 0, +yycrank+0, yysvec+9, yyvstop+53, +yycrank+0, 0, yyvstop+56, +yycrank+130, 0, 0, +yycrank+0, 0, yyvstop+58, +yycrank+0, 0, yyvstop+60, +yycrank+155, yysvec+9, 0, +yycrank+158, yysvec+9, 0, +yycrank+134, 0, 0, +yycrank+0, yysvec+9, yyvstop+62, +yycrank+0, yysvec+9, yyvstop+65, +yycrank+0, 0, yyvstop+68, +0, 0, 0}; +struct yywork *yytop = yycrank+238; +struct yysvf *yybgin = yysvec+1; +char yymatch[] = { +00 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,011 ,01 ,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 ,01 ,01 , +'0' ,'0' ,'0' ,'0' ,'0' ,'0' ,'0' ,'0' , +'0' ,'0' ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' , +'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' , +'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' , +'A' ,'A' ,'A' ,01 ,01 ,01 ,01 ,'_' , +01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,01 ,01 ,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/unix/boot/generic/mkpkg.sh b/unix/boot/generic/mkpkg.sh new file mode 100644 index 00000000..5ab35c4d --- /dev/null +++ b/unix/boot/generic/mkpkg.sh @@ -0,0 +1,18 @@ +# Bootstrap the generic preprocessor. The -lln library is not used to avoid +# the enternal dependency. The sed script is used to edit certain nonportable +# constructs in the LEX code, and the filename lex.yy.c is changed to lexyy.c +# for portability reasons. + +find tok.l -newer lexyy.c -exec rm lexyy.c \; +if test -f lexyy.c; then\ + $CC -c $HSI_CF -w lexyy.c;\ +else\ + lex tok.l;\ + sed -f lex.sed lex.yy.c > lexyy.c; rm lex.yy.c;\ + $CC -c $HSI_CF -w lexyy.c;\ +fi + +$CC -c $HSI_CF generic.c chario.c yywrap.c +$CC $HSI_LF generic.o lexyy.o chario.o yywrap.o $HSI_LIBS -o generic.e +mv -f generic.e ../../hlib +rm *.o diff --git a/unix/boot/generic/tok.l b/unix/boot/generic/tok.l new file mode 100644 index 00000000..f72c1bb8 --- /dev/null +++ b/unix/boot/generic/tok.l @@ -0,0 +1,91 @@ +%{ + +#include + +/* + * GENERIC -- This filter takes a file containing a generic operator as input + * and generates as output either a set of files, one for each of the data + * types in the generic family, or a single file wherein the generic section + * has been duplicated for each case. + */ + +#undef output +extern char *type_string; +extern char xtype_string[]; +extern char type_char; + +%} + +W [ \t] + +%% + +PIXEL outstr (type_string); +XPIXEL outstr (xtype_string); +INDEF output_indef (type_char); +INDEF(S|I|L|R|D|X) ECHO; +SZ_PIXEL output_upper ("SZ_"); +TY_PIXEL output_upper ("TY_"); +$PIXEL outstr ("PIXEL"); +$INDEF outstr ("INDEF"); + +[A-Z][A-Z_]*PIXEL { + yytext[strlen(yytext)-5] = '\0'; + output_upper (yytext); + } + +"$t" { if (isupper (type_char)) + output (tolower (type_char)); + else + output (type_char); + } +"$T" { if (islower (type_char)) + output (toupper (type_char)); + else + output (type_char); + } + +"$/" pass_through(); +[0-9]+("$f"|"$F") make_float (type_char); + +{W}*"$if" do_if(); +{W}*"$else" do_else(); +{W}*"$endif" do_endif(); +{W}*"$for" do_for(); +{W}*"$endfor" do_endfor(); +{W}*"$IF" do_if(); +{W}*"$ELSE" do_else(); +{W}*"$ENDIF" do_endif(); +{W}*"$FOR" do_for(); +{W}*"$ENDFOR" do_endfor(); + +"$$" output ('$'); +"/*" copy_comment(); +\" copy_string(); + +^\#if ECHO; +^\#else ECHO; +^\#endif ECHO; +^\#include ECHO; + +\# copy_line(); +^\% copy_line(); + +%% + + +/* LEX_INPUT -- Make input() callable as a function from the .c code. + */ +lex_input() +{ + return (input()); +} + + +/* LEX_UNPUT -- Make unput() callable as a function from the .c code. + */ +lex_unput (ch) +int ch; +{ + unput (ch); +} diff --git a/unix/boot/generic/yywrap.c b/unix/boot/generic/yywrap.c new file mode 100644 index 00000000..627dff08 --- /dev/null +++ b/unix/boot/generic/yywrap.c @@ -0,0 +1,10 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* YYWRAP -- Called by lex when end of file is seen. + */ +int +yywrap() +{ + return (1); +} diff --git a/unix/boot/generic/z b/unix/boot/generic/z new file mode 100644 index 00000000..91a515fe --- /dev/null +++ b/unix/boot/generic/z @@ -0,0 +1,20 @@ +# Bootstrap the generic preprocessor. The -lln library is not used to avoid +# the enternal dependency. The sed script is used to edit certain nonportable +# constructs in the LEX code, and the filename lex.yy.c is changed to lexyy.c +# for portability reasons. + +find tok.l -newer lexyy.c -exec rm lexyy.c \; +if test -f lexyy.c; then\ + $CC -c $HSI_CF -w lexyy.c;\ +else\ + lex tok.l;\ + sed -f lex.sed lex.yy.c > lexyy.c; rm lex.yy.c;\ + $CC -c $HSI_CF -w lexyy.c;\ +fi + +$CC -c -g $HSI_CF generic.c chario.c yywrap.c +$CC $HSI_LF generic.o lexyy.o chario.o yywrap.o $HSI_LIBS -o generic.e + + +echo "Running .... " +./generic.e -k -t csilrdx /tmp/acht.gx diff --git a/unix/boot/mkpkg.sh b/unix/boot/mkpkg.sh new file mode 100644 index 00000000..1ad069c1 --- /dev/null +++ b/unix/boot/mkpkg.sh @@ -0,0 +1,21 @@ +# Bootstrap the bootstrap utilities. The logical directory hlib$ should be +# defined for the cshell when this is run. + +echo "----------------------- BOOTLIB ------------------------" +(cd bootlib; sh -x mkpkg.sh) +echo "----------------------- GENERIC ------------------------" +(cd generic; sh -x mkpkg.sh) +echo "----------------------- MKPKG --------------------------" +(cd mkpkg; sh -x mkpkg.sh) +echo "----------------------- RMBIN -------------------------" +(cd rmbin; sh -x mkpkg.sh) +echo "----------------------- RMFILES -----------------------" +(cd rmfiles; sh -x mkpkg.sh) +echo "----------------------- RTAR --------------------------" +(cd rtar; sh -x mkpkg.sh) +echo "----------------------- WTAR --------------------------" +(cd wtar; sh -x mkpkg.sh) +echo "----------------------- SPP ----------------------------" +(cd spp; sh -x mkpkg.sh) +echo "----------------------- XYACC --------------------------" +(cd xyacc; sh -x mkpkg.sh) diff --git a/unix/boot/mkpkg/README b/unix/boot/mkpkg/README new file mode 100644 index 00000000..999d154c --- /dev/null +++ b/unix/boot/mkpkg/README @@ -0,0 +1,54 @@ +MKPKG -- Package maintenance utility. + + The MKPKG utility is used to maintain the IRAF system libraries as well +as the system executables and the applications packages. The file "mkpkg.csh" +in this directory will make and install the initial mkpkg.e executable. +The libraries lib$libboot.a and lib$libos.a must have been made first. +Once MKPKG is up it can be used to remake itself. + + +NOTES + + The MKPKG utility is used to keep libraries and/or packages up to date. +The dates of the library modules are compared to the corresponding SOURCE +(not object) files in the directories contributing to the library. +Any source files newer than their corresponding library modules are +compiled and the library is updated. Note that the sources contributing +to the library may reside in multiple subdirectories as well as in the +current directory. Each source file may depend on zero or more other files. +If any of these files are newer than the source file, the source file is +recompiled and replaced in the library. + +MKPKG is built upon a preprocessor front end providing macro replacement +and conditional interpretation facilities. These facilities, in combination +with the OS escape mechanism used to send commands to the host system, +make it possible to use MKPKG for more than just updating libraries. + +As far as possible, the system dependent functions required by MKPKG have +been isolated and placed in separate small files. The bulk of the code is +machine independent. Additional system dependent functions are provided +by the BOOTLIB library (LIBBOOT) and by the IRAF kernel (LIBOS). The MKPKG +specific functions required are the following: + + [1] Given the NAME of a source file, return the date of the + corresponding object module in a library. + [2] Replace (or add) a series of object modules in a library, + creating the library if it does not already exist. + [3] "Rebuild" the library after all updates are complete. + +The library functions are normally implemented by formatting a command +for the host librarian utility and sending it to the host with the ZOSCMD +utility. Note that an entire command script can be built in a temporary +file if the ZOSCMD interface is too inefficient for multiple small calls +on your system. + +All filenames in the portable code (and in the Makelib files) are in the +IRAF format, which is very similar to UNIX format. Do not change the high +level code to manipulate host system filenames directly. All filename +mapping should be performed in the host interface code; the VFN2OSFN +function is convenient to use for this purpose. + +For simplicity, most buffers are fixed in size. Dynamically allocating +everything is less efficient and is not warranted since the memory +requirements of this program are modest. If a buffer overflows simply +increase the allocation below and remake mkpkg. diff --git a/unix/boot/mkpkg/char.c b/unix/boot/mkpkg/char.c new file mode 100644 index 00000000..9532dfd6 --- /dev/null +++ b/unix/boot/mkpkg/char.c @@ -0,0 +1,478 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "mkpkg.h" +#include "extern.h" + +/* + * CHAR.C -- Character functions, character i/o. + */ + +/* M_GETC -- Get a (possibly pushed back) character from the mkpkgfile + * associated with the given context. If the sequence $( is encountered + * in the input, fetch the value of the named macro and push it back into + * the input stream and continue scanning. Implementing recursive macro + * expansion at this low level permits the use of macros in any part of + * the input except comments. + */ +int +m_getc (register struct context *cx) +{ + register int ch, nch; + register char *op; + char name[SZ_FNAME+1], *val; + char lbuf[SZ_CMD+1]; + + while ((ch = m_rawgetc (cx)) == '$') { + /* Check for the escape sequence "$$" and return the literal $ + * if this is seen. Also return if $ is seen but the next char + * is not left paren ("$(..)" is a macro reference). + */ + nch = m_rawgetc (cx); + if (nch == '$') + return (nch); + else if (nch != '(') { + m_ungetc (nch, cx); + break; + } + + /* Extract the name of the macro from the input stream. + */ + for (op=name; (*op = m_rawgetc(cx)) != ')'; op++) + if (*op == '\n' || *op == EOF) { + *op = EOS; + warns ("missing right paren in $(M) macro reference: `%s'", + name); + *op++ = '\n'; + *op = EOS; + val = name; + goto push; + break; + } + *op = EOS; + + /* If the symbol name is prefixed by a question mark, e.g., $(?sym), + * query for the symbol and read the value from the standard input. + * If the syntax is "$(@file)" return the contents of the named + * file as the value of the macro reference. Otherwise look in + * the symbol table and then in the environment for the named + * symbol. If the symbol cannot be found in either place push + * its name and hope for the best. + */ + if (name[0] == '?') { + /* Interactive query. */ + if ((cx->fp == stdin)) { + warns ("`$(%s)': cannot query in -f stdin mode", name); + val = &name[1]; + } else { + printf ("%s: ", &name[1]); + fflush (stdout); + if (fgets (lbuf, SZ_CMD, stdin) == NULL) + strcpy (lbuf, name); + if ((val = index (lbuf, '\n'))) + *val = EOS; + val = lbuf; + } + } else if (name[0] == '@') { + /* Return contents of a file. */ + FILE *fp; + int ch, n; + + if ((fp = fopen (&name[1], "r")) == NULL) { + warns ("`$(%s)': cannot open file", name); + val = &name[1]; + } else { + for (n=SZ_CMD,op=lbuf; --n >= 0 && (ch=getc(fp)) != EOF; ) + *op++ = isspace(ch) ? ' ' : ch; + while (op > lbuf) { + ch = *(op-1); + if (isspace (ch)) + --op; + else + break; + } + *op = EOS; + val = lbuf; + fclose (fp); + } + + } else if ((val = getsym (name)) == NULL) { + if ((val = os_getenv (name)) == NULL) { + warns ("macro `%s' not found", name); + val = name; + } + } +push: + if (debug > 1) { + printf ("pushback macro `%s' = `%s'\n", name, val); + fflush (stdout); + } + + m_pushstr (cx, val); + } + + /* Get rid of the tabs once and for all. + */ + return ((ch == '\t') ? ' ' : ch); +} + + + +/* M_RAWGETC -- Get a (possibly pushed back) character from the mkpkgfile + * associated with the given context. + */ +int +m_rawgetc (register struct context *cx) +{ + register struct pushback *pb; + register int ch; + + for (;;) { + /* Check for single character pushback first. This type of pushback + * occurs at the end of every token. + */ + if ((ch = cx->pbchar)) { + if (debug > 3) { + if (ch <= 040) + printf ("return pushback character 0%o\n", ch); + else + printf ("return pushback character `%c'\n", ch); + fflush (stdout); + } + cx->pbchar = 0; + break; + } + + /* Check for string type pushback; return character directly from + * file if no pushback. + */ + if (!cx->pushback) { + ch = k_getc (cx); + break; + } + + /* Get pushed back character from pushback buffer. + */ + pb = cx->pb; + if ((ch = *(pb->ip)++) != EOS) { + if (debug > 3) { + if (ch <= 040) + printf ("return pbbuf character 0%o\n", ch); + else + printf ("return pbbuf character `%c'\n", ch); + fflush (stdout); + } + break; + } + + /* End of pushed back string; pop pushback stack. + */ + if (debug > 3) { + printf ("pop pushback stack at level=%d\n", pb->npb); + fflush (stdout); + } + + pb->op = pb->pbstk[--(pb->npb)]; + pb->ip = pb->pbstk[--(pb->npb)]; + + if (pb->npb <= 0) + cx->pushback = 0; + } + + if (ch == '\n') + cx->lineno++; + + return (ch); +} + + +/* M_UNGETC -- Pushback a single character, last in first out. Only a single + * character of this type of pushback is normally allowed, however by using + * PUSHSTR we can provide additional pushback at additional expense (no + * problem provided it is not used a lot). + */ +void +m_ungetc ( + int ch, + struct context *cx +) +{ + static char ps[2] = "\0"; + + if (ch == '\n') + --cx->lineno; + + if ((ps[0] = cx->pbchar)) + m_pushstr (cx, ps); + + cx->pbchar = ch; + + if (debug > 3) { + if (ch <= 040) + printf ("ungetc 0%o\n", ch); + else + printf ("ungetc `%c'\n", ch); + fflush (stdout); + } +} + + +/* M_PUSHSTR -- Pushback a string. Pushed strings are read back LIFO, although + * of course the individual characters are returned FIFO. + */ +void +m_pushstr ( + struct context *cx, + char *str +) +{ + register struct pushback *pb; + register char *ip, *op, *otop, ch; + + if (debug > 2) { + if (str[0] <= 040) + printf ("pushback punct char 0x%lx\n", (long) str); + else + printf ("pushback string `%s'\n", str); + fflush (stdout); + } + + cx->pushback++; + while ((pb = cx->pb) == NULL) + mk_pbbuf (cx); + + pb->pbstk[(pb->npb)++] = pb->ip; + pb->pbstk[(pb->npb)++] = pb->op; + otop = pb->otop; + + for (ip=str, op=pb->op; (*op++ = ch = *ip++); ) { + if (ch == '\n') + --cx->lineno; + if (op >= otop) + break; + } + + pb->ip = pb->op; + pb->op = op; + + if (debug > 2) { + printf ("pb status: "); + printf ("level=%d(%d) nleft=%ld ip=%ld op=%ld bp=%ld otop=%ld\n", + pb->npb, SZ_PBSTK, + (long) (otop-op), + (long) pb->ip, + (long) pb->op, + (long) pb->pbbuf, + (long) otop); + fflush (stdout); + } + + if (pb->npb + 2 >= SZ_PBSTK || pb->op >= pb->otop) + fatals ("excessive pushback in `%s'; macro recursion?", + cx->mkpkgfile); +} + + +/* MK_PBBUF -- Allocate and initialize the pushback descriptor. + */ +void +mk_pbbuf (register struct context *cx) +{ + register struct pushback *pb; + + pb = cx->pb = (struct pushback *) malloc (sizeof (struct pushback)); + if (pb == NULL) + fatals ("out of memory in `%s'", cx->mkpkgfile); + + pb->npb = 0; + pb->ip = pb->pbbuf; + pb->op = pb->pbbuf; + pb->otop = &pb->pbbuf[SZ_PBBUF]; +} + + +/* PB_CANCEL -- Cancel any pushback. + */ +void +pb_cancel (register struct context *cx) +{ + register struct pushback *pb; + + cx->pushback = 0; + cx->pbchar = 0; + + if ((pb = cx->pb) != NULL) { + pb->npb = 0; + pb->ip = pb->pbbuf; + pb->op = pb->pbbuf; + pb->otop = &pb->pbbuf[SZ_PBBUF]; + } +} + + +/* PUTSTR -- Add a string to end of the string buffer. It is a fatal error + * if the string buffer overflows. + */ +char * +putstr (char *s) +{ + register char *ip, *op, *otop; + char *start; + + start = cp; + otop = ctop; + + for (ip=s, op=cp; (*op++ = *ip++); ) + if (op >= otop) + fatals ("string buffer overflow at `%s'", s); + + cp = op; + + if (debug > 2) { + printf ("putstr `%s': nleft=%ld\n", s, (long)(otop-op)); + fflush (stdout); + } + + return (start); +} + + +/* + * OS Character I/O. This set of routines are provided as a workaround in + * the event that the host system cannot execute FTELL/FSEEK reliably (VMS/C + * could not). The idea here is to keep track of the character offset from + * the beginning of the file. K_FTELL returns the character offset. K_FSEEK + * rewinds the file and reads characters forward to the indicated offset. + * K_GETC keeps a count of the file position. (the k_ stands for kludge). + */ + +#ifdef vms + +int +k_getc (register struct context *cx) +{ + register int ch; + + cx->fpos++; + if (debug > 3) { + if ((ch = getc (cx->fp)) > 0) + printf ("%5d %03o %c\n", cx->fpos, ch, ch > 040 ? ch : 040); + return (ch); + } else + return (getc (cx->fp)); +} + +char * +k_fgets ( + char *obuf, + int maxch, + register struct context *cx +) +{ + register int ch, n; + register char *op; + + for (op=obuf, n=maxch; --n >= 0; ) + if ((ch = k_getc(cx)) < 0) + return (NULL); + else { + *op++ = ch; + if (ch == '\n') + break; + } + + return (obuf); +} + +int +k_fseek ( + register struct context *cx, + long offset, + int type +) +{ + register FILE *fp = cx->fp; + register int ch; + + if (debug > 1) + printf ("seek (%s, %ld, %d)\n", cx->mkpkgfile, offset, type); + + if (type == 0) { + fseek (fp, 0L, 0); + cx->fpos = 0; + + while (cx->fpos < offset && (ch = getc(fp)) != EOF) { + if (debug > 1) + fputc (ch, stdout); + cx->fpos++; + } + + if (debug > 1) + printf ("[]\n"); + + return (0); + } + + if (fseek (fp, offset, type) == ERR) + return (ERR); + else { + cx->fpos = ftell (fp); + return (0); + } +} + +long +k_ftell (register struct context *cx) +{ + if (debug > 1) { + printf ("ftell returns %d\n", cx->fpos); + fflush (stdout); + } + return (cx->fpos); +} + +#else + +int +k_getc (struct context *cx) +{ + return (getc (cx->fp)); +} + +char * +k_fgets ( + char *op, + int maxch, + register struct context *cx +) +{ + return (fgets (op, maxch, cx->fp)); +} + +int +k_fseek ( + struct context *cx, + long offset, + int type +) +{ + return (fseek (cx->fp, offset, type)); +} + +long +k_ftell (struct context *cx) +{ + return (ftell (cx->fp)); +} + +#endif diff --git a/unix/boot/mkpkg/extern.h b/unix/boot/mkpkg/extern.h new file mode 100644 index 00000000..6ade9584 --- /dev/null +++ b/unix/boot/mkpkg/extern.h @@ -0,0 +1,18 @@ +/* EXTERN.H -- External static variables. + */ +extern char sbuf[]; /* string buffer */ +extern struct symbol symtab[]; /* symbol table (macros) */ +extern struct context *topcx; /* currently active context */ +extern char *cp; /* pointer into sbuf */ +extern char *ctop; /* top of sbuf */ +extern char irafdir[]; /* iraf root directory */ +extern int nsymbols; /* number of defined symbols */ +extern int ifstate[]; /* $IF stack */ +extern int iflev; /* $IF stack pointer */ +extern int debug; /* print debug messages */ +extern int dbgout; /* compile for debugging */ +extern int verbose; /* print informative messages */ +extern int ignore; /* ignore warns */ +extern int execute; /* think but don't act? */ +extern int exit_status; /* exit status of last syscall */ +extern int forceupdate; /* foribly update libmod dates */ diff --git a/unix/boot/mkpkg/fdcache.c b/unix/boot/mkpkg/fdcache.c new file mode 100644 index 00000000..7dfca1a3 --- /dev/null +++ b/unix/boot/mkpkg/fdcache.c @@ -0,0 +1,190 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +/* + * FDCACHE -- Maintain a cache of filenames and their associated modification + * dates. This can greatly reduce the amount of time required to determine + * which, if any, of the modules in a library need updating because an include + * file they depend upon has been modified. + * + * External entry points: + * + * l = m_fdate (fname) # return file (modification) date + * m_fdinit (debug) # initialize cache + */ + +#define MAX_FILES 20 /* size of the cache */ +#define SZ_NAME 32 /* size of filename slot */ +#define EOS '\0' + +struct _fdate { /* cache list element structure */ + struct _fdate *uplnk; + struct _fdate *dnlnk; + int nrefs; /* number of references */ + int chksum; /* speeds searches */ + long fdate; /* file modification date */ + char fname[SZ_NAME+1]; /* file name */ +}; + +struct _fdate fdcache[MAX_FILES]; /* the cache */ +struct _fdate *fd_head; /* doubly linked list */ +struct _fdate *fd_tail; +int fd_hits, fd_misses; + +struct _fdate *fd_unlink(); +struct _fdate *fd_tohead(); +struct _fdate *fd_totail(); + +long m_fdate (char *fname); +void m_fdinit (int debug); +int fd_chksum (char *s); + +extern long os_fdate (char *fname); + + +/* M_FDATE -- Get file modification date. This is functionally equivalent to + * os_fdate(). + */ +long +m_fdate (char *fname) +{ + register struct _fdate *fd; + register int chksum; + + /* Look in the cache first. + */ + chksum = fd_chksum (fname); + for (fd=fd_head; fd != NULL; fd=fd->dnlnk) + if (fd->chksum == chksum && strcmp (fname, fd->fname) == 0) { + fd_tohead (fd_unlink (fd)); + fd->nrefs++; + fd_hits++; + return (fd->fdate); + } + + /* Cache miss. Don't put in cache it name is too long. + */ + fd_misses++; + if (strlen (fname) > SZ_NAME) + return (os_fdate (fname)); + + /* Put fname in the cache. Reuse slot at tail of list. + */ + fd = fd_tohead (fd_unlink (fd_tail)); + strncpy (fd->fname, fname, SZ_NAME); + fd->chksum = fd_chksum (fname); + fd->fdate = os_fdate (fname); + fd->nrefs = 1; + + return (fd->fdate); +} + + +/* M_FDINIT -- Initialize (clear) the fdate cache. + */ +void +m_fdinit (int debug) +{ + register struct _fdate *fd; + register int i; + int total; + + if (debug) { + total = fd_hits + fd_misses; + printf ("file date cache: %d hits, %d misses, %d%% of %d\n", + fd_hits, fd_misses, (total ? fd_hits * 100 / total : 0), total); + + for (fd=fd_head; fd != NULL; fd=fd->dnlnk) + if (fd->fname[0]) + printf ("%3d %10ld (%05d) %s\n", + fd->nrefs, fd->fdate, fd->chksum, fd->fname); + + fd_hits = 0; + fd_misses = 0; + + fflush (stdout); + } + + fd = fd_head = fd_tail = &fdcache[0]; + fd->uplnk = NULL; + fd->dnlnk = NULL; + fd->nrefs = 0; + fd->chksum = -1; + fd->fname[0] = EOS; + + for (i=1; i < MAX_FILES; i++) { + fd = fd_tohead (&fdcache[i]); + fd->fname[0] = EOS; + fd->chksum = -1; + fd->nrefs = 0; + } +} + + +/* FD_TOHEAD -- Link a fdate struct at the head of the list. + */ +struct _fdate * +fd_tohead (register struct _fdate *fd) +{ + if (fd != fd_head) { + fd->uplnk = NULL; + fd->dnlnk = fd_head; + fd_head->uplnk = fd; + fd_head = fd; + } + + return (fd); +} + + +/* FD_TOTAIL -- Link a fdate struct at the tail of the list. + */ +struct _fdate * +fd_totail (register struct _fdate *fd) +{ + if (fd != fd_tail) { + fd->uplnk = fd_tail; + fd->dnlnk = NULL; + fd_tail->dnlnk = fd; + fd_tail = fd; + } + + return (fd); +} + + +/* FD_UNLINK -- Unlink an fdate struct. + */ +struct _fdate * +fd_unlink (register struct _fdate *fd) +{ + if (fd == fd_head) + fd_head = fd->dnlnk; + if (fd == fd_tail) + fd_tail = fd->uplnk; + + if (fd->uplnk) + fd->uplnk->dnlnk = fd->dnlnk; + if (fd->dnlnk) + fd->dnlnk->uplnk = fd->uplnk; + + return (fd); +} + + +/* FD_CHKSUM -- Compute the checksum of a character string. + */ +int +fd_chksum (char *s) +{ + register int sum=0; + + while (*s) + sum += *s++; + + return (sum); +} diff --git a/unix/boot/mkpkg/fncache.c b/unix/boot/mkpkg/fncache.c new file mode 100644 index 00000000..2053f2fe --- /dev/null +++ b/unix/boot/mkpkg/fncache.c @@ -0,0 +1,228 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +//#include "../bootProto.h" + + +/* + * FNCACHE -- Maintain a cache of system logical filenames (e.g., ) + * and their associated virtual filenames (e.g., "host$hlib/config.h"). + * This can greatly reduce the amount of time required to resolve references + * to system include files in dependency file lists. + * + * External entry points: + * + * nc = m_sysfile (lname, fname, maxch) # return file name + * m_fninit (debug) # initialize cache + */ + +#define MAX_FILES 20 /* size of the cache */ +#define SZ_LNAME 32 /* size of logical name */ +#define SZ_FNAME 32 /* size of virtual file name */ +#define EOS '\0' + +struct _sysfile { /* cache list element structure */ + struct _sysfile *uplnk; + struct _sysfile *dnlnk; + int nrefs; /* number of references */ + int chksum; /* speeds searches */ + char lname[SZ_LNAME+1]; /* logical name */ + char fname[SZ_FNAME+1]; /* file name */ +}; + +struct _sysfile fncache[MAX_FILES]; /* the cache */ +struct _sysfile *fn_head; /* doubly linked list */ +struct _sysfile *fn_tail; +int fn_hits, fn_misses; + +struct _sysfile *fn_unlink(); +struct _sysfile *fn_tohead(); +struct _sysfile *fn_totail(); + + +extern int os_sysfile (char *sysfile, char *fname, int maxch); + +int m_sysfile (char *lname, char *fname, int maxch); +void m_fninit (int debug); +int fn_chksum (char *s); +int fn_strncpy (char *out, char *in, int maxch); + + + +/* M_SYSFILE -- Search for the named system file and return the virtual file + * name in the output string if the system file is found. This is functionally + * equivalent to os_sysfile(). + */ +int +m_sysfile ( + char *lname, /* logical name of system file */ + char *fname, /* receives virtual file name */ + int maxch +) +{ + register struct _sysfile *fn; + register int chksum; + int fnlen; + + /* Look in the cache first. For a small cache a linear search is + * plenty fast enough. + */ + chksum = fn_chksum (lname); + for (fn=fn_head; fn != NULL; fn=fn->dnlnk) + if (fn->chksum == chksum && strcmp (lname, fn->lname) == 0) { + fn_tohead (fn_unlink (fn)); + fn->nrefs++; + fn_hits++; + return (fn_strncpy (fname, fn->fname, maxch)); + } + + /* Cache miss. Don't put in cache it name is too long. + */ + fn_misses++; + fnlen = os_sysfile (lname, fname, maxch); + if (fnlen > SZ_FNAME || strlen(lname) > SZ_LNAME) + return (fnlen); + + /* Put fname in the cache. Reuse slot at tail of list. + */ + fn = fn_tohead (fn_unlink (fn_tail)); + strcpy (fn->lname, lname); + strcpy (fn->fname, fname); + fn->chksum = fn_chksum (lname); + fn->nrefs = 1; + + return (fnlen); +} + + +/* M_FNINIT -- Initialize (clear) the sysfile cache. + */ +void +m_fninit (int debug) +{ + register struct _sysfile *fn; + register int i; + int total; + + if (debug) { + char lname[SZ_FNAME+1]; + + total = fn_hits + fn_misses; + printf ("file name cache: %d hits, %d misses, %d%% of %d\n", + fn_hits, fn_misses, (total ? fn_hits * 100 / total : 0), total); + + for (fn=fn_head; fn != NULL; fn=fn->dnlnk) + if (fn->lname[0]) { + sprintf (lname, "<%s>", fn->lname); + printf ("%3d (%05d) %-20s => %s\n", + fn->nrefs, fn->chksum, lname, fn->fname); + } + + fn_hits = 0; + fn_misses = 0; + + fflush (stdout); + } + + fn = fn_head = fn_tail = &fncache[0]; + fn->uplnk = NULL; + fn->dnlnk = NULL; + fn->nrefs = 0; + fn->chksum = -1; + fn->lname[0] = EOS; + + for (i=1; i < MAX_FILES; i++) { + fn = fn_tohead (&fncache[i]); + fn->lname[0] = EOS; + fn->chksum = -1; + fn->nrefs = 0; + } +} + + +/* FN_TOHEAD -- Link a sysfile struct at the head of the list. + */ +struct _sysfile * +fn_tohead (register struct _sysfile *fn) +{ + if (fn != fn_head) { + fn->uplnk = NULL; + fn->dnlnk = fn_head; + fn_head->uplnk = fn; + fn_head = fn; + } + + return (fn); +} + + +/* FN_TOTAIL -- Link a sysfile struct at the tail of the list. + */ +struct _sysfile * +fn_totail (register struct _sysfile *fn) +{ + if (fn != fn_tail) { + fn->uplnk = fn_tail; + fn->dnlnk = NULL; + fn_tail->dnlnk = fn; + fn_tail = fn; + } + + return (fn); +} + + +/* FN_UNLINK -- Unlink an sysfile struct. + */ +struct _sysfile * +fn_unlink (register struct _sysfile *fn) +{ + if (fn == fn_head) + fn_head = fn->dnlnk; + if (fn == fn_tail) + fn_tail = fn->uplnk; + + if (fn->uplnk) + fn->uplnk->dnlnk = fn->dnlnk; + if (fn->dnlnk) + fn->dnlnk->uplnk = fn->uplnk; + + return (fn); +} + + +/* FN_CHKSUM -- Compute the checksum of a character string. + */ +int +fn_chksum (char *s) +{ + register int sum=0; + + while (*s) + sum += *s++; + + return (sum); +} + + +/* FN_STRNCPY -- Copy up to maxch characters from a string and return the + * number of characters copied as the function value. + */ +int +fn_strncpy ( + char *out, + char *in, + int maxch +) +{ + register char *ip, *op; + register int n; + + for (ip=in, op=out, n=maxch; --n >= 0 && (*op++ = *ip++); ) + ; + return (op-1 - out); +} diff --git a/unix/boot/mkpkg/host.c b/unix/boot/mkpkg/host.c new file mode 100644 index 00000000..2f7c140b --- /dev/null +++ b/unix/boot/mkpkg/host.c @@ -0,0 +1,917 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include + +#define import_spp +#define import_error +#include +#include "mkpkg.h" +#include "extern.h" +#include "../bootProto.h" + +#ifdef LINUX +# undef SYSV +# undef i386 +# define GNUAR +#else +# ifdef BSD +# undef SYSV +# endif +#endif + +/* + * HOST.C -- [MACHDEP] Special host interface routines required by the MKPKG + * utility. + */ + +#define SZ_COPYBUF 4096 +#ifndef SZ_CMD +#define SZ_CMD 2048 /* max size OS command, see mkpkg.h */ +#endif +#define SZ_LIBPATH 512 /* path to library */ +#define LIBRARIAN "ar" +#define LIBTOOL "libtool" +#define LIBFLAGS "r" +#define REBUILD "ranlib" +#define XC "xc" +#define INTERRUPT SYS_XINT + +extern char *makeobj(); +extern char *vfn2osfn(); +extern char *getenv(); + +extern void fatals (char *fmt, char *arg); + +char *resolvefname(); +char *mkpath(); + +int h_updatelibrary (char *library, char *flist[], int totfiles, + char *xflags, char *irafdir); +int h_rebuildlibrary (char *library); +int h_incheck (char *file, char *dir); +int h_outcheck (char *file, char *dir, int clobber); +void h_getlibname (char *file, char *fname); +int h_xc (char *cmd); +int h_purge (char *dir); +int h_copyfile (char *oldfile, char *newfile); + +int u_fcopy (char *old, char *new); +int h_movefile (char *old, char *new); +int u_fmove (char *old, char *new ); +int add_sources (char *cmd, int maxch, char *flist[], + int totfiles, int hostnames, int *nsources); +int add_objects (char *cmd, int maxch, char *flist[], + int totfiles, int hostnames); + +char *makeobj (char *fname); +char *mkpath (char *module, char *directory, char *outstr); +char *resolvefname (char *fname); +int h_direq (char *dir1, char *dir2); + + + +/* H_UPDATELIBRARY -- Compile a list of source files and replace them in the + * host library. This is done by formatting a command for the XC compiler + * and passing it to the host system. Since XC is pretty much the same on + * all systems, this should be close to portable. Note that when we are + * called we are not necessarily in the same directory as the library, but + * we are always in the same directory as the files in the file list. + * Note also that the file list may contain object files which cannot be + * compiled, but which must be replaced in the library. + */ +int +h_updatelibrary ( + char *library, /* pathname of library */ + char *flist[], /* pointers to filename strings */ + int totfiles, /* number of files in list */ + char *xflags, /* XC compiler flags */ + char *irafdir /* iraf root directory */ +) +{ + char cmd[SZ_CMD+1], *args; + int exit_status, baderr, npass; + int nsources, nfiles, ndone, nleft; + int hostnames, status; + char libfname[SZ_PATHNAME+1]; + char *lname = NULL; + + /* Get the library file name. */ + h_getlibname (library, libfname); + lname = resolvefname(libfname); + + /* + * Compile the files. + * ------------------- + */ + if (irafdir[0]) + sprintf (cmd, "%s -r %s %s", XC, irafdir, xflags); + else + sprintf (cmd, "%s %s", XC, xflags); + + if (debug) + strcat (cmd, " -d"); + if (dbgout) + strcat (cmd, " -x"); + + /* Compute offset to the file list and initialize loop variables. + * Since the maximum command length is limited, only a few files + * are typically processed in each iteration. + */ + exit_status = OK; + baderr = NO; + args = &cmd[strlen(cmd)]; + nleft = totfiles; + ndone = 0; + + while (nleft > 0) { + /* Add as many filenames as will fit on the command line. + */ + nfiles = add_sources (cmd, SZ_CMD, &flist[ndone], nleft, + hostnames=NO, &nsources); + + /* This should not happen. + */ + if (nfiles <= 0) { + printf ("OS command overflow; cannot compile files\n"); + fflush (stdout); + exit_status = ERR; + return 0; + } + + if (verbose) { + if (nsources > 0) + printf ("%s\n", cmd); + else + printf ("file list contains only object files\n"); + fflush (stdout); + } + + if (execute && nsources > 0) + if ((status = os_cmd (cmd)) != OK) { + if (status == INTERRUPT) + fatals (" interrupt %s", library); + if (!ignore) + baderr++; + exit_status += status; + } + + /* Truncate command and repeat with the next few files. + */ + (*args) = EOS; + + ndone += nfiles; + nleft -= nfiles; + } + + /* Do not update object modules in library if a compilation error + * occurred. The object files will be left on disk and the user + * will rerun us after fixing the problem; the next time around we + * will see that the objects exist and are up to date, hence will + * not recompile them. When all have been successfully compiled + * the library will be updated. + */ + if (baderr) + return 0; + + /* + * Update the library. + * --------------------- + */ +#if defined(LINUX) || defined(BSD) || defined(MACOSX) +#if defined(MACOSX) && !defined(MACH64) + /* For FAT libraries we need to use libtool to update. + */ + if (access (lname, F_OK) == 0) + sprintf (cmd, "%s %s %s %s", LIBTOOL, "-a -T -o", lname, lname); + else + sprintf (cmd, "%s %s %s ", LIBTOOL, "-a -T -o", lname); +#else + sprintf (cmd, "%s %s %s", LIBRARIAN, LIBFLAGS, resolvefname(libfname)); +#endif +#else + sprintf (cmd, "%s %s %s", LIBRARIAN, LIBFLAGS, libfname); +#endif + + /* Compute offset to the file list and initialize loop variables. + * Since the maximum command length is limited, only a few files + * are typically processed in each iteration. + */ + args = &cmd[strlen(cmd)]; + nleft = totfiles; + ndone = 0; + + for (npass=0; nleft > 0; npass++) { + +#if defined(MACOSX) && !defined(MACH64) + if (npass > 0) { + /* For FAT libraries we need to use libtool to update. + */ + if (access (lname, F_OK) == 0) + sprintf (cmd, "%s %s %s %s", LIBTOOL, "-a -T -o", + lname, lname); + else + sprintf (cmd, "%s %s %s ", LIBTOOL, "-a -T -o", lname); + } +#endif + + /* Add as many filenames as will fit on the command line. */ + nfiles = add_objects (cmd, SZ_CMD, &flist[ndone], nleft, + hostnames=NO); + + /* This should not happen. */ + if (nfiles <= 0) { + printf ("OS command overflow; cannot update library `%s'\n", + libfname); + fflush (stdout); + exit_status = ERR; + return 0; + } + + if (verbose) { + printf ("%s\n", cmd); + fflush (stdout); + } + + if (execute) { + if ((exit_status = os_cmd (cmd)) == OK) { + /* Delete the object files. + */ + int i; + + for (i=0; i < nfiles; i++) + os_delete (makeobj (flist[ndone+i])); + } else if (exit_status == INTERRUPT) + fatals (" interrupt %s", library); + } + + /* Truncate command and repeat with the next few files. + */ + (*args) = EOS; + + ndone += nfiles; + nleft -= nfiles; + +#if defined(MACOSX) && !defined(MACH64) + h_rebuildlibrary (lname); +#endif + } + + return (exit_status); +} + + +/* H_REBUILDLIBRARY -- Called after all recently recompiled modules have been + * replaced in the library. When we are called we are in the same directory + * as the library. + */ +int +h_rebuildlibrary ( + char *library /* filename of library */ +) +{ +#ifdef SYSV + /* Skip the library rebuild if COFF format library. */ + return (OK); +#else + char cmd[SZ_LINE+1]; + char libfname[SZ_PATHNAME+1]; + char *libpath; + + /* Get the library file name. */ + h_getlibname (library, libfname); + libpath = resolvefname (vfn2osfn(libfname,0)); + + sprintf (cmd, "%s %s", REBUILD, libpath); + if (verbose) { + printf ("%s\n", cmd); + fflush (stdout); + } + + if (execute) + return (os_cmd (cmd)); + else + return (OK); +#endif +} + + +/* H_INCHECK -- Check a file, e.g., a library, back into the directory it + * was originally checked out from. If the directory name pointer is NULL + * merely delete the checked out copy of the file. On a UNIX system the + * checked out file is a symbolic link, so all we do is delete the link. + * On a VMS system the checked out file is a copy, and we have to physically + * copy the new file back, creating a new version of the original file. + */ +int +h_incheck ( + char *file, /* file to be checked in */ + char *dir /* where to put the file */ +) +{ + char backup[SZ_PATHNAME+1]; + char path[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + char *osfn, *ip; + struct stat fi; + int status; + + /* Get the library file name. */ + h_getlibname (file, fname); + osfn = vfn2osfn (fname, 0); + + if (verbose) { + printf ("check file `%s' into `%s'\n", fname, dir ? dir : ""); + fflush (stdout); + } + + if (stat (osfn, &fi) == ERR) { + printf ("$checkin: file `%s' not found\n", osfn); + fflush (stdout); + return (ERR); + } + + /* If the file is not a symbolic link to an existing remote file it + * is probably a new library, so move it to the destination directory, + * otherwise just delete the link. If the named file exists in + * IRAFULIB update that version of the file instead of the standard one. + */ + if (dir != NULL && !(fi.st_mode & S_IFLNK)) { + path[0] = EOS; + if ((ip = getenv("IRAFULIB"))) + if (access (mkpath(fname,ip,path), 0) < 0) + path[0] = EOS; + + if (path[0] == EOS) + status = h_movefile (osfn, mkpath(fname,dir,path)); + else + status = h_movefile (osfn, path); + + } else + status = unlink (osfn); + + /* If there was a local copy of the file it will have been renamed + * with a .cko extension when the file was checked out, and should be + * restored. + */ + sprintf (backup, "%s.cko", fname); + if (access (backup, 0) == 0) { + if (debug) { + printf ("h_incheck: rename %s -> %s\n", backup, fname); + fflush (stdout); + } + if (rename (backup, fname) == -1) + printf ("cannot rename %s -> %s\n", backup, fname); + } + + return (status); +} + + +/* H_OUTCHECK -- Check out a file, e.g., gain access to a library in the + * current directory so that it can be updated. If the file has already + * been checked out do not check it out again. In principle we should also + * place some sort of a lock on the file while it is checked out, but... + */ +int +h_outcheck ( + char *file, /* file to be checked out */ + char *dir, /* where to get the file */ + int clobber /* clobber existing copy of file? */ +) +{ + register char *ip, *op; + char path[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + + /* Get the library file name. */ + h_getlibname (file, fname); + + /* Make the UNIX pathname of the destination file. [MACHDEP] + * Use the IRAFULIB version of the file if there is one. + */ + path[0] = EOS; + if ((ip = getenv("IRAFULIB"))) + if (access (mkpath(fname,ip,path), 0) < 0) + path[0] = EOS; + + if (path[0] == EOS) { + for (ip=vfn2osfn(dir,0), op=path; (*op = *ip++); op++) + ; + if (*(op-1) != '/') + *op++ = '/'; + for (ip=vfn2osfn(fname,0); (*op = *ip++); op++) + ; + *op = EOS; + } + + if (verbose) { + printf ("check out file `%s = %s'\n", fname, path); + fflush (stdout); + } + + /* If the file already exists and clobber is enabled, delete it. + * If the file is a symbolic link (a pathname), and IRAF has been + * moved since the link was created, then the symlink will be + * pointing off into never never land and must be redone. If clobber + * is NOT enabled, then probably the remote copy of the file is an + * alternate source for the local file, which must be preserved. + */ + if (access (fname, 0) != -1) { + char backup[SZ_PATHNAME+1]; + + if (clobber) { + if (debug) { + printf ("h_outcheck: deleting %s\n", fname); + fflush (stdout); + } + unlink (fname); + } else { + /* Do not rename the file twice; if the .cko file already + * exists, the second time would clobber it. Note that if a + * mkpkg run is aborted, the checked out file and renamed + * local file will remain, but a subsequent successful mkpkg + * will restore everything. + */ + sprintf (backup, "%s.cko", fname); + if (access (backup, 0) == -1) { + if (debug) { + printf ("h_outcheck: rename %s -> %s\n", fname, backup); + fflush (stdout); + } + if (rename (fname, backup) == -1) + printf ("cannot rename %s -> %s\n", fname, backup); + } + } + } + + return (symlink (path, fname)); +} + + +/* H_GETLIBNAME -- Get a library filename. If debug output is enabled (-g + * or -x), and we are checking out a library file (.a), update the debug + * version of the library (XX_p.a). + */ +void +h_getlibname ( + char *file, + char *fname +) +{ + register char *ip; + + strcpy (fname, file); + if (dbgout) { + for (ip=fname; *ip; ip++) + ; + if (*(ip-2) == '.' && *(ip-1) == 'a' && + !(*(ip-4) == '_' && *(ip-3) == 'p')) { + *(ip-2) = '_'; + *(ip-1) = 'p'; + *(ip-0) = '.'; + *(ip+1) = 'a'; + *(ip+2) = '\0'; + } + } +} + + +/* H_XC -- Host interface to the XC compiler. On UNIX all we do is use the + * oscmd facility to pass the XC command line on to UNIX. + */ +int +h_xc (char *cmd) +{ + return (os_cmd (cmd)); +} + + +/* H_PURGE -- Purge all old versions of all files in the named directory. + * This is a no-op on UNIX since multiple file versions are not supported. + */ +int +h_purge ( + char *dir /* LOGICAL directory name */ +) +{ + if (verbose) { + printf ("purge directory `%s'\n", dir); + fflush (stdout); + } + + /* + * format command "purge [dir]*.*;*" + * if (verbose) + * echo command to stdout + * if (execute) + * call os_cmd to execute purge command + */ + + return (OK); +} + + +/* H_COPYFILE -- Copy a file. If the new file already exists it is + * clobbered (updated). + */ +int +h_copyfile ( + char *oldfile, /* existing file to be copied */ + char *newfile /* new file, not a directory name */ +) +{ + char old[SZ_PATHNAME+1]; + char new[SZ_PATHNAME+1]; + + strcpy (old, vfn2osfn (oldfile, 0)); + strcpy (new, vfn2osfn (newfile, 1)); + + if (verbose) { + printf ("copy %s to %s\n", old, new); + fflush (stdout); + } + + if (execute) { + if (os_access (old, 0,0) == NO) { + printf ("$copy: file `%s' not found\n", oldfile); + fflush (stdout); + return (ERR); + } else + return (u_fcopy (old, new)); + } + + return (OK); +} + + +/* U_FCOPY -- Copy a file, UNIX. + */ +int +u_fcopy ( + char *old, + char *new +) +{ + char buf[SZ_COPYBUF], *ip; + int in, out, nbytes; + struct stat fi; + long totbytes; + + /* Open the old file and create the new one with the same mode bits + * as the original. + */ + if ((in = open(old,0)) == ERR || fstat(in,&fi) == ERR) { + printf ("$copy: cannot open input file `%s'\n", old); + fflush (stdout); + return (ERR); + } if ((out = creat(new,0644)) == ERR || fchmod(out,fi.st_mode) == ERR) { + printf ("$copy: cannot create output file `%s'\n", new); + fflush (stdout); + close (in); + return (ERR); + } + + /* Copy the file. + */ + totbytes = 0; + while ((nbytes = read (in, buf, SZ_COPYBUF)) > 0) + if (write (out, buf, nbytes) == ERR) { + close (in); close (out); + printf ("$copy: file write error on `%s'\n", new); + fflush (stdout); + return (ERR); + } else + totbytes += nbytes; + + close (in); + close (out); + + /* Check for premature termination of the copy. + */ + if (totbytes != fi.st_size) { + printf ("$copy: file changed size `%s' oldsize=%d, newsize=%d\n", + old, (int)fi.st_size, (int)totbytes); + fflush (stdout); + return (ERR); + } + + /* If file is a library (".a" extension in UNIX), preserve the + * modify date else UNIX will think the library symbol table is + * out of date. + */ + for (ip=old; *ip; ip++) + ; + ip -= 2; + if (ip > old && strcmp (ip, ".a") == 0) { + struct timeval tv[2]; + + tv[0].tv_sec = fi.st_atime; + tv[1].tv_sec = fi.st_mtime; + utimes (new, tv); + } + + return (OK); +} + + +/* H_MOVEFILE -- Move a file from the current directory to another directory, + * or rename the file within the current directory. If the destination file + * already exists it is clobbered. + */ +int +h_movefile ( + char *old, /* file to be moved */ + char *new /* new pathname of file */ +) +{ + char old_osfn[SZ_PATHNAME+1]; + char new_osfn[SZ_PATHNAME+1]; + + strcpy (old_osfn, vfn2osfn (old, 0)); + strcpy (new_osfn, vfn2osfn (new, 0)); + + if (debug) { + printf ("move %s to %s\n", old_osfn, new_osfn); + fflush (stdout); + } + + if (execute) { + if (os_access (old_osfn, 0,0) == NO) { + printf ("$move: file `%s' not found\n", old); + fflush (stdout); + return (ERR); + } else + return (u_fmove (old_osfn, new_osfn)); + } + + return (OK); +} + + +/* U_FMOVE -- Unix procedure to move or rename a file. Will move file to a + * different device (via a file copy) if necessary. + */ +int +u_fmove ( + char *old, + char *new +) +{ + unlink (new); + if (link (old, new) == ERR) + if (u_fcopy (old, new) == ERR) { + printf ("$move: cannot create `%s'\n", new); + fflush (stdout); + return (ERR); + } + + if (unlink (old) == ERR) { + printf ("$move: cannot unlink `%s'\n", old); + fflush (stdout); + return (ERR); + } + + return (OK); +} + + +/* ADD_SOURCES -- Append source files from the file list to the command + * buffer. Omit object files. Return a count of the number of files to + * be compiled. This code is machine dependent since Unix permits arbitrarily + * long command lines, but most systems do not, in which case something + * else must be done (e.g., write a command file and have the host system + * process that). + */ +int +add_sources ( + char *cmd, /* concatenate to this */ + int maxch, /* max chars out */ + char *flist[], /* pointers to filename strings */ + int totfiles, /* number of files in list */ + int hostnames, /* return host filenames? */ + int *nsources /* receives number of src files */ +) +{ + register char *ip, *op, *otop; + register int i; + int nfiles; + + *nsources = 0; + nfiles = 0; + + otop = &cmd[maxch]; + for (op=cmd; *op; op++) + ; + + for (i=0; i < totfiles; i++) { + /* Skip over object files. + */ + for (ip=flist[i]; *ip; ip++) + ; + if (strcmp (ip-2, ".o") == 0) { + nfiles++; + continue; + } + + if (op + strlen (flist[i]) + 1 >= otop) + break; + + nfiles++; + (*nsources)++; + *op++ = ' '; + + if (hostnames) + ip = vfn2osfn (flist[i], 0); + else + ip = flist[i]; + + for (; (*op = *ip++); op++) + ; + } + + return (nfiles); +} + + +/* ADD_OBJECTS -- Append the ".o" equivalent of each file name to the + * output command buffer. Return the number of file names appended. + */ +int +add_objects ( + char *cmd, /* concatenate to this */ + int maxch, /* max chars out */ + char *flist[], /* pointers to filename strings */ + int totfiles, /* number of files in list */ + int hostnames /* return host filenames? */ +) +{ + register char *ip, *op, *otop; + register int i; + int nfiles; + + otop = &cmd[maxch]; + for (op=cmd; *op; op++) + ; + + for (i=0, nfiles=0; i < totfiles; i++) { + if (op + strlen (flist[i]) + 1 >= otop) + break; + + nfiles++; + *op++ = ' '; + + ip = makeobj (flist[i]); + if (hostnames) + ip = vfn2osfn (ip,0); + + for (; (*op = *ip++); op++) + ; + } + + return (nfiles); +} + + +/* MAKEOBJ -- Return a pointer to the ".o" equivalent of the input file + * name. The last period in the input filename is assumed to delimit the + * filename extension. + */ +char * +makeobj (char *fname) +{ + register char *ip, *op; + static char objfile[SZ_FNAME+1]; + char *lastdot; + + for (ip=fname, op=objfile, lastdot=NULL; (*op = *ip++); op++) + if (*op == '.') + lastdot = op; + + if (lastdot != NULL) + op = lastdot; + strcpy (op, ".o"); + + return (objfile); +} + + +/* MKPATH -- Given a module name and a directory name, return the pathname of + * the module in the output string. Do not use the directory pathname if the + * module name is already a pathname. + */ +char * +mkpath ( + char *module, + char *directory, + char *outstr +) +{ + register char *ip, *op; + + if (directory && module[0] != '/') { + for (ip=directory, op=outstr; (*op = *ip++); op++) + ; + if (op > outstr && *(op-1) != '/') { + *op++ = '/'; + *op = EOS; + } + for (ip=module; (*op = *ip++); op++) + ; + } else + strcpy (outstr, module); + + return (outstr); +} + + +/* RESOLVEFNAME -- If a filename reference is a symbolic link resolve it to + * the pathname of an actual file by tracing back through all symbolic links + * to the fully resolved file or path. + * + * Example: + * + * ./libsys.a -> /iraf/iraf/lib/libsys.a + * /iraf/iraf/lib/libsys.a -> ../bin/libsys.a + * -> /iraf/iraf/bin/libsys.a + * + * Note that the "fully resolved" filename may still contain unresolved links + * for directory elements - it is only the filename which is fully resolved + * in the output pathname. + */ +char * +resolvefname (char *fname) +{ + static char pathname[SZ_LIBPATH]; + char relpath[SZ_LIBPATH]; + extern char *strrchr(); + + strcpy (pathname, fname); + while (os_symlink (pathname, relpath, SZ_LIBPATH)) { + if (relpath[0] == '/') { + /* Link to an absolute pathname, just use new path. */ + strcpy (pathname, relpath); + } else { + /* Relative path. This includes upwards references such + * as ../foo. Replace the filename by the relative path. + * Let unix resolve any upwards references later, when the + * file is accessed. + */ + char *str = strrchr(pathname,'/'); + strcpy ((str ? (str+1) : pathname), relpath); + } + } + + return (pathname); +} + + +/* H_DIREQ -- Compare two directory pathnames for equality. This is easy + * in most cases, but the comparison can fail when it shouldn't due to aliases + * for directory names, e.g., a directory may be referred to by a symbolic + * name, but get-cwd will return a different path, causing the comparison to + * fail. + */ +int +h_direq (char *dir1, char *dir2) +{ + register char *ip1, *ip2; + + /* If the pathname contains a directory named "irafXXX" (where the + * XXX are optional characters in the directory name) everything to + * the left for the purposes of this comparision. This allows the + * iraf root directory to be specified with a path such as + * + * //iraf/iraf.version/ + * + * and the directory name comparision will take place using only + * the portion of the path following this prefix. + */ + for (ip1=dir1; *ip1; ip1++) + if (*ip1 == '/' && *(ip1+1) == 'i') + if (strncmp (ip1+1, "iraf", 4) == 0) { + for (ip1++; *ip1 && *ip1 != '/'; ip1++) + ; + if (*ip1 == '/') + dir1 = ip1 + 1; + --ip1; + } + for (ip2=dir2; *ip2; ip2++) + if (*ip2 == '/' && *(ip2+1) == 'i') + if (strncmp (ip2+1, "iraf", 4) == 0) { + for (ip2++; *ip2 && *ip2 != '/'; ip2++) + ; + if (*ip2 == '/') + dir2 = ip2 + 1; + --ip2; + } + + return (strcmp (dir1, dir2) == 0); +} diff --git a/unix/boot/mkpkg/main.c b/unix/boot/mkpkg/main.c new file mode 100644 index 00000000..eb2cb5c3 --- /dev/null +++ b/unix/boot/mkpkg/main.c @@ -0,0 +1,347 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_spp +#define import_knames +#define import_error + +#include + +#include "mkpkg.h" +#include "../bootProto.h" + +/* + * MKPKG -- Make a package or library, following the instructions given in + * the mkpkg file in the current directory. + * + * mkpkg [-flags] [module] [sym=val ...] + * + * -dddd output debug info; up to 4 levels + * -i ignore errors (cannot ignore interrupt) + * -f fname set mkpkg filename; default "mkpkg" + * -n no execute, just go through the motions + * -p pkg load environment for the named package + * -u forcibly update library module dates + * -v verbose: show actions (implied by -n) + * + * The switch "-f stdin" causes MKPKG to read its commands from the standard + * input, e.g., the terminal. If a module name is given execution will start + * at the mkpkg entry for the module, else execution starts at the beginning + * of file. See the manual page, etc. for additional documentation. + */ + +char sbuf[SZ_SBUF]; /* string buffer */ +struct symbol symtab[MAX_SYMBOLS]; /* symbol table (macros) */ +struct context *topcx; /* currently active context */ +char *cp = sbuf; /* pointer into sbuf */ +char *ctop = &sbuf[SZ_SBUF]; /* top of sbuf */ +int npkg = 0; /* number of packages */ +char *pkgenv[MAX_PKGENV]; /* package environments */ +char v_pkgenv[SZ_PKGENV+1]; /* buffer for pkgenv names */ +char irafdir[SZ_PATHNAME+1]; /* iraf root directory */ +int nsymbols = 0; /* number of defined symbols */ +int ifstate[SZ_IFSTACK]; /* $IF stack */ +int iflev; /* $IF stack pointer */ +int debug = 0; /* print debug messages */ +int dbgout = 0; /* compile for debugging */ +int verbose = NO; /* print informative messages */ +int ignore = YES; /* ignore warns */ +int execute = YES; /* think but don't act? */ +int exit_status; /* exit status of last syscall */ +int forceupdate = NO; /* forcibly update libmod dates */ +extern char *os_getenv(); + + +void warns (char *fmt, char *arg); +void fatals (char *fmt, char *arg); + +extern int ZZSTRT (void); +extern int ZZSTOP (void); + +extern int do_mkpkg (struct context *cx, int islib); + + + +void zzpause () { printf ("ready ...."); (void) getc(stdin); } + + +/* MAIN -- Entry point of mkpkg.e + */ +int +main (int argc, char *argv[]) +{ + struct context *cx; + char flags[SZ_LINE+1]; + char *symargs[MAX_ARGS], *modules[MAX_ARGS]; + int islib, nsymargs=0, nmodules=0, i; + char **argp, *ip, *op; + + ZZSTRT(); + + /* Initialize the MKPKG context. + */ + irafdir[0] = EOS; + topcx = cx = (struct context *) calloc (1, sizeof (struct context)); + if (cx == NULL) + fatals ("out of memory (%s)", "mkpkg.e"); + + strcpy (cx->mkpkgfile, MKPKGFILE); + os_fpathname ("", cx->dirpath, SZ_PATHNAME); + m_fninit (0); + m_fdinit (0); + + exit_status = OK; + ifstate[0] = PASS; + iflev = 0; + flags[0] = EOS; + islib = YES; + npkg = 0; + + /* Process the command line. + */ + for (argp = &argv[1]; *argp; ) { + if (**argp == '-') { + /* A Mkpkg switch, or a flag to be passed on to XC. + */ + for (ip = *argp++ + 1; *ip; ip++) { + switch (*ip) { + case 'f': + if (*argp == NULL) + warns ("missing argument to switch `-f'", NULL); + else + strcpy (cx->mkpkgfile, *argp++); + break; + case 'i': + ignore = YES; + break; + case 'd': + /* There are multiple levels of "debug"; each + * -d in the arg list adds a level. + */ + debug++; + verbose = YES; + break; + case 'x': + case 'g': + dbgout++; + goto addflag; + case 'n': + execute = NO; + verbose = YES; + break; + case 'p': + if (*argp == NULL) + warns ("missing argument to switch `-p'", NULL); + else { + pkgenv[npkg] = *argp++; + loadpkgenv (pkgenv[npkg]); + if (npkg++ >= MAX_PKGENV) + fatals ("too many -p package arguments", NULL); + } + break; + case 'u': + forceupdate = YES; + break; + case 'v': + verbose = YES; + break; + case 'w': + zzpause(); + break; + case 'r': + if (*argp == NULL) + warns ("missing argument to switch `-r'", NULL); + else + strcpy (irafdir, *argp++); + break; + default: +addflag: for (op=flags; *op; op++) + ; + *op++ = ' '; + *op++ = '-'; + *op++ = *ip; + *op++ = EOS; + break; + } + } + + } else if (index (*argp, '=') != NULL) { + /* Mark the position of a symbol definition argument. Wait + * to enter this into the symbol table until after the command + * line has been processed and the mkpkg global include file + * has been read in, but go ahead and update the environment + * in case a logical name is affected which is referenced while + * processing the rest of the argument list. + */ + char symbol[SZ_FNAME+1]; + char *ip, *op; + + ip = symargs[nsymargs++] = *argp++; + for (op=symbol; (*op = *ip++) != '='; op++) + ; + *op = EOS; + os_putenv (symbol, ip); + + } else { + /* The name of a module to be processed. + */ + modules[nmodules++] = *argp++; + } + } + + if (debug) { + printf ("mkpkg"); + for (argp = &argv[1]; *argp; argp++) + printf (" %s", *argp); + printf ("\n"); + fflush (stdout); + } + + /* Initialize the package environment. This has already been done + * if any -p pkgname arguments were given on the command line, + * otherwise look for the name PKGENV in the user's environment. + */ + if (npkg <= 0) + if ((pkgenv[0] = os_getenv (PKGENV))) { + char *ip; + + strcpy (v_pkgenv, pkgenv[0]); + for (ip=v_pkgenv; *ip; ) { + while (isspace (*ip)) + ip++; + pkgenv[npkg] = ip; + while (*ip && !isspace (*ip)) + ip++; + *ip++ = EOS; + loadpkgenv (pkgenv[npkg]); + if (npkg++ >= MAX_PKGENV) + fatals ("too many -p package arguments", NULL); + } + } + + /* Initialize the symbol table from the system dependent global + * MKPKG include file. + */ + do_include (cx, MKPKGINC); + + /* Likewise load the package global mkpkg.inc files for each + * reference package. + */ + if (npkg > 0) { + char fname[SZ_PATHNAME+1]; + int i; + + for (i=0; i < npkg; i++) { + sprintf (fname, "%s$lib/mkpkg.inc", pkgenv[i]); + do_include (cx, fname); + } + } + + /* Append any flags given on the command line to XFLAGS. + */ + if (flags[0]) { + char new_xflags[SZ_LINE+1]; + sprintf (new_xflags, "%s %s", getsym(XFLAGS), flags); + putsym (XFLAGS, new_xflags); + } + + /* Append any flags given on the command line to XVFLAGS. + */ + if (flags[0]) { + char new_xvflags[SZ_LINE+1]; + sprintf (new_xvflags, "%s %s", getsym(XVFLAGS), flags); + putsym (XVFLAGS, new_xvflags); + } + + /* Append any flags given on the command line to LFLAGS. + */ + if (flags[0]) { + char new_lflags[SZ_LINE+1]; + sprintf (new_lflags, "%s %s", getsym(LFLAGS), flags); + putsym (LFLAGS, new_lflags); + } + + /* Define the symbol "DEBUG" if building for debugging (-x). + */ + if (dbgout) + putsym (DEBUGSYM, "1"); + + /* Enter any symbols or macros defined on the command line into the + * symbol table and environment. Must be given without embedded + * whitespace, e.g., "symbol=value". + */ + for (i=0; i < nsymargs; i++) { + char symbol[SZ_FNAME+1]; + char *ip, *op, *value; + + for (ip = symargs[i], op=symbol; (*op = *ip++) != '='; op++) + ; + *op = EOS; + value = ip; + putsym (symbol, value); + os_putenv (symbol, value); + } + + /* Process the named modules (or the first module in the mkpkg file + * if no modules were named. + */ + if (nmodules == 0) { + cx->library[0] = EOS; + exit_status = do_mkpkg (cx, islib = 0); + } else { + for (i=0; i < nmodules; i++) { + /* If the module is a library specification, the module name, + * which is the filename of the library, must end in ".a". + */ + char *ip, *op; + for (ip = modules[i], op=cx->library; (*op = *ip++); op++) + ; + islib = (strcmp (op - 2, ".a") == 0); + exit_status += do_mkpkg (cx, islib); + } + } + + free (cx); + m_fninit (debug); + m_fdinit (debug); + + ZZSTOP(); + exit (exit_status == OK ? OSOK : exit_status); +} + + +/* WARNS -- Print error message with one string argument but do not terminate + * program execution. + */ +void +warns (char *fmt, char *arg) +{ + char errmsg[SZ_LINE+1]; + + sprintf (errmsg, fmt, arg); + printf ("Warning, %s line %d: %s\n", topcx->mkpkgfile, topcx->lineno, + errmsg); + fflush (stdout); +} + + +/* FATALS -- Print error message with one string argument and terminate + * program execution. + */ +void +fatals (char *fmt, char *arg) +{ + char errmsg[SZ_LINE+1]; + + sprintf (errmsg, fmt, arg); + printf ("Fatal error, %s line %d: %s\n", topcx->mkpkgfile, + topcx->lineno, errmsg); + fflush (stdout); + exit (OSOK+1); +} diff --git a/unix/boot/mkpkg/mkpkg b/unix/boot/mkpkg/mkpkg new file mode 100644 index 00000000..d842357d --- /dev/null +++ b/unix/boot/mkpkg/mkpkg @@ -0,0 +1,33 @@ +# Make the MKPKG utility [MACHDEP]. + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $set LIBS = "$(HSI_LIBS)" + $set XFLAGS = "-c $(HSI_XF)" + + $update libpkg.a + $omake main.c mkpkg.h + !$(CC) $(HSI_LF) main.o libpkg.a $(LIBS) $(HSI_OSLIBS) -o mkpkg.e + ; + +install: + $move mkpkg.e $(hlib) + ; + +libpkg.a: + char.c extern.h mkpkg.h + fdcache.c + fncache.c + host.c + pkg.c extern.h mkpkg.h + scanlib.c + sflist.c mkpkg.h extern.h + tok.c extern.h mkpkg.h + ; diff --git a/unix/boot/mkpkg/mkpkg.h b/unix/boot/mkpkg/mkpkg.h new file mode 100644 index 00000000..9b8073d7 --- /dev/null +++ b/unix/boot/mkpkg/mkpkg.h @@ -0,0 +1,254 @@ +/* MKPKG.H -- Global definitions for MKPKG. + */ + +#define SZ_SBUF 10240 /* string buffer size (fixed) */ +#define SZ_PBSTK 50 /* push back stack */ +#define SZ_PBBUF 2048 /* push back buffer */ +#define SZ_CMD 2048 /* buf for os escape */ +#define SZ_IFSTACK 50 /* max $IF nesting */ +#define SZ_PREDBUF 1024 /* largest $IF predicate */ +#define SZ_PKGENV 256 /* pkgenv package list buffer */ +#define MAX_ARGS 50 /* max args to a $IF */ +#define MAX_FILES 512 /* max files in a module list */ +#define MAX_LIBFILES 8192 /* max files in a library index */ +#define MAX_DEPFILES 100 /* max dependency files */ +#define MAX_SYMBOLS 256 /* max macros */ +#define MAX_SFDIRS 128 /* max dirs containing special files */ +#define MAX_SFFILES 1024 /* max special files */ +#define MAX_PKGENV 20 /* max package environments */ + +#define INTERRUPT SYS_XINT +#define MKPKGFILE "mkpkg" +#define MKPKGINC "hlib$mkpkg.inc" +#define PKGENV "PKGENV" +#define LFLAGS "lflags" +#define XFLAGS "xflags" +#define XVFLAGS "xvflags" +#define DEBUGSYM "debug" +#define XC "xc" +#define GENERIC "generic" +#define GFLAGS "gflags" +#define BACK ".." + +#define BEGIN_CHAR ':' +#define END_CHAR ';' +#define SUBDIR_CHAR '@' +#define COMMENT '#' +#define PREPROCESSOR '$' +#define SYSCMD '!' +#define SYSFILE_BEGIN '<' +#define SYSFILE_END '>' +#define ESCAPE '\\' + +#define PASS 1 +#define STOP 0 +#define TOK_FNAME 1 +#define TOK_NEWLINE 2 +#define TOK_BEGIN 3 +#define TOK_END 4 +#define TOK_WHITESPACE 5 + +/* Pushback structure, used to implement macro expansion. + */ +struct pushback { + char *ip; /* next char to return */ + char *op; /* next avail char in buffer */ + char *otop; /* top of buffer */ + int npb; /* number of pushed ips */ + char *pbstk[SZ_PBSTK]; /* save pushed ips */ + char pbbuf[SZ_PBBUF+1]; /* push back buffer */ +}; + +/* Mkpkg context descriptor. + */ +struct context { + FILE *fp; /* mkpkg file descriptor */ + long fpos; /* saved file pointer */ + struct pushback *pb; /* pushback descriptor */ + int pbchar; /* single char pushback */ + int pushback; /* flag that is pushback */ + struct context *prev; /* previous mkpkg context */ + int totfiles; /* total library files updated */ + int nfiles; /* nfiles last updated */ + int nrfiles; /* nrfiles last updated */ + int lineno; /* lineno in mkpkg file */ + int level; /* subdirectory level */ + int sublib; /* called from lib module list */ + char *old_cp; /* old cp when pushing new ctx */ + int old_nsymbols; /* old nsymbols */ + int old_iflev; /* old IF stack pointer */ + char *flist[MAX_FILES]; /* file list */ + char *rflist[MAX_FILES]; /* remote file list */ + char curdir[SZ_PATHNAME+1]; /* cwd for printed output */ + char dirpath[SZ_PATHNAME+1]; /* os path of cwd */ + char library[SZ_PATHNAME+1]; /* library being updated */ + char libpath[SZ_PATHNAME+1]; /* pathname of library */ + char mkpkgfile[SZ_FNAME+1]; /* mkpkg file being scanned */ +}; + +/* Macros. + */ +struct symbol { + char *s_name; /* symbol name */ + char *s_value; /* symbol value */ +}; + +/* Special file list. + */ +struct sfile { + char *sf_stname; /* standard filename */ + char *sf_sfname; /* special filename */ + char *sf_mkobj; /* MKPKG command to make object */ + struct sfile *sf_next; /* next file in directory */ +}; + + +/* External functions. + */ +struct sfile *sf_dirsearch(), *sf_filesearch(); +struct context *push_context(); +struct context *pop_context(); +char *vfn2osfn(); +char *os_getenv(); +char *mklower(); +char *getargs(); +char *makeobj(); +char *getsym(); +char *putstr(); +/* +char *malloc(); +char *calloc(); +*/ +long os_fdate(); +long m_fdate(); +char *index(); +char *k_fgets(); + + +/*****************************************************************************/ + +/* main.c */ +void warns (char *fmt, char *arg); +void fatals (char *fmt, char *arg); + + +/* char.c */ +int m_getc (register struct context *cx); +int m_rawgetc (register struct context *cx); +void m_ungetc (int ch, struct context *cx); +void m_pushstr (struct context *cx, char *str); +void mk_pbbuf (register struct context *cx); +void pb_cancel (register struct context *cx); +char *putstr (char *s); + +int k_getc (register struct context *cx); +char *k_fgets (char *obuf, int maxch, register struct context *cx); +int k_fseek (register struct context *cx, long offset, int type); +long k_ftell (register struct context *cx); + + +/* fdcache.c */ +long m_fdate (char *fname); +void m_fdinit (int debug); +int fd_chksum (char *s); + + +/* fncache.c */ +int m_sysfile (char *lname, char *fname, int maxch); +void m_fninit (int debug); +int fn_chksum (char *s); +int fn_strncpy (char *out, char *in, int maxch); + + +/* host.c */ +int h_updatelibrary (char *library, char *flist[], int totfiles, + char *xflags, char *irafdir); +int h_rebuildlibrary (char *library); +int h_incheck (char *file, char *dir); +int h_outcheck (char *file, char *dir, int clobber); +void h_getlibname (char *file, char *fname); +int h_xc (char *cmd); +int h_purge (char *dir); +int h_copyfile (char *oldfile, char *newfile); + +int u_fcopy (char *old, char *new); +int h_movefile (char *old, char *new); +int u_fmove (char *old, char *new ); + +int add_sources (char *cmd, int maxch, char *flist[], + int totfiles, int hostnames, int *nsources); +int add_objects (char *cmd, int maxch, char *flist[], + int totfiles, int hostnames); + +char *makeobj (char *fname); +char *mkpath (char *module, char *directory, char *outstr); +char *resolvefname (char *fname); +int h_direq (char *dir1, char *dir2); + + +/* pkg.c */ +int do_mkpkg (struct context *cx, int islib); +int scan_modlist (struct context *cx, int islib); +void parse_modname (char *modname, char *module, char *subdir, char *fname); +void parse_fname (char *path, char *dname, char *fname); +struct context *push_context (register struct context *cx, char *module, + char *newdir, char *fname); +struct context *pop_context (register struct context *cx); +void get_dependency_list (struct context *cx, char *module, + char *dflist[], int maxfiles); +int up_to_date (struct context *cx, char *module, char *lname, + char *dflist[], int *useobj); +int open_mkpkgfile (register struct context *cx); +void close_mkpkgfile (register struct context *cx); +struct context *find_mkpkgfile ( struct context *head_cx, + char *mkpkgfile, int level); +int search_mkpkgfile (register struct context *cx); + + +/* tok.c */ +int gettok (register struct context *cx, char *outstr, int maxch ); + +void do_osescape (register struct context *cx); +void do_ppdir (struct context *cx, char *token); +void do_if (struct context *cx, char *keyword); +void do_else (struct context *cx); +void do_endif (struct context *cx); +void do_end (struct context *cx); +void do_call (struct context *cx, char *program, int islib); +void do_echo (struct context *cx, char *msg); +int do_goto (struct context *cx, char *symbol); +int do_include (struct context *cx, char *fname); +void do_omake (struct context *cx, char *fname); +int do_xc (struct context *cx); +int do_link (struct context *cx); +int do_generic (struct context *cx); +void do_set (struct context *cx); +int do_incheck (struct context *cx); +int do_outcheck (struct context *cx); +int do_copyfile (struct context *cx); +int do_movefile (struct context *cx); +void do_delete (struct context *cx); +void do_purge (struct context *cx, char *dname); + +int getcmd (register struct context *cx, char *prefix, char *cmd, int maxch); +char *getargs (register struct context *cx); +int getstr (register struct context *cx, char *outstr, int maxch, int delim); +int getkwvpair (register struct context *cx, char *symbol, char *value); +int getword (char **str, char *outstr, int maxch); +void putsym (char *name, char *value); +char *getsym (char *name); +char *mklower (char *s); + + +/* sflist.c */ +int sf_scanlist (struct context *cx); +struct sfile *sf_dirsearch (char *dirname); +struct sfile *sf_filesearch (struct sfile *sflist, char *stname); +void sf_prune (register char *cp); + + +/* scanlib.c */ +int h_scanlibrary (char *library); +long h_ardate (char *fname); +int mlb_setdate (char *modname, long fdate); +long mlb_getdate (char *modname); diff --git a/unix/boot/mkpkg/mkpkg.hlp b/unix/boot/mkpkg/mkpkg.hlp new file mode 100644 index 00000000..39dd1163 --- /dev/null +++ b/unix/boot/mkpkg/mkpkg.hlp @@ -0,0 +1,626 @@ +.help mkpkg Mar90 "softools" +.ih +NAME +mkpkg - make or update a package or library +.ih +USAGE +mkpkg [switches] [module ...] [name=value ...] +.ih +ARGUMENTS +.ls 10 \fB-d[ddd]\fR +Debug mode. Print detailed messages describing what \fImkpkg\fR is doing. +There are four levels of debug messages, selected by repeating the "d" +character in the switch, e.g., "-d" is level one, "-dd" is level two, and +so on. The debug messages get progressively more detailed as the debug level +increases. Debug mode automatically enables the verbose mode messages. +.le +.ls 10 \fB-f file\fR +Set the name of the file to be interpreted (default: "mkpkg"). +The special value "stdin" (lower case) allows commands to be entered +interactively from the standard input, e.g., for debugging \fImkpkg\fR. +.le +.ls 10 \fB-i\fR +Ignore errors. Execution continues even if an error occurs. In most cases +it does anyhow, so this switch has little effect at present. +.le +.ls 10 \fB-n\fR +No execute. Go through the motions, but do not touch any files. +No execute mode automatically enables verbose mode (flag "-v"). +This switch should be used to verify new mkpkg files before execution. +.le +.ls 10 \fB-p \fIpkgname\fR +Load the package environment for the named external package, e.g., +"mkpkg -p noao update". If the same package is always specified +the environment variable or logical name PKGENV may be defined at the +host level to accomplish the same thing. The package name \fImust\fR +be specified when doing software development in an external or layered +package. +.le +.ls 10 \fB-u\fR [AOSVS/IRAF only] +Forcibly update the dates of improperly dated library modules. This option +is used when a binary archive is restored on a machine which cannot restore +the file modify dates. In this case, all source file dates would appear to +have been modified since the libraries were updated, causing all sources to +be recompiled. By running \fImkpkg\fR with the \fI-u\fR flag, one can update +the library module dates without recompiling the associated files. This is +done by setting the date of each library module to be no older than the +file \fIhlib$iraf.h\fR, which should be "touched" after the system has fully +been restored to disk to mark the installation time. Note that files which +have been modified \fIsince\fR the system was restored to disk will still +cause the affected library modules to be updated, even when the \fI-u\fR flag +is specfied. +.le +.ls 10 \fB-v\fR +Verbose mode. A message is printed whenever a file is touched. +Recommended when running large mkpkg jobs in batch mode. +.le +.ls 10 \fBmodule\fR +The names of the module or modules (named entries in the "mkpkg" file) to be +executed. If no module is named the first module encountered is executed, +unless a \fImkpkg\fR macro preprocessor directive at the beginning of the file +specifies a different default action. +.le +.ls 10 \fBname=value [name=value...]\fR +Enter the named symbol/value pair into the symbol table of the \fImkpkg\fR +macro preprocessor. The symbols \fIXFLAGS\fR (for the XC compiler) and +\fILFLAGS\fR (for the linker) are predefined but may be redefined on the +command line. Case is ignored in symbol names for portability reasons. +.le +.ih +DESCRIPTION +The \fImkpkg\fR utility is used to make or update IRAF packages or libraries. +\fIMkpkg\fR is used to bootstrap the IRAF system hence is implemented as +a foreign task, callable either from within the IRAF environment or from the +host system. Usage is identical in either case (except that the details of +when a particular argument may need to be quoted will vary depending on the +command language used). \fIMkpkg\fR is upwards compatible with the old +\fImklib\fR utility. + + +.tp 4 +1. \fBIntroduction\fR + + \fIMkpkg\fR provides two major facilities: a library update capability and +a macro preprocessor. The macro preprocessor provides symbol definition and +replacement, conditional execution, and a number of builtin commands. +The usefulness of these facilities is enhanced by the ability of \fImkpkg\fR +to update entire directory trees, or to enter the hierarchy of \fImkpkg\fR +descriptors at any level. For example, typing "mkpkg" in the root directory +of IRAF will make or update the entire system, whereas in the "iraf$sys" +directory \fImkpkg\fR will update only the system libraries, and in the +"iraf$sys/fio" directory \fImkpkg\fR will update only the FIO portion of the +system library "libsys.a". + +The \fImkpkg\fR utility is quite simple to use to maintain small packages +or libraries, despite the complexity of the discussion which follows. +The reader is encouraged to study several examples of working mkpkg-files +before reading further; examples will be found throughout the IRAF system. +The mkpkg files for applications packages tend to be very similar to one +another, and it is quite possible to successfully copy and modify the +mkpkg-file from another package without studying the reference information +given here. + + +.tp 4 +2. \fBLexical Conventions\fR + + The lexical conventions employed in \fImkpkg\fR are those used throughout +IRAF. Comments may occur anywhere, begin with the character #, and extend +to the end of the current line. Blank lines are ignored virtually everywhere. +Newline may be escaped with backslash to continue on the next line. +All filenames are IRAF virtual filenames with the following extensions. + + +.ks +.nf + .a object library + .c C source + .e executable (e.g., "x_package.e") + .f Fortran source + .gc generic C source + .gx generic SPP source + .h C or SPP header file + .inc include file + .l Lex source + .o object file + .r Ratfor source + .s assembler source + .y Yacc source +.fi +.ke + + +Since \fImkpkg\fR is an IRAF utility it recognizes the major IRAF logical +directories; these are summarized in the list below. The IRAF (or UNIX) +pathname convention is used to specify pathnames rooted in the current +directory or a logical directory. + + +.ks +.nf + as$ where .s files go host$as/ + bin$ installed executables iraf$bin/ + dev$ device tables iraf$dev/ + hlib$ machdep header files host$hlib/ + host$ host system interface [MACHDEP] + iraf$ the root directory of IRAF [MACHDEP] + lib$ system library iraf$lib/ + math$ math sources iraf$math/ + pkg$ applications packages iraf$pkg/ + sys$ the VOS, system libraries iraf$sys/ + tmp$ where temporary files go [MACHDEP] +.fi +.ke + + +All other directories should be referenced by giving the path from either the +current directory or from one of the system logical directories shown above. +For example, "pkg$system/" is the root directory of the SYSTEM package, +and ".." is the directory one level up from the current directory. + + +.tp 4 +3. \fBMaintaining Libraries with MKPKG\fR + + Libraries are described by a \fBmember list\fR module in the "mkpkg" file. +The syntax of a library member list module is shown below. Note that the +\fBmkpkg\fR module name for a library member list module is the same as the +name of the actual library, hence must end with the extension ".a". + + +.ks +.nf + libname.a: + member1 dep1 dep2 ... depN + member2 dep1 dep2 ... depN + ... + memberN dep1 dep2 ... depN + ; +.fi +.ke + + +Here, "libname.a" is the IRAF virtual filename of the library (regardless of +what directory it resides in), "memberN" is the name of a source file which +may contain any number of actual library object modules, and "depN" is the +name of a file upon which the named member depends. If any of the named +dependency files is newer than the corresponding member source file, or if +the member source file is newer than the compiled library object module, +the source file is recompiled and replaced in the library. Both source +files and dependency files may reside in remote directories. The names of +dependency files in system libraries should be enclosed in <> delimiters, +e.g., "". Each member must be described on a separate line. + +If the library being updated does not reside in the current directory +(directory from which the "mkpkg" command was entered) then the library must +be "checked out" of the remote directory before it can be updated, and checked +back in when updating is complete. These operations are performed by macro +preprocessor directives, e.g.: + + +.ks +.nf + $checkout libsys.a lib$ + $update libsys.a + $checkin libsys.a lib$ + $exit + + libsys.a: + @symtab # update libsys.a in ./symtab + brktime.x + environ.x environ.com environ.h \ + + main.x \ + \ + + onentry.x + spline.x + ; +.fi +.ke + + +Note that the checkout operation is required only in the directory from which +the "mkpkg" command was entered, since the library has already been checked +out when the mkpkg-file in a subdirectory is called to update its portion +of the library (as in the "@symtab" in the example above). The checkout +commands should however be included in each mkpkg-file in a hierarchy in such +a way that the library will be automatically checked out and back in if +\fImkpkg\fR is run from that directory. The checkout commands are ignored +if the mkpkg-file is entered when updating the library from a higher level, +because in that case \fImkpkg\fR will search for the named entry for the +library being updated, ignoring the remainder of the mkpkg-file. + +Sometimes it is necessary or desirable to break the library member list up +into separate modules within the same mkpkg-file, e.g., to temporarily +change the value of the symbol XFLAGS when compiling certain modules. +To do this use the "@" indirection operator in the primary module list to +reference a named sublist, as in the example below. Normal indirection +cannot be used unless the sublist resides in a subdirectory or in a different +file in the current directory, e.g., "@./mki2", since a single mkpkg-file +cannot contain two modules with the same name. The same restrictions apply +to the \fI$update\fR operator. + + +.ks +.nf + libpkg.a: + @(i2) + alpha.x + beta.x + zeta.f + ; + i2: + $set XFLAGS = "-cO -i2" + gamma.f + delta.f + ; +.fi +.ke + + +In the example above five object modules are to be updated in the library +"libpkg.a". The files listed in module "i2", if out of date, will be compiled +with the nonstandard XFLAGS (compiler flags) specified by the \fI$set\fR +statement shown. + + +.tp 4 +4. \fBThe MKPKG Macro Preprocessor\fR + + The \fImkpkg\fR macro preprocessor provides a simple recursive symbol +definition and replacement facility, an include file facility, conditional +execution facilities, an OS escape facility, and a number of builtin directives. +The names of the preprocessor directives always begin with a dollar sign; +whitespace is not permitted between the dollar sign and the remainder of the +name. Several preprocessor directives may be given on one line if desired. +Preprocessor directives are executed as they are encountered, and may appear +anywhere, even in the member list for a library. + + +.tp 4 +4.1 Symbol Replacement + + Symbol substitution in the \fImkpkg\fR macro preprocessor is carried out +at the character level rather than at the token level, allowing macro expansion +within tokens, quoted strings, or OS escape commands. Macros are recursively +expanded but may not have arguments. + +Macros may be defined on the \fBmkpkg\fR command line, in the argument list +to a \fB$call\fR or \fB$update\fR directive (see below), in an include file +referenced with the \fB$include\fR directive, or in a \fB$set\fR directive. +All symbols are global and hence available to all lower level modules, +but symbols are automatically discarded whenever a module exits, hence cannot +affect higher level modules. A local symbol may redefine a previously +defined symbol. The IRAF and host system environment is treated as an +extension of the \fBmkpkg\fR symbol table, i.e., a logical directory such +as "iraf" may be referenced like a locally defined symbol. + +Macro replacement occurs only when explicitly indicated in the input text, +as in the following example, which prints the pathname of the +\fBdev$graphcap\fR file on the \fBmkpkg\fR standard output. The sequence +"$(" triggers macro substitution. The value of a symbol may be obtained +interactively from the standard input by adding a question mark after the +left parenthesis, i.e., "$(?terminal)" (this does not work with the -f stdin +flag). The contents of a file may be included using the notation +"$(@\fIfile\fR)". Note that case is ignored in macro names; by convention, +logical directories are normally given in lower case, and locally defined +symbols in upper case. + + +.ks +.nf + $echo $(dev)graphcap + !xc $(XFLAGS) filea.x fileb.x +.fi +.ke + + +Symbols are most commonly defined locally with the \fB$set\fR directive. +The \fB$include\fR directive is useful for sharing symbols amongst different +modules, or for isolating any machine dependent definitions in a separate +file. The IRAF \fBmkpkg\fR system include file \fBhlib$mkpkg.inc\fR is +automatically included whenever \fImkpkg\fR is run. +.ls 4 +.ls \fB$set\fR symbol = value +Enter the named symbol into the symbol table with the given string value. +Any existing symbol will be silently redefined. Symbols defined within a +module are discarded when the module exits. +.le +.ls \fB$include\fR filename +Read commands (e.g., \fB$set\fR directives) from the named include file. +The include filename may be any legal virtual filename, but only the +major logical directories are recognized, e.g., "iraf$", "host$", "hlib$", +"lib$", "pkg$", and so on. +.le +.le + + +The use of the \fB$set\fR directive is illustrated in the example below. +Note the doubling of the preprocessor meta-character to avoid macro expansion +when entering the value of the GEN macro into the symbol table. The sequence +"$$" is replaced by a single "$" whenever it is encountered in the input +stream. + + +.ks +.nf + $set GFLAGS = "-k -t silrdx -p ak/" + $set GEN = "$generic $$(GFLAGS)" + + ifolder (amulr.x, amul.x) $(GEN) amul.x $endif +.fi +.ke + + +.tp 4 +4.2 Conditional Execution + + Conditional control flow is implemented by the \fB$if\fR directives +introduced in the last example and described below. The character "n" may +be inserted after the "$if" prefix of any directive to negate the sense of +the test, e.g., "$ifndef" tests whether the named symbol does not exist. +Nesting is permitted. +.ls 4 +.ls \fB$ifdef\fR (symbol [, symbol, ...]) +.sp +Test for the existence of one of the named symbols. +.le +.ls \fB$ifeq\fR (symbol, value [, value,...]) +.sp +Test if the value of the named symbol matches one of the listed value strings. +.le +.ls \fB$iferr\fR +.sp +Test for an error return from the last directive executed which touched +a file. +.le +.ls \fB$iffile\fR (file [, file,...]) +.sp +Test for the existence of any of the named files. +.le +.ls \fB$ifnewer\fR (file, filea) +.in -4 +\fB$ifnewer\fR (file: filea [, fileb, ...]) +.in 4 +.sp +Test if the named file is newer (has been modified more recently) than +any of the named files to the right. The colon syntax may be used for +clarity when comparing one file to many, but a comma will do. +.le +.ls \fB$ifolder\fR (file, filea) +.in -4 +\fB$ifolder\fR (file: filea [, fileb, ...]) +.in 4 +.sp +Test if the named file is older than any of the named files. +.le +.ls \fB$else\fR +.sp +Marks the \fIelse\fR clause of an \fIif\fR statement. The \fIelse-if\fR +construct is implemented as "$else $if", i.e., as a combination of the two +more primitive constructs. +.le +.ls \fB$endif\fR +.sp +Terminates a $if or $if-$else statement. +.le +.ls \fB$end\fR +.sp +Terminates an arbitrary number of $if or $if-$else statements. This is most +useful for terminating a long list of $if-$else clauses, where the alternative +would be a long string of $endif directives. +.le +.ls \fB$exit\fR +Terminate the current program; equivalent to a semicolon, but the latter +is normally used only at the end of the program to match the colon at the +beginning, whereas \fB$exit\fR is used in conditionals. +.le +.le + + +.tp 4 +4.3 Calling Modules + + The following preprocessor directives are available for calling \fImkpkg\fR +modules or altering the normal flow of control. +.ls +.ls \fB$call\fR module[@subdir[/file]] [name=value] [name=value...] +.sp +Call the named mkpkg-file module as a subroutine. In most cases the called +module will be in the current mkpkg-file, but the full module name syntax +permits the module to be in any file of any subdirectory ("./file" references +a different file in the current directory). Arguments may be passed to +the called module using the symbol definition facility; any symbols +defined in this fashion are available to any modules called in turn by +the called module, but the symbols are discarded when the called module returns. +.le +.ls \fB$update\fR module[@subdir[/file]] [name=value] [name=value...] +.sp +Identical to \fB$call\fR except that the named module is understood to +be a library member list. The current value of the symbol XFLAGS is used +if XC is called to compile any files. If the named library does not exist +one will be created (a warning message is issued). +.le +.ls \fB$goto\fR label +.sp +Causes execution to resume at the line following the indicated label. +The syntax of a goto label is identical to that of a mkpkg-file module name, +i.e., a line starting with the given name followed by a colon. +The \fI$goto\fR statement automatically cancels any \fI$if\fR nesting. +.le +.le + + +.tp 4 +4.4 Preprocessor Directives + + The remaining preprocessor directives are described below in alphabetical +order. Additional capability is available via OS escapes, provided the +resultant machine dependence is acceptable. +.ls +.ls \fB$echo\fR message +.sp +Print the given message string on the standard output. The string must be +quoted if it contains any spaces. +.le +.ls \fB$checkout\fR file directory +.sp +Check the named file out of the indicated directory. The checkout operation +makes the file accessible as if it were in the current directory; checkout +is implemented either as a symbolic link or as a physical file copy depending +upon the host system. The referenced directory may be a logical directory, +e.g., "lib$", or a path, e.g, "pkg$images/". Checkout is not disabled by +the "-n" flag. +.le +.ls \fB$checkin\fR file directory +.sp +Check the named file back into the indicated directory. The checkin operation +is implemented either as a remove link or copy and delete depending upon the +host system. Checkin is not disabled by the "-n" flag. +.le +.ls \fB$copy\fR filea fileb +.sp +Make a copy \fIfileb\fR of the existing file \fIfilea\fR. On a UNIX host +the copy operation will preserve the file modify date if the file is a library +(to avoid the "symbol table out of date" syndrome). +.le +.ls \fB$delete\fR file [file ...] +.sp +Delete the named file or files. +.le +.ls \fB$generic\fR [-k] [-p prefix] [-t types] [-o root] files +.sp +Run the generic preprocessor on the named files. The generic preprocessor +is an IRAF bootstrap utility and may not be available on non-UNIX hosts. +.le +.ls \fB$link\fR [switches] file1 file2 ... fileN [-o file.e] +.sp +Call XC with the given argument list to link the indicated files and libraries. +The value of the symbol LFLAGS (default value the null string) is automatically +inserted at the beginning of the command line. This is equivalent to +"!xc $(LFLAGS) ...". +.le +.ls \fB$move\fR file destination +.sp +Move the named file to the indicated directory, or rename the file in the +current directory. +.le +.ls \fB$omake\fR file [dep1] [dep2 ...] +.sp +Compile the named source file if it does not have a corresponding object file +in the current directory, if the object file is older, or if any of the +listed dependency files are newer (or not found). The current value of the +symbol XFLAGS is used if XC is called to compile the file. +.le +.ls \fB$purge\fR directory +.sp +Delete all old versions of all files in the named directory. Nothing is done +if the system does not support multiple file versions. +.le +.ls \fB$special\fR directory : filelist ; +.sp +Add one or more files to the special file list for the host system. This is +a system facility, not intended for use in applications \fImkpkg\fR files. +The special file list is a list of all source files needing special processing +for the local host system. Examples of special files are files which are +optimized in assembler (or some other nonstandard language), or files which +must be compiled in a special way to get around bugs in a host compiler. +The special file list makes it possible to flag arbitrary files for special +processing, without having to modify the standard software distribution. +In the IRAF system, the special file list is defined in the file +"hlib$mkpkg.sf" which is included automatically by "hlib$mkpkg.inc" whenever +\fImkpkg\fR is run. + +The syntax of a \fIfilelist\fR entry is as follows: + + modname source_file mkobj_command + +where \fImodname\fR is the filename of a library module as it appears in a +library module list for the named directory, \fIsource_file\fR is the virtual +pathname of the source file to be used in lieu of the standard portable +source file \fImodname\fR, and \fImkobj_command\fR is the \fImkpkg\fR command +(e.g., $xc or an OS escape) to be executed to compile the named module. +The character "&" appearing in either the source file name or mkobj command +is replaced by \fImodname\fR. If the \fImkobj_command\fR is omitted the +specified source file will be compiled with $XC using the current value of +XFLAGS. +.le +.ls \fB$xc\fR [switches] file1 file2 ... fileN +.sp +Call the XC compiler to compile the named files. Note that the value of +the symbol XFLAGS is \fInot\fR used when XC is explicitly called in this +fashion (XFLAGS is used by \fB$update\fR and \fB$omake\fR). +.le +.ls \fB$debug\fR [on|off] +.sp +Turn debug mode on or off. If no argument is supplied debug mode is turned +on. Turning on debug mode automatically enables verbose mode. +.le +.ls \fB$verbose\fR [on|off] +.sp +Turn verbose mode on or off. If no argument is supplied verbose mode is turned +on. +.le +.le + + +.tp 4 +5. Error Recovery + + \fBMkpkg\fR is implemented in such a way that it is restartable. If a mkpkg +operation terminates prematurely for some reason, e.g., because of a compile +error, execution error (such as cannot find the mkpkgfile in a subdirectory), +interrupt, etc., then the mkpkg command can be repeated after correcting +the error, without repeating the operations already completed. If \fBmkpkg\fR +is interrupted it may leave checked out files, objects compiled but not yet +updated in a library, etc. lying about, but this is harmless and the +intermediate files will be cleaned up when the errors have been corrected +and the run successfully completes. + +.ih +EXAMPLES +Update the current package. + + cl> mkpkg + +Update the package library but do not relink. + + cl> mkpkg libpkg.a + +Make a listing of the package. + + cl> mkpkg listing + + +.ks +.nf +Sample mkpkg-file for the above commands: + + + # Make my package. + + $call relink + $exit + + relink: + $update libpkg.a + $omake x_mypkg.x + $link x_mypkg.o -lxtools + ; + + libpkg.a: + task1.x pkg.h + task2.x + filea.x pkg.com pkg.h + fileb.x pkg.com + ; + + listing: + !pr task1.x task2.x file[ab].x | vpr -Pvup + ; +.fi +.ke +.ih +SEE ALSO +xc, generic, softools package diff --git a/unix/boot/mkpkg/mkpkg.sh b/unix/boot/mkpkg/mkpkg.sh new file mode 100644 index 00000000..a565cd70 --- /dev/null +++ b/unix/boot/mkpkg/mkpkg.sh @@ -0,0 +1,9 @@ +# Bootstrap MKPKG. + +$CC -c $HSI_CF char.c fdcache.c fncache.c host.c main.c pkg.c scanlib.c\ + sflist.c tok.c +$CC $HSI_LF main.o char.o fdcache.o fncache.o host.o pkg.o scanlib.o\ + sflist.o tok.o $HSI_LIBS -o mkpkg.e + +mv -f mkpkg.e ../../hlib +rm *.o diff --git a/unix/boot/mkpkg/pkg.c b/unix/boot/mkpkg/pkg.c new file mode 100644 index 00000000..a8875bc3 --- /dev/null +++ b/unix/boot/mkpkg/pkg.c @@ -0,0 +1,902 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "mkpkg.h" +#include "extern.h" +#include "../bootProto.h" + + +/* DO_MKPKG -- Open the mkpkg file and scan it for the named program. A program + * may be either a sequence of preprocessor directives or the module list for + * a library, as indicated by the ISLIB flag. In the case of a library build + * up a list of library modules needing updating, and replace these modules + * in the library. + */ +int +do_mkpkg ( + struct context *cx, /* current context */ + int islib /* update a library? */ +) +{ + if (cx->mkpkgfile[0] == EOS) + strcpy (cx->mkpkgfile, MKPKGFILE); + + if (debug) { + printf ("do_mkpkg (file=%s, library=%s, islib=%d)\n", + cx->mkpkgfile, cx->library, islib); + fflush (stdout); + } + + if (open_mkpkgfile (cx) == ERR) { + char fname[SZ_PATHNAME+1]; + struct context *save_cx; + + save_cx = topcx; + if (cx->prev) + topcx = cx->prev; + + sprintf (fname, "%s%s", cx->curdir, cx->mkpkgfile); + warns ("cannot open `%s'", fname); + + topcx = save_cx; + return (ERR); + } + + /* Search the mkpkg file for the module list for the named library, + * or the first module list encountered if no library is named. + * Any number of preprocessor directives may be executed while + * searching; in particular, $EXIT will terminate the search, + * causing ERR to be returned by the search procedure to indicate + * that no module list was found. + */ + if (search_mkpkgfile (cx) == ERR) { + if (cx->library[0] != EOS) { + warns ("no entry in mkpkg file for `%s'", cx->library); + return (ERR); + } else { + /* Presumably we just executed a bunch of preprocessor + * commands and there is no library to update, or it was + * already updated by the commands just executed. + */ + return (OK); + } + } + + /* The mkpkg file is open and positioned to the entry for a library + * (or any other sequence of commands with the given name). Update + * the named library, close the mkpkgfile, and exit. + */ + exit_status = scan_modlist (cx, islib); + close_mkpkgfile (cx); + + return (exit_status); +} + + +/* SCAN_MODLIST -- Called when positioned to the module list for a library. + * Scan the module list and compare file and library module dates, building + * up a list of files to be updated. If any files were found which need + * updating recompile them and replace them in the library. Call the rebuild + * procedure when done to perform any library rebuild or cleanup operations + * necessary on the local system. + */ +int +scan_modlist ( + struct context *cx, /* current mkpkg context */ + int islib +) +{ + char token[SZ_FNAME+1]; + char *dflist[MAX_DEPFILES+1]; + struct sfile *sflist; + int root_modlist; + int tok; + + /* This is for the case "@(module)" in a library member list, indicating + * that the named module is a library member list for the current + * library, even though the module name is not the same as the library + * name. For searching purposes the cl->library field contains the + * module name until we get here, and now we must overwrite this with + * the name of the library being updated. + */ + if (islib && cx->sublib) + strcpy (cx->library, cx->prev->library); + + if (debug) { + printf ("scan_modlist (file=%s, line=%d, library=%s, islib=%d)\n", + cx->mkpkgfile, cx->lineno, cx->library, islib); + fflush (stdout); + } + + /* Check if this directory contains any files needing special + * processing. + */ + sflist = sf_dirsearch (cx->dirpath); + + if (cx->prev) + root_modlist = (strcmp (cx->library, cx->prev->library) != 0); + else + root_modlist = 1; + + if (islib && root_modlist) { + /* Save the pathname of the library in the context descriptor. + * We may be changing the current directory later, so a pathname + * is required. + */ + os_fpathname (cx->library, cx->libpath, SZ_PATHNAME); + if (debug) { + printf ("pathname of `%s' is `%s'\n", cx->library, + cx->libpath); + fflush (stdout); + } + + /* Scan the library and build up a list of modules and their dates. + * This will create a new library if necessary. If there are any + * fatal warns the scan library routine prints its own error + * messages and we return, since no further processing of the + * library is possible. + */ + if ((exit_status = h_scanlibrary (cx->library)) != OK) { + warns ("error reading library file `%s'", cx->library); + return (ERR); + } + } + + /* Scan the module list in the mkpkg file. An "@subdir" reference + * causes us to push a new context and continue scanning the entry + * for the same library in a subdirectory. Any number of preprocessor + * directives may be executed while we are scanning the module list. + * For each module in the list, test the file dates and add the name + * to the file list if the module has to be updated. + */ + for (;;) { +next_: tok = gettok (cx, token, SZ_FNAME); + + if (tok == TOK_NEWLINE) { + ; /* ignore blank lines */ + + } else if (islib && tok == TOK_FNAME && token[0] != SUBDIR_CHAR) { + /* Check if the named module is up to date, and if not, + * add to the file list for the library. The useobj flag + * is set if the module is not up to date, but the object + * file has already been compiled and should be replaced + * in the library. + */ + char srcname[SZ_PATHNAME+1], modname[SZ_PATHNAME+1]; + char dname[SZ_FNAME+1], fname[SZ_FNAME+1]; + struct sfile *sfp; + int useobj; + + strcpy (modname, token); + + /* If this directory has any files needing special processing, + * determine if this is such a file, and if so obtain the name + * of the actual source file to be used. + */ + sfp = sf_filesearch (sflist, modname); + strcpy (srcname, sfp ? sfp->sf_sfname : modname); + if (sfp && debug) { + printf ("module %s on special file list: ", modname); + if (sfp->sf_mkobj[0]) + printf ("mkobj=`%s'\n", sfp->sf_mkobj); + else + printf ("src=%s\n", srcname); + fflush (stdout); + } + + /* Check that the regular, standard source file has not been + * modified more recently than the special file, if any. + */ + if (sfp && debug && os_fdate(modname) > os_fdate(srcname)) + warns ("special file for %s is out of date", modname); + + /* Break filename into the logical directory and local + * filenames; if file is remote a local copy will be + * created temporarily (see below). Get list of files + * upon which the module is dependent, if any. + */ + parse_fname (srcname, dname, fname); + get_dependency_list (cx, modname, dflist, MAX_DEPFILES); + + if (!up_to_date (cx, srcname, fname, dflist, &useobj)) { + + /* If file is remote add its name to the remote file list + * and "checkout" the file, making it accessible in the + * current directory. The file will be checked back in + * after the library is updated. It may not be necessary + * to compile the file locally, but it is too risky to + * predict what the host system will do when asked to + * compile a file resident in a remote directory. + */ + if (dname[0]) { + int clobber, i; + + for (i=0; i < cx->nrfiles; i++) + if (strcmp (fname, cx->rflist[i]) == 0) { + /* Multiple modules map to the same remote + * source file, which has already been checked + * out. Skip duplicate references to the same + * source file. + */ + goto next_; + } + cx->rflist[cx->nrfiles++] = putstr (fname); + h_outcheck (fname, dname, clobber=NO); + } + + /* If the module needs special processing and a mkobj + * command string was given, but the source file has not + * yet been compiled, push the command back into the input + * stream to compile the source, and set the useobj flag + * to defeat recompilation of this module. + */ + if (sfp && sfp->sf_mkobj[0]) { + if (useobj) { + warns ("module %s has already been compiled", + modname); + } else { + m_pushstr (cx, "\n"); + m_pushstr (cx, sfp->sf_mkobj); + useobj++; + } + } + + /* Add the local filename to the list of files to be + * updated. + */ + cx->flist[cx->nfiles++] = + putstr (useobj ? makeobj(fname) : fname); + + if (debug) { + printf ("add %s to file list for %s\n", + cx->flist[cx->nfiles-1], cx->library); + fflush (stdout); + } + + if (cx->nfiles > MAX_FILES) + fatals ("too many modules listed for library `%s'", + cx->library); + } + + } else if (tok == TOK_FNAME && token[0] == SUBDIR_CHAR) { + /* Push a new context, open mkpkg file and continue scanning + * in the new subdirectory. + */ + struct context *ncx; + char module[SZ_FNAME+1]; + char subdir[SZ_FNAME+1]; + char fname[SZ_FNAME+1]; + + /* Parse the "module@subdir/fname" string. */ + parse_modname (token, module, subdir, fname); + + /* Push a new context and start over; recursive call. May + * "reopen" (soft) the current mkpkg file or the mkpkg in a + * subdirectory. + */ + if ((ncx = push_context (cx, module, subdir, fname)) == NULL) + exit_status = ERR; + else { + exit_status = do_mkpkg (ncx, islib); + cx = pop_context (ncx); + } + + if (exit_status != OK && !ignore) + return (exit_status); + + } else if (tok == TOK_END || tok == 0) { + /* We have reached the end of the current module list (;), + * executed a $EXIT, or seen EOF on the mkpkg file. If the + * file list is nonempty update the current library, restore + * the previous context, and return (from the do_mkpkg, above). + */ + + /* The file list now contains the names of all the files that + * need to be updated. Compile and update the archive. + */ + if (islib && cx->nfiles == 0) { + /* No modules were found that need updating. + */ + if (cx->prev != NULL && cx->level > cx->prev->level) { + char dirname[SZ_FNAME+1]; + char *ip, *op; + + /* Prettify the directory name. + */ + for (ip=cx->curdir, op=dirname; (*op = *ip++); op++) + ; + if (*(op-1) == '/') + *(op-1) = EOS; + + printf ("Subdirectory %s is up to date\n", dirname); + fflush (stdout); + } + } else if (islib) { + char dname[SZ_FNAME+1], fname[SZ_FNAME+1]; + int i; + + /* Compile the modules and update the library. + */ + exit_status = h_updatelibrary (cx->libpath, + cx->flist, cx->nfiles, getsym(XFLAGS), irafdir); + if (exit_status == INTERRUPT) + fatals (" interrupt %s", cx->library); + cx->totfiles += cx->nfiles; + + /* Delete any local copies of (or links to) files that were + * checked out of a remote directory. + */ + for (i=0; i < cx->nrfiles; i++) { + parse_fname (cx->rflist[i], dname, fname); + h_incheck (fname, NULL); + } + } + + /* If the module list just terminated was a partial list, + * return immediately to continue processing the next higher + * level module list for the same library. + */ + if (root_modlist && islib) + break; + else { + if (debug) { + printf ("not root library; return to higher level\n"); + fflush (stdout); + } + return (exit_status); + } + + } else if (islib) + warns ("bad token `%s' in library module list", token); + } + + /* We get here when the end of the root module list for a library has + * been reached (but only if the module being processed is a library + * list). + */ + if (cx->totfiles == 0 && !forceupdate) { + printf ("Library %s is up to date\n", cx->library); + fflush (stdout); + } else if (exit_status == OK || ignore) { + /* Run the system dependent library rebuild operator. + */ + if ((exit_status = h_rebuildlibrary (cx->library)) == INTERRUPT) + fatals (" interrupt %s", cx->library); + printf ("Updated %d files in %s\n", cx->totfiles, cx->library); + fflush (stdout); + } + + return (exit_status); +} + + +/* PARSE_MODNAME -- Parse a module reference into its component parts. + * + * Syntax: module@subdir/fname + * or @(module)subdir/fname + */ +void +parse_modname ( + char *modname, /* "module@subdir/fname" */ + char *module, /* receives module */ + char *subdir, /* receives subdir */ + char *fname /* receives fname */ +) +{ + register char *ip, *op; + register int ch; + char *path; + + for (ip=modname; isspace (*ip); ip++) + ; + + /* Module name XXX@ */ + op = module; + for (; (*op = *ip) && *op != '@'; op++, ip++) + ; + *op = EOS; + + /* Module name @(XXX) */ + if (op == module && *ip == '@' && *(ip+1) == '(') { + for (ip++; (*op = *ip) && *op != ')'; op++, ip++) + ; + *(op+1) = EOS; + if (*ip == ')') + ip++; + } + + if (*ip == '@') + ip++; + + /* Get subdirectory and mkpkg file names. If a simple identifier is + * given it is taken to be the name of the subdirectory, otherwise + * ($ or / found) the given pathname is parsed. + */ + fname[0] = EOS; + for (op=subdir, path=ip; (ch = *op = *ip++); op++) + if (ch == '$' || ch == '/') { + if (*(op-1) == '\\') + *--op = ch; + else { + parse_fname (path, subdir, fname); + break; + } + } +} + + +/* PARSE_FNAME -- Return logical directory and filename fields of a filename. + */ +void +parse_fname ( + char *path, /* input filename */ + char *dname, /* receives directory name */ + char *fname /* receives file name */ +) +{ + register char *ip, *op; + register char *delim; + + delim = NULL; + for (ip=path, op=fname; (*op = *ip); op++, ip++) + if (*ip == '$' || *ip == '/') { + if (*(ip-1) == '\\') + *(--op) = *ip; + else + delim = ip; + } + + if (delim == NULL) { + dname[0] = EOS; + return; /* no directory name */ + } + + for (ip=path, op=dname; ip <= delim; ) + *op++ = *ip++; + *op = EOS; + + for (op=fname; (*op++ = *ip++); ) + ; +} + + +/* PUSH_CONTEXT -- Push a new context, i.e., save the current context in the + * current context descriptor, allocate and initialize a new context + * descriptor. Set up the new context, including the current directory, + * but do not open the new mkpkgfile. + */ +struct context * +push_context ( + register struct context *cx, /* current context */ + char *module, /* new module (library) */ + char *newdir, /* new directory */ + char *fname /* mkpkgfile name */ +) +{ + register struct context *ncx; + + if (debug) { + printf ("push_context (module=%s, newdir=%s, fname=%s)\n", + module, newdir, fname); + fflush (stdout); + } + + /* Update old context. + */ + cx->old_nsymbols = nsymbols; + cx->old_iflev = iflev; + cx->old_cp = cp; + + if (cx->fp && cx->fp != stdin) + cx->fpos = k_ftell (cx); + + /* Initialize new context. + */ + ncx = (struct context *) malloc (sizeof (struct context)); + if (ncx == NULL) + fatals ("out of memory in `%s'", fname); + + *ncx = *cx; /* copy old struct to new */ + + ncx->pb = NULL; + ncx->prev = cx; + ncx->totfiles = 0; + ncx->nfiles = 0; + ncx->nrfiles = 0; + ncx->pbchar = 0; + ncx->pushback = 0; + ncx->sublib = 0; + + /* In the case of a (XXX) module name reference to a module containing + * a sub-member list of the current library, strip the () and set the + * sublib flag for scanlibrary(). + */ + if (module[0]) { + if (strcmp (module, "BOF") == 0) { + ncx->library[0] = EOS; + } else if (module[0] == '(') { + char *ip, *op; + + for (ip=module+1, op=ncx->library; (*op = *ip++); op++) + if (*op == ')') + break; + *op = EOS; + ncx->sublib = YES; + } else + strcpy (ncx->library, module); + } + + if (newdir[0] && strcmp(newdir,".") != 0 && strcmp(newdir,"./") != 0) { + /* Record the directory path for printed output. Note that this + * will be a conventional pathname only if each "newdir" reference + * is to a subdirectory. + */ + strcat (ncx->curdir, newdir); + strcat (ncx->curdir, "/"); + + if (debug) { + printf ("change directory to `%s'\n", newdir); + fflush (stdout); + } + + if (os_chdir (newdir) == ERR) { + warns ("cannot access subdirectory `%s'", newdir); + free (ncx); + return (NULL); + } else { + os_fpathname ("", ncx->dirpath, SZ_PATHNAME); + ncx->level++; + } + + /* Initialize the file date cache, since the filenames therein + * often reference the current directory. + */ + m_fdinit (debug); + } + + if (fname[0]) + strcpy (ncx->mkpkgfile, fname); + + return (topcx = ncx); +} + + +/* POP_CONTEXT -- Restore the previous context, including the current + * directory. + */ +struct context * +pop_context ( + register struct context *cx /* current context */ +) +{ + register struct context *pcx; + int root_modlist; + int level; + + if (debug) { + printf ("pop_context (library=%s)\n", cx->library); + fflush (stdout); + } + + /* Pop the previous context. + */ + if (cx->prev != NULL) { + level = cx->level; + pcx = cx->prev; + + root_modlist = (strcmp (cx->library, pcx->library) != 0); + if (!root_modlist) + pcx->totfiles += cx->totfiles; + + free (cx); + topcx = cx = pcx; + + if (cx->fp && cx->fp != stdin) + k_fseek (cx, cx->fpos, 0); + + sf_prune (cp = cx->old_cp); + nsymbols = cx->old_nsymbols; + iflev = cx->old_iflev; + + if (level > pcx->level) { + if (debug) { + printf ("chdir ..\n"); + fflush (stdout); + } + + if (os_chdir (pcx->dirpath) == ERR) + fatals ("cannot return from subdirectory", cx->curdir); + + /* Initialize the file date cache, since the filenames therein + * often reference the current directory. + */ + m_fdinit (debug); + } + } + + return (cx); +} + + +/* GET_DEPENDENCY_LIST -- Each file name in a library membership list occurs + * on a separate line in the Makelib file. This file name may be followed by + * the names of zero or more other files, upon which the primary file is + * dependent. The following procedure extracts the names of these files into + * the string buffer, returning a list of pointers to the filenames to the + * caller. Note that the string buffer space is only "borrowed" and the + * filenames should be used promptly, before the string buffer space is reused. + */ +void +get_dependency_list ( + struct context *cx, /* current library context */ + char *module, /* module list is for */ + char *dflist[], /* receives filename pointers */ + int maxfiles /* maxfiles out */ +) +{ + char fname[SZ_FNAME+1]; + int token, nfiles=0; + char *save_cp; + int i; + + save_cp = cp; + + while ((token = gettok (cx, fname, SZ_FNAME)) != 0) { + switch (token) { + case TOK_NEWLINE: + goto done; + case TOK_FNAME: + if (nfiles >= MAX_DEPFILES) + warns ("too many dependency files for module `%s'", module); + dflist[nfiles++] = putstr (fname); + break; + case TOK_END: + warns ("unexpected EOF in dependency list for `%s'", module); + default: + warns ("bad token `%s' in dependency list", fname); + } + } + +done: + /* A null string pointer marks the end of the list. + */ + dflist[nfiles] = NULL; + + if (debug) { + printf ("%s:", module); + for (i=0; i < nfiles; i++) + printf (" %s", dflist[i]); + printf ("\n"); + fflush (stdout); + } + + cp = save_cp; +} + + +/* UP_TO_DATE -- Determine if the named module is up to date. A module is up + * to date if: + * + * (1) The lib module is newer than the source file, and + * (2) The source file is newer than any of its dependents. + * + * If the module is out of date, and an object file exists which is current + * (newer than the source, which is in turn newer than any dependents), + * set the USEOBJ flag to tell our caller to use the .o file, rather than + * recompile the module. + */ +int +up_to_date ( + struct context *cx, /* current library context */ + char *module, /* module to compare dates for */ + char *lname, /* local name of module */ + char *dflist[], /* list of dependent files */ + int *useobj /* obj exists and is usable */ +) +{ + long armod_date, newest_date, date; + long h_ardate(); + char *fname; + int old, i; + + armod_date = h_ardate (lname); + newest_date = armod_date; + (*useobj) = NO; + + /* Compare lib module date and source file date. + */ + date = os_fdate (module); + if (date == 0) { + warns ("module source file `%s' not found", module); + return (YES); + } else if (armod_date < date) { + if (debug > 1) { + printf ("(%s) ar: %ld fil: %ld\n", module, armod_date, date); + fflush (stdout); + } + old = YES; + newest_date = date; + } else + old = NO; + + /* Compare dates of archive file and any dependent files. + */ + for (i=0; (fname = dflist[i]) != NULL; i++) { + date = m_fdate (fname); + if (date == 0) { + warns ("dependency file `%s' not found", fname); + } else if (armod_date < date) { + old = YES; + if (date > newest_date) + newest_date = date; + } + } + + if (old == NO) { + /* Module is up to date. + */ + return (YES); + } else { + /* Library module is not up to date. Check if an object file + * exists which can be used w/o recompilation. + */ + if (newest_date <= os_fdate (makeobj (module))) + (*useobj) = YES; + return (NO); + } +} + + +/* OPEN_MKPKGFILE -- Open the mkpkgfile for the current library context. + * If the same file is already physically open by this process, this is + * a "soft" open. + */ +int +open_mkpkgfile (register struct context *cx) +{ + register char *fname = cx->mkpkgfile; + struct context *find_mkpkgfile(); + struct context *ax; + + if (strcmp (fname, "stdin") == 0 || strcmp (fname, "STDIN") == 0) { + cx->fp = stdin; + } else if ((ax = find_mkpkgfile (cx->prev, fname, cx->level)) == NULL) { + cx->fp = fopen (vfn2osfn(fname,0), "r"); + if (cx->fp) + k_fseek (cx, 0L, 0); + } else { + cx->fp = ax->fp; + if (cx->fp && cx->fp != stdin) + k_fseek (cx, 0L, 0); + } + + cx->lineno = 1; + return (cx->fp == NULL ? ERR : OK); +} + + +/* CLOSE_MKPKGFILE -- Close a mkpkgfile. If the file is multiply open (in + * software) wait until the last context closes the file to physically close + * the file. + */ +void +close_mkpkgfile (register struct context *cx) +{ + struct context *find_mkpkgfile(); + + if (cx->fp != stdin) + if (find_mkpkgfile (cx->prev, cx->mkpkgfile, cx->level) == NULL) + fclose (cx->fp); +} + + +/* FIND_MKPKGFILE -- Search the list of open library contexts for an entry + * which already has the named mkpkgfile open. + */ +struct context * +find_mkpkgfile ( + struct context *head_cx, /* head of context list */ + char *mkpkgfile, /* file to search for */ + int level /* subdirectory level */ +) +{ + register struct context *cx; + + for (cx=head_cx; cx != NULL; cx=cx->prev) + if (cx->level == level && strcmp (cx->mkpkgfile, mkpkgfile) == 0) + return (cx); + + return (NULL); +} + + +/* SEARCH_MKPKGFILE -- Search the mkpkgfile for the named entry. A mkpkg + * entry consists of a TOK_FNAME (identifier) followed by TOK_BEGIN (colon), + * e.g., "entry:". If a specific module is named, go directly there without + * processing any preprocessor directives. If no module is named, search + * for the first entry, executing any preprocessor directives encountered + * while searching. + */ +int +search_mkpkgfile (register struct context *cx) +{ + char word1[SZ_FNAME+1], word2[SZ_FNAME+1]; + char *prev, *curr, *temp; + int tok, gettok(); + + if (debug) { + printf ("search_mkpkgfile (file=%s, library=%s)\n", + cx->mkpkgfile, cx->library); + fflush (stdout); + } + + /* If a specific module is desired and we are not in search mode, + * go directly to the named module without executing any preprocessor + * directives. + */ + if (cx->library[0]) + return (do_goto (cx, cx->library)); + + /* Search Makelib file until an entry for the named library is found. + * Execute any preprocessor directives encountered while searching. + */ + prev = word1; + curr = word2; + + /* Advance to the next entry. If an @subdir reference is + * encountered, go process the subdirectory in search mode + * and then continue locally. + */ + while ((tok = gettok (cx, curr, SZ_FNAME)) != TOK_BEGIN) { + if (tok == 0 || tok == TOK_END) { + /* Exit; no entry found. + */ + return (ERR); + + } else if (tok == TOK_FNAME && curr[0] == SUBDIR_CHAR) { + /* Continue the search in the context of a subdirectory. + */ + struct context *ncx; + char module[SZ_FNAME+1]; + char subdir[SZ_FNAME+1]; + char fname[SZ_FNAME+1]; + int islib; + + /* Push a new context and start over; recursive call. + * May "reopen" (soft) the current mkpkg file or the mkpkg + * in a subdirectory. + */ + parse_modname (curr, module, subdir, fname); + if ((ncx = push_context (cx, module,subdir,fname)) == NULL) + exit_status = ERR; + else { + exit_status = do_mkpkg (ncx, islib=NO); + cx = pop_context (ncx); + } + + if (exit_status != OK && !ignore) + return (exit_status); + + } else { + /* Save the old token; pointer swapping rather than copy + * used for efficiency. + */ + temp = curr; + curr = prev; + prev = temp; + } + } + + strcpy (cx->library, prev); /* return module name */ + return (OK); +} diff --git a/unix/boot/mkpkg/scanlib.c b/unix/boot/mkpkg/scanlib.c new file mode 100644 index 00000000..cb70efd5 --- /dev/null +++ b/unix/boot/mkpkg/scanlib.c @@ -0,0 +1,355 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#include +#ifdef MACOSX +#include +#include +#endif + +#define import_spp +#include +#include "mkpkg.h" +#include "extern.h" + +#ifdef OLD_MACOSX +#define AR_EFMT1 1 +#endif + + +/* + * SCANLIB.C -- Routines to scan a 4.2BSD UNIX archive file and create a + * symbol table naming the files in the archive and their dates. + * + * External entry points: + * + * h_scanlibrary (libname) extract list of modules and their dates + * h_ardate (modname) return long integer module date + */ + +#define SZ_KEY 128 /* arbitrary */ +extern int forceupdate; /* NOT IMPLEMENTED for UNIX */ + +char mlb_sbuf[SZ_SBUF]; /* string buffer */ +int mlb_op = 0; /* index into string buffer */ +int mlb_index[MAX_LIBFILES]; /* sbuf indices for each symbol */ +long mlb_fdate[MAX_LIBFILES]; /* file date of each module */ +int mlb_modified; /* modified flag */ +char *mlb_filename(); + +struct dbentry { /* module entry on disk */ + long fdate; + int keylen; + /* key chars */ +}; + + +/** + * Local procedure declarations. + */ +int mlb_setdate (char *modname, long fdate); + + + +/* SCANLIBRARY -- Scan the archive file, extract module names and dates, + * building the "ar" module list. + */ +int +h_scanlibrary (char *library) +{ + register char *ip, *op; + register int i, is_fat = 0; + char libfname[SZ_PATHNAME+1]; + char modname[SZ_KEY+1]; + char lbuf[SZ_LINE]; + struct ar_hdr arf; + long length, fdate; + int len=0, len_arfmag, nmodules; + FILE *fp; + + /* Get the library file name. */ + h_getlibname (library, libfname); + + /* Clear the symbol table. + */ + mlb_modified = NO; + mlb_op = 1; + nmodules = 0; + + len = 0; + for (i=0; i < MAX_LIBFILES; i++) + mlb_index[i] = 0; + + /* Open the UNIX archive file. + */ + if ((fp = fopen (libfname, "r")) == NULL) { + printf ("warning: library `%s' not found\n", libfname); + fflush (stdout); + return (0); + } + + if (debug) { + printf ("scan unix archive %s:\n", libfname); + fflush (stdout); + } + + /* Verify that file is indeed an archive file. + */ + memset (lbuf, 0, SZ_LINE); + fread (lbuf, 1, SARMAG, fp); + if (strncmp (lbuf, ARMAG, SARMAG) != 0) { +#ifndef MACOSX + printf ("file `%s' is not a library\n", libfname); + goto err; +#else + /* See if it's a FAT archive file. + */ + struct fat_header fh; + struct fat_arch fa; + char *ip; + + rewind (fp); + memset (&fh, 0, sizeof(struct fat_header)); + fread (&fh, 1, sizeof(struct fat_header), fp); /* read header */ + if (fh.magic == FAT_MAGIC || fh.magic == FAT_CIGAM) { + int narch = 0; + + is_fat++; + + /* The following is a cheat to avoid byte swapping the + * nfat_arch field in Intel systems. Assumes we'll never + * see more that 8-bits worth of architectures. 8-) + */ + ip = (char *) &fh, ip += 7; + memmove (&narch, ip, 1); + for (i=0; i < narch; i++) { /* skip headers */ + memset (&fa, 0, sizeof(struct fat_arch)); + fread (&fa, 1, sizeof(struct fat_arch), fp); + } + + /* Read the AR header. + */ + memset (lbuf, 0, SZ_LINE); + fread (lbuf, 1, SARMAG, fp); + if (strncmp (lbuf, ARMAG, SARMAG) != 0) { + printf ("file `%s' is not a library\n", libfname); + goto err; + } + } else { + printf ("file `%s' is not a library\n", libfname); + goto err; + } +#endif + } + + len_arfmag = strlen (ARFMAG); + memset (&arf, 0, sizeof(arf)); + while ((int)(fread (&arf, 1, sizeof(arf), fp)) > 0) { + + /* Don't scan past the first architecture for FAT libs. + */ + if (is_fat && strncmp (arf.ar_name, ARMAG, SARMAG) == 0) + break; + + if (strncmp (arf.ar_fmag, ARFMAG, len_arfmag) != 0) { + printf ("cannot decode library `%s'\n", libfname); + goto err; + } + + if (debug > 1) { + char name[17], date[13]; + strncpy (name, arf.ar_name, 16); name[16] = '\0'; + strncpy (date, arf.ar_date, 12); date[12] = '\0'; + printf ("objname='%s', date='%s'\n", name, date); + } + + /* Extract module name. */ + for (ip=arf.ar_name; *ip == ' '; ip++) ; + for (op=modname; (*op = *ip++) != ' ' && *op != '/'; op++) ; + *op++ = EOS; + + /* Skip dummy entry with null modname (COFF format) as well + * as the __SYMDEF from ranlib. + */ +#ifdef MACOSX + if (strncmp (modname, RANLIBMAG, 9) || modname[0] != EOS) { +#else + if (modname[0] != EOS) { +#endif +#if defined(AR_EFMT1) && !defined(__CYGWIN__) + /* + * BSD 4.4 extended AR format: #1/, with name as the + * first bytes of the file + */ + if ((arf.ar_name[0] == '#') && + (arf.ar_name[1] == '1') && + (arf.ar_name[2] == '/') && (isdigit(arf.ar_name[3]))) { + + char p[SZ_PATHNAME]; + + len = atoi(&arf.ar_name[3]); + bzero (p, SZ_PATHNAME); + if (fread(p, len, 1, fp) != 1) { + fprintf (stderr, "%s: premature EOF", libfname); + } + bzero (modname, SZ_KEY+1); + sprintf (modname, "%s", p); + } else + len = 0; +#endif + /* Get module date. */ + sscanf (arf.ar_date, "%ld", &fdate); + + /* Insert entry into symbol table. */ + mlb_setdate (modname, fdate); + } + + /* Advance to the next entry. + */ + if (sscanf (arf.ar_size, "%ld", &length) == 1) { + if (length & 1) /* must be even */ + length++; +#if defined(AR_EFMT1) && !defined(__CYGWIN__) + fseek (fp, length-len, 1); +#else + fseek (fp, length, 1); +#endif + } else { + printf ("could not decode length `%s' of library module\n", + arf.ar_size); + goto err; + } + + memset (&arf, 0, sizeof(arf)); + } + + fclose (fp); + return (nmodules); + +err: + fflush (stdout); + fclose (fp); + return (ERR); +} + + +/* H_ARDATE -- Look up file in archive. If found, return date of archive + * version, otherwise return zero. This is the entry point called by MKLIB + * to get the update date of a library module. + */ +long +h_ardate (char *fname) +{ + extern char *makeobj(); + long mlb_getdate(); + + return (mlb_getdate (makeobj (fname))); +} + + +/* MLB_SETDATE -- Enter the given module and file date into the symbol table, + * or update the file date if the module is already present in the table. + */ +int +mlb_setdate ( + char *modname, /* module name */ + long fdate /* object file date */ +) +{ + register int hashval, keylen, i; + register char *ip; + int start; + + + if (*modname == EOS || fdate <= 0) { + printf ("warning, mlb_setdate: attempted illegal entry for %s\n", + modname); + fflush (stdout); + return (ERR); + } + + /* Hash the key. + */ + for (hashval=0, keylen=0, ip=modname; *ip; ip++, keylen++) + hashval += hashval + *ip; + start = hashval % MAX_LIBFILES; + + mlb_modified = YES; + + /* Update the entry if the module is already in the table, else find + * an empty slot, checking for table overflow in the process. + */ + for (i=start; mlb_index[i]; ) { + ip = &mlb_sbuf[mlb_index[i]]; + if (*ip == *modname) + if (strncmp (modname, ip, keylen) == 0) { + mlb_fdate[i] = fdate; + return (OK); + } + if (++i >= MAX_LIBFILES) + i = 0; + if (i == start) { + printf ("error: library module list overflow\n"); + fflush (stdout); + return (ERR); + } + } + + if (mlb_op + keylen + 1 >= SZ_SBUF) { + printf ("error: library module list string buffer overflow\n"); + fflush (stdout); + return (ERR); + } + + /* Enter the module into the symbol table. + */ + mlb_index[i] = mlb_op; + mlb_fdate[i] = fdate; + + strcpy (&mlb_sbuf[mlb_op], modname); + mlb_op += (keylen + 1); + + return (OK); +} + + +/* MLB_GETDATE -- Lookup a module in the symbol table and return its date. + * Return zero if the module is not found. + */ +long +mlb_getdate (char *modname) +{ + register int hashval, keylen, i; + register char *ip; + int start; + + if (*modname == EOS) + return (0L); + + /* Hash the key. + */ + for (hashval=0, keylen=0, ip=modname; *ip; ip++, keylen++) + hashval += hashval + *ip; + start = hashval % MAX_LIBFILES; + + /* Search the symbol table for the named module. + */ + for (i=start; mlb_index[i]; ) { + ip = &mlb_sbuf[mlb_index[i]]; + if (*ip == *modname) + if (strncmp (modname, ip, keylen) == 0) + return (mlb_fdate[i]); + if (++i >= MAX_LIBFILES) + i = 0; + if (i == start) + return (0L); + } + + return (0L); +} diff --git a/unix/boot/mkpkg/sflist.c b/unix/boot/mkpkg/sflist.c new file mode 100644 index 00000000..e487df77 --- /dev/null +++ b/unix/boot/mkpkg/sflist.c @@ -0,0 +1,321 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "mkpkg.h" +#include "extern.h" +#include "../bootProto.h" + + +/* + * SFLIST.C -- Special file list package. The special file list is a list of + * library module list source files which need special processing on a given + * host system. Examples of such files are files which have been optimized in + * a machine dependent way, e.g., in assembler or C, or files which must be + * compiled in a nonstandard way due to host compiler bugs. The special file + * list makes this special processing possible without having to modify the + * mkpkg files in the portable system in a host dependent way, concentrating + * all knowledge of those parts of the system which have been tailored for the + * local host into a single, easily modifiable table file stored in HLIB. + * + * External functions: + * + * sf_scanlist (cx) # parse $special file list + * sflist = sf_dirsearch (dirname) # lookup directory in sflist + * sfp = sf_filesearch (sflist, filename) # lookup file in dir file list + * sf_prune (cp) # free space in string buffer + * + * where + * + * struct context *cx; + * struct sfile *sflist, *sfp; + * char *filename, *dirname; + * + * The special file list is organized by source directory to speed searches + * (most directories will not contain any files needing special processing, + * eliminating the need to lookup the files in module lists in that directory) + * and to reduce storage requirements for the list. The special file database + * thus consists of a list of directories containing special files, and for + * each directory, a pointer to a linked list of special file entries, one + * for each special file in the directory. Since the organization by directory + * tends to produce a database consisting of very short file lists, we use a + * linked list rather than a hash table for the file lists. + * + * For each special file we record the standard file name, the pathname of + * the special file to be used, and a command to be pushed back into the MKPKG + * command input stream to generate the object file for the module. + * The special file name may be the same as the standard file name, e.g, if + * the standard file only needs to be compiled in a nonstandard way. If the + * mkobj string is null the special file name will simply be returned in the + * module list, and compiled with XC using the default compile flags. + */ + +static int sf_ndirs = 0; /* no. of directories */ +static int sf_nfiles = 0; /* no. of special files */ +static char *sf_dirs[MAX_SFDIRS]; /* source directories */ +static struct sfile *sf_flist[MAX_SFDIRS]; /* directory file lists */ +static struct sfile sf_files[MAX_SFFILES]; /* special file list */ +static char nullstr[] = ""; + + +/* SF_SCANLIST -- Called when the $special macro preprocessor directive is + * encountered to parse a special file list, entering each file listed into + * the special file list database. The syntax of a $special special file + * list directive is as follows: + * + * $special dirname: + * stname1 sfname1 mkobj_command1 + * stname2 sfname2 mkobj_command2 + * ... + * stnameN sfnameN mkobj_commandN + * ; + * + * where any string value may optionally be quoted, and the mkobj command + * strings are optional. The token "&" in or is + * replaced by . + */ +int +sf_scanlist ( + struct context *cx /* current mkpkg context */ +) +{ + register struct sfile *sfp; + register char *ip, *op, *tp; + + char dirname[SZ_PATHNAME+1]; + char stname[SZ_PATHNAME+1]; + char sfname[SZ_PATHNAME+1]; + char mkobj[SZ_CMD+SZ_PATHNAME+1]; + char token[SZ_CMD+1]; + struct sfile *head, *tail; + int tok, nfiles, eol=0; + char *old_cp; + + old_cp = cp; /* mark position in sbuf */ + nfiles = 0; + + /* Get the directory name. */ + if (gettok (cx, token, SZ_LINE) != TOK_FNAME) { + warns ("missing directory name in special file list", ""); + goto err; + } else + os_fpathname (token, dirname, SZ_PATHNAME); + + if (debug) { + printf ("scan special file list for directory %s\n", + debug > 1 ? dirname : token); + fflush (stdout); + } + + /* Advance to the start of the module list. */ + while ((tok = gettok (cx, token, SZ_LINE)) != TOK_BEGIN) + if (tok == EOF || tok == TOK_END) + goto err; + + /* Get a pointer to the last element in the special file list for + * the named directory. If this is the first entry for the named + * directory, enter the name in the symbol table and set the sflist + * pointer to NULL. + */ + if ((head = sf_dirsearch (dirname)) == NULL) { + sf_dirs[sf_ndirs++] = putstr (dirname); + if (sf_ndirs >= MAX_SFDIRS) + fatals ("too many special file list directories: %s", dirname); + tail = NULL; + } else { + for (tail=sfp=head; sfp; sfp=sfp->sf_next) + tail = sfp; + } + + /* Read successive entries from the special file list for the named + * directory, entering each file at the tail of the list. + */ + while (!eol && (tok = gettok (cx, token, SZ_LINE)) != TOK_END) { + if (tok == EOF || tok == TOK_END) + break; + + /* Get standard file name (module name). */ + if (tok == TOK_NEWLINE) + continue; /* blank line */ + else if (tok != TOK_FNAME) + goto badline; + else + strcpy (stname, token); + + /* Get the special file name. */ + if ((tok = gettok (cx, sfname, SZ_PATHNAME)) == TOK_END) + eol++; + if (tok != TOK_FNAME) + goto badline; + + /* Get the mkobj command string, if any. */ + if ((tok = gettok (cx, token, SZ_LINE)) == TOK_NEWLINE) { + mkobj[0] = EOS; + } else if (tok == TOK_END) { + mkobj[0] = EOS; + eol++; + } else if (tok != TOK_FNAME) { + goto badline; + } else { + /* Extract the command string, expanding any "&" filename + * references therein. + */ + for (ip=token, op=mkobj; (*op = *ip++); op++) + if (*op == '&') { + for (tp=stname; (*op = *tp++); op++) + ; + --op; + } + } + + if (debug) + printf ("file %s -> %s, mkobj = `%s'\n", + stname, (sfname[0] == '&') ? stname : sfname, mkobj); + + /* Add the file to the tail of the file list. */ + nfiles++; + sfp = &sf_files[sf_nfiles++]; + if (sf_nfiles >= MAX_SFFILES) + fatals ("too many special files: %s", stname); + + sfp->sf_stname = putstr (stname); + sfp->sf_sfname = (sfname[0]=='&') ? sfp->sf_stname : putstr(sfname); + sfp->sf_mkobj = mkobj[0] ? putstr(mkobj) : nullstr; + sfp->sf_next = NULL; + + if (tail) { + tail->sf_next = sfp; + tail = sfp; + } else + sf_flist[sf_ndirs-1] = head = tail = sfp; + + continue; +badline: + /* Print message and discard rest of line, but do not quit. */ + warns ("bad token `%s' in special file list", token); + while (!eol && (tok = gettok (cx, token, SZ_LINE)) != TOK_NEWLINE) + if (tok == TOK_END) + break; + else if (tok == EOF) + goto err; + } + + if (debug) { + printf ("%d special files added; total ndirs=%d, nfiles=%d\n", + nfiles, sf_ndirs, sf_nfiles); + fflush (stdout); + } + + if (nfiles == 0) { + warns ("empty special file list for %s", dirname); + sf_prune (cp = old_cp); + return (ERR); + } else + return (OK); + +err: + /* Discard rest of directive. */ + while (!eol && (tok = gettok (cx, token, SZ_LINE)) != TOK_END) + if (tok == EOF || tok == TOK_END) + break; + + /* Return memory and sfile database space. */ + sf_prune ((cp = old_cp)); + + return (ERR); +} + + +/* SF_DIRSEARCH -- Search the special file database for the named directory, + * returning a pointer to the special file list for that directory if the + * directory is found, else NULL. Note that directory names are stored as + * host system pathnames (so that any equivalent form of reference may be used + * in the mkpkg files), and we assume that we are called with the directory + * pathname already resolved. + */ +struct sfile * +sf_dirsearch ( + char *dirname /* host pathname of directory */ +) +{ + register int i; + + if (debug) { + printf ("search sflist for directory %s\n", dirname); + fflush (stdout); + } + + for (i=0; i < sf_ndirs; i++) + if (h_direq (sf_dirs[i], dirname)) + return (sf_flist[i]); + + return (NULL); +} + + +/* SF_FILESEARCH -- Search the special file list for a directory for the named + * file. File names are stored in the list by the name given in the library + * module list in the mkpkg file. If the named file is found a pointer to the + * special file descriptor for that file is returned, otherwise NULL is + * returned. Note that "file*" is a prefix match, whereas "file" requires an + * exact match. + */ +struct sfile * +sf_filesearch ( + struct sfile *sflist, /* special file list */ + char *stname /* standard file name */ +) +{ + register struct sfile *sfp; + register char *p1, *p2; + + for (sfp=sflist; sfp; sfp=sfp->sf_next) { + for (p1=sfp->sf_stname, p2=stname; *p1 && *p1 == *p2; p1++, p2++) + ; + if ((*p1 == EOS && *p2 == EOS) || *p1 == '*') + return (sfp); + } + + return (NULL); +} + + +/* SF_PRUNE -- Prune the special file database back to the given point in the + * string buffer. + */ +void +sf_prune ( + register char *cp /* lop off everything here and above */ +) +{ + register struct sfile *sfp, *sf_top; + register int i; + + /* Prune the directory list. */ + for (i=0; i < sf_ndirs; i++) + if (sf_dirs[i] >= cp || sf_flist[i]->sf_stname >= cp) { + sf_ndirs = i; + break; + } + + /* Prune the global file list. */ + for (i=0; i < sf_nfiles; i++) + if (sf_files[i].sf_stname >= cp) { + sf_nfiles = i; + break; + } + + /* Prune the individual directory file lists. */ + for (i=0, sf_top = &sf_files[sf_nfiles]; i < sf_nfiles; i++) { + sfp = &sf_files[i]; + if (sfp->sf_next >= sf_top) + sfp->sf_next = NULL; + } +} diff --git a/unix/boot/mkpkg/tok.c b/unix/boot/mkpkg/tok.c new file mode 100644 index 00000000..41bdf626 --- /dev/null +++ b/unix/boot/mkpkg/tok.c @@ -0,0 +1,1457 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "mkpkg.h" +#include "extern.h" +#include "../bootProto.h" + + + + +/* + * TOK.C -- Preprocessor functions. + */ + +/* GETTOK -- Get the next token from the make file currently being scanned. + * Conditional interpretation is provided via the $IFxxx directives. + */ +int +gettok ( + register struct context *cx, /* current context */ + char *outstr, /* receives token */ + int maxch +) +{ + register int ch; + register char *op; + char tokbuf[SZ_COMMAND+1]; + int token, delim; + + if (debug > 1) { + printf ("gettok:\n"); + fflush (stdout); + } + +again: + /* Skip whitespace */ + for (ch = m_getc(cx); ch == ' '; ch = m_getc(cx)) + ; + if (ch == EOF) { + outstr[0] = EOS; + return (TOK_END); + } + outstr[0] = ch; + outstr[1] = EOS; + + /* First nonwhite character identifies each token. + */ + switch (ch) { + case COMMENT: + /* Ignore a comment. + */ + while ((ch = m_rawgetc(cx)) != '\n' && ch != EOF) + ; + m_ungetc ('\n', cx); + goto again; + + case PREPROCESSOR: + /* Preprocessor directive. + */ + for (op=tokbuf, *op++ = ch; (ch = m_getc(cx)) != EOF; ) + if (islower (ch)) + *op++ = ch; + else if (isupper (ch)) + *op++ = tolower (ch); + else { + m_ungetc (ch, cx); + break; + } + + *op = EOS; + if (strncmp (tokbuf, "$exit", 5) == 0) + return (TOK_END); + + do_ppdir (cx, tokbuf); + goto again; + + case SYSCMD: + /* Send a command to host system. + */ + do_osescape (cx); + goto again; + + case BEGIN_CHAR: + /* Start of program. + */ + token = TOK_BEGIN; + break; + + case END_CHAR: + /* End of program. + */ + token = TOK_END; + break; + + case '\n': + token = TOK_NEWLINE; + break; + + case SYSFILE_BEGIN: + /* Replace '<' by system library pathname, concatentate + * filename and exit. + */ + getstr (cx, tokbuf, SZ_COMMAND, SYSFILE_END); + if (m_sysfile (tokbuf, outstr, maxch) <= 0) + sprintf (outstr, "<%s>", tokbuf); + + if (debug) { + /* Don't print diagnostic if the file was found to be + * in the usual place, i.e., the system library lib$. + */ + if (strncmp (outstr, "iraf$lib/", 9) != 0) { + printf ("<%s> matched with `%s'\n", tokbuf, outstr); + fflush (stdout); + } + } + + token = TOK_FNAME; + break; + + case '\'': + case '"': + /* Quoted strings are treated as fname tokens, permitting + * optional quoting of filenames in module lists. + */ + getstr (cx, outstr, maxch, delim = ch); + token = TOK_FNAME; + break; + + case '\\': + if ((ch = m_getc(cx)) == '\n') + goto again; + /* fall through */ + + default: + /* Unquoted filename token. + */ + m_ungetc (ch, cx); + getstr (cx, outstr, maxch, delim = ' '); + token = TOK_FNAME; + break; + } + + /* Discard token? */ + if (ifstate[iflev] == STOP) + goto again; + + if (debug > 1) { + if (outstr[0] <= 040) + printf ("token = char 0%o\n", outstr[0]); + else + printf ("token = `%s'\n", outstr); + fflush (stdout); + } + + return (token); +} + + +/* DO_OSESCAPE -- Send a command to host system. If the first char after + * the ! is a left paren or quote then the matching char is taken to terminate + * the command, otherwise an (unescaped) newline terminates the command. + * The parenthesized form permits additional directives on the same line. + */ +void +do_osescape (register struct context *cx) +{ + register int ch; + char cmd[SZ_CMD+1]; + + if (debug > 1) { + printf ("do_osescape:\n"); + fflush (stdout); + } + + ch = m_getc (cx); + if (ch == '(' || ch == '\'' || ch == '"') { + getstr (cx, cmd, SZ_CMD, (ch == '(' ? ')' : ch)); + } else if (ch == '\n') { + return; + + } else { + char *op, *otop; + + op = cmd; + *op++ = ch; + otop = &cmd[SZ_CMD]; + + while (op < otop && (ch = m_getc(cx)) != EOF) + if (ch == ESCAPE) { + ch = m_getc (cx); + if (ch != '\n') { + *op++ = ESCAPE; + *op++ = ch; + } + } else if (ch == '\n') { + break; + } else + *op++ = ch; + + *op = EOS; + } + + if (ifstate[iflev] == STOP) + return; + if (verbose) { + printf ("!%s\n", cmd); + fflush (stdout); + } + + if (execute) + exit_status = os_cmd (cmd); + if (exit_status == INTERRUPT) + fatals (" interrupt %s", cx->library); +} + + +/* DO_PPDIR -- Execute a preprocessor directive. A hash table would be more + * efficient, but the complexity is not warranted since this is only called + * when a $ prefixed preprocessor directive has already been recognized in + * the input. + */ +void +do_ppdir ( + struct context *cx, /* current context */ + char *token /* directive to be executed */ +) +{ + int islib; + + if (debug > 1) { + printf ("do_ppdir: %s\n", token); + fflush (stdout); + } + + if ( strncmp (token, "$if", 3) == 0) + do_if (cx, token); + else if (strncmp (token, "$else", 5) == 0) + do_else (cx); + else if (strncmp (token, "$endif", 6) == 0) + do_endif (cx); + else if (strncmp (token, "$end", 4) == 0) + do_end (cx); + + else if (strncmp (token, "$call", 5) == 0) + do_call (cx, getargs(cx), islib=NO); + else if (strncmp (token, "$echo", 5) == 0) + do_echo (cx, getargs(cx)); + else if (strncmp (token, "$goto", 5) == 0) + do_goto (cx, getargs(cx)); + else if (strncmp (token, "$include", 8) == 0) + do_include (cx, getargs(cx)); + else if (strncmp (token, "$set", 4) == 0) + do_set (cx); + else if (strncmp (token, "$special", 8) == 0) + sf_scanlist (cx); + else if (strncmp (token, "$update", 7) == 0) + do_call (cx, getargs(cx), islib=YES); + + else if (strncmp (token, "$checkin", 8) == 0) + do_incheck (cx); + else if (strncmp (token, "$checkout", 9) == 0) + do_outcheck (cx); + else if (strncmp (token, "$copy", 5) == 0) + do_copyfile (cx); + else if (strncmp (token, "$delete", 7) == 0) + do_delete (cx); + else if (strncmp (token, "$generic", 8) == 0) + do_generic (cx); + else if (strncmp (token, "$link", 5) == 0) + do_link (cx); + else if (strncmp (token, "$move", 5) == 0) + do_movefile (cx); + else if (strncmp (token, "$omake", 6) == 0) + do_omake (cx, getargs(cx)); + else if (strncmp (token, "$purge", 6) == 0) + do_purge (cx, getargs(cx)); + else if (strncmp (token, "$xc", 3) == 0) + do_xc (cx); + + else if (strncmp (token, "$debug", 6) == 0) { + if ((debug = (strcmp (getargs(cx), "off")) != 0)) + verbose++; } + else if (strncmp (token, "$verbose", 8) == 0) + verbose = (strcmp (getargs(cx), "off") != 0); + + else + warns ("illegal preprocessor directive `%s'", token); +} + + +/* DO_IF -- Called when a "$if.." token is seen in the input stream. Read in + * the predicate and set the state of the ifcode accordingly. + */ +void +do_if (struct context *cx, char *keyword) +{ + register int ch; + register char *op; + char tokbuf[SZ_COMMAND+1]; + char buf[SZ_PREDBUF], *argv[MAX_ARGS]; + long fdate, altdate, os_fdate(); + int argc, negate, bval, i; + char *key; + + if (debug > 1) { + printf ("do_if: %s\n", keyword); + fflush (stdout); + } + + /* Set the negate flag for the "$ifn" form of the if. Leave key + * pointing to the first char of whatever follows. Watch out for + * "$ifnewer". + */ + key = &keyword[3]; /* "$if^" */ + negate = (*key == 'n' && strncmp(key,"newer",5) != 0); + if (negate) + key++; + + /* Extract the paren delimited list of predicate strings. This may + * extend over multiple lines if the newlines are escaped. + */ + while ((ch = m_getc(cx)) != '(') + if (ch == '\n') + warns ("illegal `%s' predicate", keyword); + else if (ch == EOF) + warns ("unexpected EOF in `%s'", keyword); + + argv[0] = buf; + op = buf; + argc = 0; + + while ((ch = m_getc(cx)) != ')') { + if (ch == ESCAPE) { + ch = m_getc (cx); + if (ch == '\n') + continue; + else + *op++ = ch; + } else if (ch == '\n') { + warns ("missing right paren in `%s'", keyword); + } else if (ch == EOF) { + warns ("unexpected EOF in `%s'", keyword); + } else if (ch == ' ') { + continue; + } else if (ch == SYSFILE_BEGIN && op == argv[argc]) { + getstr (cx, tokbuf, SZ_COMMAND, SYSFILE_END); + if (m_sysfile (tokbuf, op, SZ_PREDBUF+buf-op) <= 0) + sprintf (op, "<%s>", tokbuf); + while (*op) + op++; + continue; + } else if (ch == ':' || ch == ',') { + *op++ = EOS; + if (op - buf >= SZ_PREDBUF) + warns ("predicate too large in `%s'", keyword); + if (++argc >= MAX_ARGS) + warns ("too many arguments in `%s' predicate", keyword); + argv[argc] = op; + } else + *op++ = ch; + } + + *op = EOS; + argc++; + + if (++iflev > SZ_IFSTACK) + warns ("$IFs nested too deeply (%s)", keyword); + + /* If the $IF is encountered while scanning the tokens in a false-IF + * clause, do not "execute" the $IF. We still have to push the IF + * onto the control stack, because the matching $ENDIF is going to + * pop the stack. + */ + if (ifstate[iflev-1] == STOP) { + ifstate[iflev] = STOP; + return; + } + + /* Execute the $IF statement. + */ + bval = 0; + if (strcmp (key, "def") == 0) { + /* $IFDEF. If the named symbol exists execute the true clause, + * else go to the else clause. + */ + if (argc > 0) { + bval = (getsym (argv[0]) != NULL); + if (!bval) + bval = (os_getenv (argv[0]) != NULL); + } + + } else if (strcmp (key, "eq") == 0) { + /* $IFEQ. Test if the named environment variable has one of the + * indicated values. + */ + char *valstr; + + if (argc > 0) { + if ((valstr = getsym (argv[0])) == NULL && + (valstr = os_getenv (argv[0])) == NULL) { + + warns ("symbol `%s' not found", argv[0]); + bval = 0; + + } else { + if (argc == 1) + bval = 1; + else { + for (i=1; i < argc; i++) + if (strcmp (valstr, argv[i]) == 0) { + bval = 1; + break; + } + } + } + } + + } else if (strcmp (key, "file") == 0) { + /* $IFFILE. Check for the existence of any of the named files. + */ + for (i=0; i < argc; i++) + if (os_access (argv[i], 0,0) == YES) { + bval = 1; + break; + } + + } else if (strcmp (key, "older") == 0) { + /* $IFOLDER. Check if the named file is older than any of the + * listed files. If the named file does not exist the result + * is true. If any of the listed files do not exist a warning + * is printed and they are ignored. + */ + if (os_access (argv[1], 0,0) == NO) { + warns ("file `%s' not found", argv[1]); + bval = 1; + } else if ((fdate = os_fdate(argv[0])) <= 0) { + warns ("file `%s' not found", argv[0]); + bval = 1; + } else { + for (i=1; i < argc; i++) { + altdate = m_fdate (argv[i]); + if (altdate <= 0) { + warns ("file `%s' not found", argv[i]); + bval = 1; + break; + } else if (fdate < altdate) { + bval = 1; + break; + } + } + } + + } else if (strcmp (key, "newer") == 0) { + /* $IFNEWER. Check if the named file is newer than any of the + * listed files. If the named file does not exist the result + * is false. If any of the listed files do not exist a warning + * is printed and they are ignored. + */ + if (os_access (argv[1], 0,0) == NO) { + warns ("file `%s' not found", argv[1]); + bval = 1; + } else if ((fdate = os_fdate(argv[0])) <= 0) { + warns ("file `%s' not found", argv[0]); + bval = 1; + } else { + for (i=1; i < argc; i++) { + altdate = m_fdate (argv[i]); + if (altdate <= 0) + warns ("file `%s' not found", argv[i]); + else if (fdate > altdate) { + bval = 1; + break; + } + } + } + + } else if (strcmp (key, "err") == 0) { + /* $IFERR. Test the exit status of the last command executed. + */ + bval = (exit_status != OK); + + } else + warns ("unrecognized $if statement `%s'", keyword); + + if (negate) + bval = !bval; + ifstate[iflev] = bval; + + if (debug) { + printf ("%s (", keyword); + if (argc > 0) + printf ("%s", argv[0]); + for (i=1; i < argc; i++) + printf (", %s", argv[i]); + printf (") -> %s\n", bval ? "YES" : "NO"); + fflush (stdout); + } +} + + +/* DO_ELSE -- Called when the token "$else" is seen in the input stream. + * Toggle the if state. Do nothing if the state one level down in STOP, + * indicating that this $ELSE is nested inside the false clause of an + * outer $IF. + */ +void +do_else (struct context *cx) +{ + if (debug > 1) { + printf ("do_else:\n"); + fflush (stdout); + } + + if (iflev < 1) + warns ("%s with no matching $if", "$else"); + else if (iflev > 1 && ifstate[iflev-1] == STOP) + return; + else + ifstate[iflev] = (ifstate[iflev] == PASS) ? STOP : PASS; +} + + +/* DO_ENDIF -- Called when the token "$endif" is seen in the input stream. + * Pop the if stack. + */ +void +do_endif (struct context *cx) +{ + if (debug > 1) { + printf ("do_endif:\n"); + fflush (stdout); + } + + if (--iflev < 0) + warns ("unmatched %s", "$endif"); +} + + +/* DO_END -- Called when the token "$end" is seen in the input stream. + * Clear the if stack and reenable pass-token. + */ +void +do_end (struct context *cx) +{ + if (debug > 1) { + printf ("do_end:\n"); + fflush (stdout); + } + + if (cx->prev && cx->prev->old_iflev >= 0) + iflev = cx->prev->old_iflev; + else + iflev = 0; +} + + +/* DO_CALL -- Call a "subroutine", i.e., named entry in a mkpkg file. The call + * may include definitions for any temporary symbols (arguments) to be passed + * to the subroutine. The subroutine is assumed to be in the current mkpkg + * file unless otherwise indicated. + * + * Syntax: + * $call module + * $call module (sym1=value, sym2=value, ...) + * $call module@subdir/file + * $call module@subdir/file (sym1=value, ...) + * (etc.) + * + * Note that the statements are interpreted (as is everything in mkpkg), hence + * mkpkg subroutines should not be used for trivial things. + */ +void +do_call ( + struct context *cx, /* current context */ + char *program, /* module to be called */ + int islib /* module list for a library */ +) +{ + struct context *ncx; + char module[SZ_FNAME+1], subdir[SZ_FNAME+1], fname[SZ_FNAME+1]; + char symbol[SZ_FNAME+1], value[SZ_COMMAND+1]; + char modspec[SZ_FNAME+1]; + char *old_cp; + int old_nsymbols; + + strcpy (modspec, program); + if (debug && ifstate[iflev] == PASS) { + printf ("$call %s\n", modspec); + fflush (stdout); + } + + old_cp = cp; + old_nsymbols = nsymbols; + + /* Process the argument list, if any, into the symbol table. + */ + while (getkwvpair (cx, symbol, value) != ERR) + if (ifstate[iflev] == PASS) + putsym (symbol, value); + + if (ifstate[iflev] == STOP) + return; + + /* Parse the module name, push a new context, and execute the + * subroutine. + */ + parse_modname (modspec, module, subdir, fname); + if ((ncx = push_context (cx, module, subdir, fname)) == NULL) + exit_status = ERR; + else { + exit_status = do_mkpkg (ncx, islib); + cx = pop_context (ncx); + } + + /* Restore the old context and discard the argument temporaries. + */ + if (exit_status != OK) + warns ("module `%s' not found or returned error", modspec); + + cp = old_cp; + nsymbols = old_nsymbols; +} + + +/* DO_ECHO -- Print a message on the standard output. + */ +void +do_echo (struct context *cx, char *msg) +{ + if (ifstate[iflev] == PASS) { + printf ("%s\n", msg); + fflush (stdout); + } +} + + +/* DO_GOTO -- Advance the file pointer to the named symbol in the current + * file, without changing the current context. + */ +int +do_goto (struct context *cx, char *symbol) +{ + register char *ip; + char match[SZ_FNAME+1]; + char lbuf[SZ_LINE+1]; + int len_matchstr; + long fpos; + + if (ifstate[iflev] == STOP) + return (OK); + + if (debug) { + printf ("goto %s\n", symbol); + fflush (stdout); + } + + sprintf (match, "%s:", symbol); + len_matchstr = strlen (match); + + fpos = k_ftell (cx); + if (cx->fp != stdin) + k_fseek (cx, 0L, 0); + + while (k_fgets (lbuf, SZ_LINE, cx) != NULL) { + cx->lineno++; + for (ip=lbuf; isspace (*ip); ip++) + ; + if (strncmp (ip, match, len_matchstr) == 0) { + /* GOTO clears the IF stack back to where it whatever it was + * upon entry to the module. + */ + if (cx->prev && cx->prev->old_iflev >= 0) + iflev = cx->prev->old_iflev; + return (OK); + } + } + + warns ("could not find mkpkg module or label `%s'", symbol); + if (cx->fp != stdin) + k_fseek (cx, fpos, 0); + + return (ERR); +} + + +/* DO_INCLUDE -- Open a file and execute any preprocessor directives therein. + * Macros defined in an include are retained after the context of the include + * is popped. + */ +int +do_include ( + struct context *cx, /* current context */ + char *fname /* include file name */ +) +{ + struct context *ncx; + int islib; + + if (ifstate[iflev] == STOP) + return (OK); + + if (debug > 1) { + printf ("do_include: %s\n", fname); + fflush (stdout); + } + + ncx = push_context (cx, "BOF", "", fname); + do_mkpkg (ncx, islib=NO); + cx->old_cp = cp; /* keep symbols */ + cx->old_nsymbols = nsymbols; + cx = pop_context (ncx); + + return (OK); +} + + +/* DO_OMAKE -- Generate the object module for the named source module, if + * the object does not exist or is older than the source module. + */ +void +do_omake ( + struct context *cx, + char *fname +) +{ + char cmd[SZ_COMMAND+1]; + char xflags[SZ_LINE+1]; + char *dflist[MAX_DEPFILES+1]; + char *s_xflags, *dfile; + long sourcedate, objdate, date; + int recompile, i; + + + if (ifstate[iflev] == STOP) + return; + + if (debug) { + printf ("omake %s\n", fname); + fflush (stdout); + } + + if ((sourcedate = os_fdate (fname)) <= 0) { + warns ("file `%s' not found", fname); + exit_status = ERR; + return; + + } else { + get_dependency_list (cx, fname, dflist, MAX_DEPFILES); + objdate = os_fdate (makeobj (fname)); + recompile = 0; + + if (sourcedate > objdate) + recompile++; + else { + for (i=0; (dfile = dflist[i]) != NULL; i++) + if ((date = m_fdate (dfile)) == 0) + warns ("dependency file `%s' not found", dfile); + else if (date > objdate) { + recompile++; + break; + } + } + } + + if (recompile) { + /* Get XFLAGS. */ + s_xflags = getsym (XFLAGS); + xflags[0] = EOS; + if (debug) + strcat (xflags, "-d "); + if (dbgout) + strcat (xflags, "-x "); + strcat (xflags, s_xflags); + + if (irafdir[0]) + sprintf (cmd, "%s %s -r %s %s", XC, xflags, irafdir, fname); + else + sprintf (cmd, "%s %s %s", XC, xflags, fname); + + if (verbose) { + printf ("%s\n", cmd); + fflush (stdout); + } + + if (execute) + exit_status = h_xc (cmd); + if (exit_status == INTERRUPT) + fatals (" interrupt %s", cx->library); + + } else if (verbose) { + printf ("Object %s is up to date\n", makeobj(fname)); + fflush (stdout); + } +} + + +/* DO_XC -- Call XC. Note that the current default xflags are not + * automatically included in the generated command. + */ +int +do_xc (struct context *cx) +{ + char cmd[SZ_CMD+1]; + + + if (debug > 1) { + printf ("do_xc:\n"); + fflush (stdout); + } + + if (irafdir[0]) + sprintf (cmd, "%s -r %s", XC, irafdir); + else + sprintf (cmd, "%s", XC); + + if (debug) + strcat (cmd, " -d"); + if (dbgout) + strcat (cmd, " -x"); + + getcmd (cx, cmd, cmd, SZ_CMD); + + if (ifstate[iflev] == STOP) + return 0; + + if (verbose) { + printf ("%s\n", cmd); + fflush (stdout); + } + + if (execute) + exit_status = h_xc (cmd); + if (exit_status == INTERRUPT) + fatals (" interrupt %s", cx->library); + + return (exit_status); +} + + +/* DO_LINK -- Call XC to link a list of objects and/or libraries. This is + * equivalent to $XC, except that the LFLAGS are used instead of the XFLAGS. + */ +int +do_link (struct context *cx) +{ + register struct sfile *sflist, *sfp=NULL; + static int skip_sf = 0; + char *ip, token[SZ_FNAME+1]; + char linkline[SZ_CMD+1]; + char cmdbuf[SZ_CMD+1]; + char *cmd = cmdbuf; + int lflags_set = 0; + char *lflags; + + + if (debug > 1) { + printf ("do_link:\n"); + fflush (stdout); + } + + /* Get the link command from the input stream. */ + getcmd (cx, "", linkline, SZ_CMD); + + /* Check whether the executable being generated is on the special + * file list. + */ + if (!skip_sf && (sflist = sf_dirsearch (cx->dirpath))) { + for (ip=linkline; getword(&ip,token,SZ_FNAME); ) + if (strcmp (token, "-o") == 0) + if (getword (&ip, token, SZ_FNAME)) + if ((sfp = sf_filesearch (sflist, token))) + break; + } + + /* Check if LFLAGS is being substituted for this file. */ + if (sfp && strncmp (sfp->sf_mkobj, "LFLAGS", 6) == 0) { + for (ip=sfp->sf_mkobj; *ip && *ip != '='; ip++) + ; + lflags = (*ip == '=') ? ip + 1 : ip; + lflags_set++; + } else + lflags = getsym (LFLAGS); + + if (irafdir[0]) + sprintf (cmd, "%s %s -r %s", XC, lflags, irafdir); + else + sprintf (cmd, "%s %s", XC, lflags); + + if (debug) + strcat (cmd, " -d"); + if (dbgout) + strcat (cmd, " -x"); + + strcat (cmd, linkline); + + if (ifstate[iflev] == STOP) + return 0; + + /* Check whether a special $link command or other build command + * should be executed. + */ + if (sfp && !lflags_set) { + /* Push back the special link command. */ + m_pushstr (cx, "\n"); + m_pushstr (cx, sfp->sf_mkobj); + + /* Avoid recursion if $link is pushed back. */ + if (strncmp (sfp->sf_mkobj, "$link", 5) == 0) + skip_sf++; + return (OK); + } + + if (verbose) { + printf ("%s\n", cmd); + fflush (stdout); + } + + if (execute) + exit_status = h_xc (cmd); + if (exit_status == INTERRUPT) + fatals (" interrupt %s", cx->library); + + skip_sf = 0; + return (exit_status); +} + + +/* DO_GENERIC -- Call the generic preprocessor. + */ +int +do_generic (struct context *cx) +{ + char cmd[SZ_CMD+1]; + + if (debug > 1) { + printf ("do_generic:\n"); + fflush (stdout); + } + + getcmd (cx, GENERIC, cmd, SZ_CMD); + + if (ifstate[iflev] == STOP) + return 0; + + if (verbose) { + printf ("%s\n", cmd); + fflush (stdout); + } + + if (execute) + exit_status = os_cmd (cmd); + if (exit_status == INTERRUPT) + fatals (" interrupt %s", cx->library); + + return (exit_status); +} + + +/* DO_SET -- Enter the name and value of a symbol (macro) into the symbol + * table. + */ +void +do_set (struct context *cx) +{ + char symbol[SZ_FNAME+1]; + char value[SZ_PBBUF+1]; + + if (debug > 1) { + printf ("do_set:\n"); + fflush (stdout); + } + + if (getkwvpair (cx, symbol, value) != ERR) { + if (ifstate[iflev] == STOP) + return; + + if (debug) { + printf ("set %s = `%s'\n", symbol, value); + fflush (stdout); + } + putsym (symbol, value); + } +} + + +/* DO_INCHECK -- Check a file (e.g, library) back into the named directory. + * (the "in" is first to make the external function name unique on systems + * which truncate external names). + */ +int +do_incheck (struct context *cx) +{ + char fname[SZ_FNAME+1]; + char dname[SZ_FNAME+1]; + + if (debug > 1) { + printf ("do_checkin:\n"); + fflush (stdout); + } + + strcpy (fname, getargs (cx)); + strcpy (dname, getargs (cx)); + + exit_status = h_incheck (fname, dname); + if (exit_status != OK) + warns ("error during checkin of %s", fname); + + return (exit_status); +} + + +/* DO_OUTCHECK -- Check a file (e.g, library) out of the named directory. + */ +int +do_outcheck (struct context *cx) +{ + char fname[SZ_FNAME+1]; + char dname[SZ_FNAME+1]; + int clobber; + + if (debug > 1) { + printf ("do_checkout:\n"); + fflush (stdout); + } + + strcpy (fname, getargs (cx)); + strcpy (dname, getargs (cx)); + + exit_status = h_outcheck (fname, dname, clobber=YES); + if (exit_status != OK) + warns ("error during checkout of %s", fname); + + return (exit_status); +} + + +/* DO_COPYFILE -- Copy a file. + */ +int +do_copyfile (struct context *cx) +{ + char old[SZ_FNAME+1]; + char new[SZ_FNAME+1]; + + if (debug > 1) { + printf ("do_copyfile:\n"); + fflush (stdout); + } + + strcpy (old, getargs (cx)); + strcpy (new, getargs (cx)); + + if (ifstate[iflev] == STOP) + return 0; + + if (verbose) { + printf ("copy `%s' to `%s'\n", old, new); + fflush (stdout); + } + + exit_status = h_copyfile (old, new); + if (exit_status != OK) + warns ("error making copy of %s", old); + + return (exit_status); +} + + +/* DO_MOVEFILE -- Move a file to another directory, or rename the file in the + * current directory. + */ +int +do_movefile (struct context *cx) +{ + register char *ip, *op; + char old[SZ_FNAME+1]; + char new[SZ_PATHNAME+1]; + + if (debug > 1) { + printf ("do_movefile:\n"); + fflush (stdout); + } + + strcpy (old, getargs (cx)); + strcpy (new, getargs (cx)); + + if (ifstate[iflev] == STOP) + return 0; + + /* If NEW is a directory, concatenate the filename. Always pass a + * filename to h_movefile. + */ + for (op=new; *op; op++) + ; + if (*(op-1) == '$' || *(op-1) == '/') + for (ip=old; (*op++ = *ip++); ) + ; + + if (verbose) { + printf ("move `%s' to `%s'\n", old, new); + fflush (stdout); + } + + exit_status = h_movefile (old, new); + if (exit_status != OK) + warns ("error moving file %s", old); + + return (exit_status); +} + + +/* DO_DELETE -- Delete a file or list of files. + */ +void +do_delete (struct context *cx) +{ + char fname[SZ_PATHNAME+1]; + + + if (debug > 1) { + printf ("do_delete:\n"); + fflush (stdout); + } + + for (;;) { + strcpy (fname, getargs (cx)); + if (fname[0] == EOS) + return; + + if (ifstate[iflev] == STOP) + return; + + if (execute) { + if (verbose) { + printf ("delete file %s\n", vfn2osfn(fname,0)); + fflush (stdout); + } + + exit_status = os_delete (fname); + if (exit_status != OK) + warns ("cannot delete file %s", fname); + } + } +} + + +/* DO_PURGE -- Purge all files in a directory. This is a no-op on systems + * that do not support multiple file versions. + */ +void +do_purge ( + struct context *cx, /* not used */ + char *dname /* logical directory name */ +) +{ + if (debug > 1) { + printf ("do_purge: %s\n", dname); + fflush (stdout); + } + + if (ifstate[iflev] == STOP) + return; + + exit_status = h_purge (dname); + if (exit_status != OK) + warns ("error during purge of %s", dname); +} + + +/* GETCMD -- Extract a possibly multiline command from the input stream + * into a buffer, with macro replacement in the process. + */ +int +getcmd ( + register struct context *cx, + char *prefix, /* first part of command */ + char *cmd, /* receives the command */ + int maxch +) +{ + register char *op, *otop; + register int ch; + + + otop = &cmd[maxch]; + strcpy (cmd, prefix); + for (op=cmd; *op; op++) + ; + + while (op < otop && (ch = m_getc(cx)) != EOF) + if (ch == ESCAPE) { + ch = m_getc (cx); + if (ch != '\n') { + *op++ = ESCAPE; + *op++ = ch; + } + } else if (ch == '\n') { + *op = EOS; + break; + } else if (ch == PREPROCESSOR && *(op-1) == ' ') { + /* $ is only recognized as a command delimiter if it occurs + * at the start of a new token. + */ + m_ungetc (ch, cx); + *op = EOS; + break; + } else + *op++ = ch; + + return (op - cmd); +} + + +/* GETARGS -- Accumulate the argument list of a preprocessor macro. + * The argument list may optionally be enclosed in parens or quotes, + * otherwise we look for whitespace or newline as the delimiter. + */ +char * +getargs ( + register struct context *cx /* current context */ +) +{ + register int ch; + static char args[SZ_PBBUF+1]; + char tokbuf[SZ_COMMAND+1]; + int delim; + + + while ((ch = m_getc(cx)) == ' ') + ; + + if (ch == '(') + delim = ')'; + else if (ch == '"' || ch == '\'') + delim = ch; + else if (ch == SYSFILE_BEGIN) + delim = SYSFILE_END; + else { + delim = ' '; + m_ungetc (ch, cx); + } + + getstr (cx, tokbuf, SZ_COMMAND, delim); + strcpy (args, tokbuf); + + if (delim == SYSFILE_END) + if (m_sysfile (tokbuf, args, SZ_PBBUF) <= 0) + sprintf (args, "<%s>", tokbuf); + + return (args); +} + + +/* GETSTR -- Accumulate a string from the input stream, stopping when the + * specified delimiter character is seen. Note that macros are expanded + * even within quoted strings, as in MAKE (macros are defined at the character + * level, rather than at the token level). + */ +int +getstr ( + register struct context *cx, /* current context */ + char *outstr, /* receives string */ + int maxch, /* max chars out */ + int delim /* delimiter character */ +) +{ + register char *op; + register int ch, n; + + for (op=outstr, n=maxch; --n >= 0 && (ch = m_getc(cx)) != delim; ) + if (ch == '\\') { + ch = m_getc(cx); + if (ch == '\n') + ; + else if (ch == delim) + *op++ = ch; + else { + *op++ = '\\'; + *op++ = ch; + } + } else if (ch == '\n' || ch == EOF) { + *op = EOS; + if (delim != ' ') + warns ("missing closing quote in string `%s'", outstr); + m_ungetc ('\n', cx); + break; + } else + *op++ = ch; + + *op = EOS; + return (op - outstr); +} + + +/* GETKWVPAIR -- Extract the keyword and value fields from a "keyword=value" + * construct in the input stream. + */ +int +getkwvpair ( + register struct context *cx, /* current context */ + char *symbol, /* receives name of symbol */ + char *value /* receives value of symbol */ +) +{ + register char *op; + register int ch; + + while ((ch = m_getc(cx)) == ' ') + ; + if (!isalpha(ch)) { + m_ungetc (ch, cx); + return (ERR); + } + + /* Extract module name */ + for (op=symbol, *op++ = ch; (ch = m_getc(cx)) != '='; ) { + if (ch == ' ') { + continue; + } else if (ch == '\n') { + warns ("missing `=' in $set statement `%s'", symbol); + m_ungetc ('\n', cx); + return (ERR); + } else + *op++ = ch; + } + *op = EOS; + + /* Extract symbol value */ + strcpy (value, getargs(cx)); + return (OK); +} + + +/* GETWORD -- Extract a whitespace delimited substring from a string. + * The input pointer is left pointing to the first character following + * the extracted string. + */ +int +getword ( + char **str, + char *outstr, + int maxch +) +{ + register char *ip=(*str), *op=outstr; + register char *otop = outstr + maxch; + register int ch; + + while (*ip && isspace (*ip)) + ip++; + + while (op < otop && (ch = *ip++)) + if (isspace (ch)) + break; + else + *op++ = ch; + + *op = EOS; + *str = ip; + + return (op - outstr); +} + + +/* PUTSYM -- Add a symbol (macro definition) to the symbol table. Symbol + * storage is in the string buffer, with all symbols defined local to a + * module being discarded when the module exits. All symbols are globally + * accessible, with local symbols possibly redefining (temporarily) existing + * external symbols (e.g., the value of "xflags" might be reset locally, + * but should not affect outer level code once the module has exited). + * Symbol names are treated in a case insensitive fashion to simplify use + * on systems that do not preserve case, e.g., in the MKPKG argument list. + */ +void +putsym ( + char *name, /* symbol name */ + char *value /* symbol value */ +) +{ + char *symbol; + + if (debug) { + printf ("put symbol %s = `%s'\n", name, value); + fflush (stdout); + } + + symbol = mklower (name); + symtab[nsymbols].s_name = putstr (symbol); + symtab[nsymbols].s_value = putstr (value); + + if (++nsymbols >= MAX_SYMBOLS) + fatals ("too many symbols (`%s')", name); +} + + +/* GETSYM -- Lookup a symbol in the symbol table. Return the symbol value + * as the function value if the symbol is found, else return NULL. The symbol + * table is searched most-recently-defined symbols first, permitting symbols + * to be redefined locally. Note that the full table is searched, hence the + * outer symbols are globally accessible. The number of symbols tends to be + * quite small and symbol lookup only occurs when a macro is explicitly + * referenced as $(NAME), hence a simple linear search is best. + */ +char * +getsym ( + char *name /* symbol name */ +) +{ + register struct symbol *sp, *stop; + register int ch; + char *symbol; + + symbol = mklower (name); + stop = &symtab[0]; + sp = &symtab[nsymbols]; + ch = symbol[0]; + + /* Search the symbol table. + */ + while (--sp >= stop) + if (sp->s_name[0] == ch) + if (strcmp (sp->s_name, symbol) == 0) + return (sp->s_value); + + return (NULL); +} + + +/* MKLOWER -- Convert a small string to lower case and return a pointer to + * a local copy of the new string. + */ +char * +mklower (char *s) +{ + register char *ip, *op; + register int n, ch; + static char lstr[SZ_FNAME+1]; + + for (ip=s, op=lstr, n=SZ_FNAME; --n >= 0 && (ch = *ip++); ) + if (isupper (ch)) + *op++ = tolower (ch); + else + *op++ = ch; + *op = EOS; + + return (lstr); +} diff --git a/unix/boot/rmbin/README b/unix/boot/rmbin/README new file mode 100644 index 00000000..7eb6a6c4 --- /dev/null +++ b/unix/boot/rmbin/README @@ -0,0 +1 @@ +RMBIN -- Descend a directory tree, removing all binary files therein. diff --git a/unix/boot/rmbin/mkpkg.sh b/unix/boot/rmbin/mkpkg.sh new file mode 100644 index 00000000..aa2aa4ad --- /dev/null +++ b/unix/boot/rmbin/mkpkg.sh @@ -0,0 +1,6 @@ +# Make and install the RMBIN utility. + +$CC -c $HSI_CF rmbin.c +$CC $HSI_LF rmbin.o $HSI_LIBS -o rmbin.e +mv -f rmbin.e ../../hlib +rm *.o diff --git a/unix/boot/rmbin/rmbin.c b/unix/boot/rmbin/rmbin.c new file mode 100644 index 00000000..760a1fb3 --- /dev/null +++ b/unix/boot/rmbin/rmbin.c @@ -0,0 +1,264 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#define import_spp +#define import_knames +#include + +#include "../bootProto.h" + + +#define MAXEXTN 128 + +char *only[MAXEXTN]; /* delete files with these extensions */ +char *excl[MAXEXTN]; /* exclude these files */ +int interactive; /* verify if file does not have extn */ +int recurse; /* recursively descend directories */ +int verbose; /* print names of deleted files */ +int execute; /* permission to delete files */ + + +extern int ZZSTRT(void); +extern int ZZSTOP(void); + +static void rmbin (char *dir, int recurse, char *path); +static int verify_delete (char *fname, char *path); +static int exclude_file (char *fname); + + +/* + * RMBIN -- Delete all binary files in a directory tree or trees. + * + * rmbin [-dinrv] [-o extns] [-e extns] dir1 dir2 ... dirN + * + * -d disable recursive descent + * -e exclude files with the following extensions + * -i verify before deleting files without extensions + * -n no execute; do not delete files + * -o delete only files with the following extensions + * -r enable recursive descent + * -v print names of files as they are deleted + * + * Note that flags may be inserted between directory name arguments to change + * switches for different directories. + * + */ +int +main (int argc, char *argv[]) +{ + char path[SZ_PATHNAME+1]; + char *argp; + int argno, i; + + ZZSTRT(); + + if (argc < 2) + goto help_; + + only[0] = NULL; + excl[0] = NULL; + path[0] = EOS; + + interactive = 0; + recurse = 0; + verbose = 0; + execute = 1; + + for (argno=1; (argp = argv[argno]) != NULL; argno++) + if (*argp == '-') { + for (argp++; *argp; argp++) + switch (*argp) { + case 'd': /* disable recursion */ + recurse = 0; + break; + case 'i': /* verify deletions */ + interactive = 1; + break; + case 'r': /* enable recursion */ + recurse = 1; + break; + case 'n': /* no execute */ + execute = 0; + /* fall through */ + case 'v': /* set verbose mode */ + verbose = 1; + break; + + case 'e': /* exclude listed files */ + i = 0; + argno++; + while (argv[argno] != NULL && *(argv[argno]) == '.' && + *(argv[argno]+1) != EOS) + excl[i++] = argv[argno++]; + --argno; + break; + + case 'o': /* only the listed files */ + i = 0; + argno++; + while (argv[argno] != NULL && *(argv[argno]) == '.' && + *(argv[argno]+1) != EOS) + only[i++] = argv[argno++]; + --argno; + break; + + default: + goto help_; + } + } else + rmbin (argp, recurse, path); + + ZZSTOP(); + exit (OSOK); +help_: + fprintf (stderr, "rmbin [-dinrv] [-o extns] [-e extns] dir dir ...\n"); + ZZSTOP(); + exit (OSOK+1); +} + + +/* RMBIN -- Remove all binaries in a directory or in a directory tree. + * We chdir to each directory to minimize path searches. + */ +static void +rmbin ( + char *dir, + int recurse, + char *path /* pathname of current directory */ +) +{ + char newpath[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + int dp, ftype; + + if ((dp = os_diropen (dir)) == ERR) { + fprintf (stderr, "cannot open directory `%s'\n", dir); + fflush (stderr); + return; + } + + sprintf (newpath, "%s%s/", path, dir); + + /* Descend into the subdirectory. + */ + if (strcmp (dir, ".") != 0) + if (os_chdir (dir) == ERR) { + os_dirclose (dp); + fprintf (stderr, "cannot change directory to `%s'\n", newpath); + fflush (stderr); + return; + } + + /* Scan through the directory. + */ + while (os_gfdir (dp, fname, SZ_PATHNAME) > 0) { + if (os_symlink (fname, 0, 0)) + continue; + + if ((ftype = os_filetype (fname)) == DIRECTORY_FILE) + rmbin (fname, recurse, newpath); + else { + if (only[0] != NULL) { + if (exclude_file (fname)) + continue; + } else if (ftype != BINARY_FILE || exclude_file (fname)) + continue; + + /* We have a binary file which is not excluded from deletion + * by its extension, so delete it. + */ + if (interactive && (verify_delete (fname, newpath) == NO)) + continue; + + if (verbose) { + printf ("%s%s\n", newpath, fname); + fflush (stdout); + } + + if (execute) + if (os_delete (fname) == ERR) { + fprintf (stderr, "cannot delete `%s'\n", fname); + fflush (stderr); + } + } + } + + /* Return from the subdirectory. + */ + if (strcmp (dir, ".") != 0) + if (os_chdir ("..") == ERR) { + fprintf (stderr, "cannot return from subdirectory `%s'\n", + newpath); + fflush (stderr); + } + + os_dirclose (dp); +} + + +/* EXCLUDE_FILE -- Check the "only" and "exclude" file lists to see if the + * file should be excluded from deletion. + */ +static int +exclude_file (char *fname) +{ + register char *ip, *ep; + register int ch, i; + char *extn; + + extn = NULL; + for (ip=fname; (ch = *ip); ip++) + if (ch == '.') + extn = ip; + + /* If the file has no extension all we have to do is check if there is + * an "only" file list. + */ + if (extn == NULL) + return (only[0] != NULL ? YES : NO); + + /* Check the only and exclude file lists. + */ + ch = *(extn + 1); + if (only[0] != NULL) { + for (i=0; (ep = only[i]); i++) + if (*(ep+1) == ch) + if (strcmp (ep, extn) == 0) + return (NO); + return (YES); + } else if (excl[0] != NULL) { + for (i=0; (ep = excl[i]); i++) + if (*(ep+1) == ch) + if (strcmp (ep, extn) == 0) + return (YES); + return (NO); + } else + return (NO); +} + + +/* VERIFY_DELETE -- Ask the user if they want to delete the named file. + */ +static int +verify_delete ( + char *fname, /* name of file to be deleted */ + char *path /* current directory pathname */ +) +{ + char lbuf[SZ_LINE+1]; + char *ip; + + fprintf (stderr, "delete file %s%s? ", path, fname); + fflush (stderr); + fgets (lbuf, SZ_LINE, stdin); + + for (ip=lbuf; *ip == ' ' || *ip == '\t'; ip++) + ; + if (*ip == 'y' || *ip == 'Y') + return (YES); + else + return (NO); +} diff --git a/unix/boot/rmbin/rmbin.hlp b/unix/boot/rmbin/rmbin.hlp new file mode 100644 index 00000000..30f54c9e --- /dev/null +++ b/unix/boot/rmbin/rmbin.hlp @@ -0,0 +1,70 @@ +.help rmbin Feb86 "softools" +.ih +NAME +rmbin -- find/remove binary files in subdirectories +.ih +USAGE +rmbin [-dinrv] [-o extns] [-e extns] dir1 dir2 ... dirN +.ih +PARAMETERS +.ls 4 -d +Disable recursive descent into subdirectories. +.le +.ls 4 -e extns +Exclude files with the listed extensions (whitespace delimited). +.le +.ls 4 -i +Verify before deleting files without extensions. Files with well known +extensions like ".[aoe]" are deleted without a query. A heuristic (ZFACSS) +is used to determine the filetype of files with unknown extensions, and +it can fail, though in practice it works quite well. +.le +.ls 4 -n +No execute; do not delete files. This option may be used to generate +a list of binary files for some purpose other than deletion. For example, +on a UNIX host, the following command will compute the disk space used +by the binary files in a directory tree: + + % du `rmbin -n .` + +The -n option, of course, is also useful for verifying the delete operation +before destroying the files. +.le +.ls 4 -o extns +Delete only files with the listed extensions (whitespace delimited). +.le +.ls 4 -r +Reenable recursive descent. Recursive descent is the default, however +it may be turned off at one point in the command line, and later reenabled +with this switch. +.le +.ls 4 -v +Print names of files as they are deleted. +.le + +Note that flags may be inserted between directory name arguments to change +switches for different directories. +.ih +DESCRIPTION +The \fIrmbin\fR task is used to descend a directory tree, deleting (or listing) +all the binary files therein. The task may also be used to delete or list +nonbinary files by explicitly listing their extensions. + +\fIRmbin\fR is used the strip the IRAF system down to the sources, prior to +a full system rebuild. After changing to the IRAF root directory, one runs +\fIrmbin\fR to delete all the binaries in lib, sys, pkg, etc. (but \fInot\fR +in hlib, else a bootstrap will be necessary too). \fIMkpkg\fR is then run +to recompile the system; this currently takes about 20 hours on our UNIX +11/750 development system, provided nothing else is running on the system. +.ih +EXAMPLES +1. Delete all binaries in the pkg and sys directories of IRAF. The example +is for a UNIX host, but this works for all other IRAF hosts as well. + +.nf + % cd $iraf + % rmbin -v pkg sys +.fi +.ih +SEE ALSO +rtar, wtar, mkpkg diff --git a/unix/boot/rmfiles/README b/unix/boot/rmfiles/README new file mode 100644 index 00000000..45bc830c --- /dev/null +++ b/unix/boot/rmfiles/README @@ -0,0 +1,4 @@ +RMFILES -- Descend a directory tree, removing or listing all the specified + files therein. This is similar to the RMBIN utility, except that + it is not limited to removing binary files. This task is used to + strip production versions of the system down to the essentials. diff --git a/unix/boot/rmfiles/mkpkg.sh b/unix/boot/rmfiles/mkpkg.sh new file mode 100644 index 00000000..43d8dbd3 --- /dev/null +++ b/unix/boot/rmfiles/mkpkg.sh @@ -0,0 +1,6 @@ +# Make and install the RMFILES utility. + +$CC -c $HSI_CF rmfiles.c +$CC $HSI_LF rmfiles.o $HSI_LIBS -o rmfiles.e +mv -f rmfiles.e ../../hlib +rm *.o diff --git a/unix/boot/rmfiles/rmfiles.c b/unix/boot/rmfiles/rmfiles.c new file mode 100644 index 00000000..a6321d41 --- /dev/null +++ b/unix/boot/rmfiles/rmfiles.c @@ -0,0 +1,383 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#define import_spp +#define import_knames +#include + +#include "../bootProto.h" + + +#define MAXEXTN 128 +#define ALL 0 /* delete all files */ +#define ALLBUT 1 /* delete all but listed files */ +#define ONLY 2 /* delete only listed files */ + +int verbose; /* print names of deleted files */ +int execute; /* permission to delete files */ +int debug; /* print debugging info */ + +extern char *vfn2osfn(); + + +extern int ZZSTRT (void); +extern int ZZSTOP (void); + +static void rmfiles (char *prog, int oneliner); +static void stripdir (char *dir, char *path, char *extnlist[], int mode); +static int got_one (char *fname, char *extnlist[]); + + +/* + * RMFILES -- Delete all files with the listed extensions in the listed + * directory trees. + * + * rmfiles [-dnv] [-f progfile] dir action extns + * + * -d debug + * -n no execute; do not delete files + * -v print names of files as they are deleted + * -f progfile name of file containing program script + * dir root directory of tree to be pruned + * action one of "-all", "-allbut", "-only" + * extns extensions of files to be deleted + * + * There is no default action as a safety measure. If -all is specifed, + * the extension list is ignored. + */ +int main (int argc, char *argv[]) +{ + char prog[SZ_LINE+1]; + char *argp, *ip, *op; + int oneliner, argno; + + ZZSTRT(); + + if (argc < 2) + goto help_; + + verbose = 0; + execute = 1; + debug = 0; + + for (argno=1; (argp = argv[argno]) != NULL; argno++) + if (*argp == '-') { + for (argp++; *argp; argp++) + switch (*argp) { + case 'd': + debug++; + break; + case 'n': /* no execute */ + execute = 0; + /* fall through */ + case 'v': /* set verbose mode */ + verbose = 1; + break; + + case 'f': + argno++; + if (argv[argno] == NULL) { + fprintf (stderr, "illegal `-f progfile' switch\n"); + exit (OSOK+1); + } + rmfiles (argv[argno], oneliner=NO); + break; + + default: + goto help_; + } + + } else { + /* Program is on command line. The rest of the command + * line is assumed to be the program. + */ + for (op=prog; (ip = argv[argno]) != NULL; argno++) { + while ((*op = *ip++)) + op++; + *op++ = ' '; + } + *op = EOS; + + rmfiles (prog, oneliner=YES); + break; + } + + + ZZSTOP(); + exit (OSOK); +help_: + fprintf (stderr, "rmfiles [-dnv] [-p prog] [progfile]\n"); + ZZSTOP(); + exit (OSOK+1); + + return (0); +} + + +/* RMFILES -- Strip (delete) the indicated files in the indicated + * directories. We are driven either by a program in the named text file, + * or in the prog string itself. + */ +static void +rmfiles ( + char *prog, /* program, or program file name */ + int oneliner /* if !oneliner, open program file */ +) +{ + char dir[SZ_PATHNAME+1], path[SZ_PATHNAME+1]; + char *extnlist[MAXEXTN], *ip, *op; + char lbuf[SZ_LINE+1]; + int nextn, mode; + FILE *fp = NULL; + + if (debug) { + fprintf (stderr, "rmfiles @(%s), exe=%d, ver=%d\n", prog, execute, + verbose); + fflush (stderr); + } + + /* Is program in a file, or in the "prog" string? + */ + if (oneliner) + strcpy (lbuf, prog); + else { + /* Open the program file. + */ + if ((fp = fopen (vfn2osfn(prog,0), "r")) == NULL) { + fprintf (stderr, "cannot open progfile `%s'\n", prog); + fflush (stderr); + return; + } + } + + while (oneliner || fgets (lbuf, SZ_LINE, fp) != NULL) { + /* Skip comment lines and blank lines, and any whitespace at + * the beginning of program lines. + */ + for (ip=lbuf; isspace(*ip); ip++) + ; + if (*ip == EOS || *ip == '#') { + if (oneliner) + break; + else + continue; + } + + /* Check for a single filename entry of the form `-file filename', + * deleting the named file if this type of entry is encountered. + */ + if (strncmp (ip, "-file", 5) == 0) { + for (ip=ip+5; isspace(*ip); ip++) + ; + for (op=path; (*op = *ip); ip++, op++) + if (isspace(*op)) + break; + *op = EOS; + if (*path == EOS) + continue; + + if (verbose) { + printf ("%s\n", path); + fflush (stdout); + } + + if (execute) { + if (os_delete (path) == ERR) { + fprintf (stderr, "cannot delete `%s'\n", path); + fflush (stderr); + } + } + + continue; + } + + /* Parse the program line into the directory pathname, mode, + * and extension list. The program entry must be all on one + * line. + */ + for (op=dir; (*op = *ip); ip++, op++) + if (isspace(*op)) + break; + *op = EOS; + + while (isspace(*ip)) + ip++; + if (strncmp (ip, "-allbut", 7) == 0) { + mode = ALLBUT; + ip += 7; + } else if (strncmp (ip, "-all", 4) == 0) { + mode = ALL; + ip += 4; + } else if (strncmp (ip, "-only", 5) == 0) { + mode = ONLY; + ip += 5; + } else { + fprintf (stderr, "error: no action specified: %s\n", lbuf); + fflush (stderr); + if (oneliner) + return; + else + continue; + } + + /* Construct a list of pointers to the extension strings. + */ + for (nextn=0; nextn < MAXEXTN; nextn++) { + while (isspace(*ip)) + ip++; + if (*ip == EOS || *ip == '#') + break; + + extnlist[nextn] = ip; + while (*ip && !isspace(*ip)) + ip++; + *ip++ = EOS; + } + + extnlist[nextn] = NULL; + + if (debug) { + fprintf (stderr, "rootdir=%s, mode=%d, extns:", dir, mode); + for (nextn=0; extnlist[nextn]; nextn++) + fprintf (stderr, " %s", extnlist[nextn]); + fprintf (stderr, "\n"); + fflush (stderr); + } + + /* Strip the named directory tree. + */ + path[0] = EOS; + stripdir (dir, path, extnlist, mode); + + if (oneliner) + break; + } + + if (!oneliner) + fclose (fp); +} + + +/* STRIPDIR -- Starting with the named directory, scan that directory and + * all subdirectories, deleting (or listing) the files therein depending + * on the mode, which can be ALL, ALLBUT, or ONLY. We chdir to each directory + * to minimize path searches. + */ +static void +stripdir ( + char *dir, /* start with this directory */ + char *path, /* pathname of current directory */ + char *extnlist[], /* list of file extensions */ + int mode /* ALL, ALLBUT, ONLY */ +) +{ + char oldpath[SZ_PATHNAME+1]; + char newpath[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + int deleteit, dp; + + if (debug) { + fprintf (stderr, "stripdir %s%s\n", path, dir); + fflush (stderr); + } + + if ((dp = os_diropen (dir)) == ERR) { + fprintf (stderr, "cannot open subdirectory `%s'\n", dir); + fflush (stderr); + return; + } + + os_fpathname ("", oldpath, SZ_PATHNAME); + sprintf (newpath, "%s%s/", path, dir); + + /* Descend into the subdirectory. + */ + if (strcmp (dir, ".") != 0) + if (os_chdir (dir) == ERR) { + os_dirclose (dp); + fprintf (stderr, "cannot change directory to `%s'\n", newpath); + fflush (stderr); + return; + } + + /* Scan through the directory. + */ + while (os_gfdir (dp, fname, SZ_PATHNAME) > 0) { + if (os_filetype (fname) == DIRECTORY_FILE) { + stripdir (fname, newpath, extnlist, mode); + continue; + } else if (mode == ALL) { + deleteit = YES; + } else { + deleteit = got_one (fname, extnlist); + if (mode == ALLBUT) + deleteit = !deleteit; + } + + if (!deleteit) + continue; + + if (verbose) { + printf ("%s%s\n", newpath, fname); + fflush (stdout); + } + + if (execute) { + if (os_delete (fname) == ERR) { + fprintf (stderr, "cannot delete `%s'\n", fname); + fflush (stderr); + } + } + } + + /* Return from the subdirectory. + */ + if (strcmp (dir, ".") != 0) + if (os_chdir (oldpath) == ERR) { + fprintf (stderr, "cannot return from subdirectory `%s'\n", + newpath); + fflush (stderr); + } + + os_dirclose (dp); +} + + +/* GOT_ONE -- Check the file extension, if there is one, to see if the + * file is on the list of extensions. + */ +static int +got_one ( + char *fname, /* file to be examined */ + char *extnlist[] /* list of extensions */ +) +{ + register char *ip, *ep; + register int ch, i; + char *extn; + + extn = NULL; + for (ip=fname; (ch = *ip); ip++) + if (ch == '.') + extn = ip; + + /* If the file has no extension it is not on the list. + */ + if (extn == NULL) + return (NO); + + /* Check the list of extensions. + */ + ch = *(extn + 1); + if (extnlist[0] != NULL) + for (i=0; (ep = extnlist[i]); i++) + if (*(ep+1) == ch) + if (strcmp (ep, extn) == 0) + return (YES); + + return (NO); +} diff --git a/unix/boot/rmfiles/rmfiles.hlp b/unix/boot/rmfiles/rmfiles.hlp new file mode 100644 index 00000000..b9e0125d --- /dev/null +++ b/unix/boot/rmfiles/rmfiles.hlp @@ -0,0 +1,95 @@ +.help rmfiles Jul86 "softools" +.ih +NAME +rmfiles -- find/remove files in subdirectories +.ih +USAGE +rmfiles [-dnv] [-f progfile] rootdir action extns +.ih +PARAMETERS +.ls 4 -d +Print debug messages. +.le +.ls 4 -n +No execute; do not delete files. This option may be used to generate +a list of binary files for some purpose other than deletion, or to verify +the delete operation before destroying the files. +.le +.ls 4 -v +Print names of files as they are deleted. +.le +.ls 4 -f progfile +Take delete commands from the named file. If this option is specified +the remaining arguments are normally omitted. +.le +.ls 4 rootdir +The root directory of the directory tree to be pruned. This must be a +path from the current directory or from a logical directory. +.le +.ls 4 action +The possible actions are listed below. This is a required parameter. +.ls +.ls 8 -all +Delete all files. +.le +.ls 8 -allbut +Delete all files except those with the listed extensions. +.le +.ls 8 -only +Delete only those files with the listed extensions. +.le +.le +.le +.ls 4 extns +A list of filename extensions delimited by spaces, e.g., ".a .o .e .hlp". +.le +.ih +DESCRIPTION +The \fIrmfiles\fR utility is used to delete (or list) files in one or more +directory trees. If only one directory tree is to be pruned the necessary +instructions can be entered on the command line, otherwise a program file +must be used. When developing a program file, a dry run using the "-n" +switch is recommended to see what files will be deleted. + +If a program file is used each line in the file has one of two possible +formats. If a directory is to be pruned the syntax is the same as is +used when a one line program is entered on the command line, i.e.: + + rootdir action extns + +The significance of each field is as described in the ARGUMENTS section +above. The program file may also contain lines of the form + + -file filename + +to delete one or more files by name. This is useful for removing files +which do not fit into any recognizable class. + +Comments and blank lines are permitted anywhere in the program file. +All filenames are IRAF virtual filenames (or host filenames). + +\fIRmfiles\fR is a bootstrap utility implemented as a foreign task, hence +it may be called either from within IRAF or from the host system. +.ih +EXAMPLES +1. Delete all .o, .e, .a, and .hd files in the directory "iraf$pkg". +Print the names of the files as they are deleted. Note that one must +move to the directory containing the directory to be pruned before running +\fIrmfiles\fR. + +.nf + cl> cd iraf + cl> rmfiles -v pkg .o .e .a .hd +.fi + +2. Strip the entire IRAF system, using the program in file "hlib$stripper". +The use of the $ in the filename here could cause problems on some systems +since \fIrmfiles\fR is a foreign task. + +.nf + cl> cd iraf + cl> rmfiles -vf hlib$stripper +.fi +.ih +SEE ALSO +rmbin, rtar, wtar diff --git a/unix/boot/rtar/README b/unix/boot/rtar/README new file mode 100644 index 00000000..61e45d80 --- /dev/null +++ b/unix/boot/rtar/README @@ -0,0 +1,5 @@ +RTAR -- Read tar format file or tape. This is a portable, non-UNIX, non- + proprietary program for reading tar format files on a variety of + systems. The TAR format is an excellent choice for transporting + files between different machines because of its simplicity, efficiency, + and machine independence. diff --git a/unix/boot/rtar/mkpkg.sh b/unix/boot/rtar/mkpkg.sh new file mode 100644 index 00000000..ec801f5f --- /dev/null +++ b/unix/boot/rtar/mkpkg.sh @@ -0,0 +1,6 @@ +# Bootstrap RTAR. + +$CC -c $HSI_CF rtar.c +$CC $HSI_LF rtar.o $HSI_LIBS -o rtar.e +mv rtar.e ../../hlib +rm -f rtar.o diff --git a/unix/boot/rtar/rtar.c b/unix/boot/rtar/rtar.c new file mode 100644 index 00000000..6ef2e37e --- /dev/null +++ b/unix/boot/rtar/rtar.c @@ -0,0 +1,863 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define NOKNET +#define import_spp +#define import_knames +#include + +#include "../bootProto.h" + + +/* + * RTAR -- Read a UNIX tar format tape containing files with legal IRAF + * virtual filenames. Map tape filenames to host system filenames using + * IRAF filename mapping if the tape does not contain legal host system + * filenames. + * + * Switches: + * a advance to first file in filelist before doing + * anything. useful for restarting an aborted + * operation. first file is not otherwise used. + * b generate only C style binary byte stream output + * files (default is to write a text file when + * the input stream is text). + * d print debug messages + * e exclude, rather than include, listed files + * f read from named file rather than stdin + * l do not try to resolve links by a file copy + * m do not restore file modify times + * n do not strip tailing blank lines from text files + * o omit binary files (e.g. when foreign host has + * incompatible binary file format) + * p omit the given pathname prefix when creating files + * r replace existing file at extraction + * t print name of each file matched + * u do not attempt to restore user id + * v verbose; print full description of each file + * x extract files (extract everything if no files + * listed or if -e is set) + * + * Switches must be given in a group, in any order, e.g.: + * + * rtar -xetvf tarfile sys/osb sys/os lib/config.h$ + * + * would extract all files from tarfile with names not beginning with sys/os + * or sys/osb or with names not equal to lib/config.h, printing a verbose + * description of each file extracted. If an exclude filename does not end + * with a $ all files with the given string as a prefix are excluded. + */ + +#define TBLOCK 512 +#define NBLOCK 20 +#define NAMSIZ 100 +#define MAXERR 20 +#define MAXTRYS 100 +#define MAXLINELEN 256 +#define SZ_TAPEBUFFER (TBLOCK * NBLOCK) +#define EOS '\0' +#define ERR (-1) +#define OK 0 +#define RWXR_XR_X 0755 +#define SZ_PADBUF 8196 +#define ctrlcode(c) ((c) >= '\007' && (c) <= '\017') + +#define LF_LINK 1 +#define LF_SYMLINK 2 +#define LF_DIR 5 + +/* File header structure. One of these precedes each file on the tape. + * Each file occupies an integral number of TBLOCK size logical blocks + * on the tape. The number of logical blocks per physical block is variable, + * with at most NBLOCK logical blocks per physical tape block. Two zero + * blocks mark the end of the tar file. + */ +union hblock { + char dummy[TBLOCK]; + struct header { + char name[NAMSIZ]; /* NULL delimited */ + char mode[8]; /* octal, ascii */ + char uid[8]; + char gid[8]; + char size[12]; + char mtime[12]; + char chksum[8]; + char linkflag; + char linkname[NAMSIZ]; + } dbuf; +}; + + +/* Decoded file header. + */ +struct fheader { + char name[NAMSIZ]; + int mode; + int uid; + int gid; + int isdir; + long size; + long mtime; + long chksum; + int linkflag; + char linkname[NAMSIZ]; +}; + + +static int advance; /* Advance to named file */ +static int stripblanks; /* strip blank padding at end of file */ +static int debug; /* Print debugging messages */ +static int binaryout; /* make only binary byte stream files */ +static int omitbinary; /* omit binary files (do not write) */ +static int extract; /* Extract files from the tape */ +static int replace; /* Replace existing files */ +static int exclude; /* Excluded named files */ +static int printfnames; /* Print file names */ +static int verbose; /* Print everything */ +static int links; /* Defeat copy to resolve link */ +static int setmtime; /* Restore file modify times */ +static int rsetuid; /* Restore file user id */ + +static char *pathprefix = NULL; +static int len_pathprefix = 0; +static struct fheader *curfil; +static int eof; +static int nerrs; +static char *first_file; +static char tapeblock[SZ_TAPEBUFFER]; +static char *nextblock; +static int nblocks; + +extern int ZZSTRT (void); +extern int ZZSTOP (void); + +extern int tape_open (char *fname, int mode); +extern int tape_close (int fd); +extern int tape_read (int fd, char *buf, int nbytes); + +static int matchfile (char *fname, register char **files); +static int getheader (int in, register struct fheader *fh); +static int cchksum (register char *p, register int nbyte); +static void printheader (FILE *out, register struct fheader *fh, int verbose); +static int filetype (int in, struct fheader *fh); +static int newfile (char *fname, int mode, int uid, int gid, int type); +static int checkdir (register char *path, int mode, int uid, int gid); +static void copyfile (int in, int out, struct fheader *fh, int ftype); +static void strip_blanks (int in, int out, long nbytes); +static void skipfile (int in, struct fheader *fh); +static char *getblock (int in); + + + + +char *getblock(); + + +/* MAIN -- "rtar [xtvlef] [names]". The default operation is to extract all + * files from the tar format standard input in quiet mode. + */ +int main (int argc, char *argv[]) +{ + struct fheader fh; + char **argp; + char *ip; + int in = 0, out; + int ftype; + int ch; + + ZZSTRT(); /* initialize the IRAF kernel */ + + advance = 0; + debug = 0; + binaryout = 0; + omitbinary = 0; + extract = 0; + replace = 0; + exclude = 0; + printfnames = 0; + verbose = 0; + links = 0; + setmtime = 1; + rsetuid = 1; + stripblanks = 1; /* strip blanks at end of file by default */ + + /* Get parameters. Argp is left pointing at the list of files to be + * extracted (default all if no files named). + */ + argp = &argv[1]; + if (argc <= 1) + extract++; + else { + while (*argp && **argp == '-') { + ip = *argp++ + 1; + while ((ch = *ip++) != EOS) { + switch (ch) { + case 'a': + advance++; + break; + case 'n': + stripblanks = 0; + break; + case 'x': + extract++; + break; + case 'b': + binaryout++; + break; + case 'd': + debug++; + break; + case 'e': + exclude++; + break; + case 'r': + replace++; + break; + case 't': + printfnames++; + break; + case 'v': + printfnames++; + verbose++; + break; + case 'l': + links++; + break; + case 'm': + setmtime = 0; + break; + case 'u': + rsetuid = 0; + break; + case 'o': + omitbinary++; + break; + case 'p': + if (*argp != NULL) { + pathprefix = *argp++; + len_pathprefix = strlen (pathprefix); + } + break; + case 'f': + if (*argp == NULL) { + fprintf (stderr, "missing filename argument\n"); + exit (OSOK+1); + } + in = tape_open (*argp, 0); + if (in == ERR) { + fprintf (stderr, "cannot open `%s'\n", *argp); + ZZSTOP(); + exit (OSOK+1); + } + argp++; + break; + default: + fprintf (stderr, "Warning: unknown switch `%c'\n", ch); + fflush (stderr); + break; + } + } + } + } + + /* If advancing to a file get the name of the file. This file name + * occurs at the beginning of the file list but is not part of the list. + * Only full filenames are permitted here. + */ + if (advance) + first_file = *argp++; + + /* Step along through the tar format file. Read file header and if + * file is in list and extraction is enabled, extract file. + */ + while (getheader (in, &fh) != EOF) { + curfil = &fh; + if (advance) { + if (strcmp (fh.name, first_file) == 0) { + if (debug) + fprintf (stderr, "match\n"); + advance = 0; + } else { + if (debug) + printheader (stderr, &fh, verbose); + skipfile (in, &fh); + continue; + } + } + + if (matchfile (fh.name, argp) == exclude) { + if (debug) + fprintf (stderr, "skip file `%s'\n", fh.name); + skipfile (in, &fh); + continue; + } + + if (printfnames) { + printheader (stdout, &fh, verbose); + fflush (stdout); + } + + if (fh.linkflag == LF_SYMLINK || fh.linkflag == LF_LINK) { + /* No file follows header if file is a link. Try to resolve + * the link by copying the original file, assuming it has been + * read from the tape. + */ + if (extract) { + if (fh.linkflag == LF_SYMLINK) { + if (replace) + os_delete (fh.name); + if (symlink (fh.linkname, fh.name) != 0) { + fprintf (stderr, + "Cannot make symbolic link %s -> %s\n", + fh.name, fh.linkname); + } + } else if (fh.linkflag == LF_LINK && !links) { + if (replace) + os_delete (fh.name); + if (os_fcopy (fh.linkname, fh.name) == ERR) { + fprintf (stderr, "Copy `%s' to `%s' fails\n", + fh.linkname, fh.name); + } else { + os_setfmode (fh.name, fh.mode); + if (rsetuid) + os_setowner (fh.name, fh.uid, fh.gid); + if (setmtime) + os_setmtime (fh.name, fh.mtime); + } + } else { + fprintf (stderr, + "Warning: cannot make link `%s' to `%s'\n", + fh.name, fh.linkname); + } + } + continue; + } + + if (extract) { + ftype = filetype (in, &fh); + if (fh.size > 0 && ftype == BINARY_FILE && omitbinary) { + if (printfnames) + fprintf (stderr, "omit binary file `%s'\n", fh.name); + skipfile (in, &fh); + continue; + } + out = newfile (fh.name, fh.mode, fh.uid, fh.gid, ftype); + if (out == ERR) { + fprintf (stderr, "cannot create file `%s'\n", fh.name); + skipfile (in, &fh); + continue; + } + if (!fh.isdir) { + copyfile (in, out, &fh, ftype); + os_close (out); + } + os_setfmode (fh.name, fh.mode); + if (rsetuid) + os_setowner (fh.name, fh.uid, fh.gid); + if (setmtime) + os_setmtime (fh.name, fh.mtime); + } else + skipfile (in, &fh); + } + + /* End of TAR file normally occurs when a zero tape block is read; + * this is not the same as the physical end of file, leading to + * problems when reading from sequential devices (e.g. pipes and + * magtape). Advance to the physical end of file before exiting. + */ + if (!eof) + while (tape_read (in, tapeblock, SZ_TAPEBUFFER) > 0) + ; + if (in) + tape_close (in); + + ZZSTOP(); + exit (OSOK); + + return (0); +} + + +/* MATCHFILE -- Search the filelist for the named file. If the file list + * is empty anything is a match. If the list element ends with a $ an + * exact match is required (excluding the $), otherwise we have a match if + * the list element is a prefix of the filename. + */ +static int +matchfile ( + char *fname, /* filename to be compared to list */ + register char **files /* pointer to array of fname pointers */ +) +{ + register char *fn, *ln; + register int firstchar; + + if (*files == NULL) + return (1); + + firstchar = *fname; + do { + if (**files++ == firstchar) { + for (fn=fname, ln = *(files-1); *ln && *ln == *fn++; ) + ln++; + if (*ln == EOS) + return (1); + else if (*ln == '$' && *(fn-1) == EOS) + return (1); + } + } while (*files); + + return (0); +} + + +/* GETHEADER -- Read the next file block and attempt to interpret it as a + * file header. A checksum error on the file header is fatal and usually + * indicates that the tape is not positioned to the beginning of a file. + * If we have a legal header, decode the character valued fields into binary. + */ +static int +getheader ( + int in, /* input file */ + register struct fheader *fh /* decoded file header (output) */ +) +{ + register char *ip, *op; + register int n; + union hblock *hb; + int tape_checksum, ntrys; + + for (ntrys=0; ; ntrys++) { + if ((hb = (union hblock *)getblock (in)) == NULL) + return (EOF); + + /* Decode the checksum value saved in the file header and then + * overwrite the field with blanks, as the field was blank when + * the checksum was originally computed. Compute the actual + * checksum as the sum of all bytes in the header block. If the + * sum is zero this indicates the end of the tar file, otherwise + * the checksums must match. + */ + if (*hb->dbuf.chksum == '\0' && cchksum ((char *)hb, TBLOCK) == 0) + return (EOF); + else + sscanf (hb->dbuf.chksum, "%o", &tape_checksum); + + for (ip=hb->dbuf.chksum, n=8; --n >= 0; ) + *ip++ = ' '; + if (cchksum ((char *)hb, TBLOCK) != tape_checksum) { + /* If a checksum error occurs try to advance to the next + * header block. + */ + if (ntrys == 0) { + fprintf (stderr, + "rtar: file header checksum error %o != %o\n", + cchksum ((char *)hb, TBLOCK), tape_checksum); + } else if (ntrys >= MAXTRYS) { + fprintf (stderr, "cannot recover from checksum error\n"); + exit (OSOK+1); + } + } else + break; + } + + if (ntrys > 1) + fprintf (stderr, "found next file following checksum error\n"); + + /* Decode the ascii header fields into the output file header + * structure. + */ + for (ip=hb->dbuf.name, op=fh->name; (*op++ = *ip++); ) + ; + fh->isdir = (*(op-2) == '/'); + + sscanf (hb->dbuf.mode, "%o", &fh->mode); + sscanf (hb->dbuf.uid, "%o", &fh->uid); + sscanf (hb->dbuf.gid, "%o", &fh->gid); + sscanf (hb->dbuf.size, "%lo", &fh->size); + sscanf (hb->dbuf.mtime, "%lo", &fh->mtime); + + n = hb->dbuf.linkflag; + if (n >= '0' && n <= '9') + fh->linkflag = n - '0'; + else + fh->linkflag = 0; + + if (fh->linkflag) + strcpy (fh->linkname, hb->dbuf.linkname); + + return (TBLOCK); +} + + +/* CCHKSUM -- Compute the checksum of a byte array. + */ +static int +cchksum ( + register char *p, + register int nbytes +) +{ + register int sum; + + for (sum=0; --nbytes >= 0; ) + sum += *p++; + + return (sum); +} + + +struct _modebits { + int code; + char ch; +} modebits[] = { + { 040000, 'd' }, + { 0400, 'r' }, + { 0200, 'w' }, + { 0100, 'x' }, + { 040, 'r' }, + { 020, 'w' }, + { 010, 'x' }, + { 04, 'r' }, + { 02, 'w' }, + { 01, 'x' }, + { 0, 0 } +}; + + +/* PRINTHEADER -- Print the file header in either short or long (verbose) + * format, e.g.: + * drwxr-xr-x 9 tody 1024 Nov 3 17:53 . + */ +static void +printheader ( + FILE *out, /* output file */ + register struct fheader *fh, /* file header struct */ + int verbose /* long format output */ +) +{ + register struct _modebits *mp; + char *tp, *ctime(); + + if (!verbose) { + fprintf (out, "%s\n", fh->name); + return; + } + + for (mp=modebits; mp->code; mp++) + fprintf (out, "%c", mp->code & fh->mode ? mp->ch : '-'); + + tp = ctime (&fh->mtime); + fprintf (out, "%3d %4d %2d %8ld %-12.12s %-4.4s %s", + fh->linkflag, + fh->uid, + fh->gid, + fh->size, + tp + 4, tp + 20, + fh->name); + + if (fh->linkflag && *fh->linkname) + fprintf (out, " -> %s\n", fh->linkname); + else + fprintf (out, "\n"); +} + + +/* FILETYPE -- Determine the file type (text, binary, or directory) of the + * next file on the input stream. Directory files are easy; the tar format + * identifies directories unambiguously. Discriminating between text and + * binary files is not possible in general because UNIX does not make such + * a distinction, but in practice we can apply a heuristic which will work + * in nearly all cases. This can be overriden, producing only binary byte + * stream files as output, by a command line switch. + */ +static int +filetype ( + int in, /* input file */ + struct fheader *fh /* decoded file header */ +) +{ + register char *cp; + register int n, ch; + int newline_seen, nchars; + + /* Easy cases first. + */ + if (fh->isdir) + return (DIRECTORY_FILE); + else if (fh->size == 0 || binaryout) + return (BINARY_FILE); + + /* Get a pointer to the first block of the input file and set the + * input pointers back so that the block is returned by the next + * call to getblock. + */ + if ((cp = getblock (in)) == NULL) + return (BINARY_FILE); + nextblock -= TBLOCK; + nblocks++; + + /* Examine the data to see if it is text. The simple heuristic + * used requires that all characters be either printable ascii + * or common control codes. + */ + n = nchars = (fh->size < TBLOCK) ? fh->size : TBLOCK; + for (newline_seen=0; --n >= 0; ) { + ch = *cp++; + if (ch == '\n') + newline_seen++; + else if (!isprint(ch) && !isspace(ch) && !ctrlcode(ch)) + break; + } + + if (n >= 0 || (nchars > MAXLINELEN && !newline_seen)) + return (BINARY_FILE); + else + return (TEXT_FILE); +} + + +/* NEWFILE -- Try to open a new file for writing, creating the new file + * with the mode bits given. Create all directories leading to the file if + * necessary (and possible). + */ +static int +newfile ( + char *fname, /* pathname of file */ + int mode, /* file mode bits */ + int uid, int gid, /* file owner, group codes */ + int type /* text, binary, directory */ +) +{ + int fd; + char *cp; + char *rindex(); + + if (len_pathprefix && strncmp(fname,pathprefix,len_pathprefix) == 0) + fname += len_pathprefix; + + if (debug) + fprintf (stderr, "newfile `%s':\n", fname); + + if (checkdir (fname, mode, uid, gid) == ERR) + return (ERR); + + if (type == DIRECTORY_FILE) { + cp = rindex (fname, '/'); + if (cp && *(cp+1) == EOS) + *cp = EOS; + fd = os_createdir (fname, mode); + + /* Ignore any error creating directory, as this may just mean + * that the directory already exists. If the directory does + * not exist and cannot be created, there will be plenty of + * other errors when we try to write files into it. + */ + fd = OK; + + } else { + if (replace) + os_delete (fname); + fd = os_createfile (fname, mode, type); + } + + return (fd); +} + + +/* CHECKDIR -- Verify that all the directories in the pathname of a file + * exist. If they do not exist, try to create them. + */ +static int +checkdir ( + register char *path, + int mode, + int uid, int gid +) +{ + register char *cp; + char *rindex(); + + /* Quick check to see if the directory exists. + */ + if ((cp = rindex (path, '/')) == NULL) + return (OK); + + *cp = EOS; + if (os_access (path, 0, DIRECTORY_FILE) == YES) { + *cp = '/'; + return (OK); + } + *cp = '/'; + + /* The directory cannot be accessed. Try to make all directories + * in the pathname. If the file is itself a directory leave its + * creation until later. + */ + for (cp=path; *cp; cp++) { + if (*cp != '/') + continue; + if (*(cp+1) == EOS) + return (OK); + + *cp = EOS; + if (os_access (path, 0, DIRECTORY_FILE) == NO) { + if (os_createdir (path, RWXR_XR_X) == ERR) { + fprintf (stderr, "cannot create directory `%s'\n", path); + *cp = '/'; + return (ERR); + } else + os_setowner (path, uid, gid); + } + *cp = '/'; + } + + return (OK); +} + + +/* COPYFILE -- Copy bytes from the input (tar) file to the output file. + * Each file consists of a integral number of TBLOCK size blocks on the + * input file. + */ +static void +copyfile ( + int in, /* input file */ + int out, /* output file */ + struct fheader *fh, /* file header structure */ + int ftype /* text or binary file */ +) +{ + long nbytes = fh->size; + int nblocks = 0, maxpad; + char *bp; + + + /* Link files are zero length on the tape. */ + if (fh->linkflag) + return; + + if (ftype == BINARY_FILE || !stripblanks) + maxpad = 0; + else + maxpad = SZ_PADBUF; + + /* Copy all but the last MAXPAD characters if the file is a text file + * and stripping is enabled. + */ + while (nbytes > maxpad && (bp = getblock (in)) != NULL) + if (os_write (out, bp, nbytesname); + if (nerrs++ > MAXERR) { + fprintf (stderr, "Too many errors\n"); + exit (OSOK+1); + } + } else { + nbytes -= TBLOCK; + nblocks++; + } + + /* Strip whitespace at end of file added by WTAR when the archive was + * created. + */ + if (nbytes > 0) + strip_blanks (in, out, nbytes); + + if (debug) + fprintf (stderr, "%d blocks written\n", nblocks); +} + + +/* STRIP_BLANKS -- Read the remaining file data into the pad buffer. + * Write out the remaining data, minus any extra blanks or empty blank lines + * at the end of the file. Some versions of WTAR (e.g., VMS) do not know + * the actual size of a text file and have to pad with blanks at the end to + * make the file the size noted in the file header. + */ +static void +strip_blanks (int in, int out, long nbytes) +{ + register char *ip, *op; + char padbuf[SZ_PADBUF+10]; + char *lastnl; + int n; + + /* Fill buffer. + */ + op = padbuf; + while (nbytes > 0 && (ip = getblock (in)) != NULL) { + n = nbytes < TBLOCK ? (int)nbytes : TBLOCK; + os_amovb (ip, op, n + sizeof(XCHAR)-1); + nbytes -= n; + op += n; + } + + /* Backspace from the end of the buffer until the last nonblank line + * is found. + */ + lastnl = op - 1; + for (ip=lastnl; ip > padbuf; --ip) + if (*ip == '\n') + lastnl = ip; + else if (*ip != ' ') + break; + + /* Write out everything up to and including the newline at the end of + * the last line containing anything but blanks. + */ + os_write (out, padbuf, lastnl - padbuf + 1); +} + + +/* SKIPFILE -- Skip the indicated number of bytes on the input (tar) file. + */ +static void +skipfile ( + int in, /* input file */ + struct fheader *fh /* file header */ +) +{ + register long nbytes = fh->size; + + /* Link files are zero length on the tape. */ + if (fh->linkflag) + return; + + while (nbytes > 0 && getblock (in) != NULL) + nbytes -= TBLOCK; +} + + +/* GETBLOCK -- Return a pointer to the next file block of size TBLOCK bytes + * in the input file. + */ +static char * +getblock (int in) +{ + char *bp; + int nbytes; + + for (;;) { + if (eof) + return (NULL); + else if (--nblocks >= 0) { + bp = nextblock; + nextblock += TBLOCK; + return (bp); + } + + if ((nbytes = tape_read (in, tapeblock, SZ_TAPEBUFFER)) < TBLOCK) + eof++; + else { + nblocks = (nbytes + TBLOCK-1) / TBLOCK; + nextblock = tapeblock; + } + } +} diff --git a/unix/boot/rtar/rtar.hlp b/unix/boot/rtar/rtar.hlp new file mode 100644 index 00000000..843add6f --- /dev/null +++ b/unix/boot/rtar/rtar.hlp @@ -0,0 +1,165 @@ +.help rtar Oct92 softools +.IH +NAME +rtar -- read TAR format archive file +.IH +USAGE +rtar [ flags ] [ archive ] [ after ] [ files ] +.IH +PARAMETERS +.ls 4 -a +Advance to the archive file named by the \fIafter\fR argument before +performing the main operation. The extract or list operation will begin with +the file \fIafter\fR and continue to the end of the archive. +.le +.ls 4 -b +Output only binary byte stream files. By default, \fIrtar\fR outputs text +files in the host system textfile format. The conversion from the byte stream +\fItar\fR format to host textfile format may involve modification of the +file, e.g., conversion from ASCII to EBCDIC. A binary extraction copies +the file to disk without modification. +.le +.ls 4 -d +Print detailed information about what \fIrtar\fR is doing. +.le +.ls 4 -e +Extract the entire contents of the tape \fIexcluding\fR the files or directories +listed in \fIfiles\fR. +.le +.ls 4 -f filename +\fIRtar\fR uses the first filename argument as the host filename of the +archive instead of reading from \fIstdin\fR. Magtape devices should be +specified using the host device name, e.g., "/dev/nrmt8" or "MSA0". +Since \fIrtar\fR is a host level program and does not read the IRAF tapecap +file, IRAF device names such as "mta" cannot be used. +.le +.ls 4 -l +Do not try to resolve file links by a disk to disk file copy. By default, +if file A appears in the archive as a link to file B, +\fIrtar\fR trys to resolve the link by performing a disk to disk copy of +file B to A. This is valid providing file B was present in the archive and +has already been extracted. If the \fBl\fR flag is present linked files +will not be extracted. +.le +.ls 4 -m +Do not restore the file modify time. +.le +.ls 4 -n +Do not strip trailing blank lines from text files read from the tape. +The default is to strip any blank lines at the ends of files. +This is necessary when the file was written by \fIwtar\fR on a system +like VMS, where the size of the file is not known before it has been +read. The \fIwtar\fR utility must guess at the final size and pad the +file at the end with spaces to ensure that the size of the file actually +written agrees with the file header. +.le +.ls 4 -o +Omit binary files when performing the extraction. A binary file is any +file containing ASCII values other than 040 through 0176 (the printable +ASCII characters), tab, or newline in the first 512 byte block of the file. +.le +.ls 4 -p pathprefix +When creating directories and files from the pathnames recorded in the archive, +omit the given path prefix if it matches the pathname given in the archive. +This feature is used to relocate directories, or to read tar archives +containing absolute pathnames. For example, given "-p /usr/", the archive +pathname "/usr/me/file" would be written to the file "me/file". +.le +.ls 4 -r +The extracted file replaces any existing file of the same name, i.e., +\fIrtar\fR performs a delete before creating the extracted file. +.le +.ls 4 -t +The names of the specified files are listed each time they occur on +the tape. If no \fIfiles\fR argument is given, all of the names on the tape +are listed. +.le +.ls 4 -u +Do not attempt to restore the owner and group identification of each file. +.le +.ls 4 -v +Print more information about the tape entries than just their names. +The verbose file list format gives the file permissions, the link flag +(zero if there were no links to the file), the owner and group identification +numbers of the file on the system that wrote the archive, the file size in +bytes, the date of last modification of the file, and the file name. +.le +.ls 4 -x +The named files are extracted from the tape. If the named file +matches a directory whose contents had been written onto the tape, this +directory is (recursively) extracted. The owner, modification time, and mode +are restored (if possible). If no file argument is given, the entire content +of the tape is extracted. Note that if multiple entries specifying the same +file are on the tape, the last one overwrites all earlier. +.le +.IH +DESCRIPTION +\fIRtar\fR reads multiple files from a UNIX \fItar\fR format file, +restoring the files to disk on the local host machine. +Output filenames are mapped according to the IRAF filenaming conventions +of the local host operating system. + +\fIRtar\fR's actions are controlled by the \fIflags\fR argument. +\fIFlags\fR consists of a minus sign followed by a string of characters +containing any combination of the function flags described below. +Other arguments to \fIrtar\fR are the name of the archive file to be read, +the name of the file on the archive at which reading is to begin, +and the names of the files or directories to be read or to be excluded +from the read. In all cases, appearance of a directory name refers to +the files and (recursively) subdirectories of that directory. + +All \fIrtar\fR filename arguments are IRAF virtual filenames (or host +filenames), except the prefix strings, which pertain to the tape format and +hence are UNIX pathnames. Magtape devices must be specified using a host +physical or logical device name (i.e., IRAF device names like "mta" will not +work). + +If the input archive file is a tape the blocksize must be a multiple +of 512 bytes, with a maximum blocksize of 10240 bytes. Each archived file +occupies an integral number of 512 byte blocks in the archive (this is +required by the \fItar\fR format). + +Filenames appearing in the file list are interpreted as prefix strings, +i.e., a match occurs if the given string is a prefix of an actual filename +in the archive. If the last character in the \fIfiles\fR filename is +a \fB$\fR then an exact match is required (excluding the $ meta-character). +.IH +DIAGNOSTICS +A file read error occurring while reading the archive file is fatal unless +caught and corrected by the host system. +File header checksum errors result in skipping of the archive file +currently being read, with execution continuing with the next archive +file if possible. +File write errors on the output file are reported but do not cause +termination of \fIrtar\fR. The output file being written will be corrupted. +.ih +EXAMPLES +Since \fIrtar\fR is a bootstrap utility implemented as a foreign task in +the CL, it may be called either from within the CL (as in the examples), +or at the host system level. The command syntax is identical on both cases. + +1. List the contents of the disk archive file "foo.tar". + + cl> rtar -tvf foo.tar + +2. Unpack the tape archive on unix device /dev/nrmt8 in the current +directory. + + cl> rtar -xf /dev/nrmt8 + +3. Unpack the tape archive on the VMS device MSA0: in the current +directory. + + cl> rtar -xf msa0 + +When working within the CL, commands such as \fIrewind\fR may be used +with \fIrtar\fR, but switching between IRAF and host device names may be +confusing. +.IH +BUGS +The current limit on file name length is 100 characters (this restriction +is imposed by the standard UNIX \fItar\fR format). +File links are not recreated. +.ih +SEE ALSO +wtar, rmbin diff --git a/unix/boot/rtar/rtar.ms b/unix/boot/rtar/rtar.ms new file mode 100644 index 00000000..43746400 --- /dev/null +++ b/unix/boot/rtar/rtar.ms @@ -0,0 +1,125 @@ +.TH RTAR 1 "14 November 1984" +.SH NAME +rtar \- read tape archive format file +.SH SYNOPSIS +.B rtar +[ flags ] [ archive ] [ after ] [ files ] +.SH DESCRIPTION +.PP +.I Rtar +reads multiple files from a UNIX \fItar\fR format file, restoring the files +to disk on the local host machine. Output filenames are mapped according to +the IRAF filenaming conventions of the local host operating system. +.IR Rtar 's +actions are controlled by the +.I flags +argument. +.I Flags +consists of an \fB-\fR followed by +a string of characters containing any combination of the function flags +described below. +Other arguments to +.I rtar +are the name of the archive file to be read, +the name of the file on the archive at which reading is to begin, +and the names of the files or directories to be read or to be excluded +from the read. +In all cases, appearance of a directory name refers to +the files and (recursively) subdirectories of that directory. +All +.I rtar +filename arguments are UNIX pathnames except +.I archive, +which is a host system filename. +.PP +The default action of \fIrtar\fR is to unpack all files from the \fItar\fR +format standard input. The following flag characters may be used to further +control the function of \fIrtar\fR: +.TP 8 +.B x +The named files are extracted from the tape. If the named file +matches a directory whose contents had been written onto the tape, this +directory is (recursively) extracted. The owner, modification time, and mode +are restored (if possible). If no file argument is given, the entire content +of the tape is extracted. Note that if multiple entries specifying the same +file are on the tape, the last one overwrites all earlier. +.TP 8 +.B r +The extracted file replaces any existing file of the same name, i.e., +.I rtar +performs a delete before creating the extracted file. +.TP 8 +.B e +Extract the entire contents of the tape \fIexcluding\fR the files or directories +listed in \fIfiles\fR. +.TP 8 +.B a +Advance to the archive file named by the \fIafter\fR argument before +performing the main operation. The extract or list operation will begin with +the file \fIafter\fR and continue to the end of the archive. +.TP 8 +.B t +The names of the specified files are listed each time they occur on +the tape. If no \fIfiles\fR argument is given, all of the names on the tape +are listed. +.TP 8 +.B v +Print more information about the tape entries than just their names. +The verbose file list format gives the file permissions, the link flag +(zero if there were no links to the file), the owner and group identification +numbers of the file on the system that wrote the archive, the file size in +bytes, the date of last modification of the file, and the file name. +.TP 8 +.B d +Print detailed information about what \fIrtar\fR is doing. +.TP 8 +.B f +.I Rtar +uses the first filename argument as the host filename of the archive +instead of reading from \fIstdin\fR. +.TP 8 +.B l +Do not try to resolve file links by a disk to disk file copy. By default, +if file A appears in the archive as a link to file B, +\fIrtar\fR trys to resolve the link by performing a disk to disk copy of +file B to A. This is valid providing file B was present in the archive and +has already been extracted. If the \fBl\fR flag is present linked files +will not be extracted. +.TP 8 +.B o +Omit binary files when performing the extraction. A binary file is any +file containing ASCII values other than 040 through 0176 (the printable +ASCII characters), tab, or newline in the first 512 byte block of the file. +.TP 8 +.B b +Output only binary byte stream files. By default, \fIrtar\fR outputs text +files in the host system textfile format. The conversion from the byte stream +\fItar\fR format to host textfile format may involve modification of the +file, e.g., conversion from ASCII to EBCDIC. A binary extraction copies +the file to disk without modification. +.PP +If the input archive file is a tape the blocksize must be a multiple +of 512 bytes, with a maximum blocksize of 10240 bytes. Each archived file +occupies an integral number of 512 byte blocks in the archive. +.PP +Filenames appearing in the file list are interpreted as prefix strings, +i.e., a match occurs if the given string is a prefix of an actual filename +in the archive. If the last character in the \fIfiles\fR filename is +a \fB$\fR then an exact match is required (excluding the $ metacharacter). +.SH DIAGNOSTICS +.br +A file read error occurring while reading the archive file is fatal unless +caught and corrected by the host system. +.br +File header checksum errors result in skipping of the archive file +currently being read, with execution continuing with the next archive +file if possible. +.br +File write errors on the output file are reported but do not cause +termination of \fIrtar\fR. The output file being written will be corrupted. +.SH BUGS +.br +The current limit on file name length is 100 characters (this restriction +is imposed by the standard UNIX \fItar\fR format). +.br +File links are not recreated. diff --git a/unix/boot/spp/README b/unix/boot/spp/README new file mode 100644 index 00000000..d4d64dfc --- /dev/null +++ b/unix/boot/spp/README @@ -0,0 +1,43 @@ +These directories contain the source code for the UNIX version of the compiler +for the IRAF subset preprocessor language (SPP). In its current implementation +the compiler consists of the following modules: + + xc.e main program (like cc) + xpp.e first pass (written in Lex and C) + rpp.e second pass (written in ratfor) + +files: + xpp subdirectory containing XPP + rpp subdirectory containing RPP + xc.c the XC compiler/linker + +runtime files: + lib$xc.e installed UNIX xc compiler + lib$xpp.e installed first pass + lib$rpp.e installed second pass + + +This implementation of the SPP preprocessor (kludgy though it may be) should be +portable to any host computer supporting C and Fortran compilers. A Ratfor +compiler and runtime library is no longer required. XPP does contain some +machine dependencies in its internal tables describing the host Fortran +compiler, and these should be reviewed. RPP has a C language interface to the +host machine which contains knowledge of how the host system permits C and +Fortran to be mixed in the same program. Hopefully all machine dependence +has been concentrated in the two files xpp/xppcode.c and rpp/ratlibc/ratdef.h. + +This version of the preprocessor no longer knows about pathnames other than +those defined in the C include file "iraf.h", which is also used by the +CL and all other C files in IRAF. The "iraf.h" file is the only file used +by IRAF which does not reside in the IRAF directories (although a copy appears +in lib$libc and we make a symbolic link to it on our 4.2BSD UNIX system). +XC has to know the root directory of IRAF to reference important files in +iraf$lib. The root directory may be set on the command line with the "-r" +(root) argument; if "-r ospathname" is omitted the default is the value of +IRAFDIR given in "iraf.h" + +On our UNIX development system we have the executables (xc.e, xpp.e, etc.) +linked into both the source directory and the IRAF library lib$. Hence when +any of these executables are relinked, the new versions do not have to +be installed. If your system does not support links you will need to copy +the executable to lib$ after compilation. diff --git a/unix/boot/spp/mkpkg.sh b/unix/boot/spp/mkpkg.sh new file mode 100644 index 00000000..71417ba7 --- /dev/null +++ b/unix/boot/spp/mkpkg.sh @@ -0,0 +1,12 @@ +# Make the Subset Preprocessor language (SPP) compiler. + +echo "----------------------- XC ----------------------------" +$CC -c $HSI_CF xc.c +$CC $HSI_LF xc.o $HSI_LIBS -o xc.e +mv -f xc.e ../../hlib +rm -f xc.o + +echo "----------------------- XPP ----------------------------" +(cd xpp; sh -x mkpkg.sh) +echo "----------------------- RPP ----------------------------" +(cd rpp; sh -x mkpkg.sh) diff --git a/unix/boot/spp/mkxc.sh b/unix/boot/spp/mkxc.sh new file mode 100644 index 00000000..853e89bc --- /dev/null +++ b/unix/boot/spp/mkxc.sh @@ -0,0 +1,6 @@ +# Make the XC driver program. + +$CC -c $HSI_CF xc.c +$CC $HSI_LF xc.o $HSI_LIBS -o xc.e +mv -f xc.e ../../hlib +rm xc.o diff --git a/unix/boot/spp/mkxc_dbg.sh b/unix/boot/spp/mkxc_dbg.sh new file mode 100644 index 00000000..c9cea5af --- /dev/null +++ b/unix/boot/spp/mkxc_dbg.sh @@ -0,0 +1,6 @@ +# Make the XC driver program. + +$CC -c -g $HSI_CF xc.c +$CC $HSI_LF -g xc.o $HSI_LIBS -o xc.e +mv -f xc.e ../../bin.redhat +rm xc.o diff --git a/unix/boot/spp/rpp/README b/unix/boot/spp/rpp/README new file mode 100644 index 00000000..a9df5096 --- /dev/null +++ b/unix/boot/spp/rpp/README @@ -0,0 +1,40 @@ +RPP -- Second pass of the SPP preprocessor. + + While RPP is derived from ratfor, it is not a ratfor preprocessor. +It accepts as input the output of the first pass, XPP, and produces Fortran as +output. XPP and RPP together with the UNIX driver program XC make up the +preprocessor for the IRAF SPP language. + + +subdirectories: + + ratlibc Interface to the host system, written in C + ratlibf Fortran version of the ratfor library (used by RPP) + ratlibr Ratfor version of the ratfor library + rppfor Fortran source for RPP + rpprat Ratfor source for RPP + + +RPP consists of the source for the program itself, the portable library +functions, and the interface to the host system. Everything required to +compile and link RPP on a host system providing a C and Fortran compiler +is included in these directories. RPP is currently implemented as a stand +alone (bootstrap) program, i.e. it can be compiled before IRAF itself is +running. While the ratfor sources for the preprocessor and the library +are included in the distribution, a ratfor preprocessor is not necessary +to compile RPP. All ratfor sources are distributed already preprocessed +into Fortran. + +To compile RPP on a UNIX host type "make". If there are any problems they +will most likely be in the interface routines, which are not (cannot be) +completely portable. In particular the definitions in ratlibc/ratdef.h +should be examined to see is they are appropriate for your machine. The +single biggest difference between different host systems providing C and +simple UNIX like STDIO is in the naming conventions of external identifiers. +All C externals called from Fortran are defined in ratdef.h to make it +easier to change the names. RPP is a C program (it has a C main) even +though most of the code is written in Fortran. + +Source for a Fortran (ratfor) version of the interface routines is provided +in ratlibr/old. Since XPP is currently written in C we have not bothered +to try to use these routines. diff --git a/unix/boot/spp/rpp/mkpkg.sh b/unix/boot/spp/rpp/mkpkg.sh new file mode 100644 index 00000000..33bc0b88 --- /dev/null +++ b/unix/boot/spp/rpp/mkpkg.sh @@ -0,0 +1,13 @@ +# Make the second pass (RPP) of the SPP language compiler. + +echo "----------------------- RPPFOR -------------------------" +(cd rppfor; sh -x mkpkg.sh) +echo "----------------------- RATLIBF ------------------------" +(cd ratlibf; sh -x mkpkg.sh) +echo "----------------------- RATLIBC ------------------------" +(cd ratlibc; sh -x mkpkg.sh) + +$CC -c $HSI_CF rpp.c +$CC $HSI_LF rpp.o librpp.a libf.a libc.a $HSI_F77LIBS -o rpp.e +mv -f rpp.e ../../../hlib +rm *.[ao] diff --git a/unix/boot/spp/rpp/ratlibc/README b/unix/boot/spp/rpp/ratlibc/README new file mode 100644 index 00000000..427e3969 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/README @@ -0,0 +1 @@ +RPP/RATLIBC -- Host system interface routines for the RPP program. diff --git a/unix/boot/spp/rpp/ratlibc/cant.c b/unix/boot/spp/rpp/ratlibc/cant.c new file mode 100644 index 00000000..2d82c3e9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/cant.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +extern int ENDST (void); + + +void CANT(rname) +register RCHAR *rname; +{ + while (*rname != REOS) + putc(*rname++, stderr); + fprintf(stderr, ": cant open\n"); + ENDST(); +} diff --git a/unix/boot/spp/rpp/ratlibc/close.c b/unix/boot/spp/rpp/ratlibc/close.c new file mode 100644 index 00000000..a54d4a80 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/close.c @@ -0,0 +1,10 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +void CLOSE(fd) +FINT *fd; +{ + fclose(_fdtofile[*fd]); +} diff --git a/unix/boot/spp/rpp/ratlibc/endst.c b/unix/boot/spp/rpp/ratlibc/endst.c new file mode 100644 index 00000000..b8f83f3d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/endst.c @@ -0,0 +1,10 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "ratdef.h" + +void ENDST() +{ + exit(0); +} diff --git a/unix/boot/spp/rpp/ratlibc/getarg.c b/unix/boot/spp/rpp/ratlibc/getarg.c new file mode 100644 index 00000000..2952d7d7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/getarg.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +FINT +GETARG(n, s, maxsiz) +FINT *n; +register RCHAR *s; +FINT *maxsiz; +{ + extern int xargc; + extern char **xargv; + register char *t; + register int i; + + if(*n>=0 && *n=0) { + *cs++ = c; + if (c == '\n') { + *cs++ = REOS; + return (count); /* count includes newline, but does + not include the EOS */ + } + } + + if (c<0 && cs==line) + return(REOF); + + *cs++ = REOS; + return(count); +} diff --git a/unix/boot/spp/rpp/ratlibc/initst.c b/unix/boot/spp/rpp/ratlibc/initst.c new file mode 100644 index 00000000..6cf4a9a4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/initst.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +FILE *_fdtofile[10]; + +/* + * Ratfor initialization routine. To be called as the first + * executable statement of every program using the tools + * subroutines. + */ +void INITST() +{ + _fdtofile[0] = stdin; + _fdtofile[1] = stdout; + _fdtofile[2] = stderr; +} diff --git a/unix/boot/spp/rpp/ratlibc/mkpkg.sh b/unix/boot/spp/rpp/ratlibc/mkpkg.sh new file mode 100644 index 00000000..8159d992 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/mkpkg.sh @@ -0,0 +1,9 @@ +# Host system interface for the RPP program. + +$CC -c -g $HSI_CF cant.c close.c endst.c getarg.c getlin.c initst.c open.c\ + putch.c putlin.c r4tocstr.c remark.c + +ar rv libc.a *.o +$RANLIB libc.a +mv -f libc.a .. +rm *.o diff --git a/unix/boot/spp/rpp/ratlibc/open.c b/unix/boot/spp/rpp/ratlibc/open.c new file mode 100644 index 00000000..fa4558d9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/open.c @@ -0,0 +1,30 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +extern void r4tocstr (register RCHAR *rstr, register char *cstr); + +FINT +OPEN(rname, mode) +RCHAR *rname; +register FINT *mode; +{ + register FILE *fp; + char cname[FILENAMESIZE]; + + r4tocstr(rname, cname); + + if (*mode == APPEND) + fp = fopen(cname, "a"); + else if (*mode == READWRITE || *mode == WRITE) + fp = fopen(cname, "w"); + else + fp = fopen(cname, "r"); + + if (fp == NULL) + return(RERR); /* unable to open file */ + + _fdtofile[fileno(fp)] = fp; + return(fileno(fp)); +} diff --git a/unix/boot/spp/rpp/ratlibc/putch.c b/unix/boot/spp/rpp/ratlibc/putch.c new file mode 100644 index 00000000..322628cc --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/putch.c @@ -0,0 +1,15 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +int PUTCH(c, fd) +register RCHAR *c; +register FINT *fd; +{ + register FILE *file; + + file = _fdtofile[*fd]; + putc(*c, file); + return 0; +} diff --git a/unix/boot/spp/rpp/ratlibc/putlin.c b/unix/boot/spp/rpp/ratlibc/putlin.c new file mode 100644 index 00000000..0da6c4d9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/putlin.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +void PUTLIN(line, fd) +RCHAR *line; +FINT *fd; +{ + register FILE *fp; + register int c; + + fp = _fdtofile[*fd]; + while((c = *line++) != REOS) + putc(c, fp); +} diff --git a/unix/boot/spp/rpp/ratlibc/r4tocstr.c b/unix/boot/spp/rpp/ratlibc/r4tocstr.c new file mode 100644 index 00000000..36924353 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/r4tocstr.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +/* Convert a Ratfor string (one character per integer, terminated + * by an EOS) to a C string (one character per 8-bit byte, terminated + * by a byte of zero). + */ +void r4tocstr(rstr, cstr) +register RCHAR *rstr; +register char *cstr; +{ + while (*rstr != REOS) { + if (*rstr > 0177) { + *cstr++ = *((char *)rstr); + rstr++; + } else + *cstr++ = *rstr++; + } + *cstr = '\0'; +} diff --git a/unix/boot/spp/rpp/ratlibc/ratdef.h b/unix/boot/spp/rpp/ratlibc/ratdef.h new file mode 100644 index 00000000..2f5b7e1c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/ratdef.h @@ -0,0 +1,73 @@ +#include + +extern FILE *_fdtofile[]; /* map file descriptor (small integer) to + FILE pointer. Ratfor uses file descriptors, + we must use FILE pointers for stdio lib */ + +/* + * The following definitions must be the same as those used by the + * Ratfor system. + */ +#define REOF (-1) /* Ratfor EOF */ +#define REOS (-2) /* Ratfor end-of-string */ +#define RERR (-3) /* Ratfor error return */ +#define NO 0 +#define YES 1 +#define NOERR 0 +#define OK (-2) +#define MAXLINE 128 +#define FILENAMESIZE 40 /* max num chars per filename */ + +#define READ 1 /* modes for file open */ +#define WRITE 2 +#define READWRITE 3 +#define APPEND 4 + +/* + * The following typedefs refer to the data types passed by the + * Fortran compiler (Ratfor) calling us. + */ +#ifdef ILP32 +typedef int RCHAR; /* Ratfor character string */ +typedef int FINT; /* Fortran plain vanilla integer */ + /* integer*2 with new f77 on Unix */ +#else +typedef long int RCHAR; /* Ratfor character string */ +typedef long int FINT; /* Fortran plain vanilla integer */ + /* integer*2 with new f77 on Unix */ +#endif + + +/* All names of C functions called from ratfor are defined here to make them + * easy to change to reflect the characteristics of the host machine. Some + * versions of UNIX append an underscore to Fortran external names, some + * prepend an underscore, and some do both. VMS renders C and Fortran external + * names the same, making it easier to mix the two languages but causing + * name conflicts. + */ +#define AMOVE amove_ +#define CANT cant_ +#define CLOSE rfclos_ +#define CREATE create_ +#define ENDST endst_ +#define EXIT rexit_ +#define FLUSH rfflus_ +#define GETARG getarg_ +#define GETCH getch_ +#define GETLIN getlin_ +#define GETNOW getnow_ +#define INITST initst_ +#define ISATTY isatty_ +#define MKUNIQ mkuniq_ +#define NOTE rfnote_ +#define OPEN rfopen_ +#define PUTCH putch_ +#define PUTHOL puthol_ +#define PUTLIN putlin_ +#define RATFOR ratfor_ +#define READF readf_ +#define REMARK remark_ +#define REMOVE rfrmov_ +#define RWIND rwind_ +#define SEEK rfseek_ +#define WRITEF writef_ diff --git a/unix/boot/spp/rpp/ratlibc/remark.c b/unix/boot/spp/rpp/ratlibc/remark.c new file mode 100644 index 00000000..23e30213 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/remark.c @@ -0,0 +1,43 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +void REMARK (strarg) +int *strarg; /* hollerith string is an integer array */ +{ + register char *strin = (char *)strarg; + register char c; + + while (((c = *strin++) != '.') && (c != '\0')) + if (c == '@') { + switch (*strin) { + case '.': + putc ('.', stderr); + strin++; + break; + + case 't': + putc ('\t', stderr); + strin++; + break; + + case 'b': + putc ('\b', stderr); + strin++; + break; + + case 'n': + putc ('\n', stderr); + strin++; + break; + + default: + putc ('@', stderr); + break; + } + } else + putc (c, stderr); + + putc ('\n', stderr); +} diff --git a/unix/boot/spp/rpp/ratlibf/README b/unix/boot/spp/rpp/ratlibf/README new file mode 100644 index 00000000..52be57b2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/README @@ -0,0 +1 @@ +RPP/RATLIBF -- Fortran source for the library utilities used by the RPP program. diff --git a/unix/boot/spp/rpp/ratlibf/addset.f b/unix/boot/spp/rpp/ratlibf/addset.f new file mode 100644 index 00000000..629b4b91 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/addset.f @@ -0,0 +1,13 @@ + integer function addset (c, str, j, maxsiz) + integer j, maxsiz + integer c, str (maxsiz) + if (.not.(j .gt. maxsiz))goto 23000 + addset = 0 + goto 23001 +23000 continue + str(j) = c + j = j + 1 + addset = 1 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/addstr.f b/unix/boot/spp/rpp/ratlibf/addstr.f new file mode 100644 index 00000000..eedc7cf3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/addstr.f @@ -0,0 +1,16 @@ + integer function addstr (s, str, j, maxsiz) + integer j, maxsiz + integer s (100), str (maxsiz) + integer i, addset + i = 1 +23000 if (.not.(s (i) .ne. -2))goto 23002 + if (.not.(addset (s (i), str, j, maxsiz) .eq. 0))goto 23003 + addstr = 0 + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + addstr = 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/amatch.f b/unix/boot/spp/rpp/ratlibf/amatch.f new file mode 100644 index 00000000..fe23fb53 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/amatch.f @@ -0,0 +1,68 @@ + integer function amatch (lin, from, pat, tagbeg, tagend) + integer lin (128), pat (128) + integer from, tagbeg (10), tagend (10) + integer i, j, offset, stack + integer omatch, patsiz + i = 1 +23000 if (.not.(i .le. 10))goto 23002 + tagbeg (i) = 0 + tagend (i) = 0 +23001 i = i + 1 + goto 23000 +23002 continue + tagbeg (1) = from + stack = 0 + offset = from + j = 1 +23003 if (.not.(pat (j) .ne. -2))goto 23005 + if (.not.(pat (j) .eq. 42))goto 23006 + stack = j + j = j + 4 + i = offset +23008 if (.not.(lin (i) .ne. -2))goto 23010 + if (.not.(omatch (lin, i, pat, j) .eq. 0))goto 23011 + goto 23010 +23011 continue +23009 goto 23008 +23010 continue + pat (stack + 1) = i - offset + pat (stack + 3) = offset + offset = i + goto 23007 +23006 continue + if (.not.(pat (j) .eq. 123))goto 23013 + i = pat (j + 1) + tagbeg (i + 1) = offset + goto 23014 +23013 continue + if (.not.(pat (j) .eq. 125))goto 23015 + i = pat (j + 1) + tagend (i + 1) = offset + goto 23016 +23015 continue + if (.not.(omatch (lin, offset, pat, j) .eq. 0))goto 23017 +23019 if (.not.(stack .gt. 0))goto 23021 + if (.not.(pat (stack + 1) .gt. 0))goto 23022 + goto 23021 +23022 continue +23020 stack = pat (stack + 2) + goto 23019 +23021 continue + if (.not.(stack .le. 0))goto 23024 + amatch = 0 + return +23024 continue + pat (stack + 1) = pat (stack + 1) - 1 + j = stack + 4 + offset = pat (stack + 3) + pat (stack + 1) +23017 continue +23016 continue +23014 continue +23007 continue +23004 j = j + patsiz (pat, j) + goto 23003 +23005 continue + amatch = offset + tagend (1) = offset + return + end diff --git a/unix/boot/spp/rpp/ratlibf/catsub.f b/unix/boot/spp/rpp/ratlibf/catsub.f new file mode 100644 index 00000000..a7dbc318 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/catsub.f @@ -0,0 +1,28 @@ + subroutine catsub (lin, from, to, sub, new, k, maxnew) + integer lin(128) + integer from(10), to(10) + integer maxnew + integer sub(maxnew), new(128) + integer k + integer i, j, junk, ri + integer addset + i = 1 +23000 if (.not.(sub (i) .ne. -2))goto 23002 + if (.not.(sub (i) .eq. -3))goto 23003 + i = i + 1 + ri = sub (i) + 1 + j = from (ri) +23005 if (.not.(j .lt. to (ri)))goto 23007 + junk = addset (lin (j), new, k, maxnew) +23006 j = j + 1 + goto 23005 +23007 continue + goto 23004 +23003 continue + junk = addset (sub (i), new, k, maxnew) +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/clower.f b/unix/boot/spp/rpp/ratlibf/clower.f new file mode 100644 index 00000000..e001f4fd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/clower.f @@ -0,0 +1,12 @@ + integer function clower(c) + integer c + integer k + if (.not.(c .ge. 65 .and. c .le. 90))goto 23000 + k = 97 - 65 + clower = c + k + goto 23001 +23000 continue + clower = c +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/concat.f b/unix/boot/spp/rpp/ratlibf/concat.f new file mode 100644 index 00000000..9385f2d1 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/concat.f @@ -0,0 +1,8 @@ + subroutine concat (buf1, buf2, outstr) + integer buf1(100), buf2(100), outstr(100) + integer i + i = 1 + call stcopy (buf1, 1, outstr, i) + call scopy (buf2, 1, outstr, i) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/ctoc.f b/unix/boot/spp/rpp/ratlibf/ctoc.f new file mode 100644 index 00000000..a5d3d4b3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/ctoc.f @@ -0,0 +1,14 @@ + integer function ctoc (from, to, len) + integer len + integer from (100), to (len) + integer i + i = 1 +23000 if (.not.(i .lt. len .and. from (i) .ne. -2))goto 23002 + to (i) = from (i) +23001 i = i + 1 + goto 23000 +23002 continue + to (i) = -2 + ctoc=(i - 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/ctoi.f b/unix/boot/spp/rpp/ratlibf/ctoi.f new file mode 100644 index 00000000..8aa92061 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/ctoi.f @@ -0,0 +1,26 @@ + integer function ctoi(in, i) + integer in (100) + integer i + integer d + external index + integer index + integer digits(11) + data digits (1) /48/, digits (2) /49/, digits (3) /50/, digits (4) + * /51/, digits (5) /52/, digits (6) /53/, digits (7) /54/, digits ( + *8) /55/, digits (9) /56/, digits (10) /57/, digits (11) /-2/ +23000 if (.not.(in (i) .eq. 32 .or. in (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + ctoi = 0 +23002 if (.not.(in (i) .ne. -2))goto 23004 + d = index (digits, in (i)) + if (.not.(d .eq. 0))goto 23005 + goto 23004 +23005 continue + ctoi = 10 * ctoi + d - 1 +23003 i = i + 1 + goto 23002 +23004 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/ctomn.f b/unix/boot/spp/rpp/ratlibf/ctomn.f new file mode 100644 index 00000000..a2e0294e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/ctomn.f @@ -0,0 +1,30 @@ + integer function ctomn (c, rep) + integer c, rep (4) + integer i + integer length + integer mntext (136) + data mntext / 78, 85, 76, -2, 83, 79, 72, -2, 83, 84, 88, -2, 69, + * 84, 88, -2, 69, 79, 84, -2, 69, 78, 81, -2, 65, 67, 75, -2, 66, 6 + *9, 76, -2, 66, 83, -2, -2, 72, 84, -2, -2, 76, 70, -2, -2, 86, 84, + * -2, -2, 70, 70, -2, -2, 67, 82, -2, -2, 83, 79, -2, -2, 83, 73, - + *2, -2, 68, 76, 69, -2, 68, 67, 49, -2, 68, 67, 50, -2, 68, 67, 51, + * -2, 68, 67, 52, -2, 78, 65, 75, -2, 83, 89, 78, -2, 69, 84, 66, - + *2, 67, 65, 78, -2, 69, 77, -2, -2, 83, 85, 66, -2, 69, 83, 67, -2, + * 70, 83, -2, -2, 71, 83, -2, -2, 82, 83, -2, -2, 85, 83, -2, -2, 8 + *3, 80, -2, -2, 68, 69, 76, -2/ + i = mod (max0(c,0), 128) + if (.not.(0 .le. i .and. i .le. 32))goto 23000 + call scopy (mntext, 4 * i + 1, rep, 1) + goto 23001 +23000 continue + if (.not.(i .eq. 127))goto 23002 + call scopy (mntext, 133, rep, 1) + goto 23003 +23002 continue + rep (1) = c + rep (2) = -2 +23003 continue +23001 continue + ctomn=(length (rep)) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/cupper.f b/unix/boot/spp/rpp/ratlibf/cupper.f new file mode 100644 index 00000000..549ee9df --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/cupper.f @@ -0,0 +1,10 @@ + integer function cupper (c) + integer c + if (.not.(c .ge. 97 .and. c .le. 122))goto 23000 + cupper = c + (65 - 97) + goto 23001 +23000 continue + cupper = c +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/delete.f b/unix/boot/spp/rpp/ratlibf/delete.f new file mode 100644 index 00000000..92d5fb37 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/delete.f @@ -0,0 +1,13 @@ + subroutine delete (symbol, st) + integer symbol (100) + integer st + integer mem( 1) + common/cdsmem/mem + integer stlu + integer node, pred + if (.not.(stlu (symbol, node, pred, st) .eq. 1))goto 23000 + mem (pred + 0) = mem (node + 0) + call dsfree (node) +23000 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/docant.f b/unix/boot/spp/rpp/ratlibf/docant.f new file mode 100644 index 00000000..0bcdd7ca --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/docant.f @@ -0,0 +1,13 @@ + subroutine docant(name) + integer name(100), prog(30) + integer length + integer getarg + length = getarg(0, prog, 30) + if (.not.(length .ne. -1))goto 23000 + call putlin(prog, 2) + call putch(58, 2) + call putch(32, 2) +23000 continue + call cant(name) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dodash.f b/unix/boot/spp/rpp/ratlibf/dodash.f new file mode 100644 index 00000000..63dd7e48 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dodash.f @@ -0,0 +1,18 @@ + subroutine dodash (valid, array, i, set, j, maxset) + integer i, j, maxset + integer valid (100), array (100), set (maxset) + integer esc + integer junk, k, limit + external index + integer addset, index + i = i + 1 + j = j - 1 + limit = index (valid, esc (array, i)) + k = index (valid, set (j)) +23000 if (.not.(k .le. limit))goto 23002 + junk = addset (valid (k), set, j, maxset) +23001 k = k + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsdbiu.f b/unix/boot/spp/rpp/ratlibf/dsdbiu.f new file mode 100644 index 00000000..62efd56e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsdbiu.f @@ -0,0 +1,47 @@ + subroutine dsdbiu (b, form) + integer b + integer form + integer mem( 1) + common/cdsmem/mem + integer l, s, lmax + integer blanks(6) + data blanks(1)/9/,blanks(2)/32/,blanks(3)/32/,blanks(4)/32/,blanks + *(5)/32/,blanks(6)/-2/ + call putint (b, 5, 2) + call putch (32, 2) + call putint (mem (b + 0), 0, 2) + call remark (14H words in use.) + l = 0 + s = b + mem (b + 0) + if (.not.(form .eq. 48))goto 23000 + lmax = 5 + goto 23001 +23000 continue + lmax = 50 +23001 continue + b = b + 2 +23002 if (.not.(b .lt. s))goto 23004 + if (.not.(l .eq. 0))goto 23005 + call putlin (blanks, 2) +23005 continue + if (.not.(form .eq. 48))goto 23007 + call putint (mem (b), 10, 2) + goto 23008 +23007 continue + if (.not.(form .eq. 97))goto 23009 + call putch (mem (b), 2) +23009 continue +23008 continue + l = l + 1 + if (.not.(l .ge. lmax))goto 23011 + l = 0 + call putch (10, 2) +23011 continue +23003 b = b + 1 + goto 23002 +23004 continue + if (.not.(l .ne. 0))goto 23013 + call putch (10, 2) +23013 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsdump.f b/unix/boot/spp/rpp/ratlibf/dsdump.f new file mode 100644 index 00000000..366bd5c4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsdump.f @@ -0,0 +1,28 @@ + subroutine dsdump (form) + integer form + integer mem( 1) + common/cdsmem/mem + integer p, t, q + t = 2 + call remark (27H** DYNAMIC STORAGE DUMP **.) + call putint (1, 5, 2) + call putch (32, 2) + call putint (2 + 1, 0, 2) + call remark (14H words in use.) + p = mem (t + 1) +23000 if (.not.(p .ne. 0))goto 23001 + call putint (p, 5, 2) + call putch (32, 2) + call putint (mem (p + 0), 0, 2) + call remark (17H words available.) + q = p + mem (p + 0) +23002 if (.not.(q .ne. mem (p + 1) .and. q .lt. mem (1)))goto 23003 + call dsdbiu (q, form) + goto 23002 +23003 continue + p = mem (p + 1) + goto 23000 +23001 continue + call remark (15H** END DUMP **.) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsfree.f b/unix/boot/spp/rpp/ratlibf/dsfree.f new file mode 100644 index 00000000..8ab2f2a0 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsfree.f @@ -0,0 +1,44 @@ + subroutine dsfree (block) + integer block + integer mem( 1) + common/cdsmem/mem + integer p0, p, q + integer n, junk + integer con (10) + p0 = block - 2 + n = mem (p0 + 0) + q = 2 +23000 continue + p = mem (q + 1) + if (.not.(p .eq. 0 .or. p .gt. p0))goto 23003 + goto 23002 +23003 continue + q = p +23001 goto 23000 +23002 continue + if (.not.(q + mem (q + 0) .gt. p0))goto 23005 + call remark (45Hin dsfree: attempt to free unallocated block.) + call remark (21Htype 'c' to continue.) + junk = getlin (con, 0) + if (.not.(con (1) .ne. 99 .and. con (1) .ne. 67))goto 23007 + call endst +23007 continue + return +23005 continue + if (.not.(p0 + n .eq. p .and. p .ne. 0))goto 23009 + n = n + mem (p + 0) + mem (p0 + 1) = mem (p + 1) + goto 23010 +23009 continue + mem (p0 + 1) = p +23010 continue + if (.not.(q + mem (q + 0) .eq. p0))goto 23011 + mem (q + 0) = mem (q + 0) + n + mem (q + 1) = mem (p0 + 1) + goto 23012 +23011 continue + mem (q + 1) = p0 + mem (p0 + 0) = n +23012 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsget.f b/unix/boot/spp/rpp/ratlibf/dsget.f new file mode 100644 index 00000000..ef4fbcfe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsget.f @@ -0,0 +1,45 @@ + integer function dsget (w) + integer w + integer mem( 1) + common/cdsmem/mem + integer p, q, l + integer n, k, junk + integer getlin + integer c (10) + n = w + 2 + q = 2 +23000 continue + p = mem (q + 1) + if (.not.(p .eq. 0))goto 23003 + call remark (31Hin dsget: out of storage space.) + call remark (41Htype 'c' or 'i' for char or integer dump.) + junk = getlin (c, 0) + if (.not.(c (1) .eq. 99 .or. c (1) .eq. 67))goto 23005 + call dsdump (97) + goto 23006 +23005 continue + if (.not.(c (1) .eq. 105 .or. c (1) .eq. 73))goto 23007 + call dsdump (48) +23007 continue +23006 continue + call error (19Hprogram terminated.) +23003 continue + if (.not.(mem (p + 0) .ge. n))goto 23009 + goto 23002 +23009 continue + q = p +23001 goto 23000 +23002 continue + k = mem (p + 0) - n + if (.not.(k .ge. 8))goto 23011 + mem (p + 0) = k + l = p + k + mem (l + 0) = n + goto 23012 +23011 continue + mem (q + 1) = mem (p + 1) + l = p +23012 continue + dsget=(l + 2) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsinit.f b/unix/boot/spp/rpp/ratlibf/dsinit.f new file mode 100644 index 00000000..9eb0ebad --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsinit.f @@ -0,0 +1,17 @@ + subroutine dsinit (w) + integer w + integer mem( 1) + common/cdsmem/mem + integer t + if (.not.(w .lt. 2 * 2 + 2))goto 23000 + call error (42Hin dsinit: unreasonably small memory size.) +23000 continue + t = 2 + mem (t + 0) = 0 + mem (t + 1) = 2 + 2 + t = 2 + 2 + mem (t + 0) = w - 2 - 1 + mem (t + 1) = 0 + mem (1) = w + return + end diff --git a/unix/boot/spp/rpp/ratlibf/enter.f b/unix/boot/spp/rpp/ratlibf/enter.f new file mode 100644 index 00000000..6711c57d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/enter.f @@ -0,0 +1,34 @@ + subroutine enter (symbol, info, st) + integer symbol (100) + integer info (100) + integer st + integer mem( 1) + common/cdsmem/mem + integer i, nodsiz, j + integer stlu, length + integer node, pred + integer dsget + nodsiz = mem (st) + if (.not.(stlu (symbol, node, pred, st) .eq. 0))goto 23000 + node = dsget (1 + nodsiz + length (symbol) + 1) + mem (node + 0) = 0 + mem (pred + 0) = node + i = 1 + j = node + 1 + nodsiz +23002 if (.not.(symbol (i) .ne. -2))goto 23003 + mem (j) = symbol (i) + i = i + 1 + j = j + 1 + goto 23002 +23003 continue + mem (j) = -2 +23000 continue + i = 1 +23004 if (.not.(i .le. nodsiz))goto 23006 + j = node + 1 + i - 1 + mem (j) = info (i) +23005 i = i + 1 + goto 23004 +23006 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/equal.f b/unix/boot/spp/rpp/ratlibf/equal.f new file mode 100644 index 00000000..1148779c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/equal.f @@ -0,0 +1,15 @@ + integer function equal (str1, str2) + integer str1(100), str2(100) + integer i + i = 1 +23000 if (.not.(str1 (i) .eq. str2 (i)))goto 23002 + if (.not.(str1 (i) .eq. -2))goto 23003 + equal=(1) + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + equal=(0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/error.f b/unix/boot/spp/rpp/ratlibf/error.f new file mode 100644 index 00000000..f4e15821 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/error.f @@ -0,0 +1,5 @@ + subroutine error (line) + integer line (100) + call remark (line) + call endst + end diff --git a/unix/boot/spp/rpp/ratlibf/errsub.f b/unix/boot/spp/rpp/ratlibf/errsub.f new file mode 100644 index 00000000..63aa3c0e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/errsub.f @@ -0,0 +1,22 @@ + integer function errsub (arg, file, access) + integer arg (100), file (100) + integer access + if (.not.(arg (1) .eq. 63 .and. arg (2) .ne. 63 .and. arg (2) .ne. + * -2))goto 23000 + errsub = 1 + access = 2 + call scopy (arg, 2, file, 1) + goto 23001 +23000 continue + if (.not.(arg (1) .eq. 63 .and. arg (2) .eq. 63 .and. arg (3) .ne. + * -2))goto 23002 + errsub = 1 + access = 4 + call scopy (arg, 3, file, 1) + goto 23003 +23002 continue + errsub = 0 +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/esc.f b/unix/boot/spp/rpp/ratlibf/esc.f new file mode 100644 index 00000000..fd3ce7fe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/esc.f @@ -0,0 +1,27 @@ + integer function esc (array, i) + integer array (100) + integer i + if (.not.(array (i) .ne. 64))goto 23000 + esc = array (i) + goto 23001 +23000 continue + if (.not.(array (i+1) .eq. -2))goto 23002 + esc = 64 + goto 23003 +23002 continue + i = i + 1 + if (.not.(array (i) .eq. 110 .or. array (i) .eq. 78))goto 23004 + esc = 10 + goto 23005 +23004 continue + if (.not.(array (i) .eq. 116 .or. array (i) .eq. 84))goto 23006 + esc = 9 + goto 23007 +23006 continue + esc = array (i) +23007 continue +23005 continue +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/fcopy.f b/unix/boot/spp/rpp/ratlibf/fcopy.f new file mode 100644 index 00000000..6c63dad8 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/fcopy.f @@ -0,0 +1,10 @@ + subroutine fcopy (in, out) + integer in, out + integer line (128) + integer getlin +23000 if (.not.(getlin (line, in) .ne. -1))goto 23001 + call putlin (line, out) + goto 23000 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/filset.f b/unix/boot/spp/rpp/ratlibf/filset.f new file mode 100644 index 00000000..d5ada767 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/filset.f @@ -0,0 +1,63 @@ + subroutine filset (delim, array, i, set, j, maxset) + integer i, j, maxset + integer array (100), delim, set (maxset) + integer esc + integer junk + external index + integer addset, index + integer digits(11) + integer lowalf(27) + integer upalf(27) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/-2/ + data lowalf(1)/97/,lowalf(2)/98/,lowalf(3)/99/,lowalf(4)/100/,lowa + *lf(5)/101/,lowalf(6)/102/,lowalf(7)/103/,lowalf(8)/104/,lowalf(9)/ + *105/,lowalf(10)/106/,lowalf(11)/107/,lowalf(12)/108/,lowalf(13)/10 + *9/,lowalf(14)/110/,lowalf(15)/111/,lowalf(16)/112/,lowalf(17)/113/ + *,lowalf(18)/114/,lowalf(19)/115/,lowalf(20)/116/,lowalf(21)/117/,l + *owalf(22)/118/,lowalf(23)/119/,lowalf(24)/120/,lowalf(25)/121/,low + *alf(26)/122/,lowalf(27)/-2/ + data upalf(1)/65/,upalf(2)/66/,upalf(3)/67/,upalf(4)/68/,upalf(5)/ + *69/,upalf(6)/70/,upalf(7)/71/,upalf(8)/72/,upalf(9)/73/,upalf(10)/ + *74/,upalf(11)/75/,upalf(12)/76/,upalf(13)/77/,upalf(14)/78/,upalf( + *15)/79/,upalf(16)/80/,upalf(17)/81/,upalf(18)/82/,upalf(19)/83/,up + *alf(20)/84/,upalf(21)/85/,upalf(22)/86/,upalf(23)/87/,upalf(24)/88 + */,upalf(25)/89/,upalf(26)/90/,upalf(27)/-2/ +23000 if (.not.(array (i) .ne. delim .and. array (i) .ne. -2))goto 23002 + if (.not.(array (i) .eq. 64))goto 23003 + junk = addset (esc (array, i), set, j, maxset) + goto 23004 +23003 continue + if (.not.(array (i) .ne. 45))goto 23005 + junk = addset (array (i), set, j, maxset) + goto 23006 +23005 continue + if (.not.(j .le. 1 .or. array (i + 1) .eq. -2))goto 23007 + junk = addset (45, set, j, maxset) + goto 23008 +23007 continue + if (.not.(index (digits, set (j - 1)) .gt. 0))goto 23009 + call dodash (digits, array, i, set, j, maxset) + goto 23010 +23009 continue + if (.not.(index (lowalf, set (j - 1)) .gt. 0))goto 23011 + call dodash (lowalf, array, i, set, j, maxset) + goto 23012 +23011 continue + if (.not.(index (upalf, set (j - 1)) .gt. 0))goto 23013 + call dodash (upalf, array, i, set, j, maxset) + goto 23014 +23013 continue + junk = addset (45, set, j, maxset) +23014 continue +23012 continue +23010 continue +23008 continue +23006 continue +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/fmtdat.f b/unix/boot/spp/rpp/ratlibf/fmtdat.f new file mode 100644 index 00000000..7a81c9c8 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/fmtdat.f @@ -0,0 +1,23 @@ + subroutine fmtdat(date, time, now, form) + integer date(100), time(100) + integer now(7), form + date(1) = now(2) / 10 + 48 + date(2) = mod(now(2), 10) + 48 + date(3) = 47 + date(4) = now(3) / 10 + 48 + date(5) = mod(now(3), 10) + 48 + date(6) = 47 + date(7) = mod(now(1), 100) / 10 + 48 + date(8) = mod(now(1), 10) + 48 + date(9) = -2 + time(1) = now(4) / 10 + 48 + time(2) = mod(now(4), 10) + 48 + time(3) = 58 + time(4) = now(5) / 10 + 48 + time(5) = mod(now(5), 10) + 48 + time(6) = 58 + time(7) = now(6) / 10 + 48 + time(8) = mod(now(6), 10) + 48 + time(9) = -2 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/fold.f b/unix/boot/spp/rpp/ratlibf/fold.f new file mode 100644 index 00000000..187bb721 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/fold.f @@ -0,0 +1,12 @@ + subroutine fold (token) + integer token (100) + integer clower + integer i + i = 1 +23000 if (.not.(token (i) .ne. -2))goto 23002 + token (i) = clower (token (i)) +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/gctoi.f b/unix/boot/spp/rpp/ratlibf/gctoi.f new file mode 100644 index 00000000..93ac3b6d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/gctoi.f @@ -0,0 +1,61 @@ + integer function gctoi (str, i, radix) + integer str (100) + integer i, radix + integer base, v, d, j + external index + integer index + integer clower + logical neg + integer digits(17) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/97/,digits(12)/98/,digits(13)/99/,digits( + *14)/100/,digits(15)/101/,digits(16)/102/,digits(17)/-2/ + v = 0 + base = radix +23000 if (.not.(str (i) .eq. 32 .or. str (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + neg = (str (i) .eq. 45) + if (.not.(str (i) .eq. 43 .or. str (i) .eq. 45))goto 23002 + i = i + 1 +23002 continue + if (.not.(str (i + 2) .eq. 114 .and. str (i) .eq. 49 .and. (48.le. + *str (i + 1).and.str (i + 1).le.57) .or. str (i + 1) .eq. 114 .and. + * (48.le.str (i).and.str (i).le.57)))goto 23004 + base = str (i) - 48 + j = i + if (.not.(str (i + 1) .ne. 114))goto 23006 + j = j + 1 + base = base * 10 + (str (j) - 48) +23006 continue + if (.not.(base .lt. 2 .or. base .gt. 16))goto 23008 + base = radix + goto 23009 +23008 continue + i = j + 2 +23009 continue +23004 continue +23010 if (.not.(str (i) .ne. -2))goto 23012 + if (.not.((48.le.str (i).and.str (i).le.57)))goto 23013 + d = str (i) - 48 + goto 23014 +23013 continue + d = index (digits, clower (str (i))) - 1 +23014 continue + if (.not.(d .lt. 0 .or. d .ge. base))goto 23015 + goto 23012 +23015 continue + v = v * base + d +23011 i = i + 1 + goto 23010 +23012 continue + if (.not.(neg))goto 23017 + gctoi=(-v) + return +23017 continue + gctoi=(+v) + return +23018 continue + end diff --git a/unix/boot/spp/rpp/ratlibf/getc.f b/unix/boot/spp/rpp/ratlibf/getc.f new file mode 100644 index 00000000..1dfabd93 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getc.f @@ -0,0 +1,6 @@ + integer function getc (c) + integer c + integer getch + getc = getch (c, 0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/getccl.f b/unix/boot/spp/rpp/ratlibf/getccl.f new file mode 100644 index 00000000..67ac73fa --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getccl.f @@ -0,0 +1,25 @@ + integer function getccl (arg, i, pat, j) + integer arg (128), pat (128) + integer i, j + integer jstart, junk + integer addset + i = i + 1 + if (.not.(arg (i) .eq. 126))goto 23000 + junk = addset (110, pat, j, 128) + i = i + 1 + goto 23001 +23000 continue + junk = addset (91, pat, j, 128) +23001 continue + jstart = j + junk = addset (0, pat, j, 128) + call filset (93, arg, i, pat, j, 128) + pat (jstart) = j - jstart - 1 + if (.not.(arg (i) .eq. 93))goto 23002 + getccl = -2 + goto 23003 +23002 continue + getccl = -3 +23003 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/getpat.f b/unix/boot/spp/rpp/ratlibf/getpat.f new file mode 100644 index 00000000..02d00ace --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getpat.f @@ -0,0 +1,6 @@ + integer function getpat (str, pat) + integer str (100), pat (100) + integer makpat + getpat=(makpat (str, 1, -2, pat)) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/getwrd.f b/unix/boot/spp/rpp/ratlibf/getwrd.f new file mode 100644 index 00000000..f1c0f8d7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getwrd.f @@ -0,0 +1,20 @@ + integer function getwrd (in, i, out) + integer in (100), out (100) + integer i + integer j +23000 if (.not.(in (i) .eq. 32 .or. in (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + j = 1 +23002 if (.not.(in (i) .ne. -2 .and. in (i) .ne. 32 .and. in (i) .ne. 9 + *.and. in (i) .ne. 10))goto 23003 + out (j) = in (i) + i = i + 1 + j = j + 1 + goto 23002 +23003 continue + out (j) = -2 + getwrd = j - 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/gfnarg.f b/unix/boot/spp/rpp/ratlibf/gfnarg.f new file mode 100644 index 00000000..19d4655d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/gfnarg.f @@ -0,0 +1,142 @@ + integer function gfnarg (name, state) + integer name (100) + integer state (4) + integer l + integer getarg, getlin + integer fd + integer rfopen + integer in1(12) + integer in2(12) + integer in3(12) + data in1(1)/47/,in1(2)/100/,in1(3)/101/,in1(4)/118/,in1(5)/47/,in1 + *(6)/115/,in1(7)/116/,in1(8)/100/,in1(9)/105/,in1(10)/110/,in1(11)/ + *49/,in1(12)/-2/ + data in2(1)/47/,in2(2)/100/,in2(3)/101/,in2(4)/118/,in2(5)/47/,in2 + *(6)/115/,in2(7)/116/,in2(8)/100/,in2(9)/105/,in2(10)/110/,in2(11)/ + *50/,in2(12)/-2/ + data in3(1)/47/,in3(2)/100/,in3(3)/101/,in3(4)/118/,in3(5)/47/,in3 + *(6)/115/,in3(7)/116/,in3(8)/100/,in3(9)/105/,in3(10)/110/,in3(11)/ + *51/,in3(12)/-2/ +23000 continue + if (.not.(state (1) .eq. 1))goto 23003 + state (1) = 2 + state (2) = 1 + state (3) = -3 + state (4) = 0 + goto 23004 +23003 continue + if (.not.(state (1) .eq. 2))goto 23005 + if (.not.(getarg (state (2), name, 128) .ne. -1))goto 23007 + state (1) = 2 + state (2) = state (2) + 1 + if (.not.(name (1) .ne. 45))goto 23009 + state (4) = state (4) + 1 + gfnarg=(-2) + return +23009 continue + if (.not.(name (2) .eq. -2))goto 23011 + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23011 continue + if (.not.(name (2) .eq. 49 .and. name (3) .eq. -2))goto 23013 + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23013 continue + if (.not.(name (2) .eq. 50 .and. name (3) .eq. -2))goto 23015 + call scopy (in2, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23015 continue + if (.not.(name (2) .eq. 51 .and. name (3) .eq. -2))goto 23017 + call scopy (in3, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23017 continue + if (.not.(name (2) .eq. 110 .or. name (2) .eq. 78))goto 23019 + state (1) = 3 + if (.not.(name (3) .eq. -2))goto 23021 + state (3) = 0 + goto 23022 +23021 continue + if (.not.(name (3) .eq. 49 .and. name (4) .eq. -2))goto 23023 + state (3) = stdin1 + goto 23024 +23023 continue + if (.not.(name (3) .eq. 50 .and. name (4) .eq. -2))goto 23025 + state (3) = stdin2 + goto 23026 +23025 continue + if (.not.(name (3) .eq. 51 .and. name (4) .eq. -2))goto 23027 + state (3) = stdin3 + goto 23028 +23027 continue + state (3) = rfopen(name (3), 1) + if (.not.(state (3) .eq. -3))goto 23029 + call putlin (name, 2) + call remark (14H: can't open.) + state (1) = 2 +23029 continue +23028 continue +23026 continue +23024 continue +23022 continue + goto 23020 +23019 continue + gfnarg=(-3) + return +23020 continue +23018 continue +23016 continue +23014 continue +23012 continue +23010 continue + goto 23008 +23007 continue + state (1) = 4 +23008 continue + goto 23006 +23005 continue + if (.not.(state (1) .eq. 3))goto 23031 + l = getlin (name, state (3)) + if (.not.(l .ne. -1))goto 23033 + name (l) = -2 + state (4) = state (4) + 1 + gfnarg=(-2) + return +23033 continue + if (.not.(fd .ne. -3 .and. fd .ne. 0))goto 23035 + call rfclos(state (3)) +23035 continue + state (1) = 2 + goto 23032 +23031 continue + if (.not.(state (1) .eq. 4))goto 23037 + state (1) = 5 + if (.not.(state (4) .eq. 0))goto 23039 + call scopy (in1, 1, name, 1) + gfnarg=(-2) + return +23039 continue + goto 23002 +23037 continue + if (.not.(state (1) .eq. 5))goto 23041 + goto 23002 +23041 continue + call error (32Hin gfnarg: bad state (1) value.) +23042 continue +23038 continue +23032 continue +23006 continue +23004 continue +23001 goto 23000 +23002 continue + name (1) = -2 + gfnarg=(-1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/index.f b/unix/boot/spp/rpp/ratlibf/index.f new file mode 100644 index 00000000..d5978954 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/index.f @@ -0,0 +1,13 @@ + integer function index (str, c) + integer str (100), c + index = 1 +23000 if (.not.(str (index) .ne. -2))goto 23002 + if (.not.(str (index) .eq. c))goto 23003 + return +23003 continue +23001 index = index + 1 + goto 23000 +23002 continue + index = 0 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/insub.f b/unix/boot/spp/rpp/ratlibf/insub.f new file mode 100644 index 00000000..72e50ff1 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/insub.f @@ -0,0 +1,11 @@ + integer function insub (arg, file) + integer arg (100), file (100) + if (.not.(arg (1) .eq. 60 .and. arg (2) .ne. -2))goto 23000 + insub = 1 + call scopy (arg, 2, file, 1) + goto 23001 +23000 continue + insub = 0 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/itoc.f b/unix/boot/spp/rpp/ratlibf/itoc.f new file mode 100644 index 00000000..3ceea6a7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/itoc.f @@ -0,0 +1,35 @@ + integer function itoc (int, str, size) + integer int, size + integer str (100) + integer mod + integer d, i, intval, j, k + integer digits (11) + data digits (1) /48/, digits (2) /49/, digits (3) /50/, digits (4) + * /51/, digits (5) /52/, digits (6) /53/, digits (7) /54/, digits ( + *8) /55/, digits (9) /56/, digits (10) /57/, digits (11) /-2/ + intval = iabs (int) + str (1) = -2 + i = 1 +23000 continue + i = i + 1 + d = mod (intval, 10) + str (i) = digits (d+1) + intval = intval / 10 +23001 if (.not.(intval .eq. 0 .or. i .ge. size))goto 23000 +23002 continue + if (.not.(int .lt. 0 .and. i .lt. size))goto 23003 + i = i + 1 + str (i) = 45 +23003 continue + itoc = i - 1 + j = 1 +23005 if (.not.(j .lt. i))goto 23007 + k = str (i) + str (i) = str (j) + str (j) = k + i = i - 1 +23006 j = j + 1 + goto 23005 +23007 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/length.f b/unix/boot/spp/rpp/ratlibf/length.f new file mode 100644 index 00000000..4bf20e40 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/length.f @@ -0,0 +1,9 @@ + integer function length (str) + integer str (100) + length = 0 +23000 if (.not.(str (length+1) .ne. -2))goto 23002 +23001 length = length + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/locate.f b/unix/boot/spp/rpp/ratlibf/locate.f new file mode 100644 index 00000000..6db95e25 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/locate.f @@ -0,0 +1,16 @@ + integer function locate (c, pat, offset) + integer c, pat (128) + integer offset + integer i + i = offset + pat (offset) +23000 if (.not.(i .gt. offset))goto 23002 + if (.not.(c .eq. pat (i)))goto 23003 + locate=(1) + return +23003 continue +23001 i = i - 1 + goto 23000 +23002 continue + locate=(0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/lookup.f b/unix/boot/spp/rpp/ratlibf/lookup.f new file mode 100644 index 00000000..f70e9842 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/lookup.f @@ -0,0 +1,24 @@ + integer function lookup (symbol, info, st) + integer symbol (100) + integer info (100) + integer st + integer mem( 1) + common/cdsmem/mem + integer i, nodsiz, kluge + integer stlu + integer node, pred + if (.not.(stlu (symbol, node, pred, st) .eq. 0))goto 23000 + lookup = 0 + return +23000 continue + nodsiz = mem (st) + i = 1 +23002 if (.not.(i .le. nodsiz))goto 23004 + kluge = node + 1 - 1 + i + info (i) = mem (kluge) +23003 i = i + 1 + goto 23002 +23004 continue + lookup = 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/lower.f b/unix/boot/spp/rpp/ratlibf/lower.f new file mode 100644 index 00000000..b3550701 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/lower.f @@ -0,0 +1,5 @@ + subroutine lower (token) + integer token (100) + call fold (token) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/makpat.f b/unix/boot/spp/rpp/ratlibf/makpat.f new file mode 100644 index 00000000..27744665 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/makpat.f @@ -0,0 +1,90 @@ + integer function makpat (arg, from, delim, pat) + integer arg (128), delim, pat (128) + integer from + integer esc + integer i, j, junk, lastcl, lastj, lj, tagnst, tagnum, tagstk (9) + integer addset, getccl, stclos + j = 1 + lastj = 1 + lastcl = 0 + tagnum = 0 + tagnst = 0 + i = from +23000 if (.not.(arg (i) .ne. delim .and. arg (i) .ne. -2))goto 23002 + lj = j + if (.not.(arg (i) .eq. 63))goto 23003 + junk = addset (63, pat, j, 128) + goto 23004 +23003 continue + if (.not.(arg (i) .eq. 37 .and. i .eq. from))goto 23005 + junk = addset (37, pat, j, 128) + goto 23006 +23005 continue + if (.not.(arg (i) .eq. 36 .and. arg (i + 1) .eq. delim))goto 23007 + junk = addset (36, pat, j, 128) + goto 23008 +23007 continue + if (.not.(arg (i) .eq. 91))goto 23009 + if (.not.(getccl (arg, i, pat, j) .eq. -3))goto 23011 + makpat = -3 + return +23011 continue + goto 23010 +23009 continue + if (.not.(arg (i) .eq. 42 .and. i .gt. from))goto 23013 + lj = lastj + if (.not.(pat (lj) .eq. 37 .or. pat (lj) .eq. 36 .or. pat (lj) .eq + *. 42 .or. pat (lj) .eq. 123 .or. pat (lj) .eq. 125))goto 23015 + goto 23002 +23015 continue + lastcl = stclos (pat, j, lastj, lastcl) + goto 23014 +23013 continue + if (.not.(arg (i) .eq. 123))goto 23017 + if (.not.(tagnum .ge. 9))goto 23019 + goto 23002 +23019 continue + tagnum = tagnum + 1 + tagnst = tagnst + 1 + tagstk (tagnst) = tagnum + junk = addset (123, pat, j, 128) + junk = addset (tagnum, pat, j, 128) + goto 23018 +23017 continue + if (.not.(arg (i) .eq. 125 .and. tagnst .gt. 0))goto 23021 + junk = addset (125, pat, j, 128) + junk = addset (tagstk (tagnst), pat, j, 128) + tagnst = tagnst - 1 + goto 23022 +23021 continue + junk = addset (97, pat, j, 128) + junk = addset (esc (arg, i), pat, j, 128) +23022 continue +23018 continue +23014 continue +23010 continue +23008 continue +23006 continue +23004 continue + lastj = lj +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(arg (i) .ne. delim))goto 23023 + makpat = -3 + goto 23024 +23023 continue + if (.not.(addset (-2, pat, j, 128) .eq. 0))goto 23025 + makpat = -3 + goto 23026 +23025 continue + if (.not.(tagnst .ne. 0))goto 23027 + makpat = -3 + goto 23028 +23027 continue + makpat = i +23028 continue +23026 continue +23024 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/maksub.f b/unix/boot/spp/rpp/ratlibf/maksub.f new file mode 100644 index 00000000..176c5321 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/maksub.f @@ -0,0 +1,40 @@ + integer function maksub (arg, from, delim, sub) + integer arg (128), delim, sub (128) + integer from + integer esc, type + integer i, j, junk + integer addset + j = 1 + i = from +23000 if (.not.(arg (i) .ne. delim .and. arg (i) .ne. -2))goto 23002 + if (.not.(arg (i) .eq. 38))goto 23003 + junk = addset (-3, sub, j, 128) + junk = addset (0, sub, j, 128) + goto 23004 +23003 continue + if (.not.(arg (i) .eq. 64 .and. type (arg (i + 1)) .eq. 48))goto 2 + *3005 + i = i + 1 + junk = addset (-3, sub, j, 128) + junk = addset (arg (i) - 48, sub, j, 128) + goto 23006 +23005 continue + junk = addset (esc (arg, i), sub, j, 128) +23006 continue +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(arg (i) .ne. delim))goto 23007 + maksub = -3 + goto 23008 +23007 continue + if (.not.(addset (-2, sub, j, 128) .eq. 0))goto 23009 + maksub = -3 + goto 23010 +23009 continue + maksub = i +23010 continue +23008 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/match.f b/unix/boot/spp/rpp/ratlibf/match.f new file mode 100644 index 00000000..de4e3638 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/match.f @@ -0,0 +1,16 @@ + integer function match (lin, pat) + integer lin (128), pat (128) + integer i, junk (9) + integer amatch + i = 1 +23000 if (.not.(lin (i) .ne. -2))goto 23002 + if (.not.(amatch (lin, i, pat, junk, junk) .gt. 0))goto 23003 + match = 1 + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + match = 0 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/mkpkg.sh b/unix/boot/spp/rpp/ratlibf/mkpkg.sh new file mode 100644 index 00000000..e9cb8822 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/mkpkg.sh @@ -0,0 +1,18 @@ +# Utility library subroutines for RPP. + +$F77 -c $HSI_FF addset.f addstr.f amatch.f catsub.f clower.f concat.f +$F77 -c $HSI_FF ctoc.f ctoi.f ctomn.f cupper.f delete.f docant.f dodash.f +$F77 -c $HSI_FF dsdbiu.f dsdump.f dsfree.f dsget.f dsinit.f enter.f equal.f +$F77 -c $HSI_FF error.f errsub.f esc.f fcopy.f filset.f fmtdat.f fold.f +$F77 -c $HSI_FF gctoi.f getc.f getccl.f getpat.f getwrd.f gfnarg.f index.f +$F77 -c $HSI_FF insub.f itoc.f length.f locate.f lookup.f lower.f makpat.f +$F77 -c $HSI_FF maksub.f match.f mktabl.f mntoc.f omatch.f outsub.f patsiz.f +$F77 -c $HSI_FF prompt.f putc.f putdec.f putint.f putstr.f query.f rmtabl.f +$F77 -c $HSI_FF scopy.f sctabl.f sdrop.f skipbl.f slstr.f stake.f stclos.f +$F77 -c $HSI_FF stcopy.f stlu.f strcmp.f strim.f termin.f trmout.f type.f +$F77 -c $HSI_FF upper.f wkday.f + +ar rv libf.a *.o +$RANLIB libf.a +mv -f libf.a .. +rm *.o diff --git a/unix/boot/spp/rpp/ratlibf/mktabl.f b/unix/boot/spp/rpp/ratlibf/mktabl.f new file mode 100644 index 00000000..9c3e7908 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/mktabl.f @@ -0,0 +1,17 @@ + integer function mktabl (nodsiz) + integer nodsiz + integer mem( 1) + common/cdsmem/mem + integer st + integer dsget + integer i + st = dsget (43 + 1) + mem (st) = nodsiz + mktabl = st + do 23000 i = 1, 43 + st = st + 1 + mem (st) = 0 +23000 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/mntoc.f b/unix/boot/spp/rpp/ratlibf/mntoc.f new file mode 100644 index 00000000..5a54ec16 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/mntoc.f @@ -0,0 +1,52 @@ + integer function mntoc (buf, p, defalt) + integer buf (100), defalt + integer p + integer i, tp + integer equal + integer c, tmp (128) + integer text (170) + data text / 6, 97, 99, 107, -2, 7, 98, 101, 108, -2, 8, 98, 115, + *-2, -2, 24, 99, 97, 110, -2, 13, 99, 114, -2, -2, 17, 100, 99, 49, + * -2, 18, 100, 99, 50, -2, 19, 100, 99, 51, -2, 20, 100, 99, 52, -2 + *, 127, 100, 101, 108, -2, 16, 100, 108, 101, -2, 25, 101, 109, -2, + * -2, 5, 101, 110, 113, -2, 4, 101, 111, 116, -2, 27, 101, 115, 99, + * -2, 23, 101, 116, 98, -2, 3, 101, 116, 120, -2, 12, 102, 102, -2, + * -2, 28, 102, 115, -2, -2, 29, 103, 115, -2, -2, 9, 104, 116, -2, + *-2, 10, 108, 102, -2, -2, 21, 110, 97, 107, -2, 0, 110, 117, 108, + *-2, 30, 114, 115, -2, -2, 15, 115, 105, -2, -2, 14, 115, 111, -2, + *-2, 1, 115, 111, 104, -2, 32, 115, 112, -2, -2, 2, 115, 116, 120, + *-2, 26, 115, 117, 98, -2, 22, 115, 121, 110, -2, 31, 117, 115, -2, + * -2, 11, 118, 116, -2, -2/ + tp = 1 +23000 continue + tmp (tp) = buf (p) + tp = tp + 1 + p = p + 1 +23001 if (.not.(.not. (((65.le.buf (p).and.buf (p).le.90).or.(97.le.buf + *(p).and.buf (p).le.122)) .or. (48.le.buf (p).and.buf (p).le.57)) . + *or. tp .ge. 128))goto 23000 +23002 continue + tmp (tp) = -2 + if (.not.(tp .eq. 2))goto 23003 + c = tmp (1) + goto 23004 +23003 continue + call lower (tmp) + i = 1 +23005 if (.not.(i .lt. 170))goto 23007 + if (.not.(equal (tmp, text (i + 1)) .eq. 1))goto 23008 + goto 23007 +23008 continue +23006 i = i + 5 + goto 23005 +23007 continue + if (.not.(i .lt. 170))goto 23010 + c = text (i) + goto 23011 +23010 continue + c = defalt +23011 continue +23004 continue + mntoc=(c) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/omatch.f b/unix/boot/spp/rpp/ratlibf/omatch.f new file mode 100644 index 00000000..60d57c83 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/omatch.f @@ -0,0 +1,60 @@ + integer function omatch (lin, i, pat, j) + integer lin (128), pat (128) + integer i, j + integer bump + integer locate + omatch = 0 + if (.not.(lin (i) .eq. -2))goto 23000 + return +23000 continue + bump = -1 + if (.not.(pat (j) .eq. 97))goto 23002 + if (.not.(lin (i) .eq. pat (j + 1)))goto 23004 + bump = 1 +23004 continue + goto 23003 +23002 continue + if (.not.(pat (j) .eq. 37))goto 23006 + if (.not.(i .eq. 1))goto 23008 + bump = 0 +23008 continue + goto 23007 +23006 continue + if (.not.(pat (j) .eq. 63))goto 23010 + if (.not.(lin (i) .ne. 10))goto 23012 + bump = 1 +23012 continue + goto 23011 +23010 continue + if (.not.(pat (j) .eq. 36))goto 23014 + if (.not.(lin (i) .eq. 10))goto 23016 + bump = 0 +23016 continue + goto 23015 +23014 continue + if (.not.(pat (j) .eq. 91))goto 23018 + if (.not.(locate (lin (i), pat, j + 1) .eq. 1))goto 23020 + bump = 1 +23020 continue + goto 23019 +23018 continue + if (.not.(pat (j) .eq. 110))goto 23022 + if (.not.(lin (i) .ne. 10 .and. locate (lin (i), pat, j + 1) .eq. + *0))goto 23024 + bump = 1 +23024 continue + goto 23023 +23022 continue + call error (24Hin omatch: can't happen.) +23023 continue +23019 continue +23015 continue +23011 continue +23007 continue +23003 continue + if (.not.(bump .ge. 0))goto 23026 + i = i + bump + omatch = 1 +23026 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/outsub.f b/unix/boot/spp/rpp/ratlibf/outsub.f new file mode 100644 index 00000000..c8da87de --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/outsub.f @@ -0,0 +1,22 @@ + integer function outsub (arg, file, access) + integer arg (100), file (100) + integer access + if (.not.(arg (1) .eq. 62 .and. arg (2) .ne. 62 .and. arg (2) .ne. + * -2))goto 23000 + outsub = 1 + access = 2 + call scopy (arg, 2, file, 1) + goto 23001 +23000 continue + if (.not.(arg (1) .eq. 62 .and. arg (2) .eq. 62 .and. arg (3) .ne. + * -2))goto 23002 + access = 4 + outsub = 1 + call scopy (arg, 3, file, 1) + goto 23003 +23002 continue + outsub = 0 +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/patsiz.f b/unix/boot/spp/rpp/ratlibf/patsiz.f new file mode 100644 index 00000000..e15449de --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/patsiz.f @@ -0,0 +1,28 @@ + integer function patsiz (pat, n) + integer pat (128) + integer n + if (.not.(pat (n) .eq. 97 .or. pat (n) .eq. 123 .or. pat (n) .eq. + *125))goto 23000 + patsiz = 2 + goto 23001 +23000 continue + if (.not.(pat (n) .eq. 37 .or. pat (n) .eq. 36 .or. pat (n) .eq. 6 + *3))goto 23002 + patsiz = 1 + goto 23003 +23002 continue + if (.not.(pat (n) .eq. 91 .or. pat (n) .eq. 110))goto 23004 + patsiz = pat (n + 1) + 2 + goto 23005 +23004 continue + if (.not.(pat (n) .eq. 42))goto 23006 + patsiz = 4 + goto 23007 +23006 continue + call error (24Hin patsiz: can't happen.) +23007 continue +23005 continue +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/prompt.f b/unix/boot/spp/rpp/ratlibf/prompt.f new file mode 100644 index 00000000..64ab202e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/prompt.f @@ -0,0 +1,11 @@ + subroutine prompt (str, buf, fd) + integer str(100), buf(100) + integer fd + integer isatty + if (.not.(isatty(fd) .eq. 1))goto 23000 + call putlin (str, fd) + call rfflus(fd) +23000 continue + call getlin (buf, fd) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putc.f b/unix/boot/spp/rpp/ratlibf/putc.f new file mode 100644 index 00000000..c3eecfde --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putc.f @@ -0,0 +1,5 @@ + subroutine putc (c) + integer c + call putch (c, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putdec.f b/unix/boot/spp/rpp/ratlibf/putdec.f new file mode 100644 index 00000000..878febcf --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putdec.f @@ -0,0 +1,20 @@ + subroutine putdec(n,w) + integer n, w + integer chars (20) + integer i, nd + integer itoc + nd = itoc (n, chars, 20) + i = nd + 1 +23000 if (.not.(i .le. w))goto 23002 + call putc (32) +23001 i = i + 1 + goto 23000 +23002 continue + i = 1 +23003 if (.not.(i .le. nd))goto 23005 + call putc (chars (i)) +23004 i = i + 1 + goto 23003 +23005 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putint.f b/unix/boot/spp/rpp/ratlibf/putint.f new file mode 100644 index 00000000..182e96e2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putint.f @@ -0,0 +1,10 @@ + subroutine putint (n, w, fd) + integer n, w + integer fd + integer chars (20) + integer junk + integer itoc + junk = itoc (n, chars, 20) + call putstr (chars, w, fd) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putstr.f b/unix/boot/spp/rpp/ratlibf/putstr.f new file mode 100644 index 00000000..aaf0f060 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putstr.f @@ -0,0 +1,27 @@ + subroutine putstr (str, w, fd) + integer str (100) + integer w + integer fd + integer length + integer i, len + len = length (str) + i = len + 1 +23000 if (.not.(i .le. w))goto 23002 + call putch (32, fd) +23001 i = i + 1 + goto 23000 +23002 continue + i = 1 +23003 if (.not.(i .le. len))goto 23005 + call putch (str (i), fd) +23004 i = i + 1 + goto 23003 +23005 continue + i = (-w) - len +23006 if (.not.(i .gt. 0))goto 23008 + call putch (32, fd) +23007 i = i - 1 + goto 23006 +23008 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/query.f b/unix/boot/spp/rpp/ratlibf/query.f new file mode 100644 index 00000000..d12c514a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/query.f @@ -0,0 +1,12 @@ + subroutine query (mesg) + integer mesg (100) + integer getarg + integer arg1 (3), arg2 (1) + if (.not.(getarg (1, arg1, 3) .ne. -1 .and. getarg (2, arg2, 1) .e + *q. -1))goto 23000 + if (.not.(arg1 (1) .eq. 63 .and. arg1 (2) .eq. -2))goto 23002 + call error (mesg) +23002 continue +23000 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/rmtabl.f b/unix/boot/spp/rpp/ratlibf/rmtabl.f new file mode 100644 index 00000000..5b552cab --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/rmtabl.f @@ -0,0 +1,21 @@ + subroutine rmtabl (st) + integer st + integer mem( 1) + common/cdsmem/mem + integer i + integer walker, bucket, node + bucket = st + do 23000 i = 1, 43 + bucket = bucket + 1 + walker = mem (bucket) +23002 if (.not.(walker .ne. 0))goto 23003 + node = walker + walker = mem (node + 0) + call dsfree (node) + goto 23002 +23003 continue +23000 continue +23001 continue + call dsfree (st) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/scopy.f b/unix/boot/spp/rpp/ratlibf/scopy.f new file mode 100644 index 00000000..a16bc5ee --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/scopy.f @@ -0,0 +1,15 @@ + subroutine scopy (from, i, to, j) + integer from (100), to (100) + integer i, j + integer k1, k2 + k2 = j + k1 = i +23000 if (.not.(from (k1) .ne. -2))goto 23002 + to (k2) = from (k1) + k2 = k2 + 1 +23001 k1 = k1 + 1 + goto 23000 +23002 continue + to (k2) = -2 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/sctabl.f b/unix/boot/spp/rpp/ratlibf/sctabl.f new file mode 100644 index 00000000..1ba16897 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/sctabl.f @@ -0,0 +1,54 @@ + integer function sctabl (table, sym, info, posn) + integer table, posn + integer sym (100) + integer info (100) + integer mem( 1) + common/cdsmem/mem + integer bucket, walker + integer dsget + integer nodsiz, i, j + if (.not.(posn .eq. 0))goto 23000 + posn = dsget (2) + mem (posn) = 1 + mem (posn + 1) = mem (table + 1) +23000 continue + bucket = mem (posn) + walker = mem (posn + 1) + nodsiz = mem (table) +23002 continue + if (.not.(walker .ne. 0))goto 23005 + i = walker + 1 + nodsiz + j = 1 +23007 if (.not.(mem (i) .ne. -2))goto 23008 + sym (j) = mem (i) + i = i + 1 + j = j + 1 + goto 23007 +23008 continue + sym (j) = -2 + i = 1 +23009 if (.not.(i .le. nodsiz))goto 23011 + j = walker + 1 + i - 1 + info (i) = mem (j) +23010 i = i + 1 + goto 23009 +23011 continue + mem (posn) = bucket + mem (posn + 1) = mem (walker + 0) + sctabl = 1 + return +23005 continue + bucket = bucket + 1 + if (.not.(bucket .gt. 43))goto 23012 + goto 23004 +23012 continue + j = table + bucket + walker = mem (j) +23006 continue +23003 goto 23002 +23004 continue + call dsfree (posn) + posn = 0 + sctabl = -1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/sdrop.f b/unix/boot/spp/rpp/ratlibf/sdrop.f new file mode 100644 index 00000000..b5334b9f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/sdrop.f @@ -0,0 +1,15 @@ + integer function sdrop (from, to, chars) + integer from (100), to (100) + integer chars + integer len, start + integer ctoc, length, min0 + len = length (from) + if (.not.(chars .lt. 0))goto 23000 + sdrop=(ctoc (from, to, len + chars + 1)) + return +23000 continue + start = min0 (chars, len) + sdrop=(ctoc (from (start + 1), to, len + 1)) + return +23001 continue + end diff --git a/unix/boot/spp/rpp/ratlibf/skipbl.f b/unix/boot/spp/rpp/ratlibf/skipbl.f new file mode 100644 index 00000000..be60610a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/skipbl.f @@ -0,0 +1,9 @@ + subroutine skipbl(lin, i) + integer lin(100) + integer i +23000 if (.not.(lin (i) .eq. 32 .or. lin (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/slstr.f b/unix/boot/spp/rpp/ratlibf/slstr.f new file mode 100644 index 00000000..d8d98292 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/slstr.f @@ -0,0 +1,32 @@ + integer function slstr (from, to, first, chars) + integer from (100), to (100) + integer first, chars + integer len, i, j, k + integer length + len = length (from) + i = first + if (.not.(i .lt. 1))goto 23000 + i = i + len + 1 +23000 continue + if (.not.(chars .lt. 0))goto 23002 + i = i + chars + 1 + chars = - chars +23002 continue + j = i + chars - 1 + if (.not.(i .lt. 1))goto 23004 + i = 1 +23004 continue + if (.not.(j .gt. len))goto 23006 + j = len +23006 continue + k = 0 +23008 if (.not.(i .le. j))goto 23010 + to (k + 1) = from (i) + i = i + 1 +23009 k = k + 1 + goto 23008 +23010 continue + to (k + 1) = -2 + slstr=(k) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/stake.f b/unix/boot/spp/rpp/ratlibf/stake.f new file mode 100644 index 00000000..08ba5652 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stake.f @@ -0,0 +1,15 @@ + integer function stake (from, to, chars) + integer from (100), to (100) + integer chars + integer len, start + integer length, ctoc, max0 + len = length (from) + if (.not.(chars .lt. 0))goto 23000 + start = max0 (len + chars, 0) + stake=(ctoc (from (start + 1), to, len + 1)) + return +23000 continue + stake=(ctoc (from, to, chars + 1)) + return +23001 continue + end diff --git a/unix/boot/spp/rpp/ratlibf/stclos.f b/unix/boot/spp/rpp/ratlibf/stclos.f new file mode 100644 index 00000000..64c041eb --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stclos.f @@ -0,0 +1,20 @@ + integer function stclos (pat, j, lastj, lastcl) + integer pat (128) + integer j, lastj, lastcl + integer addset + integer jp, jt, junk + jp = j - 1 +23000 if (.not.(jp .ge. lastj))goto 23002 + jt = jp + 4 + junk = addset (pat (jp), pat, jt, 128) +23001 jp = jp - 1 + goto 23000 +23002 continue + j = j + 4 + stclos = lastj + junk = addset (42, pat, lastj, 128) + junk = addset (0, pat, lastj, 128) + junk = addset (lastcl, pat, lastj, 128) + junk = addset (0, pat, lastj, 128) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/stcopy.f b/unix/boot/spp/rpp/ratlibf/stcopy.f new file mode 100644 index 00000000..36ca2ac2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stcopy.f @@ -0,0 +1,14 @@ + subroutine stcopy (in, i, out, j) + integer in (100), out (100) + integer i, j + integer k + k = i +23000 if (.not.(in (k) .ne. -2))goto 23002 + out (j) = in (k) + j = j + 1 +23001 k = k + 1 + goto 23000 +23002 continue + out(j) = -2 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/stlu.f b/unix/boot/spp/rpp/ratlibf/stlu.f new file mode 100644 index 00000000..6cfbd0a7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stlu.f @@ -0,0 +1,36 @@ + integer function stlu (symbol, node, pred, st) + integer symbol (100) + integer node, pred, st + integer mem( 1) + common/cdsmem/mem + integer hash, i, j, nodsiz + nodsiz = mem (st) + hash = 0 + i = 1 +23000 if (.not.(symbol (i) .ne. -2))goto 23002 + hash = hash + symbol (i) +23001 i = i + 1 + goto 23000 +23002 continue + hash = mod (hash, 43) + 1 + pred = st + hash + node = mem (pred) +23003 if (.not.(node .ne. 0))goto 23004 + i = 1 + j = node + 1 + nodsiz +23005 if (.not.(symbol (i) .eq. mem (j)))goto 23006 + if (.not.(symbol (i) .eq. -2))goto 23007 + stlu=(1) + return +23007 continue + i = i + 1 + j = j + 1 + goto 23005 +23006 continue + pred = node + node = mem (pred + 0) + goto 23003 +23004 continue + stlu=(0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/strcmp.f b/unix/boot/spp/rpp/ratlibf/strcmp.f new file mode 100644 index 00000000..9d037401 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/strcmp.f @@ -0,0 +1,30 @@ + integer function strcmp (str1, str2) + integer str1 (100), str2 (100) + integer i + i = 1 +23000 if (.not.(str1 (i) .eq. str2 (i)))goto 23002 + if (.not.(str1 (i) .eq. -2))goto 23003 + strcmp=(0) + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(str1 (i) .eq. -2))goto 23005 + strcmp = -1 + goto 23006 +23005 continue + if (.not.(str2 (i) .eq. -2))goto 23007 + strcmp = + 1 + goto 23008 +23007 continue + if (.not.(str1 (i) .lt. str2 (i)))goto 23009 + strcmp = -1 + goto 23010 +23009 continue + strcmp = +1 +23010 continue +23008 continue +23006 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/strim.f b/unix/boot/spp/rpp/ratlibf/strim.f new file mode 100644 index 00000000..f9aaa9b4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/strim.f @@ -0,0 +1,16 @@ + integer function strim (str) + integer str (100) + integer lnb, i + lnb = 0 + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + if (.not.(str (i) .ne. 32 .and. str (i) .ne. 9))goto 23003 + lnb = i +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + str (lnb + 1) = -2 + strim=(lnb) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/termin.f b/unix/boot/spp/rpp/ratlibf/termin.f new file mode 100644 index 00000000..2ba3823d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/termin.f @@ -0,0 +1,8 @@ + subroutine termin (name) + integer name (100) + integer tname(9) + data tname(1)/47/,tname(2)/100/,tname(3)/101/,tname(4)/118/,tname( + *5)/47/,tname(6)/116/,tname(7)/116/,tname(8)/121/,tname(9)/-2/ + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/trmout.f b/unix/boot/spp/rpp/ratlibf/trmout.f new file mode 100644 index 00000000..398620cd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/trmout.f @@ -0,0 +1,8 @@ + subroutine trmout (name) + integer name (100) + integer tname(9) + data tname(1)/47/,tname(2)/100/,tname(3)/101/,tname(4)/118/,tname( + *5)/47/,tname(6)/116/,tname(7)/116/,tname(8)/121/,tname(9)/-2/ + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/type.f b/unix/boot/spp/rpp/ratlibf/type.f new file mode 100644 index 00000000..decd4d15 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/type.f @@ -0,0 +1,16 @@ + integer function type (c) + integer c + if (.not.((97 .le. c .and. c .le. 122) .or. (65 .le. c .and. c .le + *. 90)))goto 23000 + type = 97 + goto 23001 +23000 continue + if (.not.(48 .le. c .and. c .le. 57))goto 23002 + type = 48 + goto 23003 +23002 continue + type = c +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/upper.f b/unix/boot/spp/rpp/ratlibf/upper.f new file mode 100644 index 00000000..1cf34941 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/upper.f @@ -0,0 +1,12 @@ + subroutine upper (token) + integer token (100) + integer cupper + integer i + i = 1 +23000 if (.not.(token (i) .ne. -2))goto 23002 + token (i) = cupper (token (i)) +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/wkday.f b/unix/boot/spp/rpp/ratlibf/wkday.f new file mode 100644 index 00000000..69d80796 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/wkday.f @@ -0,0 +1,14 @@ + integer function wkday (month, day, year) + integer month, day, year + integer lmonth, lday, lyear + lmonth = month - 2 + lday = day + lyear = year + if (.not.(lmonth .le. 0))goto 23000 + lmonth = lmonth + 12 + lyear = lyear - 1 +23000 continue + wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 3 + *4, 7) + 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibr/Makefile b/unix/boot/spp/rpp/ratlibr/Makefile new file mode 100644 index 00000000..7c4d42b4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/Makefile @@ -0,0 +1,33 @@ +# Ratfor source for the ratfor library. A TOOLS compatible ratfor compiler +# is required to compile this. The original UNIX ratfor compiler may not do +# the job. + +.r.f: + /usr/local/bin/ratfor $*.r > $*.f + +SRCS= addset.r addstr.r amatch.r catsub.r clower.r concat.r ctoc.r\ + ctoi.r ctomn.r cupper.r delete.r docant.r dodash.r dsdbiu.r\ + dsdump.r dsfree.r dsget.r dsinit.r enter.r equal.r error.r\ + errsub.r esc.r fcopy.r filset.r fmtdat.r fold.r gctoi.r getc.r\ + getccl.r getpat.r getwrd.r gfnarg.r index.r insub.r\ + itoc.r length.r locate.r lookup.r lower.r makpat.r maksub.r\ + match.r mktabl.r mntoc.r omatch.r outsub.r patsiz.r prompt.r\ + putc.r putdec.r putint.r putstr.r query.r rmtabl.r scopy.r\ + sctabl.r sdrop.r skipbl.r slstr.r stake.r stclos.r stcopy.r\ + stlu.r strcmp.r strim.r termin.r trmout.r type.r upper.r wkday.r + +FORT= addset.f addstr.f amatch.f catsub.f clower.f concat.f ctoc.f\ + ctoi.f ctomn.f cupper.f delete.f docant.f dodash.f dsdbiu.f\ + dsdump.f dsfree.f dsget.f dsinit.f enter.f equal.f error.f\ + errsub.f esc.f fcopy.f filset.f fmtdat.f fold.f gctoi.f getc.f\ + getccl.f getpat.f getwrd.f gfnarg.f index.f insub.f\ + itoc.f length.f locate.f lookup.f lower.f makpat.f maksub.f\ + match.f mktabl.f mntoc.f omatch.f outsub.f patsiz.f prompt.f\ + putc.f putdec.f putint.f putstr.f query.f rmtabl.f scopy.f\ + sctabl.f sdrop.f skipbl.f slstr.f stake.f stclos.f stcopy.f\ + stlu.f strcmp.f strim.f termin.f trmout.f type.f upper.f wkday.f + +fort: $(SRCS) defs + make fsrc; mv *.f ../ratlibf; touch fort + +fsrc: $(FORT) diff --git a/unix/boot/spp/rpp/ratlibr/addset.r b/unix/boot/spp/rpp/ratlibr/addset.r new file mode 100644 index 00000000..06f9f578 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/addset.r @@ -0,0 +1,18 @@ +include defs + +# addset - put c in string (j) if it fits, increment j + + integer function addset (c, str, j, maxsiz) + integer j, maxsiz + character c, str (maxsiz) + + if (j > maxsiz) + addset = NO + else { + str(j) = c + j = j + 1 + addset = YES + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/addstr.r b/unix/boot/spp/rpp/ratlibr/addstr.r new file mode 100644 index 00000000..2f88c74c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/addstr.r @@ -0,0 +1,19 @@ +include defs + +# addstr - add s to str(j) if it fits, increment j + + integer function addstr (s, str, j, maxsiz) + integer j, maxsiz + character s (ARB), str (maxsiz) + + integer i, addset + + for (i = 1; s (i) != EOS; i = i + 1) + if (addset (s (i), str, j, maxsiz) == NO) { + addstr = NO + return + } + addstr = YES + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/amatch.r b/unix/boot/spp/rpp/ratlibr/amatch.r new file mode 100644 index 00000000..54a2904b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/amatch.r @@ -0,0 +1,55 @@ +include defs + +# amatch --- (non-recursive) look for match starting at lin (from) + + integer function amatch (lin, from, pat, tagbeg, tagend) + character lin (MAXLINE), pat (MAXPAT) + integer from, tagbeg (10), tagend (10) + + integer i, j, offset, stack + integer omatch, patsiz + + for (i = 1; i <= 10; i = i + 1) { + tagbeg (i) = 0 + tagend (i) = 0 + } + tagbeg (1) = from + stack = 0 + offset = from # next unexamined input character + for (j = 1; pat (j) != EOS; j = j + patsiz (pat, j)) + if (pat (j) == CLOSURE) { # a closure entry + stack = j + j = j + CLOSIZE # step over CLOSURE + for (i = offset; lin (i) != EOS; ) # match as many as + if (omatch (lin, i, pat, j) == NO) # possible + break + pat (stack + COUNT) = i - offset + pat (stack + START) = offset + offset = i # character that made us fail + } + else if (pat (j) == START_TAG) { + i = pat (j + 1) + tagbeg (i + 1) = offset + } + else if (pat (j) == STOP_TAG) { + i = pat (j + 1) + tagend (i + 1) = offset + } + else if (omatch (lin, offset, pat, j) == NO) { # non-closure + for ( ; stack > 0; stack = pat (stack + PREVCL)) + if (pat (stack + COUNT) > 0) + break + if (stack <= 0) { # stack is empty + amatch = 0 # return failure + return + } + pat (stack + COUNT) = pat (stack + COUNT) - 1 + j = stack + CLOSIZE + offset = pat (stack + START) + pat (stack + COUNT) + } + # else omatch succeeded + + amatch = offset + tagend (1) = offset + return # success + end diff --git a/unix/boot/spp/rpp/ratlibr/catsub.r b/unix/boot/spp/rpp/ratlibr/catsub.r new file mode 100644 index 00000000..627e998f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/catsub.r @@ -0,0 +1,27 @@ +include defs + +# catsub --- add replacement text to end of new + + subroutine catsub (lin, from, to, sub, new, k, maxnew) + + character lin(MAXLINE) + integer from(10), to(10) + integer maxnew + character sub(maxnew), new(MAXPAT) + integer k + + integer i, j, junk, ri + integer addset + + for (i = 1; sub (i) != EOS; i = i + 1) + if (sub (i) == DITTO) { + i = i + 1 + ri = sub (i) + 1 + for (j = from (ri); j < to (ri); j = j + 1) + junk = addset (lin (j), new, k, maxnew) + } + else + junk = addset (sub (i), new, k, maxnew) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/clower.r b/unix/boot/spp/rpp/ratlibr/clower.r new file mode 100644 index 00000000..0f629ea3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/clower.r @@ -0,0 +1,18 @@ +include defs + +# clower - change letter to lower case + + character function clower(c) + character c + + character k + + if (c >= BIGA & c <= BIGZ) { + k = LETA - BIGA # avoid integer overflow in byte machines + clower = c + k + } + else + clower = c + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/concat.r b/unix/boot/spp/rpp/ratlibr/concat.r new file mode 100644 index 00000000..abe55156 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/concat.r @@ -0,0 +1,15 @@ +include defs + +# concat - concatenate two strings together + + subroutine concat (buf1, buf2, outstr) + character buf1(ARB), buf2(ARB), outstr(ARB) + + integer i + + i = 1 + call stcopy (buf1, 1, outstr, i) + call scopy (buf2, 1, outstr, i) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/ctoc.r b/unix/boot/spp/rpp/ratlibr/ctoc.r new file mode 100644 index 00000000..3b9a22ba --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/ctoc.r @@ -0,0 +1,18 @@ +include defs + +# ctoc --- convert EOS-terminated string to EOS-terminated string + + integer function ctoc (from, to, len) + integer len + character from (ARB), to (len) + + integer i + + for (i = 1; i < len & from (i) != EOS; i = i + 1) + to (i) = from (i) + + to (i) = EOS + + return (i - 1) + + end diff --git a/unix/boot/spp/rpp/ratlibr/ctoi.r b/unix/boot/spp/rpp/ratlibr/ctoi.r new file mode 100644 index 00000000..54a5769b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/ctoi.r @@ -0,0 +1,37 @@ +include defs + +# ctoi - convert string at in(i) to integer, increment i + + integer function ctoi(in, i) + character in (ARB) + integer i + + integer d + external index + integer index + + # string digits "0123456789" + character digits(11) + data digits (1) /DIG0/, + digits (2) /DIG1/, + digits (3) /DIG2/, + digits (4) /DIG3/, + digits (5) /DIG4/, + digits (6) /DIG5/, + digits (7) /DIG6/, + digits (8) /DIG7/, + digits (9) /DIG8/, + digits (10) /DIG9/, + digits (11) /EOS/ + + while (in (i) == BLANK | in (i) == TAB) + i = i + 1 + for (ctoi = 0; in (i) != EOS; i = i + 1) { + d = index (digits, in (i)) + if (d == 0) # non-digit + break + ctoi = 10 * ctoi + d - 1 + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/ctomn.r b/unix/boot/spp/rpp/ratlibr/ctomn.r new file mode 100644 index 00000000..ef59e51a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/ctomn.r @@ -0,0 +1,59 @@ +include defs + +# ctomn --- translate ASCII control character to mnemonic string + + integer function ctomn (c, rep) + character c, rep (4) + + integer i + integer length + + character mntext (136) # 4 chars/mnemonic; 32 control chars + SP + DEL + data mntext / _ + BIGN, BIGU, BIGL, EOS, + BIGS, BIGO, BIGH, EOS, + BIGS, BIGT, BIGX, EOS, + BIGE, BIGT, BIGX, EOS, + BIGE, BIGO, BIGT, EOS, + BIGE, BIGN, BIGQ, EOS, + BIGA, BIGC, BIGK, EOS, + BIGB, BIGE, BIGL, EOS, + BIGB, BIGS, EOS, EOS, + BIGH, BIGT, EOS, EOS, + BIGL, BIGF, EOS, EOS, + BIGV, BIGT, EOS, EOS, + BIGF, BIGF, EOS, EOS, + BIGC, BIGR, EOS, EOS, + BIGS, BIGO, EOS, EOS, + BIGS, BIGI, EOS, EOS, + BIGD, BIGL, BIGE, EOS, + BIGD, BIGC, DIG1, EOS, + BIGD, BIGC, DIG2, EOS, + BIGD, BIGC, DIG3, EOS, + BIGD, BIGC, DIG4, EOS, + BIGN, BIGA, BIGK, EOS, + BIGS, BIGY, BIGN, EOS, + BIGE, BIGT, BIGB, EOS, + BIGC, BIGA, BIGN, EOS, + BIGE, BIGM, EOS, EOS, + BIGS, BIGU, BIGB, EOS, + BIGE, BIGS, BIGC, EOS, + BIGF, BIGS, EOS, EOS, + BIGG, BIGS, EOS, EOS, + BIGR, BIGS, EOS, EOS, + BIGU, BIGS, EOS, EOS, + BIGS, BIGP, EOS, EOS, + BIGD, BIGE, BIGL, EOS/ + + i = mod (max(c,0), 128) + if (0 <= i & i <= 32) # non-printing character or space + call scopy (mntext, 4 * i + 1, rep, 1) + elif (i == 127) # rubout (DEL) + call scopy (mntext, 133, rep, 1) + else { # printing character + rep (1) = c + rep (2) = EOS + } + + return (length (rep)) + end diff --git a/unix/boot/spp/rpp/ratlibr/cupper.r b/unix/boot/spp/rpp/ratlibr/cupper.r new file mode 100644 index 00000000..9a39cf21 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/cupper.r @@ -0,0 +1,14 @@ +include defs + +# cupper - change letter to upper case + + character function cupper (c) + character c + + if (c >= LETA & c <= LETZ) + cupper = c + (BIGA - LETA) + else + cupper = c + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/defs b/unix/boot/spp/rpp/ratlibr/defs new file mode 100644 index 00000000..bf040c55 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/defs @@ -0,0 +1,138 @@ +# common definitions for all routines comprising the ratfor preprocessor +#--------------------------------------------------------------- +# The definition STDEFNS defines the file which contains the +# standard definitions to be used when preprocessing a file. +# It is opened and read automatically by the ratfor preprocessor. +# Set STDEFNS to the name of the file in which the standard +# definitions reside. If you don't want the preprocessor to +# automatically open this file, set STDENFS to "". +# +#--------------------------------------------------------------- +# If you want the preprocessor to output upper case only, +# set the following definition: +# +# define (UPPERC,) +# +#--------------------------------------------------------------- +# Some of the buffer sizes and other symbols might have to be +# changed. Especially check the following: +# +# MAXDEF (number of characters in a definition) +# SBUFSIZE (nbr string declarations allowed per module) +# MAXSTRTBL (size of table to buffer string declarations) +# MAXSWITCH (max stack for switch statement) +# +#----------------------------------------------------------------- + + +define (STDEFNS, string defns "") # standard defns file +#define (UPPERC,) # define if Fortran compiler wants upper case +#define (IMPNONE,) # output IMPLICIT NONE in procedures +define (NULL,0) +define (INDENT,3) # number of spaces of indentation +define (MAX_INDENT,30) # maximum column for indentation +define (FIRST_LABEL,100) # first statement label +define (SZ_SPOOLBUF,8) # for breaking continuation cards + +define (RADIX,PERCENT) # % indicates alternate radix +define (TOGGLE,PERCENT) # toggle for literal lines +define (ARGFLAG,DOLLAR) +define (CUTOFF,3) # min nbr of cases to generate branch table + # (for switch statement) +define (DENSITY,2) # reciprocal of density necessary for + # branch table +define (FILLCHAR,DIG0) # used in long-name uniquing +define (MAXIDLENGTH,6) # for Fortran 66 and 77 +define (SZ_SMEM,240) # memory common declarations string + + +# Lexical items (codes are negative to avoid conflict with character values) + +define (LEXBEGIN,-83) +define (LEXBREAK,-79) +define (LEXCASE,-91) +define (LEXDEFAULT,-90) +define (LEXDIGITS,-89) +define (LEXDO,-96) +define (LEXELSE,-87) +define (LEXEND,-82) +define (LEXERRCHK,-84) +define (LEXERROR,-73) +define (LEXFOR,-94) +define (LEXIF,-99) +define (LEXIFELSE,-72) +define (LEXIFERR,-98) +define (LEXIFNOERR,-97) +define (LEXLITERAL,-85) +define (LEXNEXT,-78) +define (LEXOTHER,-80) +define (LEXPOINTER,-88) +define (LEXRBRACE,-74) +define (LEXREPEAT,-93) +define (LEXRETURN,-77) +define (LEXGOTO,-76) +define (LEXSTOP,-71) +define (LEXSTRING,-75) +define (LEXSWITCH,-92) +define (LEXTHEN,-86) +define (LEXUNTIL,-70) +define (LEXWHILE,-95) +define (LSTRIPC,-69) +define (RSTRIPC,-68) +define (LEXDECL,-67) + +define (XPP_DIRECTIVE, -166) + +# Built-in macro functions: + +define (DEFTYPE,-4) +define (MACTYPE,-10) +define (IFTYPE,-11) +define (INCTYPE,-12) +define (SUBTYPE,-13) +define (ARITHTYPE,-14) +define (IFDEFTYPE,-15) +define (IFNOTDEFTYPE,-16) +define (PRAGMATYPE,-17) + + +# Size-limiting definitions: + +define (MEMSIZE,60000) # space allotted to symbol tables and macro text +define (BUFSIZE,4096) # pushback buffer for ngetch and putbak +define (PBPOINT,3192) # point in buffer where pushback begins +define (SBUFSIZE,2048) # buffer for string statements +define (MAXDEF,2048) # max chars in a defn +define (MAXFORSTK,200) # max space for for reinit clauses +define (MAXERRSTK,30) # max nesting of iferr statements +define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) +define (MAXSTACK,100) # max stack depth for parser +define (MAXSWITCH,1000) # max stack for switch statement +define (MAXSWNEST,10) # max nesting of switches in a procedure +define (MAXTOK,100) # max chars in a token +define (NFILES,5) # max number of include file nesting +define (MAXNBRSTR,20) #max nbr string declarations per module +define (CALLSIZE,50) +define (ARGSIZE,100) +define (EVALSIZE,500) + + +# Where to find the common blocks: + +define(COMMON_BLOCKS,"common") + +# Data types, Dynamic Memory common: + +define (XPOINTER,"integer ") + + +# The following external names are redefined to avoid name collisions with +# standard library procedures on some systems. + +define open rfopen +define close rfclos +define flush rfflus +define note rfnote +define seek rfseek +define remove rfrmov +define exit rexit diff --git a/unix/boot/spp/rpp/ratlibr/delete.r b/unix/boot/spp/rpp/ratlibr/delete.r new file mode 100644 index 00000000..f4cadeb2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/delete.r @@ -0,0 +1,21 @@ +include defs + +# delete --- remove a symbol from the symbol table + + subroutine delete (symbol, st) + character symbol (ARB) + pointer st + + DS_DECL(Mem, 1) + + integer stlu + + pointer node, pred + + if (stlu (symbol, node, pred, st) == YES) { + Mem (pred + ST_LINK) = Mem (node + ST_LINK) + call dsfree (node) + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/docant.r b/unix/boot/spp/rpp/ratlibr/docant.r new file mode 100644 index 00000000..efa14ccc --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/docant.r @@ -0,0 +1,25 @@ +include defs + +# docant +# +# Similar to cant(name), however precede the messge with the name +# of the program that was running when the file could not be +# opened. Helpful in a pipeline to verify which program was not +# able to open a file. +# + subroutine docant(name) + + character name(ARB), prog(FILENAMESIZE) + integer length + integer getarg + + length = getarg(0, prog, FILENAMESIZE) + if (length != EOF) { + call putlin(prog, STDERR) + call putch(COLON, STDERR) + call putch(BLANK, STDERR) + } + call cant(name) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dodash.r b/unix/boot/spp/rpp/ratlibr/dodash.r new file mode 100644 index 00000000..83c4f2bc --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dodash.r @@ -0,0 +1,22 @@ +include defs + +# dodash --- expand array (i-1)-array (i+1) into set (j)... from valid + + subroutine dodash (valid, array, i, set, j, maxset) + integer i, j, maxset + character valid (ARB), array (ARB), set (maxset) + + character esc + + integer junk, k, limit + external index + integer addset, index + + i = i + 1 + j = j - 1 + limit = index (valid, esc (array, i)) + for (k = index (valid, set (j)); k <= limit; k = k + 1) + junk = addset (valid (k), set, j, maxset) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsdbiu.r b/unix/boot/spp/rpp/ratlibr/dsdbiu.r new file mode 100644 index 00000000..99c2acc0 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsdbiu.r @@ -0,0 +1,45 @@ +include defs + +# dsdbiu --- dump contents of block-in-use + + subroutine dsdbiu (b, form) + pointer b + character form + + DS_DECL(Mem, 1) + + integer l, s, lmax + + string blanks " " + + call putint (b, 5, ERROUT) + call putch (BLANK, ERROUT) + call putint (Mem (b + DS_SIZE), 0, ERROUT) + call remark (" words in use.") + + l = 0 + s = b + Mem (b + DS_SIZE) + if (form == DIGIT) + lmax = 5 + else + lmax = 50 + + for (b = b + DS_OHEAD; b < s; b = b + 1) { + if (l == 0) + call putlin (blanks, ERROUT) + if (form == DIGIT) + call putint (Mem (b), 10, ERROUT) + elif (form == LETTER) + call putch (Mem (b), ERROUT) + l = l + 1 + if (l >= lmax) { + l = 0 + call putch (NEWLINE, ERROUT) + } + } + + if (l != 0) + call putch (NEWLINE, ERROUT) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsdump.r b/unix/boot/spp/rpp/ratlibr/dsdump.r new file mode 100644 index 00000000..276290db --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsdump.r @@ -0,0 +1,34 @@ +include defs + +# dsdump --- produce semi-readable dump of storage + + subroutine dsdump (form) + character form + + DS_DECL(Mem, 1) + + pointer p, t, q + + t = DS_AVAIL + + call remark ("** DYNAMIC STORAGE DUMP **.") + call putint (1, 5, ERROUT) + call putch (BLANK, ERROUT) + call putint (DS_OHEAD + 1, 0, ERROUT) + call remark (" words in use.") + + p = Mem (t + DS_LINK) + while (p != LAMBDA) { + call putint (p, 5, ERROUT) + call putch (BLANK, ERROUT) + call putint (Mem (p + DS_SIZE), 0, ERROUT) + call remark (" words available.") + q = p + Mem (p + DS_SIZE) + while (q != Mem (p + DS_LINK) & q < Mem (DS_MEMEND)) + call dsdbiu (q, form) + p = Mem (p + DS_LINK) + } + + call remark ("** END DUMP **.") + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsfree.r b/unix/boot/spp/rpp/ratlibr/dsfree.r new file mode 100644 index 00000000..34cd7e55 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsfree.r @@ -0,0 +1,53 @@ +include defs + +# dsfree --- return a block of storage to the available space list + + subroutine dsfree (block) + pointer block + + DS_DECL(Mem, 1) + + pointer p0, p, q + + integer n, junk + + character con (10) + + p0 = block - DS_OHEAD + n = Mem (p0 + DS_SIZE) + q = DS_AVAIL + + repeat { + p = Mem (q + DS_LINK) + if (p == LAMBDA | p > p0) + break + q = p + } + + if (q + Mem (q + DS_SIZE) > p0) { + call remark ("in dsfree: attempt to free unallocated block.") + call remark ("type 'c' to continue.") + junk = getlin (con, STDIN) + if (con (1) != LETC & con (1) != BIGC) + call endst + return # do not attempt to free the block + } + + if (p0 + n == p & p != LAMBDA) { + n = n + Mem (p + DS_SIZE) + Mem (p0 + DS_LINK) = Mem (p + DS_LINK) + } + else + Mem (p0 + DS_LINK) = p + + if (q + Mem (q + DS_SIZE) == p0) { + Mem (q + DS_SIZE) = Mem (q + DS_SIZE) + n + Mem (q + DS_LINK) = Mem (p0 + DS_LINK) + } + else { + Mem (q + DS_LINK) = p0 + Mem (p0 + DS_SIZE) = n + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsget.r b/unix/boot/spp/rpp/ratlibr/dsget.r new file mode 100644 index 00000000..4c62ce62 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsget.r @@ -0,0 +1,50 @@ +include defs + +# dsget --- get pointer to block of at least w available words + + pointer function dsget (w) + integer w + + DS_DECL(Mem, 1) + + pointer p, q, l + + integer n, k, junk + integer getlin + + character c (10) + + n = w + DS_OHEAD + q = DS_AVAIL + + repeat { + p = Mem (q + DS_LINK) + if (p == LAMBDA) { + call remark ("in dsget: out of storage space.") + call remark ("type 'c' or 'i' for char or integer dump.") + junk = getlin (c, STDIN) + if (c (1) == LETC | c (1) == BIGC) + call dsdump (LETTER) + else if (c (1) == LETI | c (1) == BIGI) + call dsdump (DIGIT) + call error ("program terminated.") + } + if (Mem (p + DS_SIZE) >= n) + break + q = p + } + + k = Mem (p + DS_SIZE) - n + if (k >= DS_CLOSE) { + Mem (p + DS_SIZE) = k + l = p + k + Mem (l + DS_SIZE) = n + } + else { + Mem (q + DS_LINK) = Mem (p + DS_LINK) + l = p + } + + return (l + DS_OHEAD) + + end diff --git a/unix/boot/spp/rpp/ratlibr/dsinit.r b/unix/boot/spp/rpp/ratlibr/dsinit.r new file mode 100644 index 00000000..926390b3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsinit.r @@ -0,0 +1,29 @@ +include defs + +# dsinit --- initialize dynamic storage space to w words + + subroutine dsinit (w) + integer w + + DS_DECL(Mem, 1) + + pointer t + + if (w < 2 * DS_OHEAD + 2) + call error ("in dsinit: unreasonably small memory size.") + + # set up avail list: + t = DS_AVAIL + Mem (t + DS_SIZE) = 0 + Mem (t + DS_LINK) = DS_AVAIL + DS_OHEAD + + # set up first block of space: + t = DS_AVAIL + DS_OHEAD + Mem (t + DS_SIZE) = w - DS_OHEAD - 1 # -1 for MEMEND + Mem (t + DS_LINK) = LAMBDA + + # record end of memory: + Mem (DS_MEMEND) = w + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/enter.r b/unix/boot/spp/rpp/ratlibr/enter.r new file mode 100644 index 00000000..56a3d46b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/enter.r @@ -0,0 +1,40 @@ +include defs + +# enter --- place a symbol in the symbol table, updating if already present + + subroutine enter (symbol, info, st) + character symbol (ARB) + integer info (ARB) + pointer st + + DS_DECL(Mem, 1) + + integer i, nodsiz, j + integer stlu, length + + pointer node, pred + pointer dsget + + nodsiz = Mem (st) + + if (stlu (symbol, node, pred, st) == NO) { + node = dsget (1 + nodsiz + length (symbol) + 1) + Mem (node + ST_LINK) = LAMBDA + Mem (pred + ST_LINK) = node + i = 1 + j = node + ST_DATA + nodsiz + while (symbol (i) != EOS) { + Mem (j) = symbol (i) + i = i + 1 + j = j + 1 + } + Mem (j) = EOS + } + + for (i = 1; i <= nodsiz; i = i + 1) { + j = node + ST_DATA + i - 1 + Mem (j) = info (i) + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/equal.r b/unix/boot/spp/rpp/ratlibr/equal.r new file mode 100644 index 00000000..0aa24c4c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/equal.r @@ -0,0 +1,15 @@ +include defs + +# equal - compare str1 to str2; return YES if equal, NO if not + + integer function equal (str1, str2) + character str1(ARB), str2(ARB) + + integer i + + for (i = 1; str1 (i) == str2 (i); i = i + 1) + if (str1 (i) == EOS) + return (YES) + + return (NO) + end diff --git a/unix/boot/spp/rpp/ratlibr/error.r b/unix/boot/spp/rpp/ratlibr/error.r new file mode 100644 index 00000000..326a8823 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/error.r @@ -0,0 +1,10 @@ +include defs + +# error - print message and terminate execution + + subroutine error (line) + character line (ARB) + + call remark (line) + call endst + end diff --git a/unix/boot/spp/rpp/ratlibr/errsub.r b/unix/boot/spp/rpp/ratlibr/errsub.r new file mode 100644 index 00000000..6e34195a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/errsub.r @@ -0,0 +1,26 @@ +include defs + +# errsub - see if argument is ERROUT substitution + + integer function errsub (arg, file, access) + + character arg (ARB), file (ARB) + integer access + + if (arg (1) == QMARK & arg (2) != QMARK & arg (2) != EOS) { + errsub = YES + access = WRITE + call scopy (arg, 2, file, 1) + } + + else if (arg (1) == QMARK & arg (2) == QMARK & arg (3) != EOS) { + errsub = YES + access = APPEND + call scopy (arg, 3, file, 1) + } + + else + errsub = NO + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/esc.r b/unix/boot/spp/rpp/ratlibr/esc.r new file mode 100644 index 00000000..bcb0d3a7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/esc.r @@ -0,0 +1,24 @@ +include defs + +# esc - map array (i) into escaped character if appropriate + + character function esc (array, i) + character array (ARB) + integer i + + if (array (i) != ESCAPE) + esc = array (i) + else if (array (i+1) == EOS) # @ not special at end + esc = ESCAPE + else { + i = i + 1 + if (array (i) == LETN | array (i) == BIGN) + esc = NEWLINE + else if (array (i) == LETT | array (i) == BIGT) + esc = TAB + else + esc = array (i) + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fcopy.r b/unix/boot/spp/rpp/ratlibr/fcopy.r new file mode 100644 index 00000000..755f9ad7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/fcopy.r @@ -0,0 +1,16 @@ +include defs + +# fcopy - copy file in to file out + + subroutine fcopy (in, out) + filedes in, out + + character line (MAXLINE) + + integer getlin + + while (getlin (line, in) != EOF) + call putlin (line, out) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/filset.r b/unix/boot/spp/rpp/ratlibr/filset.r new file mode 100644 index 00000000..eba728b9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/filset.r @@ -0,0 +1,35 @@ +include defs + +# filset --- expand set at array (i) into set (j), stop at delim + + subroutine filset (delim, array, i, set, j, maxset) + integer i, j, maxset + character array (ARB), delim, set (maxset) + + character esc + + integer junk + external index + integer addset, index + + string digits "0123456789" + string lowalf "abcdefghijklmnopqrstuvwxyz" + string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + + for ( ; array (i) != delim & array (i) != EOS; i = i + 1) + if (array (i) == ESCAPE) + junk = addset (esc (array, i), set, j, maxset) + else if (array (i) != DASH) + junk = addset (array (i), set, j, maxset) + else if (j <= 1 | array (i + 1) == EOS) # literal - + junk = addset (DASH, set, j, maxset) + else if (index (digits, set (j - 1)) > 0) + call dodash (digits, array, i, set, j, maxset) + else if (index (lowalf, set (j - 1)) > 0) + call dodash (lowalf, array, i, set, j, maxset) + else if (index (upalf, set (j - 1)) > 0) + call dodash (upalf, array, i, set, j, maxset) + else + junk = addset (DASH, set, j, maxset) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fmtdat.r b/unix/boot/spp/rpp/ratlibr/fmtdat.r new file mode 100644 index 00000000..652b6769 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/fmtdat.r @@ -0,0 +1,34 @@ +include defs + +# fmtdat - format date and time information + + subroutine fmtdat(date, time, now, form) + character date(ARB), time(ARB) + integer now(7), form + + # at present, simply return mm/dd/yy and hh:mm:ss + # 'form' is reserved for selecting different formats + # when those have been chosen. + + date(1) = now(2) / 10 + DIG0 + date(2) = mod(now(2), 10) + DIG0 + date(3) = SLASH + date(4) = now(3) / 10 + DIG0 + date(5) = mod(now(3), 10) + DIG0 + date(6) = SLASH + date(7) = mod(now(1), 100) / 10 + DIG0 + date(8) = mod(now(1), 10) + DIG0 + date(9) = EOS + + time(1) = now(4) / 10 + DIG0 + time(2) = mod(now(4), 10) + DIG0 + time(3) = COLON + time(4) = now(5) / 10 + DIG0 + time(5) = mod(now(5), 10) + DIG0 + time(6) = COLON + time(7) = now(6) / 10 + DIG0 + time(8) = mod(now(6), 10) + DIG0 + time(9) = EOS + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fold.r b/unix/boot/spp/rpp/ratlibr/fold.r new file mode 100644 index 00000000..d6530e90 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/fold.r @@ -0,0 +1,16 @@ +include defs + +# fold - fold all letters in a string to lower case + + subroutine fold (token) + character token (ARB) + + character clower + + integer i + + for (i = 1; token (i) != EOS; i = i + 1) + token (i) = clower (token (i)) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fort b/unix/boot/spp/rpp/ratlibr/fort new file mode 100644 index 00000000..e69de29b diff --git a/unix/boot/spp/rpp/ratlibr/gctoi.r b/unix/boot/spp/rpp/ratlibr/gctoi.r new file mode 100644 index 00000000..8efabe4f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/gctoi.r @@ -0,0 +1,58 @@ +include defs + +# gctoi --- convert any radix string to single precision integer + + integer function gctoi (str, i, radix) + character str (ARB) + integer i, radix + + integer base, v, d, j + external index + integer index + + character clower + + logical neg + + string digits "0123456789abcdef" + + v = 0 + base = radix + + while (str (i) == BLANK | str (i) == TAB) + i = i + 1 + + neg = (str (i) == MINUS) + if (str (i) == PLUS | str (i) == MINUS) + i = i + 1 + + if (str (i + 2) == LETR & str (i) == DIG1 & IS_DIGIT(str (i + 1)) + | str (i + 1) == LETR & IS_DIGIT(str (i))) { + base = str (i) - DIG0 + j = i + if (str (i + 1) != LETR) { + j = j + 1 + base = base * 10 + (str (j) - DIG0) + } + if (base < 2 | base > 16) + base = radix + else + i = j + 2 + } + + for (; str (i) != EOS; i = i + 1) { + if (IS_DIGIT(str (i))) + d = str (i) - DIG0 + else + d = index (digits, clower (str (i))) - 1 + if (d < 0 | d >= base) + break + v = v * base + d + } + + if (neg) + return (-v) + else + return (+v) + + end diff --git a/unix/boot/spp/rpp/ratlibr/getc.r b/unix/boot/spp/rpp/ratlibr/getc.r new file mode 100644 index 00000000..afd0fc81 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getc.r @@ -0,0 +1,13 @@ +include defs + +# getc - get character from STDIN + + character function getc (c) + character c + + character getch + + getc = getch (c, STDIN) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/getccl.r b/unix/boot/spp/rpp/ratlibr/getccl.r new file mode 100644 index 00000000..727cc7d6 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getccl.r @@ -0,0 +1,29 @@ +include defs + +# getccl --- expand char class at arg (i) into pat (j) + + integer function getccl (arg, i, pat, j) + character arg (MAXARG), pat (MAXPAT) + integer i, j + + integer jstart, junk + integer addset + + i = i + 1 # skip over [ + if (arg (i) == NOT) { + junk = addset (NCCL, pat, j, MAXPAT) + i = i + 1 + } + else + junk = addset (CCL, pat, j, MAXPAT) + jstart = j + junk = addset (0, pat, j, MAXPAT) # leave room for count + call filset (CCLEND, arg, i, pat, j, MAXPAT) + pat (jstart) = j - jstart - 1 + if (arg (i) == CCLEND) + getccl = OK + else + getccl = ERR + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/getpat.r b/unix/boot/spp/rpp/ratlibr/getpat.r new file mode 100644 index 00000000..ef1dc4a2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getpat.r @@ -0,0 +1,12 @@ +include defs + +# getpat - convert str into pattern + + integer function getpat (str, pat) + character str (ARB), pat (ARB) + + integer makpat + + return (makpat (str, 1, EOS, pat)) + + end diff --git a/unix/boot/spp/rpp/ratlibr/getwrd.r b/unix/boot/spp/rpp/ratlibr/getwrd.r new file mode 100644 index 00000000..ec324af0 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getwrd.r @@ -0,0 +1,25 @@ +include defs + +# getwrd - get non-blank word from in (i) into out, increment i + + integer function getwrd (in, i, out) + character in (ARB), out (ARB) + integer i + + integer j + + while (in (i) == BLANK | in (i) == TAB) + i = i + 1 + + j = 1 + while (in (i) != EOS & in (i) != BLANK + & in (i) != TAB & in (i) != NEWLINE) { + out (j) = in (i) + i = i + 1 + j = j + 1 + } + out (j) = EOS + + getwrd = j - 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibr/gfnarg.r b/unix/boot/spp/rpp/ratlibr/gfnarg.r new file mode 100644 index 00000000..39409592 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/gfnarg.r @@ -0,0 +1,115 @@ +include defs + +# gfnarg --- get the next file name from the argument list + + integer function gfnarg (name, state) + character name (ARB) + integer state (4) + + integer l + integer getarg, getlin + + filedes fd + filedes open + + string in1 "/dev/stdin1" + string in2 "/dev/stdin2" + string in3 "/dev/stdin3" + + repeat { + + if (state (1) == 1) { + state (1) = 2 # new state + state (2) = 1 # next argument + state (3) = ERR # current input file + state (4) = 0 # input file count + } + + else if (state (1) == 2) { + if (getarg (state (2), name, MAXARG) != EOF) { + state (1) = 2 # stay in same state + state (2) = state (2) + 1 # bump argument count + if (name (1) != MINUS) { + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == EOS) { + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == DIG1 & name (3) == EOS) { + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == DIG2 & name (3) == EOS) { + call scopy (in2, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == DIG3 & name (3) == EOS) { + call scopy (in3, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + + else if (name (2) == LETN | name (2) == BIGN) { + state (1) = 3 # new state + if (name (3) == EOS) + state (3) = STDIN + else if (name (3) == DIG1 & name (4) == EOS) + state (3) = STDIN1 + else if (name (3) == DIG2 & name (4) == EOS) + state (3) = STDIN2 + else if (name (3) == DIG3 & name (4) == EOS) + state (3) = STDIN3 + else { + state (3) = open (name (3), READ) + if (state (3) == ERR) { + call putlin (name, ERROUT) + call remark (": can't open.") + state (1) = 2 + } + } + } + else + return (ERR) + } + + else + state (1) = 4 # EOF state + } + + else if (state (1) == 3) { + l = getlin (name, state (3)) + if (l != EOF) { + name (l) = EOS + state (4) = state (4) + 1 # bump input file count + return (OK) + } + if (fd != ERR & fd != STDIN) + call close (state (3)) + state (1) = 2 + } + + else if (state (1) == 4) { + state (1) = 5 + if (state (4) == 0) {# no input files + call scopy (in1, 1, name, 1) + return (OK) + } + break + } + + else if (state (1) == 5) + break + + else + call error ("in gfnarg: bad state (1) value.") + + } # end of infinite repeat + + name (1) = EOS + return (EOF) + end diff --git a/unix/boot/spp/rpp/ratlibr/index.r b/unix/boot/spp/rpp/ratlibr/index.r new file mode 100644 index 00000000..f0693f02 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/index.r @@ -0,0 +1,14 @@ +include defs + +# index - find character c in string str + + integer function index (str, c) + character str (ARB), c + + for (index = 1; str (index) != EOS; index = index + 1) + if (str (index) == c) + return + + index = 0 + return + end diff --git a/unix/boot/spp/rpp/ratlibr/insub.r b/unix/boot/spp/rpp/ratlibr/insub.r new file mode 100644 index 00000000..7d71b95f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/insub.r @@ -0,0 +1,16 @@ +include defs + +# insub - determine if argument is STDIN substitution + + integer function insub (arg, file) + character arg (ARB), file (ARB) + + if (arg (1) == LESS & arg (2) != EOS) { + insub = YES + call scopy (arg, 2, file, 1) + } + else + insub = NO + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/itoc.r b/unix/boot/spp/rpp/ratlibr/itoc.r new file mode 100644 index 00000000..18d8f4bd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/itoc.r @@ -0,0 +1,50 @@ +include defs + +# itoc - convert integer int to char string in str + + integer function itoc (int, str, size) + integer int, size + character str (ARB) + + integer mod + integer d, i, intval, j, k + + # string digits "0123456789" + character digits (11) + data digits (1) /DIG0/, + digits (2) /DIG1/, + digits (3) /DIG2/, + digits (4) /DIG3/, + digits (5) /DIG4/, + digits (6) /DIG5/, + digits (7) /DIG6/, + digits (8) /DIG7/, + digits (9) /DIG8/, + digits (10) /DIG9/, + digits (11) /EOS/ + + intval = iabs (int) + str (1) = EOS + i = 1 + repeat { # generate digits + i = i + 1 + d = mod (intval, 10) + str (i) = digits (d+1) + intval = intval / 10 + } until (intval == 0 | i >= size) + + if (int < 0 & i < size) { # then sign + i = i + 1 + str (i) = MINUS + } + itoc = i - 1 + + for (j = 1; j < i; j = j + 1) { # then reverse + k = str (i) + str (i) = str (j) + str (j) = k + i = i - 1 + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/length.r b/unix/boot/spp/rpp/ratlibr/length.r new file mode 100644 index 00000000..3abb3a81 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/length.r @@ -0,0 +1,12 @@ +include defs + +# length - compute length of string + + integer function length (str) + character str (ARB) + + for (length = 0; str (length+1) != EOS; length = length + 1) + ; + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/locate.r b/unix/boot/spp/rpp/ratlibr/locate.r new file mode 100644 index 00000000..c8d1365b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/locate.r @@ -0,0 +1,17 @@ +include defs + +# locate --- look for c in char class at pat (offset) + + integer function locate (c, pat, offset) + character c, pat (MAXPAT) + integer offset + + integer i + + # size of class is at pat (offset), characters follow + for (i = offset + pat (offset); i > offset; i = i - 1) + if (c == pat (i)) + return (YES) + + return (NO) + end diff --git a/unix/boot/spp/rpp/ratlibr/lookup.r b/unix/boot/spp/rpp/ratlibr/lookup.r new file mode 100644 index 00000000..6cda8f08 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/lookup.r @@ -0,0 +1,30 @@ +include defs + +# lookup --- find a symbol in the symbol table, return its data + + integer function lookup (symbol, info, st) + character symbol (ARB) + integer info (ARB) + pointer st + + DS_DECL(Mem, 1) + + integer i, nodsiz, kluge + integer stlu + + pointer node, pred + + if (stlu (symbol, node, pred, st) == NO) { + lookup = NO + return + } + + nodsiz = Mem (st) + for (i = 1; i <= nodsiz; i = i + 1) { + kluge = node + ST_DATA - 1 + i + info (i) = Mem (kluge) + } + lookup = YES + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/lower.r b/unix/boot/spp/rpp/ratlibr/lower.r new file mode 100644 index 00000000..91161578 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/lower.r @@ -0,0 +1,11 @@ +include defs + +# lower - fold all letters to lower case + + subroutine lower (token) + character token (ARB) + + call fold (token) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/makpat.r b/unix/boot/spp/rpp/ratlibr/makpat.r new file mode 100644 index 00000000..a310ada7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/makpat.r @@ -0,0 +1,70 @@ +include defs + +# makpat --- make pattern from arg (from), terminate at delim + + integer function makpat (arg, from, delim, pat) + character arg (MAXARG), delim, pat (MAXPAT) + integer from + + character esc + + integer i, j, junk, lastcl, lastj, lj, + tagnst, tagnum, tagstk (9) + integer addset, getccl, stclos + + j = 1 # pat index + lastj = 1 + lastcl = 0 + tagnum = 0 + tagnst = 0 + for (i = from; arg (i) != delim & arg (i) != EOS; i = i + 1) { + lj = j + if (arg (i) == ANY) + junk = addset (ANY, pat, j, MAXPAT) + else if (arg (i) == BOL & i == from) + junk = addset (BOL, pat, j, MAXPAT) + else if (arg (i) == EOL & arg (i + 1) == delim) + junk = addset (EOL, pat, j, MAXPAT) + else if (arg (i) == CCL) { + if (getccl (arg, i, pat, j) == ERR) { + makpat = ERR + return + } + } + else if (arg (i) == CLOSURE & i > from) { + lj = lastj + if (pat (lj) == BOL | pat (lj) == EOL | pat (lj) == CLOSURE | + pat (lj) == START_TAG | pat (lj) == STOP_TAG) + break + lastcl = stclos (pat, j, lastj, lastcl) + } + else if (arg (i) == START_TAG) { + if (tagnum >= 9) # too many tagged sub-patterns + break + tagnum = tagnum + 1 + tagnst = tagnst + 1 + tagstk (tagnst) = tagnum + junk = addset (START_TAG, pat, j, MAXPAT) + junk = addset (tagnum, pat, j, MAXPAT) + } + else if (arg (i) == STOP_TAG & tagnst > 0) { + junk = addset (STOP_TAG, pat, j, MAXPAT) + junk = addset (tagstk (tagnst), pat, j, MAXPAT) + tagnst = tagnst - 1 + } + else { + junk = addset (CHAR, pat, j, MAXPAT) + junk = addset (esc (arg, i), pat, j, MAXPAT) + } + lastj = lj + } + if (arg (i) != delim) # terminated early + makpat = ERR + else if (addset (EOS, pat, j, MAXPAT) == NO) # no room + makpat = ERR + else if (tagnst != 0) + makpat = ERR + else + makpat = i + return + end diff --git a/unix/boot/spp/rpp/ratlibr/maksub.r b/unix/boot/spp/rpp/ratlibr/maksub.r new file mode 100644 index 00000000..6dd5e049 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/maksub.r @@ -0,0 +1,34 @@ +include defs + +# maksub --- make substitution string in sub + + integer function maksub (arg, from, delim, sub) + character arg (MAXARG), delim, sub (MAXPAT) + integer from + + character esc, type + + integer i, j, junk + integer addset + + j = 1 + for (i = from; arg (i) != delim & arg (i) != EOS; i = i + 1) + if (arg (i) == AND) { + junk = addset (DITTO, sub, j, MAXPAT) + junk = addset (0, sub, j, MAXPAT) + } + else if (arg (i) == ESCAPE & type (arg (i + 1)) == DIGIT) { + i = i + 1 + junk = addset (DITTO, sub, j, MAXPAT) + junk = addset (arg (i) - DIG0, sub, j, MAXPAT) + } + else + junk = addset (esc (arg, i), sub, j, MAXPAT) + if (arg (i) != delim) # missing delimiter + maksub = ERR + else if (addset (EOS, sub, j, MAXPAT) == NO) # no room + maksub = ERR + else + maksub = i + return + end diff --git a/unix/boot/spp/rpp/ratlibr/match.r b/unix/boot/spp/rpp/ratlibr/match.r new file mode 100644 index 00000000..c708f4cd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/match.r @@ -0,0 +1,18 @@ +include defs + +# match --- find match anywhere on line + + integer function match (lin, pat) + character lin (MAXLINE), pat (MAXPAT) + + integer i, junk (9) + integer amatch + + for (i = 1; lin (i) != EOS; i = i + 1) + if (amatch (lin, i, pat, junk, junk) > 0) { + match = YES + return + } + match = NO + return + end diff --git a/unix/boot/spp/rpp/ratlibr/mktabl.r b/unix/boot/spp/rpp/ratlibr/mktabl.r new file mode 100644 index 00000000..9269b18c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/mktabl.r @@ -0,0 +1,24 @@ +include defs + +# mktabl --- make a new (empty) symbol table + + pointer function mktabl (nodsiz) + integer nodsiz + + DS_DECL(Mem, 1) + + pointer st + pointer dsget + + integer i + + st = dsget (ST_HTABSIZE + 1) # +1 for record of nodsiz + Mem (st) = nodsiz + mktabl = st + do i = 1, ST_HTABSIZE; { + st = st + 1 + Mem (st) = LAMBDA # null link + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/mntoc.r b/unix/boot/spp/rpp/ratlibr/mntoc.r new file mode 100644 index 00000000..55d3fedd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/mntoc.r @@ -0,0 +1,74 @@ +include defs + +# mntoc --- translate ASCII mnemonic into a character + + character function mntoc (buf, p, defalt) + character buf (ARB), defalt + integer p + + integer i, tp + integer equal + + character c, tmp (MAXLINE) + + character text (170) + data text / _ + ACK, LETA, LETC, LETK, EOS, + BEL, LETB, LETE, LETL, EOS, + BS, LETB, LETS, EOS, EOS, + CAN, LETC, LETA, LETN, EOS, + CR, LETC, LETR, EOS, EOS, + DC1, LETD, LETC, DIG1, EOS, + DC2, LETD, LETC, DIG2, EOS, + DC3, LETD, LETC, DIG3, EOS, + DC4, LETD, LETC, DIG4, EOS, + DEL, LETD, LETE, LETL, EOS, + DLE, LETD, LETL, LETE, EOS, + EM, LETE, LETM, EOS, EOS, + ENQ, LETE, LETN, LETQ, EOS, + EOT, LETE, LETO, LETT, EOS, + ESC, LETE, LETS, LETC, EOS, + ETB, LETE, LETT, LETB, EOS, + ETX, LETE, LETT, LETX, EOS, + FF, LETF, LETF, EOS, EOS, + FS, LETF, LETS, EOS, EOS, + GS, LETG, LETS, EOS, EOS, + HT, LETH, LETT, EOS, EOS, + LF, LETL, LETF, EOS, EOS, + NAK, LETN, LETA, LETK, EOS, + NUL, LETN, LETU, LETL, EOS, + RS, LETR, LETS, EOS, EOS, + SI, LETS, LETI, EOS, EOS, + SO, LETS, LETO, EOS, EOS, + SOH, LETS, LETO, LETH, EOS, + SP, LETS, LETP, EOS, EOS, + STX, LETS, LETT, LETX, EOS, + SUB, LETS, LETU, LETB, EOS, + SYN, LETS, LETY, LETN, EOS, + US, LETU, LETS, EOS, EOS, + VT, LETV, LETT, EOS, EOS/ + + tp = 1 + repeat { + tmp (tp) = buf (p) + tp = tp + 1 + p = p + 1 + } until (! (IS_LETTER(buf (p)) | IS_DIGIT(buf (p))) + | tp >= MAXLINE) + tmp (tp) = EOS + + if (tp == 2) + c = tmp (1) + else { + call lower (tmp) + for (i = 1; i < 170; i = i + 5) # should use binary search here + if (equal (tmp, text (i + 1)) == YES) + break + if (i < 170) + c = text (i) + else + c = defalt + } + + return (c) + end diff --git a/unix/boot/spp/rpp/ratlibr/omatch.r b/unix/boot/spp/rpp/ratlibr/omatch.r new file mode 100644 index 00000000..598a4e24 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/omatch.r @@ -0,0 +1,48 @@ +include defs + +# omatch --- try to match a single pattern at pat (j) + + integer function omatch (lin, i, pat, j) + character lin (MAXLINE), pat (MAXPAT) + integer i, j + + integer bump + integer locate + + omatch = NO + if (lin (i) == EOS) + return + bump = -1 + if (pat (j) == CHAR) { + if (lin (i) == pat (j + 1)) + bump = 1 + } + else if (pat (j) == BOL) { + if (i == 1) + bump = 0 + } + else if (pat (j) == ANY) { + if (lin (i) != NEWLINE) + bump = 1 + } + else if (pat (j) == EOL) { + if (lin (i) == NEWLINE) + bump = 0 + } + else if (pat (j) == CCL) { + if (locate (lin (i), pat, j + 1) == YES) + bump = 1 + } + else if (pat (j) == NCCL) { + if (lin (i) != NEWLINE & locate (lin (i), pat, j + 1) == NO) + bump = 1 + } + else + call error ("in omatch: can't happen.") + if (bump >= 0) { + i = i + bump + omatch = YES + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/outsub.r b/unix/boot/spp/rpp/ratlibr/outsub.r new file mode 100644 index 00000000..ac657efe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/outsub.r @@ -0,0 +1,25 @@ +include defs + +# outsub - determine if argument is STDOUT substitution + + integer function outsub (arg, file, access) + character arg (ARB), file (ARB) + integer access + + if (arg (1) == GREATER & arg (2) != GREATER & arg (2) != EOS) { + outsub = YES + access = WRITE + call scopy (arg, 2, file, 1) + } + + else if (arg (1) == GREATER & arg (2) == GREATER & arg (3) != EOS) { + access = APPEND + outsub = YES + call scopy (arg, 3, file, 1) + } + + else + outsub = NO + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/patsiz.r b/unix/boot/spp/rpp/ratlibr/patsiz.r new file mode 100644 index 00000000..54265b64 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/patsiz.r @@ -0,0 +1,21 @@ +include defs + +# patsiz --- returns size of pattern entry at pat (n) + + integer function patsiz (pat, n) + character pat (MAXPAT) + integer n + + if (pat (n) == CHAR | pat (n) == START_TAG | pat (n) == STOP_TAG) + patsiz = 2 + else if (pat (n) == BOL | pat (n) == EOL | pat (n) == ANY) + patsiz = 1 + else if (pat (n) == CCL | pat (n) == NCCL) + patsiz = pat (n + 1) + 2 + else if (pat (n) == CLOSURE) # optional + patsiz = CLOSIZE + else + call error ("in patsiz: can't happen.") + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/prompt.r b/unix/boot/spp/rpp/ratlibr/prompt.r new file mode 100644 index 00000000..2648993c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/prompt.r @@ -0,0 +1,19 @@ +include defs + +# prompt - write to/read from teletype + + subroutine prompt (str, buf, fd) + character str(ARB), buf(ARB) + filedes fd + + integer isatty + + if (isatty(fd) == YES) + { + call putlin (str, fd) + call flush (fd) + } + call getlin (buf, fd) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putc.r b/unix/boot/spp/rpp/ratlibr/putc.r new file mode 100644 index 00000000..3ba16c13 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putc.r @@ -0,0 +1,11 @@ +include defs + +# putc - put character onto STDOUT + + subroutine putc (c) + character c + + call putch (c, STDOUT) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putdec.r b/unix/boot/spp/rpp/ratlibr/putdec.r new file mode 100644 index 00000000..6f7bb195 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putdec.r @@ -0,0 +1,20 @@ +include defs + +# putdec - put decimal integer n in field width >= w + + subroutine putdec(n,w) + integer n, w + + character chars (MAXCHARS) + + integer i, nd + integer itoc + + nd = itoc (n, chars, MAXCHARS) + for (i = nd + 1; i <= w; i = i + 1) + call putc (BLANK) + for (i = 1; i <= nd; i = i + 1) + call putc (chars (i)) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putint.r b/unix/boot/spp/rpp/ratlibr/putint.r new file mode 100644 index 00000000..0fed044b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putint.r @@ -0,0 +1,18 @@ +include defs + +# putint - output integer in specified field + + subroutine putint (n, w, fd) + integer n, w + filedes fd + + character chars (MAXCHARS) + + integer junk + integer itoc + + junk = itoc (n, chars, MAXCHARS) + call putstr (chars, w, fd) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putstr.r b/unix/boot/spp/rpp/ratlibr/putstr.r new file mode 100644 index 00000000..497e34d9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putstr.r @@ -0,0 +1,23 @@ +include defs + +# putstr - output character string in specified field + + subroutine putstr (str, w, fd) + character str (ARB) + integer w + filedes fd + + character length + + integer i, len + + len = length (str) + for (i = len + 1; i <= w; i = i + 1) + call putch (BLANK, fd) + for (i = 1; i <= len; i = i + 1) + call putch (str (i), fd) + for (i = (-w) - len; i > 0; i = i - 1) + call putch (BLANK, fd) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/query.r b/unix/boot/spp/rpp/ratlibr/query.r new file mode 100644 index 00000000..80e049be --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/query.r @@ -0,0 +1,17 @@ +include defs + +# query - print usage message if user has requested one + + subroutine query (mesg) + character mesg (ARB) + + integer getarg + + character arg1 (3), arg2 (1) + + if (getarg (1, arg1, 3) != EOF & getarg (2, arg2, 1) == EOF) + if (arg1 (1) == QMARK & arg1 (2) == EOS) + call error (mesg) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/rmtabl.r b/unix/boot/spp/rpp/ratlibr/rmtabl.r new file mode 100644 index 00000000..16a5d3d5 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/rmtabl.r @@ -0,0 +1,27 @@ +include defs + +# rmtabl --- remove a symbol table, deleting all entries + + subroutine rmtabl (st) + pointer st + + DS_DECL(Mem, 1) + + integer i + + pointer walker, bucket, node + + bucket = st + do i = 1, ST_HTABSIZE; { + bucket = bucket + 1 + walker = Mem (bucket) + while (walker != LAMBDA) { + node = walker + walker = Mem (node + ST_LINK) + call dsfree (node) + } + } + + call dsfree (st) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/scopy.r b/unix/boot/spp/rpp/ratlibr/scopy.r new file mode 100644 index 00000000..0878f45a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/scopy.r @@ -0,0 +1,19 @@ +include defs + +# scopy - copy string at from (i) to to (j) + + subroutine scopy (from, i, to, j) + character from (ARB), to (ARB) + integer i, j + + integer k1, k2 + + k2 = j + for (k1 = i; from (k1) != EOS; k1 = k1 + 1) { + to (k2) = from (k1) + k2 = k2 + 1 + } + to (k2) = EOS + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/sctabl.r b/unix/boot/spp/rpp/ratlibr/sctabl.r new file mode 100644 index 00000000..73b0b308 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/sctabl.r @@ -0,0 +1,59 @@ +include defs + +# sctabl --- scan symbol table, returning next entry or EOF + + integer function sctabl (table, sym, info, posn) + pointer table, posn + character sym (ARB) + integer info (ARB) + + DS_DECL(Mem, 1) + + pointer bucket, walker + pointer dsget + + integer nodsiz, i, j + + if (posn == 0) { # just starting scan? + posn = dsget (2) # get space for position info + Mem (posn) = 1 # get index of first bucket + Mem (posn + 1) = Mem (table + 1) # get pointer to first chain + } + + bucket = Mem (posn) # recover previous position + walker = Mem (posn + 1) + nodsiz = Mem (table) + + repeat { # until the next symbol, or none are left + if (walker != LAMBDA) { # symbol available? + i = walker + ST_DATA + nodsiz + j = 1 + while (Mem (i) != EOS) { + sym (j) = Mem (i) + i = i + 1 + j = j + 1 + } + sym (j) = EOS + for (i = 1; i <= nodsiz; i = i + 1) { + j = walker + ST_DATA + i - 1 + info (i) = Mem (j) + } + Mem (posn) = bucket # save position of next symbol + Mem (posn + 1) = Mem (walker + ST_LINK) + sctabl = 1 # not EOF + return + } + else { + bucket = bucket + 1 + if (bucket > ST_HTABSIZE) + break + j = table + bucket + walker = Mem (j) + } + } + + call dsfree (posn) # throw away position information + posn = 0 + sctabl = EOF + return + end diff --git a/unix/boot/spp/rpp/ratlibr/sdrop.r b/unix/boot/spp/rpp/ratlibr/sdrop.r new file mode 100644 index 00000000..fb3169cd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/sdrop.r @@ -0,0 +1,20 @@ +include defs + +# sdrop --- drop characters from a string APL-style + + integer function sdrop (from, to, chars) + character from (ARB), to (ARB) + integer chars + + integer len, start + integer ctoc, length, min0 + + len = length (from) + if (chars < 0) + return (ctoc (from, to, len + chars + 1)) + else { + start = min0 (chars, len) + return (ctoc (from (start + 1), to, len + 1)) + } + + end diff --git a/unix/boot/spp/rpp/ratlibr/skipbl.r b/unix/boot/spp/rpp/ratlibr/skipbl.r new file mode 100644 index 00000000..9058d09b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/skipbl.r @@ -0,0 +1,13 @@ +include defs + +# skipbl - skip blanks and tabs at lin(i) + + subroutine skipbl(lin, i) + character lin(ARB) + integer i + + while (lin (i) == BLANK | lin (i) == TAB) + i = i + 1 + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/slstr.r b/unix/boot/spp/rpp/ratlibr/slstr.r new file mode 100644 index 00000000..92d82123 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/slstr.r @@ -0,0 +1,36 @@ +include defs + +# slstr --- slice a substring from a string + + integer function slstr (from, to, first, chars) + character from (ARB), to (ARB) + integer first, chars + + integer len, i, j, k + integer length + + len = length (from) + + i = first + if (i < 1) + i = i + len + 1 + + if (chars < 0) { + i = i + chars + 1 + chars = - chars + } + + j = i + chars - 1 + if (i < 1) + i = 1 + if (j > len) + j = len + + for (k = 0; i <= j; k = k + 1) { + to (k + 1) = from (i) + i = i + 1 + } + to (k + 1) = EOS + + return (k) + end diff --git a/unix/boot/spp/rpp/ratlibr/stake.r b/unix/boot/spp/rpp/ratlibr/stake.r new file mode 100644 index 00000000..52a9a096 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stake.r @@ -0,0 +1,20 @@ +include defs + +# stake --- take characters from a string APL-style + + integer function stake (from, to, chars) + character from (ARB), to (ARB) + integer chars + + integer len, start + integer length, ctoc, max0 + + len = length (from) + if (chars < 0) { + start = max0 (len + chars, 0) + return (ctoc (from (start + 1), to, len + 1)) + } + else + return (ctoc (from, to, chars + 1)) + + end diff --git a/unix/boot/spp/rpp/ratlibr/stclos.r b/unix/boot/spp/rpp/ratlibr/stclos.r new file mode 100644 index 00000000..37cac0c5 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stclos.r @@ -0,0 +1,24 @@ +include defs + +# stclos --- insert closure entry at pat (j) + + integer function stclos (pat, j, lastj, lastcl) + character pat (MAXPAT) + integer j, lastj, lastcl + + integer addset + integer jp, jt, junk + + for (jp = j - 1; jp >= lastj; jp = jp - 1) { # make a hole + jt = jp + CLOSIZE + junk = addset (pat (jp), pat, jt, MAXPAT) + } + j = j + CLOSIZE + stclos = lastj + junk = addset (CLOSURE, pat, lastj, MAXPAT) # put closure in it + junk = addset (0, pat, lastj, MAXPAT) # COUNT + junk = addset (lastcl, pat, lastj, MAXPAT) # PREVCL + junk = addset (0, pat, lastj, MAXPAT) # START + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/stcopy.r b/unix/boot/spp/rpp/ratlibr/stcopy.r new file mode 100644 index 00000000..5c5b2396 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stcopy.r @@ -0,0 +1,17 @@ +include defs + +# stcopy - copy string from in (i) to out (j), updating j, excluding EOS + + subroutine stcopy (in, i, out, j) + character in (ARB), out (ARB) + integer i, j + + integer k + + for (k = i; in (k) != EOS; k = k + 1) { + out (j) = in (k) + j = j + 1 + } + out(j) = EOS + return + end diff --git a/unix/boot/spp/rpp/ratlibr/stlu.r b/unix/boot/spp/rpp/ratlibr/stlu.r new file mode 100644 index 00000000..2f173b1c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stlu.r @@ -0,0 +1,36 @@ +include defs + +# stlu --- symbol table lookup primitive + + integer function stlu (symbol, node, pred, st) + character symbol (ARB) + pointer node, pred, st + + DS_DECL(Mem, 1) + + integer hash, i, j, nodsiz + + nodsiz = Mem (st) + + hash = 0 + for (i = 1; symbol (i) != EOS; i = i + 1) + hash = hash + symbol (i) + hash = mod (hash, ST_HTABSIZE) + 1 + + pred = st + hash + node = Mem (pred) + while (node != LAMBDA) { + i = 1 + j = node + ST_DATA + nodsiz + while (symbol (i) == Mem (j)) { + if (symbol (i) == EOS) + return (YES) + i = i + 1 + j = j + 1 + } + pred = node + node = Mem (pred + ST_LINK) + } + + return (NO) + end diff --git a/unix/boot/spp/rpp/ratlibr/strcmp.r b/unix/boot/spp/rpp/ratlibr/strcmp.r new file mode 100644 index 00000000..9bc12c6a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/strcmp.r @@ -0,0 +1,24 @@ +include defs + +# strcmp - compare 2 strings; return -1 if <, 0 if =, +1 if > + + integer function strcmp (str1, str2) + character str1 (ARB), str2 (ARB) + + integer i + + for (i = 1; str1 (i) == str2 (i); i = i + 1) + if (str1 (i) == EOS) + return (0) + + if (str1 (i) == EOS) + strcmp = -1 + else if (str2 (i) == EOS) + strcmp = + 1 + else if (str1 (i) < str2 (i)) + strcmp = -1 + else + strcmp = +1 + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/strim.r b/unix/boot/spp/rpp/ratlibr/strim.r new file mode 100644 index 00000000..ed082ef2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/strim.r @@ -0,0 +1,18 @@ +include defs + +# strim --- trim trailing blanks and tabs from a string + + integer function strim (str) + character str (ARB) + + integer lnb, i + + lnb = 0 + for (i = 1; str (i) != EOS; i = i + 1) + if (str (i) != BLANK & str (i) != TAB) + lnb = i + + str (lnb + 1) = EOS + return (lnb) + + end diff --git a/unix/boot/spp/rpp/ratlibr/termin.r b/unix/boot/spp/rpp/ratlibr/termin.r new file mode 100644 index 00000000..0eb0c78b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/termin.r @@ -0,0 +1,12 @@ +include defs + +# termin - pick up name of input channel to users teletype + + subroutine termin (name) + character name (ARB) + + string tname TERMINAL_IN + + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/trmout.r b/unix/boot/spp/rpp/ratlibr/trmout.r new file mode 100644 index 00000000..672bc0fe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/trmout.r @@ -0,0 +1,12 @@ +include defs + +# trmout - pick up name of output channel to users teletype + + subroutine trmout (name) + character name (ARB) + + string tname TERMINAL_OUT + + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/type.r b/unix/boot/spp/rpp/ratlibr/type.r new file mode 100644 index 00000000..c98c9655 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/type.r @@ -0,0 +1,99 @@ +include defs + +# type - determine type of character + + character function type (c) + + character c + + if ((LETA <= c & c <= LETZ) | (BIGA <= c & c <= BIGZ)) + type = LETTER + else if (DIG0 <= c & c <= DIG9) + type = DIGIT + else + type = c + + # The original version used a table look-up; you'll have to + # use that method if you have subverted the convention to + # use ASCII characters internally: + # integer index + # character digits(11), lowalf(27), upalf(27) + # data digits(1) /DIG0/ + # data digits(2) /DIG1/ + # data digits(3) /DIG2/ + # data digits(4) /DIG3/ + # data digits(5) /DIG4/ + # data digits(6) /DIG5/ + # data digits(7) /DIG6/ + # data digits(8) /DIG7/ + # data digits(9) /DIG8/ + # data digits(10) /DIG9/ + # data digits(11) /EOS/ + # + # data lowalf(1) /LETA/ + # data lowalf(2) /LETB/ + # data lowalf(3) /LETC/ + # data lowalf(4) /LETD/ + # data lowalf(5) /LETE/ + # data lowalf(6) /LETF/ + # data lowalf(7) /LETG/ + # data lowalf(8) /LETH/ + # data lowalf(9) /LETI/ + # data lowalf(10) /LETJ/ + # data lowalf(11) /LETK/ + # data lowalf(12) /LETL/ + # data lowalf(13) /LETM/ + # data lowalf(14) /LETN/ + # data lowalf(15) /LETO/ + # data lowalf(16) /LETP/ + # data lowalf(17) /LETQ/ + # data lowalf(18) /LETR/ + # data lowalf(19) /LETS/ + # data lowalf(20) /LETT/ + # data lowalf(21) /LETU/ + # data lowalf(22) /LETV/ + # data lowalf(23) /LETW/ + # data lowalf(24) /LETX/ + # data lowalf(25) /LETY/ + # data lowalf(26) /LETZ/ + # data lowalf(27) /EOS/ + # + # data upalf(1) /BIGA/ + # data upalf(2) /BIGB/ + # data upalf(3) /BIGC/ + # data upalf(4) /BIGD/ + # data upalf(5) /BIGE/ + # data upalf(6) /BIGF/ + # data upalf(7) /BIGG/ + # data upalf(8) /BIGH/ + # data upalf(9) /BIGI/ + # data upalf(10) /BIGJ/ + # data upalf(11) /BIGK/ + # data upalf(12) /BIGL/ + # data upalf(13) /BIGM/ + # data upalf(14) /BIGN/ + # data upalf(15) /BIGO/ + # data upalf(16) /BIGP/ + # data upalf(17) /BIGQ/ + # data upalf(18) /BIGR/ + # data upalf(19) /BIGS/ + # data upalf(20) /BIGT/ + # data upalf(21) /BIGU/ + # data upalf(23) /BIGW/ + # data upalf(24) /BIGX/ + # data upalf(25) /BIGY/ + # data upalf(26) /BIGZ/ + # data upalf(27) /EOS/ + # + # if (index(lowalf, c) > 0) + # type = LETTER + # else if (index(upalf,c) >0) + # type = LETTER + # else if (index(digits,c) > 0) + # type = DIGIT + # else + # type = c + + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/upper.r b/unix/boot/spp/rpp/ratlibr/upper.r new file mode 100644 index 00000000..0fc337bb --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/upper.r @@ -0,0 +1,16 @@ +include defs + +# upper - fold all alphas to upper case + + subroutine upper (token) + character token (ARB) + + character cupper + + integer i + + for (i = 1; token (i) != EOS; i = i + 1) + token (i) = cupper (token (i)) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/wkday.r b/unix/boot/spp/rpp/ratlibr/wkday.r new file mode 100644 index 00000000..027d14a2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/wkday.r @@ -0,0 +1,23 @@ +include defs + +# wkday --- get day-of-week corresponding to month,day,year + + integer function wkday (month, day, year) + integer month, day, year + + integer lmonth, lday, lyear + + lmonth = month - 2 + lday = day + lyear = year + + if (lmonth <= 0) { + lmonth = lmonth + 12 + lyear = lyear - 1 + } + + wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 34, + 7) + 1 + + return + end diff --git a/unix/boot/spp/rpp/rpp.c b/unix/boot/spp/rpp/rpp.c new file mode 100644 index 00000000..b9215a9d --- /dev/null +++ b/unix/boot/spp/rpp/rpp.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratlibc/ratdef.h" + +int xargc; +char **xargv; + +extern int INITST (void); +extern int RATFOR (void); +extern int ENDST (void); + + +/* RPP -- Second pass of the SPP preprocessor. Converts a Ratfor like + * input language into Fortran. RPP differs from standard tools ratfor + * in a number of ways. Its input language is the output of XPP and + * contains tokens not intended for use in any programming language. + * Support is provided for SPP language features, and the output fortran + * is pretty-printed. + */ +int main (int argc, char *argv[]) +{ + xargc = argc; + xargv = argv; + + INITST(); + RATFOR(); + ENDST(); + + return (0); +} diff --git a/unix/boot/spp/rpp/rppfor/README b/unix/boot/spp/rpp/rppfor/README new file mode 100644 index 00000000..74fcacdc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/README @@ -0,0 +1 @@ +RPP/RPPFOR -- Fortran source for the RPP program. diff --git a/unix/boot/spp/rpp/rppfor/addchr.f b/unix/boot/spp/rpp/rppfor/addchr.f new file mode 100644 index 00000000..f5ed486c --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/addchr.f @@ -0,0 +1,10 @@ + subroutine addchr (c, buf, bp, maxsiz) + integer bp, maxsiz + integer c, buf (100) + if (.not.(bp .gt. maxsiz))goto 23000 + call baderr (16Hbuffer overflow.) +23000 continue + buf (bp) = c + bp = bp + 1 + return + end diff --git a/unix/boot/spp/rpp/rppfor/allblk.f b/unix/boot/spp/rpp/rppfor/allblk.f new file mode 100644 index 00000000..235267a5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/allblk.f @@ -0,0 +1,15 @@ + integer function allblk (buf) + integer buf (100) + integer i + allblk = 1 + i = 1 +23000 if (.not.(buf (i) .ne. 10 .and. buf (i) .ne. -2))goto 23002 + if (.not.(buf (i) .ne. 32))goto 23003 + allblk = 0 + goto 23002 +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/alldig.f b/unix/boot/spp/rpp/rppfor/alldig.f new file mode 100644 index 00000000..d922e37f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/alldig.f @@ -0,0 +1,18 @@ + integer function alldig (str) + integer str (100) + integer i + alldig = 0 + if (.not.(str (1) .eq. -2))goto 23000 + return +23000 continue + i = 1 +23002 if (.not.(str (i) .ne. -2))goto 23004 + if (.not.(.not.(48.le.str (i).and.str (i).le.57)))goto 23005 + return +23005 continue +23003 i = i + 1 + goto 23002 +23004 continue + alldig = 1 + return + end diff --git a/unix/boot/spp/rpp/rppfor/baderr.f b/unix/boot/spp/rpp/rppfor/baderr.f new file mode 100644 index 00000000..8b6564f5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/baderr.f @@ -0,0 +1,5 @@ + subroutine baderr (msg) + integer msg (100) + call synerr (msg) + call endst + end diff --git a/unix/boot/spp/rpp/rppfor/balpar.f b/unix/boot/spp/rpp/rppfor/balpar.f new file mode 100644 index 00000000..2c2b67c9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/balpar.f @@ -0,0 +1,41 @@ + subroutine balpar + integer t, token (100) + integer gettok, gnbtok + integer nlpar + if (.not.(gnbtok (token, 100) .ne. 40))goto 23000 + call synerr (19Hmissing left paren.) + return +23000 continue + call outstr (token) + nlpar = 1 +23002 continue + t = gettok (token, 100) + if (.not.(t .eq. 59 .or. t .eq. 123 .or. t .eq. 125 .or. t .eq. -1 + *))goto 23005 + call pbstr (token) + goto 23004 +23005 continue + if (.not.(t .eq. 10))goto 23007 + token (1) = -2 + goto 23008 +23007 continue + if (.not.(t .eq. 40))goto 23009 + nlpar = nlpar + 1 + goto 23010 +23009 continue + if (.not.(t .eq. 41))goto 23011 + nlpar = nlpar - 1 +23011 continue +23010 continue +23008 continue + if (.not.(t .eq. -9))goto 23013 + call squash (token) +23013 continue + call outstr (token) +23003 if (.not.(nlpar .le. 0))goto 23002 +23004 continue + if (.not.(nlpar .ne. 0))goto 23015 + call synerr (33Hmissing parenthesis in condition.) +23015 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/beginc.f b/unix/boot/spp/rpp/rppfor/beginc.f new file mode 100644 index 00000000..bf6dd872 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/beginc.f @@ -0,0 +1,72 @@ + subroutine beginc + integer labgen + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + body = 1 + ername = 0 + esp = 0 + label = 100 + retlab = labgen (1) + logic0 = 6 + 3 + col = logic0 + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/brknxt.f b/unix/boot/spp/rpp/rppfor/brknxt.f new file mode 100644 index 00000000..7bc70a77 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/brknxt.f @@ -0,0 +1,108 @@ + subroutine brknxt (sp, lextyp, labval, token) + integer labval (100), lextyp (100), sp, token + integer i, n + integer alldig, ctoi + integer t, ptoken (100) + integer gnbtok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + n = 0 + t = gnbtok (ptoken, 100) + if (.not.(alldig (ptoken) .eq. 1))goto 23000 + i = 1 + n = ctoi (ptoken, i) - 1 + goto 23001 +23000 continue + if (.not.(t .ne. 59))goto 23002 + call pbstr (ptoken) +23002 continue +23001 continue + i = sp +23004 if (.not.(i .gt. 0))goto 23006 + if (.not.(lextyp (i) .eq. -95 .or. lextyp (i) .eq. -96 .or. lextyp + * (i) .eq. -94 .or. lextyp (i) .eq. -93))goto 23007 + if (.not.(n .gt. 0))goto 23009 + n = n - 1 + goto 23005 +23009 continue + if (.not.(token .eq. -79))goto 23011 + call outgo (labval (i) + 1) + goto 23012 +23011 continue + call outgo (labval (i)) +23012 continue +23010 continue + xfer = 1 + return +23007 continue +23005 i = i - 1 + goto 23004 +23006 continue + if (.not.(token .eq. -79))goto 23013 + call synerr (14Hillegal break.) + goto 23014 +23013 continue + call synerr (13Hillegal next.) +23014 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/cascod.f b/unix/boot/spp/rpp/rppfor/cascod.f new file mode 100644 index 00000000..e6b256fe --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/cascod.f @@ -0,0 +1,146 @@ + subroutine cascod (lab, token) + integer lab, token + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, l, lb, ub, i, j, junk + integer caslab, labgen, gnbtok + integer tok (100) + if (.not.(swtop .le. 0))goto 23000 + call synerr (24Hillegal case or default.) + return +23000 continue + call indent (-1) + call outgo (lab + 1) + xfer = 1 + l = labgen (1) + if (.not.(token .eq. -91))goto 23002 +23004 if (.not.(caslab (lb, t) .ne. -1))goto 23005 + ub = lb + if (.not.(t .eq. 45))goto 23006 + junk = caslab (ub, t) +23006 continue + if (.not.(lb .gt. ub))goto 23008 + call synerr (28Hillegal range in case label.) + ub = lb +23008 continue + if (.not.(swlast + 3 .gt. 1000))goto 23010 + call baderr (22Hswitch table overflow.) +23010 continue + i = swtop + 3 +23012 if (.not.(i .lt. swlast))goto 23014 + if (.not.(lb .le. swstak (i)))goto 23015 + goto 23014 +23015 continue + if (.not.(lb .le. swstak (i+1)))goto 23017 + call synerr (21Hduplicate case label.) +23017 continue +23016 continue +23013 i = i + 3 + goto 23012 +23014 continue + if (.not.(i .lt. swlast .and. ub .ge. swstak (i)))goto 23019 + call synerr (21Hduplicate case label.) +23019 continue + j = swlast +23021 if (.not.(j .gt. i))goto 23023 + swstak (j+2) = swstak (j-1) +23022 j = j - 1 + goto 23021 +23023 continue + swstak (i) = lb + swstak (i + 1) = ub + swstak (i + 2) = l + swstak (swtop + 1) = swstak (swtop + 1) + 1 + swlast = swlast + 3 + if (.not.(t .eq. 58))goto 23024 + goto 23005 +23024 continue + if (.not.(t .ne. 44))goto 23026 + call synerr (20Hillegal case syntax.) +23026 continue +23025 continue + goto 23004 +23005 continue + goto 23003 +23002 continue + t = gnbtok (tok, 100) + if (.not.(swstak (swtop + 2) .ne. 0))goto 23028 + call error (38Hmultiple defaults in switch statement.) + goto 23029 +23028 continue + swstak (swtop + 2) = l +23029 continue +23003 continue + if (.not.(t .eq. -1))goto 23030 + call synerr (15Hunexpected EOF.) + goto 23031 +23030 continue + if (.not.(t .ne. 58))goto 23032 + call error (39Hmissing colon in case or default label.) +23032 continue +23031 continue + xfer = 0 + call outcon (l) + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/caslab.f b/unix/boot/spp/rpp/rppfor/caslab.f new file mode 100644 index 00000000..0262fadc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/caslab.f @@ -0,0 +1,54 @@ + integer function caslab (n, t) + integer n, t + integer tok(100) + integer i, s, lev + integer gnbtok, ctoi + caslab=0 + t = gnbtok (tok, 100) +23000 if (.not.(t .eq. 10))goto 23001 + t = gnbtok (tok, 100) + goto 23000 +23001 continue + if (.not.(t .eq. -1))goto 23002 + caslab=(t) + return +23002 continue + lev=0 +23004 if (.not.(t .eq. 40))goto 23006 + lev = lev + 1 +23005 t = gnbtok (tok, 100) + goto 23004 +23006 continue + if (.not.(t .eq. 45))goto 23007 + s = -1 + goto 23008 +23007 continue + s = +1 +23008 continue + if (.not.(t .eq. 45 .or. t .eq. 43))goto 23009 + t = gnbtok (tok, 100) +23009 continue + if (.not.(t .ne. 48))goto 23011 + goto 99 +c goto 23012 +23011 continue + i = 1 + n = s * ctoi (tok, i) +23012 continue + t=gnbtok(tok,100) +23013 if (.not.(t .eq. 41))goto 23015 + lev = lev - 1 +23014 t=gnbtok(tok,100) + goto 23013 +23015 continue + if (.not.(lev .ne. 0))goto 23016 + goto 99 +23016 continue +23018 if (.not.(t .eq. 10))goto 23019 + t = gnbtok (tok, 100) + goto 23018 +23019 continue + return +99 call synerr (19HInvalid case label.) + n = 0 + end diff --git a/unix/boot/spp/rpp/rppfor/declco.f b/unix/boot/spp/rpp/rppfor/declco.f new file mode 100644 index 00000000..683bd901 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/declco.f @@ -0,0 +1,120 @@ + subroutine declco (id) + integer id(100) + integer newid(100), tok, tokbl + integer junk, ludef, equal, gettok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer xptyp(9) + integer xpntr(7) + integer xfunc(7) + integer xsubr(7) + data xptyp(1)/105/,xptyp(2)/110/,xptyp(3)/116/,xptyp(4)/101/,xptyp + *(5)/103/,xptyp(6)/101/,xptyp(7)/114/,xptyp(8)/32/,xptyp(9)/-2/ + data xpntr(1)/120/,xpntr(2)/36/,xpntr(3)/112/,xpntr(4)/110/,xpntr( + *5)/116/,xpntr(6)/114/,xpntr(7)/-2/ + data xfunc(1)/120/,xfunc(2)/36/,xfunc(3)/102/,xfunc(4)/117/,xfunc( + *5)/110/,xfunc(6)/99/,xfunc(7)/-2/ + data xsubr(1)/120/,xsubr(2)/36/,xsubr(3)/115/,xsubr(4)/117/,xsubr( + *5)/98/,xsubr(6)/114/,xsubr(7)/-2/ + if (.not.(ludef (id, newid, xpptbl) .eq. 1))goto 23000 + if (.not.(equal (id, xpntr) .eq. 1))goto 23002 + tokbl = gettok (newid, 100) + if (.not.(tokbl .eq. 32))goto 23004 + tok = gettok (newid, 100) + goto 23005 +23004 continue + tok = tokbl +23005 continue + if (.not.(tok .eq. -166 .and. equal (newid, xfunc) .eq. 1))goto 2 + *3006 + call outtab + call outstr (xptyp) + junk = ludef (newid, newid, xpptbl) + call outstr (newid) + call eatup + call outdon + call poicod (0) + goto 23007 +23006 continue + call pbstr (newid) + call poicod (1) +23007 continue + goto 23003 +23002 continue + if (.not.(equal (id, xsubr) .eq. 1))goto 23008 + call outtab + call outstr (newid) + call eatup + call outdon + goto 23009 +23008 continue + call outtab + call outstr (newid) + call outch (32) +23009 continue +23003 continue + goto 23001 +23000 continue + call synerr (32HInvalid x$type type declaration.) +23001 continue + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/deftok.f b/unix/boot/spp/rpp/rppfor/deftok.f new file mode 100644 index 00000000..edd7213a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/deftok.f @@ -0,0 +1,237 @@ + integer function deftok (token, toksiz) + integer token (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, c, defn (2048), mdefn (2048) + integer gtok + integer equal + integer ap, argstk (100), callst (50), nlb, plev (50), ifl + integer ludef, push, ifparm + integer balp(3) + integer pswrg(22) + data balp(1)/40/,balp(2)/41/,balp(3)/-2/ + data pswrg(1)/115/,pswrg(2)/119/,pswrg(3)/105/,pswrg(4)/116/,pswrg + *(5)/99/,pswrg(6)/104/,pswrg(7)/95/,pswrg(8)/110/,pswrg(9)/111/,psw + *rg(10)/95/,pswrg(11)/114/,pswrg(12)/97/,pswrg(13)/110/,pswrg(14)/1 + *03/,pswrg(15)/101/,pswrg(16)/95/,pswrg(17)/99/,pswrg(18)/104/,pswr + *g(19)/101/,pswrg(20)/99/,pswrg(21)/107/,pswrg(22)/-2/ + cp = 0 + ap = 1 + ep = 1 + t = gtok (token, toksiz) +23000 if (.not.(t .ne. -1))goto 23002 + if (.not.(t .eq. -9))goto 23003 + if (.not.(ludef (token, defn, deftbl) .eq. 0))goto 23005 + if (.not.(cp .eq. 0))goto 23007 + goto 23002 +23007 continue + call puttok (token) +23008 continue + goto 23006 +23005 continue + if (.not.(defn (1) .eq. -4))goto 23009 + call getdef (token, toksiz, defn, 2048) + call entdef (token, defn, deftbl) + goto 23010 +23009 continue + if (.not.(defn (1) .eq. -15 .or. defn (1) .eq. -16))goto 23011 + c = defn (1) + call getdef (token, toksiz, defn, 2048) + ifl = ludef (token, mdefn, deftbl) + if (.not.((ifl .eq. 1 .and. c .eq. -15) .or. (ifl .eq. 0 .and. c . + *eq. -16)))goto 23013 + call pbstr (defn) +23013 continue + goto 23012 +23011 continue + if (.not.(defn(1) .eq. -17 .and. cp .eq. 0))goto 23015 + if (.not.(gtok (defn, 2048) .eq. 32))goto 23017 + if (.not.(gtok (defn, 2048) .eq. -9))goto 23019 + if (.not.(equal (defn, pswrg) .eq. 1))goto 23021 + swinrg = 1 + goto 23022 +23021 continue + goto 10 +23022 continue + goto 23020 +23019 continue +10 call pbstr (defn) + call putbak (32) + goto 23002 +23020 continue + goto 23018 +23017 continue + call pbstr (defn) + goto 23002 +23018 continue + goto 23016 +23015 continue + cp = cp + 1 + if (.not.(cp .gt. 50))goto 23023 + call baderr (20Hcall stack overflow.) +23023 continue + callst (cp) = ap + ap = push (ep, argstk, ap) + call puttok (defn) + call putchr (-2) + ap = push (ep, argstk, ap) + call puttok (token) + call putchr (-2) + ap = push (ep, argstk, ap) + t = gtok (token, toksiz) + if (.not.(t .eq. 32))goto 23025 + t = gtok (token, toksiz) + call pbstr (token) + if (.not.(t .ne. 40))goto 23027 + call putbak (32) +23027 continue + goto 23026 +23025 continue + call pbstr (token) +23026 continue + if (.not.(t .ne. 40))goto 23029 + call pbstr (balp) + goto 23030 +23029 continue + if (.not.(ifparm (defn) .eq. 0))goto 23031 + call pbstr (balp) +23031 continue +23030 continue + plev (cp) = 0 +23016 continue +23012 continue +23010 continue +23006 continue + goto 23004 +23003 continue + if (.not.(t .eq. -69))goto 23033 + nlb = 1 +23035 continue + t = gtok (token, toksiz) + if (.not.(t .eq. -69))goto 23038 + nlb = nlb + 1 + goto 23039 +23038 continue + if (.not.(t .eq. -68))goto 23040 + nlb = nlb - 1 + if (.not.(nlb .eq. 0))goto 23042 + goto 23037 +23042 continue + goto 23041 +23040 continue + if (.not.(t .eq. -1))goto 23044 + call baderr (14HEOF in string.) +23044 continue +23041 continue +23039 continue + call puttok (token) +23036 goto 23035 +23037 continue + goto 23034 +23033 continue + if (.not.(cp .eq. 0))goto 23046 + goto 23002 +23046 continue + if (.not.(t .eq. 40))goto 23048 + if (.not.(plev (cp) .gt. 0))goto 23050 + call puttok (token) +23050 continue + plev (cp) = plev (cp) + 1 + goto 23049 +23048 continue + if (.not.(t .eq. 41))goto 23052 + plev (cp) = plev (cp) - 1 + if (.not.(plev (cp) .gt. 0))goto 23054 + call puttok (token) + goto 23055 +23054 continue + call putchr (-2) + call evalr (argstk, callst (cp), ap - 1) + ap = callst (cp) + ep = argstk (ap) + cp = cp - 1 +23055 continue + goto 23053 +23052 continue + if (.not.(t .eq. 44 .and. plev (cp) .eq. 1))goto 23056 + call putchr (-2) + ap = push (ep, argstk, ap) + goto 23057 +23056 continue + call puttok (token) +23057 continue +23053 continue +23049 continue +23047 continue +23034 continue +23004 continue +23001 t = gtok (token, toksiz) + goto 23000 +23002 continue + deftok = t + if (.not.(t .eq. -9))goto 23058 + call fold (token) +23058 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/doarth.f b/unix/boot/spp/rpp/rppfor/doarth.f new file mode 100644 index 00000000..6d45409d --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/doarth.f @@ -0,0 +1,93 @@ + subroutine doarth (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer k, l + integer ctoi + integer op + k = argstk (i + 2) + l = argstk (i + 4) + op = evalst (argstk (i + 3)) + if (.not.(op .eq. 43))goto 23000 + call pbnum (ctoi (evalst, k) + ctoi (evalst, l)) + goto 23001 +23000 continue + if (.not.(op .eq. 45))goto 23002 + call pbnum (ctoi (evalst, k) - ctoi (evalst, l)) + goto 23003 +23002 continue + if (.not.(op .eq. 42 ))goto 23004 + call pbnum (ctoi (evalst, k) * ctoi (evalst, l)) + goto 23005 +23004 continue + if (.not.(op .eq. 47 ))goto 23006 + call pbnum (ctoi (evalst, k) / ctoi (evalst, l)) + goto 23007 +23006 continue + call remark (11Harith error) +23007 continue +23005 continue +23003 continue +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/docode.f b/unix/boot/spp/rpp/rppfor/docode.f new file mode 100644 index 00000000..0d5dbdb9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/docode.f @@ -0,0 +1,87 @@ + subroutine docode (lab) + integer lab + integer labgen + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer gnbtok + integer lexstr (100) + integer sdo(3) + data sdo(1)/100/,sdo(2)/111/,sdo(3)/-2/ + xfer = 0 + call outtab + call outstr (sdo) + call outch (32) + lab = labgen (2) + if (.not.(gnbtok (lexstr, 100) .eq. 48))goto 23000 + call outstr (lexstr) + goto 23001 +23000 continue + call pbstr (lexstr) + call outnum (lab) +23001 continue + call outch (32) + call eatup + call outdwe + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/doif.f b/unix/boot/spp/rpp/rppfor/doif.f new file mode 100644 index 00000000..3eabc389 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/doif.f @@ -0,0 +1,81 @@ + subroutine doif (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer a2, a3, a4, a5 + integer equal + if (.not.(j - i .lt. 5))goto 23000 + return +23000 continue + a2 = argstk (i + 2) + a3 = argstk (i + 3) + a4 = argstk (i + 4) + a5 = argstk (i + 5) + if (.not.(equal (evalst (a2), evalst (a3)) .eq. 1))goto 23002 + call pbstr (evalst (a4)) + goto 23003 +23002 continue + call pbstr (evalst (a5)) +23003 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/doincr.f b/unix/boot/spp/rpp/rppfor/doincr.f new file mode 100644 index 00000000..8bcc3e14 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/doincr.f @@ -0,0 +1,70 @@ + subroutine doincr (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer k + integer ctoi + k = argstk (i + 2) + call pbnum (ctoi (evalst, k) + 1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/domac.f b/unix/boot/spp/rpp/rppfor/domac.f new file mode 100644 index 00000000..b954ee64 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/domac.f @@ -0,0 +1,72 @@ + subroutine domac (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer a2, a3 + if (.not.(j - i .gt. 2))goto 23000 + a2 = argstk (i + 2) + a3 = argstk (i + 3) + call entdef (evalst (a2), evalst (a3), deftbl) +23000 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/dostat.f b/unix/boot/spp/rpp/rppfor/dostat.f new file mode 100644 index 00000000..038f5b72 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/dostat.f @@ -0,0 +1,7 @@ + subroutine dostat (lab) + integer lab + call indent (-1) + call outcon (lab) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rppfor/dosub.f b/unix/boot/spp/rpp/rppfor/dosub.f new file mode 100644 index 00000000..c0efa5cb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/dosub.f @@ -0,0 +1,90 @@ + subroutine dosub (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ap, fc, k, nc + integer ctoi, length + if (.not.(j - i .lt. 3))goto 23000 + return +23000 continue + if (.not.(j - i .lt. 4))goto 23002 + nc = 100 + goto 23003 +23002 continue + k = argstk (i + 4) + nc = ctoi (evalst, k) +23003 continue + k = argstk (i + 3) + ap = argstk (i + 2) + fc = ap + ctoi (evalst, k) - 1 + if (.not.(fc .ge. ap .and. fc .lt. ap + length (evalst (ap))))goto + * 23004 + k = fc + min0(nc, length (evalst (fc))) - 1 +23006 if (.not.(k .ge. fc))goto 23008 + call putbak (evalst (k)) +23007 k = k - 1 + goto 23006 +23008 continue +23004 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/eatup.f b/unix/boot/spp/rpp/rppfor/eatup.f new file mode 100644 index 00000000..65ba16b3 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/eatup.f @@ -0,0 +1,127 @@ + subroutine eatup + integer ptoken (100), t, token (100) + integer gettok + integer nlpar, equal + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer serror(6) + data serror(1)/101/,serror(2)/114/,serror(3)/114/,serror(4)/111/,s + *error(5)/114/,serror(6)/-2/ + nlpar = 0 + token(1) = -2 +23000 continue + call outstr (token) + t = gettok (token, 100) +23001 if (.not.(t .ne. 32 .and. t .ne. 9))goto 23000 +23002 continue + if (.not.(t .eq. -9))goto 23003 + if (.not.(equal (token, serror) .eq. 1))goto 23005 + ername = 1 +23005 continue +23003 continue + goto 10 +23007 continue + t = gettok (token, 100) +10 if (.not.(t .eq. 59 .or. t .eq. 10))goto 23010 + goto 23009 +23010 continue + if (.not.(t .eq. 125 .or. t .eq. 123))goto 23012 + call pbstr (token) + goto 23009 +23012 continue + if (.not.(t .eq. -1))goto 23014 + call synerr (15Hunexpected EOF.) + call pbstr (token) + goto 23009 +23014 continue + if (.not.(t .eq. 44 .or. t .eq. 43 .or. t .eq. 45 .or. t .eq. 42 . + *or. (t .eq. 47 .and. body .eq. 1) .or. t .eq. 40 .or. t .eq. 38 .o + *r. t .eq. 124 .or. t .eq. 33 .or. t .eq. 126 .or. t .eq. 126 .or. + *t .eq. 94 .or. t .eq. 61 .or. t .eq. 95))goto 23016 +23018 if (.not.(gettok (ptoken, 100) .eq. 10))goto 23019 + goto 23018 +23019 continue + call pbstr (ptoken) + if (.not.(t .eq. 95))goto 23020 + token (1) = -2 +23020 continue +23016 continue + if (.not.(t .eq. 40))goto 23022 + nlpar = nlpar + 1 + goto 23023 +23022 continue + if (.not.(t .eq. 41))goto 23024 + nlpar = nlpar - 1 +23024 continue +23023 continue + if (.not.(t .eq. -9))goto 23026 + call squash (token) +23026 continue + call outstr (token) +23008 if (.not.(nlpar .lt. 0))goto 23007 +23009 continue + if (.not.(nlpar .ne. 0))goto 23028 + call synerr (23Hunbalanced parentheses.) +23028 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/elseif.f b/unix/boot/spp/rpp/rppfor/elseif.f new file mode 100644 index 00000000..d0ecab46 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/elseif.f @@ -0,0 +1,8 @@ + subroutine elseif (lab) + integer lab + call outgo (lab+1) + call indent (-1) + call outcon (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rppfor/endcod.f b/unix/boot/spp/rpp/rppfor/endcod.f new file mode 100644 index 00000000..da8bfffc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/endcod.f @@ -0,0 +1,96 @@ + subroutine endcod (endstr) + integer endstr(1) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sret(7) + integer sepro(12) + data sret(1)/114/,sret(2)/101/,sret(3)/116/,sret(4)/117/,sret(5)/1 + *14/,sret(6)/110/,sret(7)/-2/ + data sepro(1)/99/,sepro(2)/97/,sepro(3)/108/,sepro(4)/108/,sepro(5 + *)/32/,sepro(6)/122/,sepro(7)/122/,sepro(8)/101/,sepro(9)/112/,sepr + *o(10)/114/,sepro(11)/111/,sepro(12)/-2/ + if (.not.(esp .ne. 0))goto 23000 + call synerr (36HUnmatched 'iferr' or 'then' keyword.) +23000 continue + esp = 0 + body = 0 + ername = 0 + if (.not.(errtbl .ne. 0))goto 23002 + call rmtabl (errtbl) +23002 continue + errtbl = 0 + memflg = 0 + if (.not.(retlab .ne. 0))goto 23004 + call outnum (retlab) +23004 continue + call outtab + call outstr (sepro) + call outdon + call outtab + call outstr (sret) + call outdon + col = 6 + call outtab + call outstr (endstr) + call outdon + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/entdef.f b/unix/boot/spp/rpp/rppfor/entdef.f new file mode 100644 index 00000000..ccbb82a3 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entdef.f @@ -0,0 +1,12 @@ + subroutine entdef (name, defn, table) + integer name (100), defn (100) + integer table + integer lookup + integer text + integer sdupl + if (.not.(lookup (name, text, table) .eq. 1))goto 23000 + call dsfree (text) +23000 continue + call enter (name, sdupl (defn), table) + return + end diff --git a/unix/boot/spp/rpp/rppfor/entdkw.f b/unix/boot/spp/rpp/rppfor/entdkw.f new file mode 100644 index 00000000..d8ac6ea9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entdkw.f @@ -0,0 +1,14 @@ + subroutine entdkw + integer deft(2), prag(2) + integer defnam(7) + integer prgnam(7) + data defnam(1)/100/,defnam(2)/101/,defnam(3)/102/,defnam(4)/105/,d + *efnam(5)/110/,defnam(6)/101/,defnam(7)/-2/ + data prgnam(1)/112/,prgnam(2)/114/,prgnam(3)/97/,prgnam(4)/103/,pr + *gnam(5)/109/,prgnam(6)/97/,prgnam(7)/-2/ + data deft (1), deft (2) /-4, -2/ + data prag (1), prag (2) /-17, -2/ + call ulstal (defnam, deft) + call ulstal (prgnam, prag) + return + end diff --git a/unix/boot/spp/rpp/rppfor/entfkw.f b/unix/boot/spp/rpp/rppfor/entfkw.f new file mode 100644 index 00000000..ba484c96 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entfkw.f @@ -0,0 +1,69 @@ + subroutine entfkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sequiv(12) + data sequiv(1)/101/,sequiv(2)/113/,sequiv(3)/117/,sequiv(4)/105/,s + *equiv(5)/118/,sequiv(6)/97/,sequiv(7)/108/,sequiv(8)/101/,sequiv(9 + *)/110/,sequiv(10)/99/,sequiv(11)/101/,sequiv(12)/-2/ + call enter (sequiv, 0, fkwtbl) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/entrkw.f b/unix/boot/spp/rpp/rppfor/entrkw.f new file mode 100644 index 00000000..5deaa3de --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entrkw.f @@ -0,0 +1,151 @@ + subroutine entrkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sif(3) + integer selse(5) + integer swhile(6) + integer sdo(3) + integer sbreak(6) + integer snext(5) + integer sfor(4) + integer srept(7) + integer suntil(6) + integer sret(7) + integer sstr(7) + integer sswtch(7) + integer scase(5) + integer sdeflt(8) + integer send(4) + integer serrc0(7) + integer siferr(6) + integer sifno0(8) + integer sthen(5) + integer sbegin(6) + integer spoint(8) + integer sgoto(5) + data sif(1)/105/,sif(2)/102/,sif(3)/-2/ + data selse(1)/101/,selse(2)/108/,selse(3)/115/,selse(4)/101/,selse + *(5)/-2/ + data swhile(1)/119/,swhile(2)/104/,swhile(3)/105/,swhile(4)/108/,s + *while(5)/101/,swhile(6)/-2/ + data sdo(1)/100/,sdo(2)/111/,sdo(3)/-2/ + data sbreak(1)/98/,sbreak(2)/114/,sbreak(3)/101/,sbreak(4)/97/,sbr + *eak(5)/107/,sbreak(6)/-2/ + data snext(1)/110/,snext(2)/101/,snext(3)/120/,snext(4)/116/,snext + *(5)/-2/ + data sfor(1)/102/,sfor(2)/111/,sfor(3)/114/,sfor(4)/-2/ + data srept(1)/114/,srept(2)/101/,srept(3)/112/,srept(4)/101/,srept + *(5)/97/,srept(6)/116/,srept(7)/-2/ + data suntil(1)/117/,suntil(2)/110/,suntil(3)/116/,suntil(4)/105/,s + *until(5)/108/,suntil(6)/-2/ + data sret(1)/114/,sret(2)/101/,sret(3)/116/,sret(4)/117/,sret(5)/1 + *14/,sret(6)/110/,sret(7)/-2/ + data sstr(1)/115/,sstr(2)/116/,sstr(3)/114/,sstr(4)/105/,sstr(5)/1 + *10/,sstr(6)/103/,sstr(7)/-2/ + data sswtch(1)/115/,sswtch(2)/119/,sswtch(3)/105/,sswtch(4)/116/,s + *swtch(5)/99/,sswtch(6)/104/,sswtch(7)/-2/ + data scase(1)/99/,scase(2)/97/,scase(3)/115/,scase(4)/101/,scase(5 + *)/-2/ + data sdeflt(1)/100/,sdeflt(2)/101/,sdeflt(3)/102/,sdeflt(4)/97/,sd + *eflt(5)/117/,sdeflt(6)/108/,sdeflt(7)/116/,sdeflt(8)/-2/ + data send(1)/101/,send(2)/110/,send(3)/100/,send(4)/-2/ + data serrc0(1)/101/,serrc0(2)/114/,serrc0(3)/114/,serrc0(4)/99/,se + *rrc0(5)/104/,serrc0(6)/107/,serrc0(7)/-2/ + data siferr(1)/105/,siferr(2)/102/,siferr(3)/101/,siferr(4)/114/,s + *iferr(5)/114/,siferr(6)/-2/ + data sifno0(1)/105/,sifno0(2)/102/,sifno0(3)/110/,sifno0(4)/111/,s + *ifno0(5)/101/,sifno0(6)/114/,sifno0(7)/114/,sifno0(8)/-2/ + data sthen(1)/116/,sthen(2)/104/,sthen(3)/101/,sthen(4)/110/,sthen + *(5)/-2/ + data sbegin(1)/98/,sbegin(2)/101/,sbegin(3)/103/,sbegin(4)/105/,sb + *egin(5)/110/,sbegin(6)/-2/ + data spoint(1)/112/,spoint(2)/111/,spoint(3)/105/,spoint(4)/110/,s + *point(5)/116/,spoint(6)/101/,spoint(7)/114/,spoint(8)/-2/ + data sgoto(1)/103/,sgoto(2)/111/,sgoto(3)/116/,sgoto(4)/111/,sgoto + *(5)/-2/ + call enter (sif, -99, rkwtbl) + call enter (selse, -87, rkwtbl) + call enter (swhile, -95, rkwtbl) + call enter (sdo, -96, rkwtbl) + call enter (sbreak, -79, rkwtbl) + call enter (snext, -78, rkwtbl) + call enter (sfor, -94, rkwtbl) + call enter (srept, -93, rkwtbl) + call enter (suntil, -70, rkwtbl) + call enter (sret, -77, rkwtbl) + call enter (sstr, -75, rkwtbl) + call enter (sswtch, -92, rkwtbl) + call enter (scase, -91, rkwtbl) + call enter (sdeflt, -90, rkwtbl) + call enter (send, -82, rkwtbl) + call enter (serrc0, -84, rkwtbl) + call enter (siferr, -98, rkwtbl) + call enter (sifno0, -97, rkwtbl) + call enter (sthen, -86, rkwtbl) + call enter (sbegin, -83, rkwtbl) + call enter (spoint, -88, rkwtbl) + call enter (sgoto, -76, rkwtbl) + return + end +c sifno0 sifnoerr +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/entxkw.f b/unix/boot/spp/rpp/rppfor/entxkw.f new file mode 100644 index 00000000..e8b97b69 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entxkw.f @@ -0,0 +1,172 @@ + subroutine entxkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sbool(7) + integer schar(7) + integer sshort(8) + integer sint(6) + integer slong(7) + integer sreal(7) + integer sdble(7) + integer scplx(7) + integer spntr(7) + integer sfchr(7) + integer sfunc(7) + integer ssubr(7) + integer sextn(7) + integer dbool(8) + integer dchar(10) + integer dshort(10) +C integer dint(10) +C integer dlong(10) +C integer dpntr(10) + integer dint(8) + integer dlong(8) + integer dpntr(8) + integer dreal(5) + integer ddble(17) + integer dcplx(8) + integer dfchr(10) + integer dfunc(9) + integer dsubr(11) + integer dextn(9) + data sbool(1)/120/,sbool(2)/36/,sbool(3)/98/,sbool(4)/111/,sbool(5 + *)/111/,sbool(6)/108/,sbool(7)/-2/ + data schar(1)/120/,schar(2)/36/,schar(3)/99/,schar(4)/104/,schar(5 + *)/97/,schar(6)/114/,schar(7)/-2/ + data sshort(1)/120/,sshort(2)/36/,sshort(3)/115/,sshort(4)/104/,ss + *hort(5)/111/,sshort(6)/114/,sshort(7)/116/,sshort(8)/-2/ + data sint(1)/120/,sint(2)/36/,sint(3)/105/,sint(4)/110/,sint(5)/11 + *6/,sint(6)/-2/ + data slong(1)/120/,slong(2)/36/,slong(3)/108/,slong(4)/111/,slong( + *5)/110/,slong(6)/103/,slong(7)/-2/ + data sreal(1)/120/,sreal(2)/36/,sreal(3)/114/,sreal(4)/101/,sreal( + *5)/97/,sreal(6)/108/,sreal(7)/-2/ + data sdble(1)/120/,sdble(2)/36/,sdble(3)/100/,sdble(4)/98/,sdble(5 + *)/108/,sdble(6)/101/,sdble(7)/-2/ + data scplx(1)/120/,scplx(2)/36/,scplx(3)/99/,scplx(4)/112/,scplx(5 + *)/108/,scplx(6)/120/,scplx(7)/-2/ + data spntr(1)/120/,spntr(2)/36/,spntr(3)/112/,spntr(4)/110/,spntr( + *5)/116/,spntr(6)/114/,spntr(7)/-2/ + data sfchr(1)/120/,sfchr(2)/36/,sfchr(3)/102/,sfchr(4)/99/,sfchr(5 + *)/104/,sfchr(6)/114/,sfchr(7)/-2/ + data sfunc(1)/120/,sfunc(2)/36/,sfunc(3)/102/,sfunc(4)/117/,sfunc( + *5)/110/,sfunc(6)/99/,sfunc(7)/-2/ + data ssubr(1)/120/,ssubr(2)/36/,ssubr(3)/115/,ssubr(4)/117/,ssubr( + *5)/98/,ssubr(6)/114/,ssubr(7)/-2/ + data sextn(1)/120/,sextn(2)/36/,sextn(3)/101/,sextn(4)/120/,sextn( + *5)/116/,sextn(6)/110/,sextn(7)/-2/ + data dbool(1)/108/,dbool(2)/111/,dbool(3)/103/,dbool(4)/105/,dbool + *(5)/99/,dbool(6)/97/,dbool(7)/108/,dbool(8)/-2/ + data dchar(1)/105/,dchar(2)/110/,dchar(3)/116/,dchar(4)/101/,dchar + *(5)/103/,dchar(6)/101/,dchar(7)/114/,dchar(8)/42/,dchar(9)/50/,dch + *ar(10)/-2/ + data dshort(1)/105/,dshort(2)/110/,dshort(3)/116/,dshort(4)/101/,d + *short(5)/103/,dshort(6)/101/,dshort(7)/114/,dshort(8)/42/,dshort(9 + *)/50/,dshort(10)/-2/ +C data dint(1)/105/,dint(2)/110/,dint(3)/116/,dint(4)/101/,dint(5)/1 +C *03/,dint(6)/101/,dint(7)/114/,dint(8)/42/,dint(9)/56/,dint(10)/-2/ + data dint(1)/105/,dint(2)/110/,dint(3)/116/,dint(4)/101/,dint(5)/1 + *03/,dint(6)/101/,dint(7)/114/,dint(8)/-2/ +C data dlong(1)/105/,dlong(2)/110/,dlong(3)/116/,dlong(4)/101/,dlong +C *(5)/103/,dlong(6)/101/,dlong(7)/114/,dlong(8)/42/,dlong(9)/52/,dlo +C *ng(10)/-2/ + data dlong(1)/105/,dlong(2)/110/,dlong(3)/116/,dlong(4)/101/,dlong + *(5)/103/,dlong(6)/101/,dlong(7)/114/,dlong(8)/-2/ +C data dpntr(1)/105/,dpntr(2)/110/,dpntr(3)/116/,dpntr(4)/101/,dpntr +C *(5)/103/,dpntr(6)/101/,dpntr(7)/114/,dpntr(8)/42/,dpntr(9)/56/,dpn +C *tr(10)/-2/ + data dpntr(1)/105/,dpntr(2)/110/,dpntr(3)/116/,dpntr(4)/101/,dpntr + *(5)/103/,dpntr(6)/101/,dpntr(7)/114/,dpntr(8)/-2/ + data dreal(1)/114/,dreal(2)/101/,dreal(3)/97/,dreal(4)/108/,dreal( + *5)/-2/ + data ddble(1)/100/,ddble(2)/111/,ddble(3)/117/,ddble(4)/98/,ddble( + *5)/108/,ddble(6)/101/,ddble(7)/32/,ddble(8)/112/,ddble(9)/114/,ddb + *le(10)/101/,ddble(11)/99/,ddble(12)/105/,ddble(13)/115/,ddble(14)/ + *105/,ddble(15)/111/,ddble(16)/110/,ddble(17)/-2/ + data dcplx(1)/99/,dcplx(2)/111/,dcplx(3)/109/,dcplx(4)/112/,dcplx( + *5)/108/,dcplx(6)/101/,dcplx(7)/120/,dcplx(8)/-2/ + data dfchr(1)/99/,dfchr(2)/104/,dfchr(3)/97/,dfchr(4)/114/,dfchr(5 + *)/97/,dfchr(6)/99/,dfchr(7)/116/,dfchr(8)/101/,dfchr(9)/114/,dfchr + *(10)/-2/ + data dfunc(1)/102/,dfunc(2)/117/,dfunc(3)/110/,dfunc(4)/99/,dfunc( + *5)/116/,dfunc(6)/105/,dfunc(7)/111/,dfunc(8)/110/,dfunc(9)/-2/ + data dsubr(1)/115/,dsubr(2)/117/,dsubr(3)/98/,dsubr(4)/114/,dsubr( + *5)/111/,dsubr(6)/117/,dsubr(7)/116/,dsubr(8)/105/,dsubr(9)/110/,ds + *ubr(10)/101/,dsubr(11)/-2/ + data dextn(1)/101/,dextn(2)/120/,dextn(3)/116/,dextn(4)/101/,dextn + *(5)/114/,dextn(6)/110/,dextn(7)/97/,dextn(8)/108/,dextn(9)/-2/ + call entdef (sbool, dbool, xpptbl) + call entdef (schar, dchar, xpptbl) + call entdef (sshort, dshort, xpptbl) + call entdef (sint, dint, xpptbl) + call entdef (slong, dlong, xpptbl) + call entdef (spntr, dpntr, xpptbl) + call entdef (sreal, dreal, xpptbl) + call entdef (sdble, ddble, xpptbl) + call entdef (scplx, dcplx, xpptbl) + call entdef (sfchr, dfchr, xpptbl) + call entdef (sfunc, dfunc, xpptbl) + call entdef (ssubr, dsubr, xpptbl) + call entdef (sextn, dextn, xpptbl) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/errchk.f b/unix/boot/spp/rpp/rppfor/errchk.f new file mode 100644 index 00000000..140ae204 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/errchk.f @@ -0,0 +1,124 @@ + subroutine errchk + integer tok, lastt0, gnbtok, token(100) + integer ntok + integer mktabl + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer serrc0(27) + integer serrd0(31) + data serrc0(1)/108/,serrc0(2)/111/,serrc0(3)/103/,serrc0(4)/105/,s + *errc0(5)/99/,serrc0(6)/97/,serrc0(7)/108/,serrc0(8)/32/,serrc0(9)/ + *120/,serrc0(10)/101/,serrc0(11)/114/,serrc0(12)/102/,serrc0(13)/10 + *8/,serrc0(14)/103/,serrc0(15)/44/,serrc0(16)/32/,serrc0(17)/120/,s + *errc0(18)/101/,serrc0(19)/114/,serrc0(20)/112/,serrc0(21)/97/,serr + *c0(22)/100/,serrc0(23)/40/,serrc0(24)/56/,serrc0(25)/52/,serrc0(26 + *)/41/,serrc0(27)/-2/ + data serrd0(1)/99/,serrd0(2)/111/,serrd0(3)/109/,serrd0(4)/109/,se + *rrd0(5)/111/,serrd0(6)/110/,serrd0(7)/32/,serrd0(8)/47/,serrd0(9)/ + *120/,serrd0(10)/101/,serrd0(11)/114/,serrd0(12)/99/,serrd0(13)/111 + */,serrd0(14)/109/,serrd0(15)/47/,serrd0(16)/32/,serrd0(17)/120/,se + *rrd0(18)/101/,serrd0(19)/114/,serrd0(20)/102/,serrd0(21)/108/,serr + *d0(22)/103/,serrd0(23)/44/,serrd0(24)/32/,serrd0(25)/120/,serrd0(2 + *6)/101/,serrd0(27)/114/,serrd0(28)/112/,serrd0(29)/97/,serrd0(30)/ + *100/,serrd0(31)/-2/ + ntok = 0 + tok = 0 +23000 continue + lastt0 = tok + tok = gnbtok (token, 100) + I23003=(tok) + goto 23003 +23005 continue + if (.not.(errtbl .eq. 0))goto 23006 + errtbl = mktabl(0) + call outtab + call outstr (serrc0) + call outdon + call outtab + call outstr (serrd0) + call outdon +23006 continue + call enter (token, 0, errtbl) + goto 23004 +23008 continue + goto 23004 +23009 continue + if (.not.(lastt0 .ne. 44))goto 23010 + goto 23002 +23010 continue + goto 23004 +23012 continue + call synerr (35HSyntax error in ERRCHK declaration.) + goto 23004 +23003 continue + if (I23003.eq.-9)goto 23005 + if (I23003.eq.10)goto 23009 + if (I23003.eq.44)goto 23008 + goto 23012 +23004 continue +23001 goto 23000 +23002 continue + end +c lastt0 last_tok +c logic0 logical_column +c serrc0 serrcom1 +c serrd0 serrcom2 diff --git a/unix/boot/spp/rpp/rppfor/errgo.f b/unix/boot/spp/rpp/rppfor/errgo.f new file mode 100644 index 00000000..040a5ce7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/errgo.f @@ -0,0 +1,84 @@ + subroutine errgo + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer serrc0(13) + data serrc0(1)/105/,serrc0(2)/102/,serrc0(3)/32/,serrc0(4)/40/,ser + *rc0(5)/120/,serrc0(6)/101/,serrc0(7)/114/,serrc0(8)/102/,serrc0(9) + */108/,serrc0(10)/103/,serrc0(11)/41/,serrc0(12)/32/,serrc0(13)/-2/ + if (.not.(ername .eq. 1))goto 23000 + call outtab + if (.not.(esp .gt. 0))goto 23002 + if (.not.(errstk(esp) .gt. 0))goto 23004 + call outstr (serrc0) + call ogotos (errstk(esp)+2, 0) +23004 continue + goto 23003 +23002 continue + call outstr (serrc0) + call ogotos (retlab, 0) + call outdon +23003 continue + ername = 0 +23000 continue + end +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/errorc.f b/unix/boot/spp/rpp/rppfor/errorc.f new file mode 100644 index 00000000..d587a001 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/errorc.f @@ -0,0 +1,73 @@ + subroutine errorc (str) + integer str(1) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + xfer = 1 + call outstr (str) + call balpar + ername = 0 + call outdon + call outtab + call ogotos (retlab, 0) + call outdon + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/evalr.f b/unix/boot/spp/rpp/rppfor/evalr.f new file mode 100644 index 00000000..f471c0b0 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/evalr.f @@ -0,0 +1,134 @@ + subroutine evalr (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer argno, k, m, n, t, td, instr0, delim + external index + integer index, length + integer digits(11) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/-2/ + t = argstk (i) + td = evalst (t) + if (.not.(td .eq. -10))goto 23000 + call domac (argstk, i, j) + goto 23001 +23000 continue + if (.not.(td .eq. -12))goto 23002 + call doincr (argstk, i, j) + goto 23003 +23002 continue + if (.not.(td .eq. -13))goto 23004 + call dosub (argstk, i, j) + goto 23005 +23004 continue + if (.not.(td .eq. -11))goto 23006 + call doif (argstk, i, j) + goto 23007 +23006 continue + if (.not.(td .eq. -14))goto 23008 + call doarth (argstk, i, j) + goto 23009 +23008 continue + instr0 = 0 + k = t + length (evalst (t)) - 1 +23010 if (.not.(k .gt. t))goto 23012 + if (.not.(evalst(k) .eq. 39 .or. evalst(k) .eq. 34))goto 23013 + if (.not.(instr0 .eq. 0))goto 23015 + delim = evalst(k) + instr0 = 1 + goto 23016 +23015 continue + instr0 = 0 +23016 continue + call putbak (evalst(k)) + goto 23014 +23013 continue + if (.not.(evalst(k-1) .ne. 36 .or. instr0 .eq. 1))goto 23017 + call putbak (evalst (k)) + goto 23018 +23017 continue + argno = index (digits, evalst (k)) - 1 + if (.not.(argno .ge. 0 .and. argno .lt. j - i))goto 23019 + n = i + argno + 1 + m = argstk (n) + call pbstr (evalst (m)) +23019 continue + k = k - 1 +23018 continue +23014 continue +23011 k = k - 1 + goto 23010 +23012 continue + if (.not.(k .eq. t))goto 23021 + call putbak (evalst (k)) +23021 continue +23009 continue +23007 continue +23005 continue +23003 continue +23001 continue + return + end +c logic0 logical_column +c instr0 in_string diff --git a/unix/boot/spp/rpp/rppfor/finit.f b/unix/boot/spp/rpp/rppfor/finit.f new file mode 100644 index 00000000..eef0ee6e --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/finit.f @@ -0,0 +1,79 @@ + subroutine finit + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + outp = 0 + level = 1 + linect (1) = 0 + sbp = 1 + fnamp = 2 + fnames (1) = -2 + bp = 3192 + buf (bp) = -2 + fordep = 0 + fcname (1) = -2 + swtop = 0 + swlast = 1 + swvnum = 0 + swvlev = 0 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/forcod.f b/unix/boot/spp/rpp/rppfor/forcod.f new file mode 100644 index 00000000..3d855456 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/forcod.f @@ -0,0 +1,183 @@ + subroutine forcod (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, token (100) + integer gettok, gnbtok + integer i, j, nlpar + integer length, labgen + integer ifnot(10) + integer serrc0(22) + data ifnot(1)/105/,ifnot(2)/102/,ifnot(3)/32/,ifnot(4)/40/,ifnot(5 + *)/46/,ifnot(6)/110/,ifnot(7)/111/,ifnot(8)/116/,ifnot(9)/46/,ifnot + *(10)/-2/ + data serrc0(1)/46/,serrc0(2)/97/,serrc0(3)/110/,serrc0(4)/100/,ser + *rc0(5)/46/,serrc0(6)/40/,serrc0(7)/46/,serrc0(8)/110/,serrc0(9)/11 + *1/,serrc0(10)/116/,serrc0(11)/46/,serrc0(12)/120/,serrc0(13)/101/, + *serrc0(14)/114/,serrc0(15)/102/,serrc0(16)/108/,serrc0(17)/103/,se + *rrc0(18)/41/,serrc0(19)/41/,serrc0(20)/41/,serrc0(21)/32/,serrc0(2 + *2)/-2/ + lab = labgen (3) + call outcon (0) + if (.not.(gnbtok (token, 100) .ne. 40))goto 23000 + call synerr (19Hmissing left paren.) + return +23000 continue + if (.not.(gnbtok (token, 100) .ne. 59))goto 23002 + call pbstr (token) + call outtab + call eatup + call outdwe +23002 continue + if (.not.(gnbtok (token, 100) .eq. 59))goto 23004 + call outcon (lab) + goto 23005 +23004 continue + call pbstr (token) + call outnum (lab) + call outtab + call outstr (ifnot) + call outch (40) + nlpar = 0 +23006 if (.not.(nlpar .ge. 0))goto 23007 + t = gettok (token, 100) + if (.not.(t .eq. 59))goto 23008 + goto 23007 +23008 continue + if (.not.(t .eq. 40))goto 23010 + nlpar = nlpar + 1 + goto 23011 +23010 continue + if (.not.(t .eq. 41))goto 23012 + nlpar = nlpar - 1 +23012 continue +23011 continue + if (.not.(t .eq. -1))goto 23014 + call pbstr (token) + return +23014 continue + if (.not.(t .eq. -9))goto 23016 + call squash (token) +23016 continue + if (.not.(t .ne. 10 .and. t .ne. 95))goto 23018 + call outstr (token) +23018 continue + goto 23006 +23007 continue + if (.not.(ername .eq. 1))goto 23020 + call outstr (serrc0) + goto 23021 +23020 continue + call outch (41) + call outch (41) + call outch (32) +23021 continue + call outgo (lab+2) + if (.not.(nlpar .lt. 0))goto 23022 + call synerr (19Hinvalid for clause.) +23022 continue +23005 continue + fordep = fordep + 1 + j = 1 + i = 1 +23024 if (.not.(i .lt. fordep))goto 23026 + j = j + length (forstk (j)) + 1 +23025 i = i + 1 + goto 23024 +23026 continue + forstk (j) = -2 + nlpar = 0 + t = gnbtok (token, 100) + call pbstr (token) +23027 if (.not.(nlpar .ge. 0))goto 23028 + t = gettok (token, 100) + if (.not.(t .eq. 40))goto 23029 + nlpar = nlpar + 1 + goto 23030 +23029 continue + if (.not.(t .eq. 41))goto 23031 + nlpar = nlpar - 1 +23031 continue +23030 continue + if (.not.(t .eq. -1))goto 23033 + call pbstr (token) + goto 23028 +23033 continue + if (.not.(nlpar .ge. 0 .and. t .ne. 10 .and. t .ne. 95))goto 23035 + if (.not.(t .eq. -9))goto 23037 + call squash (token) +23037 continue + if (.not.(j + length (token) .ge. 200))goto 23039 + call baderr (20Hfor clause too long.) +23039 continue + call scopy (token, 1, forstk, j) + j = j + length (token) +23035 continue + goto 23027 +23028 continue + lab = lab + 1 + call indent (1) + call errgo + return + end +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/fors.f b/unix/boot/spp/rpp/rppfor/fors.f new file mode 100644 index 00000000..cde5f501 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/fors.f @@ -0,0 +1,87 @@ + subroutine fors (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer i, j + integer length + xfer = 0 + call outnum (lab) + j = 1 + i = 1 +23000 if (.not.(i .lt. fordep))goto 23002 + j = j + length (forstk (j)) + 1 +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(length (forstk (j)) .gt. 0))goto 23003 + call outtab + call outstr (forstk (j)) + call outdon +23003 continue + call outgo (lab - 1) + call indent (-1) + call outcon (lab + 1) + fordep = fordep - 1 + ername = 0 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/getdef.f b/unix/boot/spp/rpp/rppfor/getdef.f new file mode 100644 index 00000000..06644ec7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/getdef.f @@ -0,0 +1,136 @@ + subroutine getdef (token, toksiz, defn, defsiz) + integer token (100), defn (2048) + integer toksiz, defsiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer c, t, ptoken (100) + integer gtok, ngetch + integer i, nlpar + call skpblk + c = gtok (ptoken, 100) + if (.not.(c .eq. 40))goto 23000 + t = 40 + goto 23001 +23000 continue + t = 32 + call pbstr (ptoken) +23001 continue + call skpblk + if (.not.(gtok (token, toksiz) .ne. -9))goto 23002 + call baderr (22Hnon-alphanumeric name.) +23002 continue + call skpblk + c = gtok (ptoken, 100) + if (.not.(t .eq. 32))goto 23004 + call pbstr (ptoken) + i = 1 +23006 continue + c = ngetch (c) + if (.not.(i .gt. defsiz))goto 23009 + call baderr (20Hdefinition too long.) +23009 continue + defn (i) = c + i = i + 1 +23007 if (.not.(c .eq. 35 .or. c .eq. 10 .or. c .eq. -1))goto 23006 +23008 continue + if (.not.(c .eq. 35))goto 23011 + call putbak (c) +23011 continue + goto 23005 +23004 continue + if (.not.(t .eq. 40))goto 23013 + if (.not.(c .ne. 44))goto 23015 + call baderr (24Hmissing comma in define.) +23015 continue + nlpar = 0 + i = 1 +23017 if (.not.(nlpar .ge. 0))goto 23019 + if (.not.(i .gt. defsiz))goto 23020 + call baderr (20Hdefinition too long.) + goto 23021 +23020 continue + if (.not.(ngetch (defn (i)) .eq. -1))goto 23022 + call baderr (20Hmissing right paren.) + goto 23023 +23022 continue + if (.not.(defn (i) .eq. 40))goto 23024 + nlpar = nlpar + 1 + goto 23025 +23024 continue + if (.not.(defn (i) .eq. 41))goto 23026 + nlpar = nlpar - 1 +23026 continue +23025 continue +23023 continue +23021 continue +23018 i = i + 1 + goto 23017 +23019 continue + goto 23014 +23013 continue + call baderr (19Hgetdef is confused.) +23014 continue +23005 continue + defn (i - 1) = -2 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gettok.f b/unix/boot/spp/rpp/rppfor/gettok.f new file mode 100644 index 00000000..ed74b2f7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gettok.f @@ -0,0 +1,104 @@ + integer function gettok (token, toksiz) + integer token (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer equal + integer t, deftok + integer ssubr(7) + integer sfunc(7) + data ssubr(1)/120/,ssubr(2)/36/,ssubr(3)/115/,ssubr(4)/117/,ssubr( + *5)/98/,ssubr(6)/114/,ssubr(7)/-2/ + data sfunc(1)/120/,sfunc(2)/36/,sfunc(3)/102/,sfunc(4)/117/,sfunc( + *5)/110/,sfunc(6)/99/,sfunc(7)/-2/ + gettok = deftok (token, toksiz) + if (.not.(gettok .ne. -1))goto 23000 + if (.not.(gettok .eq. -166))goto 23002 + if (.not.(equal (token, sfunc) .eq. 1))goto 23004 + call skpblk + t = deftok (fcname, 30) + call pbstr (fcname) + if (.not.(t .ne. -9))goto 23006 + call synerr (22HMissing function name.) +23006 continue + call putbak (32) + swvnum = 0 + swvlev = 0 + return +23004 continue + if (.not.(equal (token, ssubr) .eq. 1))goto 23008 + swvnum = 0 + swvlev = 0 + return +23008 continue + return +23009 continue +23005 continue +23002 continue + return +23000 continue + token (1) = -1 + token (2) = -2 + gettok = -1 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gnbtok.f b/unix/boot/spp/rpp/rppfor/gnbtok.f new file mode 100644 index 00000000..ac234f7f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gnbtok.f @@ -0,0 +1,73 @@ + integer function gnbtok (token, toksiz) + integer token (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer gettok + call skpblk +23000 continue + gnbtok = gettok (token, toksiz) +23001 if (.not.(gnbtok .ne. 32))goto 23000 +23002 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gocode.f b/unix/boot/spp/rpp/rppfor/gocode.f new file mode 100644 index 00000000..627bc5d9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gocode.f @@ -0,0 +1,83 @@ + subroutine gocode + integer token (100), t + integer gnbtok + integer ctoi, i + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + t = gnbtok (token, 100) + if (.not.(t .ne. 48))goto 23000 + call synerr (23HInvalid label for goto.) + goto 23001 +23000 continue + call outtab + i = 1 + call ogotos (ctoi(token,i), 0) +23001 continue + xfer = 1 + t=gnbtok(token,100) +23002 if (.not.(t .eq. 10))goto 23004 +23003 t=gnbtok(token,100) + goto 23002 +23004 continue + call pbstr (token) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gtok.f b/unix/boot/spp/rpp/rppfor/gtok.f new file mode 100644 index 00000000..5b021e8b --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gtok.f @@ -0,0 +1,213 @@ + integer function gtok (lexstr, toksiz) + integer lexstr (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer c + integer ngetch + integer i + c = ngetch (lexstr (1)) + if (.not.(c .eq. 32 .or. c .eq. 9))goto 23000 + lexstr (1) = 32 +23002 if (.not.(c .eq. 32 .or. c .eq. 9))goto 23003 + c = ngetch (c) + goto 23002 +23003 continue + if (.not.(c .eq. 35))goto 23004 +23006 if (.not.(ngetch (c) .ne. 10))goto 23007 + goto 23006 +23007 continue +23004 continue + if (.not.(c .ne. 10))goto 23008 + call putbak (c) + goto 23009 +23008 continue + lexstr (1) = 10 +23009 continue + lexstr (2) = -2 + gtok = lexstr (1) + return +23000 continue + i = 1 + if (.not.(((65.le.c.and.c.le.90).or.(97.le.c.and.c.le.122))))goto + *23010 + gtok = -9 + if (.not.(c .eq. 120))goto 23012 + c = ngetch (lexstr(2)) + if (.not.(c .eq. 36))goto 23014 + gtok = -166 + i = 2 + goto 23015 +23014 continue + call putbak (c) +23015 continue +23012 continue +23016 if (.not.(i .lt. toksiz - 2))goto 23018 + c = ngetch (lexstr(i+1)) + if (.not.(.not.((65.le.c.and.c.le.90).or.(97.le.c.and.c.le.122)) . + *and. .not.(48.le.c.and.c.le.57) .and. c .ne. 95))goto 23019 + goto 23018 +23019 continue +23017 i=i+1 + goto 23016 +23018 continue + call putbak (c) + goto 23011 +23010 continue + if (.not.((48.le.c.and.c.le.57)))goto 23021 + i=1 +23023 if (.not.(i .lt. toksiz - 2))goto 23025 + c = ngetch (lexstr (i + 1)) + if (.not.(.not.(48.le.c.and.c.le.57)))goto 23026 + goto 23025 +23026 continue +23024 i=i+1 + goto 23023 +23025 continue + call putbak (c) + gtok = 48 + goto 23022 +23021 continue + if (.not.(c .eq. 91))goto 23028 + lexstr (1) = 123 + gtok = 123 + goto 23029 +23028 continue + if (.not.(c .eq. 93))goto 23030 + lexstr (1) = 125 + gtok = 125 + goto 23031 +23030 continue + if (.not.(c .eq. 36))goto 23032 + if (.not.(ngetch (lexstr (2)) .eq. 40))goto 23034 + i = 2 + gtok = -69 + goto 23035 +23034 continue + if (.not.(lexstr (2) .eq. 41))goto 23036 + i = 2 + gtok = -68 + goto 23037 +23036 continue + call putbak (lexstr (2)) + gtok = 36 +23037 continue +23035 continue + goto 23033 +23032 continue + if (.not.(c .eq. 39 .or. c .eq. 34))goto 23038 + gtok = c + i = 2 +23040 if (.not.(ngetch (lexstr (i)) .ne. lexstr (1)))goto 23042 + if (.not.(lexstr (i) .eq. 95))goto 23043 + if (.not.(ngetch (c) .eq. 10))goto 23045 +23047 if (.not.(c .eq. 10 .or. c .eq. 32 .or. c .eq. 9))goto 23048 + c = ngetch (c) + goto 23047 +23048 continue + lexstr (i) = c + goto 23046 +23045 continue + call putbak (c) +23046 continue +23043 continue + if (.not.(lexstr (i) .eq. 10 .or. i .ge. toksiz - 1))goto 23049 + call synerr (14Hmissing quote.) + lexstr (i) = lexstr (1) + call putbak (10) + goto 23042 +23049 continue +23041 i = i + 1 + goto 23040 +23042 continue + goto 23039 +23038 continue + if (.not.(c .eq. 35))goto 23051 +23053 if (.not.(ngetch (lexstr (1)) .ne. 10))goto 23054 + goto 23053 +23054 continue + gtok = 10 + goto 23052 +23051 continue + if (.not.(c .eq. 62 .or. c .eq. 60 .or. c .eq. 126 .or. c .eq. 33 + *.or. c .eq. 126 .or. c .eq. 94 .or. c .eq. 61 .or. c .eq. 38 .or. + *c .eq. 124))goto 23055 + call relate (lexstr, i) + gtok = c + goto 23056 +23055 continue + gtok = c +23056 continue +23052 continue +23039 continue +23033 continue +23031 continue +23029 continue +23022 continue +23011 continue + if (.not.(i .ge. toksiz - 1))goto 23057 + call synerr (15Htoken too long.) +23057 continue + lexstr (i + 1) = -2 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ifcode.f b/unix/boot/spp/rpp/rppfor/ifcode.f new file mode 100644 index 00000000..8fbf5763 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ifcode.f @@ -0,0 +1,71 @@ + subroutine ifcode (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer labgen + xfer = 0 + lab = labgen (2) + call ifgo (lab) + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/iferrc.f b/unix/boot/spp/rpp/rppfor/iferrc.f new file mode 100644 index 00000000..f7abae81 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/iferrc.f @@ -0,0 +1,168 @@ + subroutine iferrc (lab, sense) + integer lab, sense + integer labgen, nlpar + integer t, gettok, gnbtok, token(100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer errpsh(12) + integer siferr(20) + integer sifno0(15) + data errpsh(1)/99/,errpsh(2)/97/,errpsh(3)/108/,errpsh(4)/108/,err + *psh(5)/32/,errpsh(6)/120/,errpsh(7)/101/,errpsh(8)/114/,errpsh(9)/ + *112/,errpsh(10)/115/,errpsh(11)/104/,errpsh(12)/-2/ + data siferr(1)/105/,siferr(2)/102/,siferr(3)/32/,siferr(4)/40/,sif + *err(5)/46/,siferr(6)/110/,siferr(7)/111/,siferr(8)/116/,siferr(9)/ + *46/,siferr(10)/120/,siferr(11)/101/,siferr(12)/114/,siferr(13)/112 + */,siferr(14)/111/,siferr(15)/112/,siferr(16)/40/,siferr(17)/41/,si + *ferr(18)/41/,siferr(19)/32/,siferr(20)/-2/ + data sifno0(1)/105/,sifno0(2)/102/,sifno0(3)/32/,sifno0(4)/40/,sif + *no0(5)/120/,sifno0(6)/101/,sifno0(7)/114/,sifno0(8)/112/,sifno0(9) + */111/,sifno0(10)/112/,sifno0(11)/40/,sifno0(12)/41/,sifno0(13)/41/ + *,sifno0(14)/32/,sifno0(15)/-2/ + xfer = 0 + lab = labgen (3) + call outtab + call outstr (errpsh) + call outdon + I23000=(gnbtok (token, 100)) + goto 23000 +23002 continue + call outtab + goto 23001 +23003 continue + call pbstr (token) + esp = esp + 1 + if (.not.(esp .ge. 30))goto 23004 + call baderr (35HIferr statements nested too deeply.) +23004 continue + errstk(esp) = lab + return +23006 continue + call synerr (19HMissing left paren.) + return +23000 continue + if (I23000.eq.40)goto 23002 + if (I23000.eq.123)goto 23003 + goto 23006 +23001 continue + nlpar = 1 + token(1) = -2 + esp = esp + 1 + if (.not.(esp .ge. 30))goto 23007 + call baderr (35HIferr statements nested too deeply.) +23007 continue + errstk(esp) = 0 +23009 continue + call outstr (token) + t = gettok (token, 100) + if (.not.(t .eq. 59 .or. t .eq. 123 .or. t .eq. 125 .or. t .eq. -1 + *))goto 23012 + call pbstr (token) + goto 23011 +23012 continue + if (.not.(t .eq. 10))goto 23014 + token (1) = -2 + goto 23015 +23014 continue + if (.not.(t .eq. 40))goto 23016 + nlpar = nlpar + 1 + goto 23017 +23016 continue + if (.not.(t .eq. 41))goto 23018 + nlpar = nlpar - 1 + goto 23019 +23018 continue + if (.not.(t .eq. 59))goto 23020 + call outdon + call outtab + goto 23021 +23020 continue + if (.not.(t .eq. -9))goto 23022 + call squash (token) +23022 continue +23021 continue +23019 continue +23017 continue +23015 continue +23010 if (.not.(nlpar .le. 0))goto 23009 +23011 continue + esp = esp - 1 + ername = 0 + if (.not.(nlpar .ne. 0))goto 23024 + call synerr (33HMissing parenthesis in condition.) + goto 23025 +23024 continue + call outdon +23025 continue + call outtab + if (.not.(sense .eq. 1))goto 23026 + call outstr (siferr) + goto 23027 +23026 continue + call outstr (sifno0) +23027 continue + call outgo (lab) + call indent (1) + return + end +c sifno0 sifnoerr +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ifgo.f b/unix/boot/spp/rpp/rppfor/ifgo.f new file mode 100644 index 00000000..5f2bb654 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ifgo.f @@ -0,0 +1,88 @@ + subroutine ifgo (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ifnot(10) + integer serrc0(21) + data ifnot(1)/105/,ifnot(2)/102/,ifnot(3)/32/,ifnot(4)/40/,ifnot(5 + *)/46/,ifnot(6)/110/,ifnot(7)/111/,ifnot(8)/116/,ifnot(9)/46/,ifnot + *(10)/-2/ + data serrc0(1)/46/,serrc0(2)/97/,serrc0(3)/110/,serrc0(4)/100/,ser + *rc0(5)/46/,serrc0(6)/40/,serrc0(7)/46/,serrc0(8)/110/,serrc0(9)/11 + *1/,serrc0(10)/116/,serrc0(11)/46/,serrc0(12)/120/,serrc0(13)/101/, + *serrc0(14)/114/,serrc0(15)/102/,serrc0(16)/108/,serrc0(17)/103/,se + *rrc0(18)/41/,serrc0(19)/41/,serrc0(20)/32/,serrc0(21)/-2/ + call outtab + call outstr (ifnot) + call balpar + if (.not.(ername .eq. 1))goto 23000 + call outstr (serrc0) + goto 23001 +23000 continue + call outch (41) + call outch (32) +23001 continue + call outgo (lab) + call errgo + end +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/ifparm.f b/unix/boot/spp/rpp/rppfor/ifparm.f new file mode 100644 index 00000000..4334a444 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ifparm.f @@ -0,0 +1,26 @@ + integer function ifparm (strng) + integer strng (100) + integer c + external index + integer i, index, type + c = strng (1) + if (.not.(c .eq. -12 .or. c .eq. -13 .or. c .eq. -11 .or. c .eq. - + *14 .or. c .eq. -10))goto 23000 + ifparm = 1 + goto 23001 +23000 continue + ifparm = 0 + i = 1 +23002 if (.not.(index (strng (i), 36) .gt. 0))goto 23004 + i = i + index (strng (i), 36) + if (.not.(type (strng (i)) .eq. 48))goto 23005 + if (.not.(type (strng (i + 1)) .ne. 48))goto 23007 + ifparm = 1 + goto 23004 +23007 continue +23005 continue +23003 goto 23002 +23004 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/indent.f b/unix/boot/spp/rpp/rppfor/indent.f new file mode 100644 index 00000000..40b99b9f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/indent.f @@ -0,0 +1,68 @@ + subroutine indent (nleve0) + integer nleve0 + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + logic0 = logic0 + (nleve0 * 3) + col = max0(6, min0(30, logic0)) + end +c logic0 logical_column +c nleve0 nlevels diff --git a/unix/boot/spp/rpp/rppfor/initkw.f b/unix/boot/spp/rpp/rppfor/initkw.f new file mode 100644 index 00000000..c5acfec0 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/initkw.f @@ -0,0 +1,86 @@ + subroutine initkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer mktabl + call dsinit (60000) + deftbl = mktabl (1) + call entdkw + rkwtbl = mktabl (1) + call entrkw + fkwtbl = mktabl (0) + call entfkw + namtbl = mktabl (1) + xpptbl = mktabl (1) + call entxkw + gentbl = mktabl (0) + errtbl = 0 + label = 100 + smem(1) = -2 + body = 0 + dbgout = 0 + dbglev = 0 + memflg = 0 + swinrg = 0 + col = 6 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/labelc.f b/unix/boot/spp/rpp/rppfor/labelc.f new file mode 100644 index 00000000..24d88008 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/labelc.f @@ -0,0 +1,75 @@ + subroutine labelc (lexstr) + integer lexstr (100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer length, l + xfer = 0 + l = length (lexstr) + if (.not.(l .ge. 3 .and. l .lt. 4))goto 23000 + call synerr (53HWarning: statement labels 100 and above are reserv + *ed.) +23000 continue + call outstr (lexstr) + call outtab + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/labgen.f b/unix/boot/spp/rpp/rppfor/labgen.f new file mode 100644 index 00000000..ab7538f4 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/labgen.f @@ -0,0 +1,68 @@ + integer function labgen (n) + integer n + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + labgen = label + label = label + (n / 10 + 1) * 10 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/lex.f b/unix/boot/spp/rpp/rppfor/lex.f new file mode 100644 index 00000000..6f2243f4 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/lex.f @@ -0,0 +1,119 @@ + integer function lex (lexstr) + integer lexstr (100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer gnbtok, t, c + integer lookup, n + integer sdefa0(8) + data sdefa0(1)/100/,sdefa0(2)/101/,sdefa0(3)/102/,sdefa0(4)/97/,sd + *efa0(5)/117/,sdefa0(6)/108/,sdefa0(7)/116/,sdefa0(8)/-2/ + lex = gnbtok (lexstr, 100) +23000 if (.not.(lex .eq. 10))goto 23002 +23001 lex = gnbtok (lexstr, 100) + goto 23000 +23002 continue + if (.not.(lex .eq. -1 .or. lex .eq. 59 .or. lex .eq. 123 .or. lex + *.eq. 125))goto 23003 + return +23003 continue + if (.not.(lex .eq. 48))goto 23005 + lex = -89 + goto 23006 +23005 continue + if (.not.(lex .eq. 37))goto 23007 + lex = -85 + goto 23008 +23007 continue + if (.not.(lex .eq. -166))goto 23009 + lex = -67 + goto 23010 +23009 continue + if (.not.(lookup (lexstr, lex, rkwtbl) .eq. 1))goto 23011 + if (.not.(lex .eq. -90))goto 23013 + n = -1 +23015 continue + c = ngetch (c) + n = n + 1 +23016 if (.not.(c .ne. 32 .and. c .ne. 9))goto 23015 +23017 continue + call putbak (c) + t = gnbtok (lexstr, 100) + call pbstr (lexstr) + if (.not.(n .gt. 0))goto 23018 + call putbak (32) +23018 continue + call scopy (sdefa0, 1, lexstr, 1) + if (.not.(t .ne. 58))goto 23020 + lex = -80 +23020 continue +23013 continue + goto 23012 +23011 continue + lex = -80 +23012 continue +23010 continue +23008 continue +23006 continue + return + end +c logic0 logical_column +c sdefa0 sdefault diff --git a/unix/boot/spp/rpp/rppfor/litral.f b/unix/boot/spp/rpp/rppfor/litral.f new file mode 100644 index 00000000..25bb6d3f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/litral.f @@ -0,0 +1,76 @@ + subroutine litral + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ngetch + if (.not.(outp .gt. 0))goto 23000 + call outdwe +23000 continue + outp = 1 +23002 if (.not.(ngetch (outbuf (outp)) .ne. 10))goto 23004 +23003 outp = outp + 1 + goto 23002 +23004 continue + outp = outp - 1 + call outdwe + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/lndict.f b/unix/boot/spp/rpp/rppfor/lndict.f new file mode 100644 index 00000000..c2c4c1c3 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/lndict.f @@ -0,0 +1,86 @@ + subroutine lndict + integer sym (100), c + integer sctabl, length + integer posn, locn + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + posn = 0 +23000 if (.not.(sctabl (namtbl, sym, locn, posn) .ne. -1))goto 23001 + if (.not.(length(sym) .gt. 6))goto 23002 + call outch (99) + call outtab +23004 if (.not.(mem (locn) .ne. -2))goto 23006 + c = mem (locn) + call outch (c) +23005 locn = locn + 1 + goto 23004 +23006 continue + call outch (32) + call outch (32) + call outstr (sym) + call outdon +23002 continue + goto 23000 +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ludef.f b/unix/boot/spp/rpp/rppfor/ludef.f new file mode 100644 index 00000000..3db6c8fe --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ludef.f @@ -0,0 +1,84 @@ + integer function ludef (id, defn, table) + integer id (100), defn (100) + integer table + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer i + integer lookup + integer locn + ludef = lookup (id, locn, table) + if (.not.(ludef .eq. 1))goto 23000 + i = 1 +23002 if (.not.(mem (locn) .ne. -2))goto 23004 + defn (i) = mem (locn) + i = i + 1 +23003 locn = locn + 1 + goto 23002 +23004 continue + defn (i) = -2 + goto 23001 +23000 continue + defn (1) = -2 +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/mapid.f b/unix/boot/spp/rpp/rppfor/mapid.f new file mode 100644 index 00000000..982651ee --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/mapid.f @@ -0,0 +1,13 @@ + subroutine mapid (name) + integer name(100) + integer i + i=1 +23000 if (.not.(name(i) .ne. -2))goto 23002 +23001 i=i+1 + goto 23000 +23002 continue + if (.not.(i-1 .gt. 6))goto 23003 + name(6) = name(i-1) + name(6+1) = -2 +23003 continue + end diff --git a/unix/boot/spp/rpp/rppfor/mkpkg.sh b/unix/boot/spp/rpp/rppfor/mkpkg.sh new file mode 100644 index 00000000..14896773 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/mkpkg.sh @@ -0,0 +1,22 @@ +# Fortran source for RPP preprocessor. + +$F77 -c $HSI_FF addchr.f allblk.f alldig.f baderr.f balpar.f beginc.f +$F77 -c $HSI_FF brknxt.f cascod.f caslab.f declco.f deftok.f doarth.f +$F77 -c $HSI_FF docode.f doif.f doincr.f domac.f dostat.f dosub.f +$F77 -c $HSI_FF eatup.f elseif.f endcod.f entdef.f entdkw.f entfkw.f +$F77 -c $HSI_FF entrkw.f entxkw.f errchk.f errgo.f errorc.f evalr.f +$F77 -c $HSI_FF finit.f forcod.f fors.f getdef.f gettok.f gnbtok.f +$F77 -c $HSI_FF gocode.f gtok.f ifcode.f iferrc.f ifgo.f ifparm.f +$F77 -c $HSI_FF indent.f initkw.f labelc.f labgen.f lex.f litral.f +$F77 -c $HSI_FF lndict.f ludef.f mapid.f ngetch.f ogotos.f otherc.f +$F77 -c $HSI_FF outch.f outcon.f outdon.f outdwe.f outgo.f outnum.f +$F77 -c $HSI_FF outstr.f outtab.f parse.f pbnum.f pbstr.f poicod.f +$F77 -c $HSI_FF push.f putbak.f putchr.f puttok.f ratfor.f relate.f +$F77 -c $HSI_FF repcod.f retcod.f sdupl.f skpblk.f squash.f strdcl.f +$F77 -c $HSI_FF swcode.f swend.f swvar.f synerr.f thenco.f ulstal.f +$F77 -c $HSI_FF uniqid.f unstak.f untils.f whilec.f whiles.f + +ar rv librpp.a *.o +$RANLIB librpp.a +mv -f librpp.a .. +rm *.o diff --git a/unix/boot/spp/rpp/rppfor/ngetch.f b/unix/boot/spp/rpp/rppfor/ngetch.f new file mode 100644 index 00000000..998e707a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ngetch.f @@ -0,0 +1,94 @@ + integer function ngetch (c) + integer c + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer getlin, n, i + if (.not.(buf (bp) .eq. -2))goto 23000 + if (.not.(getlin (buf (3192), infile (level)) .eq. -1))goto 23002 + c = -1 + goto 23003 +23002 continue + c = buf (3192) + bp = 3192 + 1 + if (.not.(c .eq. 35))goto 23004 + if (.not.(buf(bp) .eq. 33 .and. buf(bp+1) .eq. 35))goto 23006 + n = 0 + i=bp+3 +23008 if (.not.(buf(i) .ge. 48 .and. buf(i) .le. 57))goto 23010 + n = n * 10 + buf(i) - 48 +23009 i=i+1 + goto 23008 +23010 continue + linect (level) = n - 1 +23006 continue +23004 continue + linect (level) = linect (level) + 1 +23003 continue + goto 23001 +23000 continue + c = buf (bp) + bp = bp + 1 +23001 continue + ngetch=(c) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ogotos.f b/unix/boot/spp/rpp/rppfor/ogotos.f new file mode 100644 index 00000000..48ce0314 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ogotos.f @@ -0,0 +1,78 @@ + subroutine ogotos (n, error0) + integer n, error0 + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sgoto(6) + data sgoto(1)/103/,sgoto(2)/111/,sgoto(3)/116/,sgoto(4)/111/,sgoto + *(5)/32/,sgoto(6)/-2/ + call outtab + call outstr (sgoto) + call outnum (n) + if (.not.(error0 .eq. 1))goto 23000 + call outdwe + goto 23001 +23000 continue + call outdon +23001 continue + end +c logic0 logical_column +c error0 error_check diff --git a/unix/boot/spp/rpp/rppfor/otherc.f b/unix/boot/spp/rpp/rppfor/otherc.f new file mode 100644 index 00000000..f745eabb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/otherc.f @@ -0,0 +1,75 @@ + subroutine otherc (lexstr) + integer lexstr(100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + xfer = 0 + call outtab + if (.not.(((65.le.lexstr (1).and.lexstr (1).le.90).or.(97.le.lexst + *r (1).and.lexstr (1).le.122))))goto 23000 + call squash (lexstr) +23000 continue + call outstr (lexstr) + call eatup + call outdwe + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/outch.f b/unix/boot/spp/rpp/rppfor/outch.f new file mode 100644 index 00000000..526af517 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outch.f @@ -0,0 +1,120 @@ + subroutine outch (c) + integer c, splbuf(8+1) + integer i, ip, op, index + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + external index + integer break0(10) + data break0(1)/32/,break0(2)/41/,break0(3)/44/,break0(4)/46/,break + *0(5)/43/,break0(6)/45/,break0(7)/42/,break0(8)/47/,break0(9)/40/,b + *reak0(10)/-2/ + if (.not.(outp .ge. 72))goto 23000 + if (.not.(index (break0, c) .gt. 0))goto 23002 + ip = outp + goto 23003 +23002 continue + ip=outp +23004 if (.not.(ip .ge. 1))goto 23006 + if (.not.(index (break0, outbuf(ip)) .gt. 0))goto 23007 + goto 23006 +23007 continue +23005 ip=ip-1 + goto 23004 +23006 continue +23003 continue + if (.not.(ip .ne. outp .and. (outp-ip) .lt. 8))goto 23009 + op = 1 + i=ip+1 +23011 if (.not.(i .le. outp))goto 23013 + splbuf(op) = outbuf(i) + op = op + 1 +23012 i=i+1 + goto 23011 +23013 continue + splbuf(op) = -2 + outp = ip + goto 23010 +23009 continue + splbuf(1) = -2 +23010 continue + call outdon + op=1 +23014 if (.not.(op .lt. col))goto 23016 + outbuf(op) = 32 +23015 op=op+1 + goto 23014 +23016 continue + outbuf(6) = 42 + outp = col + ip=1 +23017 if (.not.(splbuf(ip) .ne. -2))goto 23019 + outp = outp + 1 + outbuf(outp) = splbuf(ip) +23018 ip=ip+1 + goto 23017 +23019 continue +23000 continue + outp = outp + 1 + outbuf(outp) = c + end +c logic0 logical_column +c break0 break_chars diff --git a/unix/boot/spp/rpp/rppfor/outcon.f b/unix/boot/spp/rpp/rppfor/outcon.f new file mode 100644 index 00000000..3c25b6ff --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outcon.f @@ -0,0 +1,80 @@ + subroutine outcon (n) + integer n + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer contin(9) + data contin(1)/99/,contin(2)/111/,contin(3)/110/,contin(4)/116/,co + *ntin(5)/105/,contin(6)/110/,contin(7)/117/,contin(8)/101/,contin(9 + *)/-2/ + xfer = 0 + if (.not.(n .le. 0 .and. outp .eq. 0))goto 23000 + return +23000 continue + if (.not.(n .gt. 0))goto 23002 + call outnum (n) +23002 continue + call outtab + call outstr (contin) + call outdon + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/outdon.f b/unix/boot/spp/rpp/rppfor/outdon.f new file mode 100644 index 00000000..d3582ff9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outdon.f @@ -0,0 +1,118 @@ + subroutine outdon + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer allblk + integer itoc, ip, op, i + integer obuf(80) + integer sline0(7) + data sline0(1)/35/,sline0(2)/108/,sline0(3)/105/,sline0(4)/110/,sl + *ine0(5)/101/,sline0(6)/32/,sline0(7)/-2/ + if (.not.(dbgout .eq. 1))goto 23000 + if (.not.(body .eq. 1 .or. dbglev .ne. level))goto 23002 + op = 1 + ip=1 +23004 if (.not.(sline0(ip) .ne. -2))goto 23006 + obuf(op) = sline0(ip) + op = op + 1 +23005 ip=ip+1 + goto 23004 +23006 continue + op = op + itoc (linect, obuf(op), 80-op+1) + obuf(op) = 32 + op = op + 1 + obuf(op) = 34 + op = op + 1 + i=fnamp-1 +23007 if (.not.(i .ge. 1))goto 23009 + if (.not.(fnames(i-1) .eq. -2 .or. i .eq. 1))goto 23010 + ip=i +23012 if (.not.(fnames(ip) .ne. -2))goto 23014 + obuf(op) = fnames(ip) + op = op + 1 +23013 ip=ip+1 + goto 23012 +23014 continue + goto 23009 +23010 continue +23008 i=i-1 + goto 23007 +23009 continue + obuf(op) = 34 + op = op + 1 + obuf(op) = 10 + op = op + 1 + obuf(op) = -2 + op = op + 1 + call putlin (obuf, 1) + dbglev = level +23002 continue +23000 continue + outbuf (outp + 1) = 10 + outbuf (outp + 2) = -2 + if (.not.(allblk (outbuf) .eq. 0))goto 23015 + call putlin (outbuf, 1) +23015 continue + outp = 0 + return + end +c logic0 logical_column +c sline0 s_line diff --git a/unix/boot/spp/rpp/rppfor/outdwe.f b/unix/boot/spp/rpp/rppfor/outdwe.f new file mode 100644 index 00000000..6b006269 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outdwe.f @@ -0,0 +1,4 @@ + subroutine outdwe + call outdon + call errgo + end diff --git a/unix/boot/spp/rpp/rppfor/outgo.f b/unix/boot/spp/rpp/rppfor/outgo.f new file mode 100644 index 00000000..2f4ff64c --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outgo.f @@ -0,0 +1,69 @@ + subroutine outgo (n) + integer n + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(xfer .eq. 1))goto 23000 + return +23000 continue + call ogotos (n, 0) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/outnum.f b/unix/boot/spp/rpp/rppfor/outnum.f new file mode 100644 index 00000000..8c7e7029 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outnum.f @@ -0,0 +1,22 @@ + subroutine outnum (n) + integer n + integer chars (20) + integer i, m + m = iabs (n) + i = 0 +23000 continue + i = i + 1 + chars (i) = mod (m, 10) + 48 + m = m / 10 +23001 if (.not.(m .eq. 0 .or. i .ge. 20))goto 23000 +23002 continue + if (.not.(n .lt. 0))goto 23003 + call outch (45) +23003 continue +23005 if (.not.(i .gt. 0))goto 23007 + call outch (chars (i)) +23006 i = i - 1 + goto 23005 +23007 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/outstr.f b/unix/boot/spp/rpp/rppfor/outstr.f new file mode 100644 index 00000000..28230330 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outstr.f @@ -0,0 +1,30 @@ + subroutine outstr (str) + integer str (100) + integer c + integer i, j + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + c = str (i) + if (.not.(c .ne. 39 .and. c .ne. 34))goto 23003 + call outch (c) + goto 23004 +23003 continue + i = i + 1 + j = i +23005 if (.not.(str (j) .ne. c))goto 23007 +23006 j = j + 1 + goto 23005 +23007 continue + call outnum (j - i) + call outch (72) +23008 if (.not.(i .lt. j))goto 23010 + call outch (str (i)) +23009 i = i + 1 + goto 23008 +23010 continue +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/outtab.f b/unix/boot/spp/rpp/rppfor/outtab.f new file mode 100644 index 00000000..17b0aa8c --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outtab.f @@ -0,0 +1,69 @@ + subroutine outtab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem +23000 if (.not.(outp .lt. col))goto 23001 + call outch (32) + goto 23000 +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/parse.f b/unix/boot/spp/rpp/rppfor/parse.f new file mode 100644 index 00000000..5876293a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/parse.f @@ -0,0 +1,257 @@ + subroutine parse + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer lexstr(100) + integer lab, labval(100), lextyp(100), sp, token, i, t + integer lex + logical pushs0 + sp = 1 + lextyp(1) = -1 + token = lex(lexstr) +23000 if (.not.(token .ne. -1))goto 23002 + pushs0 = .false. + I23003=(token) + goto 23003 +23005 continue + call ifcode (lab) + pushs0 = .true. + goto 23004 +23006 continue + call iferrc (lab, 1) + pushs0 = .true. + goto 23004 +23007 continue + call iferrc (lab, 0) + pushs0 = .true. + goto 23004 +23008 continue + call docode (lab) + pushs0 = .true. + goto 23004 +23009 continue + call whilec (lab) + pushs0 = .true. + goto 23004 +23010 continue + call forcod (lab) + pushs0 = .true. + goto 23004 +23011 continue + call repcod (lab) + pushs0 = .true. + goto 23004 +23012 continue + call swcode (lab) + pushs0 = .true. + goto 23004 +23013 continue + i=sp +23014 if (.not.(i .gt. 0))goto 23016 + if (.not.(lextyp(i) .eq. -92))goto 23017 + goto 23016 +23017 continue +23015 i=i-1 + goto 23014 +23016 continue + if (.not.(i .eq. 0))goto 23019 + call synerr (24Hillegal case or default.) + goto 23020 +23019 continue + call cascod (labval (i), token) +23020 continue + goto 23004 +23021 continue + call labelc (lexstr) + pushs0 = .true. + goto 23004 +23022 continue + t = lextyp(sp) + if (.not.(t .eq. -99 .or. t .eq. -98 .or. t .eq. -97))goto 23023 + call elseif (labval(sp)) + goto 23024 +23023 continue + call synerr (13HIllegal else.) +23024 continue + t = lex (lexstr) + call pbstr (lexstr) + if (.not.(t .eq. -99 .or. t .eq. -98 .or. t .eq. -97))goto 23025 + call indent (-1) + token = -72 +23025 continue + pushs0 = .true. + goto 23004 +23027 continue + if (.not.(lextyp(sp) .eq. -98 .or. lextyp(sp) .eq. -97))goto 23028 + call thenco (lextyp(sp), labval(sp)) + lab = labval(sp) + token = lextyp(sp) + sp = sp - 1 + goto 23029 +23028 continue + call synerr (41HIllegal 'then' clause in iferr statement.) +23029 continue + pushs0 = .true. + goto 23004 +23030 continue + call litral + goto 23004 +23031 continue + call errchk + goto 23004 +23032 continue + call beginc + goto 23004 +23033 continue + call endcod (lexstr) + if (.not.(sp .ne. 1))goto 23034 + call synerr (31HMissing right brace or 'begin'.) + sp = 1 +23034 continue + goto 23004 +23036 continue + if (.not.(token .eq. 123))goto 23037 + pushs0 = .true. + goto 23038 +23037 continue + if (.not.(token .eq. -67))goto 23039 + call declco (lexstr) +23039 continue +23038 continue + goto 23004 +23003 continue + I23003=I23003+100 + if (I23003.lt.1.or.I23003.gt.18)goto 23036 + goto (23005,23006,23007,23008,23009,23010,23011,23012,23013,23013, + *23021,23036,23022,23027,23030,23031,23032,23033),I23003 +23004 continue + if (.not.(pushs0))goto 23041 + if (.not.(body .eq. 0))goto 23043 + call synerr (24HMissing 'begin' keyword.) + call beginc +23043 continue + sp = sp + 1 + if (.not.(sp .gt. 100))goto 23045 + call baderr (25HStack overflow in parser.) +23045 continue + lextyp(sp) = token + labval(sp) = lab + goto 23042 +23041 continue + if (.not.(token .ne. -91 .and. token .ne. -90))goto 23047 + if (.not.(token .eq. 125))goto 23049 + token = -74 +23049 continue + I23051=(token) + goto 23051 +23053 continue + call otherc (lexstr) + goto 23052 +23054 continue + call brknxt (sp, lextyp, labval, token) + goto 23052 +23055 continue + call retcod + goto 23052 +23056 continue + call gocode + goto 23052 +23057 continue + if (.not.(body .eq. 0))goto 23058 + call strdcl + goto 23059 +23058 continue + call otherc (lexstr) +23059 continue + goto 23052 +23060 continue + if (.not.(lextyp(sp) .eq. 123))goto 23061 + sp = sp - 1 + goto 23062 +23061 continue + if (.not.(lextyp(sp) .eq. -92))goto 23063 + call swend (labval(sp)) + sp = sp - 1 + goto 23064 +23063 continue + call synerr (20HIllegal right brace.) +23064 continue +23062 continue + goto 23052 +23051 continue + I23051=I23051+81 + if (I23051.lt.1.or.I23051.gt.7)goto 23052 + goto (23053,23054,23054,23055,23056,23057,23060),I23051 +23052 continue + token = lex (lexstr) + call pbstr (lexstr) + call unstak (sp, lextyp, labval, token) +23047 continue +23042 continue +23001 token = lex(lexstr) + goto 23000 +23002 continue + if (.not.(sp .ne. 1))goto 23065 + call synerr (15Hunexpected EOF.) +23065 continue + end +c pushs0 push_stack +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/pbnum.f b/unix/boot/spp/rpp/rppfor/pbnum.f new file mode 100644 index 00000000..bf477107 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/pbnum.f @@ -0,0 +1,17 @@ + subroutine pbnum (n) + integer n + integer m, num + integer mod + integer digits(11) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/-2/ + num = n +23000 continue + m = mod (num, 10) + call putbak (digits (m + 1)) + num = num / 10 +23001 if (.not.(num .eq. 0))goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/pbstr.f b/unix/boot/spp/rpp/rppfor/pbstr.f new file mode 100644 index 00000000..da3a12a9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/pbstr.f @@ -0,0 +1,75 @@ + subroutine pbstr (s) + integer s(100) + integer lenstr, i + integer length + lenstr = length (s) + if (.not.(s(1) .eq. 46 .and. s(lenstr) .eq. 46))goto 23000 + if (.not.(lenstr .eq. 4))goto 23002 + if (.not.(s(2) .eq. 103))goto 23004 + if (.not.(s(3) .eq. 116))goto 23006 + call putbak (62) + return +23006 continue + if (.not.(s(3) .eq. 101))goto 23008 + call putbak (61) + call putbak (62) + return +23008 continue +23007 continue + goto 23005 +23004 continue + if (.not.(s(2) .eq. 108))goto 23010 + if (.not.(s(3) .eq. 116))goto 23012 + call putbak (60) + return +23012 continue + if (.not.(s(3) .eq. 101))goto 23014 + call putbak (61) + call putbak (60) + return +23014 continue +23013 continue + goto 23011 +23010 continue + if (.not.(s(2) .eq. 101 .and. s(3) .eq. 113))goto 23016 + call putbak (61) + call putbak (61) + return +23016 continue + if (.not.(s(2) .eq. 110 .and. s(3) .eq. 101))goto 23018 + call putbak (61) + call putbak (33) + return +23018 continue + if (.not.(s(2) .eq. 111 .and. s(3) .eq. 114))goto 23020 + call putbak (124) + return +23020 continue +23019 continue +23017 continue +23011 continue +23005 continue + goto 23003 +23002 continue + if (.not.(lenstr .eq. 5))goto 23022 + if (.not.(s(2) .eq. 110 .and. s(3) .eq. 111 .and. s(4) .eq. 116))g + *oto 23024 + call putbak (33) + return +23024 continue + if (.not.(s(2) .eq. 97 .and. s(3) .eq. 110 .and. s(4) .eq. 100))go + *to 23026 + call putbak (38) + return +23026 continue +23025 continue +23022 continue +23003 continue +23000 continue + i=lenstr +23028 if (.not.(i .gt. 0))goto 23030 + call putbak (s(i)) +23029 i=i-1 + goto 23028 +23030 continue + end diff --git a/unix/boot/spp/rpp/rppfor/poicod.f b/unix/boot/spp/rpp/rppfor/poicod.f new file mode 100644 index 00000000..834d1644 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/poicod.f @@ -0,0 +1,172 @@ + subroutine poicod (decla0) + integer decla0 + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer spoin0(9) + integer p1(16) + integer p2(18) + integer p3(18) +C integer p4(18) +C integer p5(18) +C integer p6(25) + integer p4(16) + integer p5(16) + integer p6(13) + integer p7(25) + integer p8(16) + integer p9(61) + integer pa(18) + +C data spoin0(1)/105/,spoin0(2)/110/,spoin0(3)/116/,spoin0(4)/101/,s +C *poin0(5)/103/,spoin0(6)/101/,spoin0(7)/114/,spoin0(8)/42/,spoin0(9 +C *)/56/,spoin0(10)/32/,spoin0(11)/-2/ + data spoin0(1)/105/,spoin0(2)/110/,spoin0(3)/116/,spoin0(4)/101/,s + *poin0(5)/103/,spoin0(6)/101/,spoin0(7)/114/,spoin0(8)/32/,spoin0(9 + *)/-2/ + + data p1(1)/108/,p1(2)/111/,p1(3)/103/,p1(4)/105/,p1(5)/99/,p1(6)/9 + *7/,p1(7)/108/,p1(8)/32/,p1(9)/77/,p1(10)/101/,p1(11)/109/,p1(12)/9 + *8/,p1(13)/40/,p1(14)/49/,p1(15)/41/,p1(16)/-2/ + data p2(1)/105/,p2(2)/110/,p2(3)/116/,p2(4)/101/,p2(5)/103/,p2(6)/ + *101/,p2(7)/114/,p2(8)/42/,p2(9)/50/,p2(10)/32/,p2(11)/77/,p2(12)/1 + *01/,p2(13)/109/,p2(14)/99/,p2(15)/40/,p2(16)/49/,p2(17)/41/,p2(18) + */-2/ + data p3(1)/105/,p3(2)/110/,p3(3)/116/,p3(4)/101/,p3(5)/103/,p3(6)/ + *101/,p3(7)/114/,p3(8)/42/,p3(9)/50/,p3(10)/32/,p3(11)/77/,p3(12)/1 + *01/,p3(13)/109/,p3(14)/115/,p3(15)/40/,p3(16)/49/,p3(17)/41/,p3(18 + *)/-2/ + + data p4(1)/105/,p4(2)/110/,p4(3)/116/,p4(4)/101/,p4(5)/103/,p4(6)/ + *101/,p4(7)/114/,p4(8)/32/,p4(9)/77/,p4(10)/101/,p4(11)/109/,p4(12) + */105/,p4(13)/40/,p4(14)/49/,p4(15)/41/,p4(16)/-2/ + data p5(1)/105/,p5(2)/110/,p5(3)/116/,p5(4)/101/,p5(5)/103/,p5(6)/ + *101/,p5(7)/114/,p5(8)/32/,p5(9)/77/,p5(10)/101/,p5(11)/109/,p5(12) + */108/,p5(13)/40/,p5(14)/49/,p5(15)/41/,p5(16)/-2/ + +C data p4(1)/105/,p4(2)/110/,p4(3)/116/,p4(4)/101/,p4(5)/103/,p4(6)/ +C *101/,p4(7)/114/,p4(8)/42/,p4(9)/56/,p4(10)/32/,p4(11)/77/,p4(12)/1 +C *01/,p4(13)/109/,p4(14)/105/,p4(15)/40/,p4(16)/49/,p4(17)/41/,p4(18 +C *)/-2/ +C data p5(1)/105/,p5(2)/110/,p5(3)/116/,p5(4)/101/,p5(5)/103/,p5(6)/ +C *101/,p5(7)/114/,p5(8)/42/,p5(9)/56/,p5(10)/32/,p5(11)/77/,p5(12)/1 +C *01/,p5(13)/109/,p5(14)/108/,p5(15)/40/,p5(16)/49/,p5(17)/41/,p5(18 +C *)/-2/ +C data p6(1)/100/,p6(2)/111/,p6(3)/117/,p6(4)/98/,p6(5)/108/,p6(6)/1 +C *01/,p6(7)/32/,p6(8)/112/,p6(9)/114/,p6(10)/101/,p6(11)/99/,p6(12)/ +C *105/,p6(13)/115/,p6(14)/105/,p6(15)/111/,p6(16)/110/,p6(17)/32/,p6 +C *(18)/77/,p6(19)/101/,p6(20)/109/,p6(21)/114/,p6(22)/40/,p6(23)/49/ +C *,p6(24)/41/,p6(25)/-2/ + + data p6(1)/114/,p6(2)/101/,p6(3)/97/,p6(4)/108/,p6(5)/32/,p6(6)/77 + */,p6(7)/101/,p6(8)/109/,p6(9)/114/,p6(10)/40/,p6(11)/49/,p6(12)/41 + */,p6(13)/-2/ + + data p7(1)/100/,p7(2)/111/,p7(3)/117/,p7(4)/98/,p7(5)/108/,p7(6)/1 + *01/,p7(7)/32/,p7(8)/112/,p7(9)/114/,p7(10)/101/,p7(11)/99/,p7(12)/ + *105/,p7(13)/115/,p7(14)/105/,p7(15)/111/,p7(16)/110/,p7(17)/32/,p7 + *(18)/77/,p7(19)/101/,p7(20)/109/,p7(21)/100/,p7(22)/40/,p7(23)/49/ + *,p7(24)/41/,p7(25)/-2/ + data p8(1)/99/,p8(2)/111/,p8(3)/109/,p8(4)/112/,p8(5)/108/,p8(6)/1 + *01/,p8(7)/120/,p8(8)/32/,p8(9)/77/,p8(10)/101/,p8(11)/109/,p8(12)/ + *120/,p8(13)/40/,p8(14)/49/,p8(15)/41/,p8(16)/-2/ + data p9(1)/101/,p9(2)/113/,p9(3)/117/,p9(4)/105/,p9(5)/118/,p9(6)/ + *97/,p9(7)/108/,p9(8)/101/,p9(9)/110/,p9(10)/99/,p9(11)/101/,p9(12) + */32/,p9(13)/40/,p9(14)/77/,p9(15)/101/,p9(16)/109/,p9(17)/98/,p9(1 + *8)/44/,p9(19)/32/,p9(20)/77/,p9(21)/101/,p9(22)/109/,p9(23)/99/,p9 + *(24)/44/,p9(25)/32/,p9(26)/77/,p9(27)/101/,p9(28)/109/,p9(29)/115/ + *,p9(30)/44/,p9(31)/32/,p9(32)/77/,p9(33)/101/,p9(34)/109/,p9(35)/1 + *05/,p9(36)/44/,p9(37)/32/,p9(38)/77/,p9(39)/101/,p9(40)/109/,p9(41 + *)/108/,p9(42)/44/,p9(43)/32/,p9(44)/77/,p9(45)/101/,p9(46)/109/,p9 + *(47)/114/,p9(48)/44/,p9(49)/32/,p9(50)/77/,p9(51)/101/,p9(52)/109/ + *,p9(53)/100/,p9(54)/44/,p9(55)/32/,p9(56)/77/,p9(57)/101/,p9(58)/1 + *09/,p9(59)/120/,p9(60)/41/,p9(61)/-2/ + data pa(1)/99/,pa(2)/111/,pa(3)/109/,pa(4)/109/,pa(5)/111/,pa(6)/1 + *10/,pa(7)/32/,pa(8)/47/,pa(9)/77/,pa(10)/101/,pa(11)/109/,pa(12)/4 + *7/,pa(13)/32/,pa(14)/77/,pa(15)/101/,pa(16)/109/,pa(17)/100/,pa(18 + *)/-2/ + if (.not.(memflg .eq. 0))goto 23000 + call poidec (p1) + call poidec (p2) + call poidec (p3) + call poidec (p4) + call poidec (p5) + call poidec (p6) + call poidec (p7) + call poidec (p8) + call poidec (p9) + call poidec (pa) + memflg = 1 +23000 continue + if (.not.(decla0 .eq. 1))goto 23002 + call outtab + call outstr (spoin0) +23002 continue + end + subroutine poidec (str) + integer str + call outtab + call outstr (str) + call outdon + end +c logic0 logical_column +c decla0 declare_variable +c spoin0 spointer diff --git a/unix/boot/spp/rpp/rppfor/push.f b/unix/boot/spp/rpp/rppfor/push.f new file mode 100644 index 00000000..2329f6c5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/push.f @@ -0,0 +1,9 @@ + integer function push (ep, argstk, ap) + integer ap, argstk (100), ep + if (.not.(ap .gt. 100))goto 23000 + call baderr (19Harg stack overflow.) +23000 continue + argstk (ap) = ep + push = ap + 1 + return + end diff --git a/unix/boot/spp/rpp/rppfor/putbak.f b/unix/boot/spp/rpp/rppfor/putbak.f new file mode 100644 index 00000000..b4252a1e --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/putbak.f @@ -0,0 +1,73 @@ + subroutine putbak (c) + integer c + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(bp .le. 1))goto 23000 + call baderr (32Htoo many characters pushed back.) + goto 23001 +23000 continue + bp = bp - 1 + buf (bp) = c +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/putchr.f b/unix/boot/spp/rpp/rppfor/putchr.f new file mode 100644 index 00000000..b502f58a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/putchr.f @@ -0,0 +1,71 @@ + subroutine putchr (c) + integer c + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(ep .gt. 500))goto 23000 + call baderr (26Hevaluation stack overflow.) +23000 continue + evalst (ep) = c + ep = ep + 1 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/puttok.f b/unix/boot/spp/rpp/rppfor/puttok.f new file mode 100644 index 00000000..41d4df64 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/puttok.f @@ -0,0 +1,11 @@ + subroutine puttok (str) + integer str (100) + integer i + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + call putchr (str (i)) +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/ratfor.f b/unix/boot/spp/rpp/rppfor/ratfor.f new file mode 100644 index 00000000..7891bd68 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ratfor.f @@ -0,0 +1,128 @@ + subroutine ratfor + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer i, n + integer getarg, rfopen + integer arg (30) + integer defns(1) + data defns(1)/-2/ + call initkw + if (.not.(defns (1) .ne. -2))goto 23000 + infile (1) = rfopen(defns, 1) + if (.not.(infile (1) .eq. -3))goto 23002 + call remark (37Hcan't open standard definitions file.) + goto 23003 +23002 continue + call finit + call parse + call rfclos(infile (1)) +23003 continue +23000 continue + n = 1 + i=1 +23004 if (.not.(getarg(i,arg,30) .ne. -1))goto 23006 + n = n + 1 + call query (37Husage: ratfor [-g] [files] >outfile.) + if (.not.(arg(1) .eq. 45 .and. arg(2) .eq. 103 .and. arg(3) .eq. - + *2))goto 23007 + dbgout = 1 + goto 23005 +23007 continue + if (.not.(arg(1) .eq. 45 .and. arg(2) .eq. -2))goto 23009 + infile(1) = 0 + call finit + goto 23010 +23009 continue + infile(1) = rfopen(arg, 1) + if (.not.(infile(1) .eq. -3))goto 23011 + call cant (arg) + goto 23012 +23011 continue + call finit + call scopy (arg, 1, fnames, 1) + fnamp=1 +23013 if (.not.(fnames(fnamp) .ne. -2))goto 23015 + if (.not.(fnames(fnamp) .eq. 46 .and. fnames(fnamp+1) .eq. 114))go + *to 23016 + fnames(fnamp+1) = 120 +23016 continue +23014 fnamp=fnamp+1 + goto 23013 +23015 continue +23012 continue +23010 continue +23008 continue + call parse + if (.not.(infile (1) .ne. 0))goto 23018 + call rfclos(infile (1)) +23018 continue +23005 i=i+1 + goto 23004 +23006 continue + if (.not.(n .eq. 1))goto 23020 + infile (1) = 0 + call finit + call parse +23020 continue + call lndict + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/relate.f b/unix/boot/spp/rpp/rppfor/relate.f new file mode 100644 index 00000000..36c3e196 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/relate.f @@ -0,0 +1,66 @@ + subroutine relate (token, last) + integer token (100) + integer last + integer ngetch + integer length + if (.not.(ngetch (token (2)) .ne. 61))goto 23000 + call putbak (token (2)) + token (3) = 116 + goto 23001 +23000 continue + token (3) = 101 +23001 continue + token (4) = 46 + token (5) = -2 + token (6) = -2 + if (.not.(token (1) .eq. 62))goto 23002 + token (2) = 103 + goto 23003 +23002 continue + if (.not.(token (1) .eq. 60))goto 23004 + token (2) = 108 + goto 23005 +23004 continue + if (.not.(token (1) .eq. 126 .or. token (1) .eq. 33 .or. token (1) + * .eq. 94 .or. token (1) .eq. 126))goto 23006 + if (.not.(token (2) .ne. 61))goto 23008 + token (3) = 111 + token (4) = 116 + token (5) = 46 +23008 continue + token (2) = 110 + goto 23007 +23006 continue + if (.not.(token (1) .eq. 61))goto 23010 + if (.not.(token (2) .ne. 61))goto 23012 + token (2) = -2 + last = 1 + return +23012 continue + token (2) = 101 + token (3) = 113 + goto 23011 +23010 continue + if (.not.(token (1) .eq. 38))goto 23014 + token (2) = 97 + token (3) = 110 + token (4) = 100 + token (5) = 46 + goto 23015 +23014 continue + if (.not.(token (1) .eq. 124))goto 23016 + token (2) = 111 + token (3) = 114 + goto 23017 +23016 continue + token (2) = -2 +23017 continue +23015 continue +23011 continue +23007 continue +23005 continue +23003 continue + token (1) = 46 + last = length (token) + return + end diff --git a/unix/boot/spp/rpp/rppfor/repcod.f b/unix/boot/spp/rpp/rppfor/repcod.f new file mode 100644 index 00000000..3279d58a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/repcod.f @@ -0,0 +1,10 @@ + subroutine repcod (lab) + integer lab + integer labgen + call outcon (0) + lab = labgen (3) + call outcon (lab) + lab = lab + 1 + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rppfor/retcod.f b/unix/boot/spp/rpp/rppfor/retcod.f new file mode 100644 index 00000000..1aa43aee --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/retcod.f @@ -0,0 +1,88 @@ + subroutine retcod + integer token (100), t + integer gnbtok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + t = gnbtok (token, 100) + if (.not.(t .ne. 10 .and. t .ne. 59 .and. t .ne. 125))goto 23000 + call pbstr (token) + call outtab + call scopy (fcname, 1, token, 1) + call squash (token) + call outstr (token) + call outch (32) + call outch (61) + call outch (32) + call eatup + call outdon + goto 23001 +23000 continue + if (.not.(t .eq. 125))goto 23002 + call pbstr (token) +23002 continue +23001 continue + call outtab + call ogotos (retlab, 0) + xfer = 1 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/sdupl.f b/unix/boot/spp/rpp/rppfor/sdupl.f new file mode 100644 index 00000000..0d35237a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/sdupl.f @@ -0,0 +1,20 @@ + integer function sdupl (str) + integer str (100) + integer mem( 60000) + common/cdsmem/mem + integer i + integer length + integer j + integer dsget + j = dsget (length (str) + 1) + sdupl = j + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + mem (j) = str (i) + j = j + 1 +23001 i = i + 1 + goto 23000 +23002 continue + mem (j) = -2 + return + end diff --git a/unix/boot/spp/rpp/rppfor/skpblk.f b/unix/boot/spp/rpp/rppfor/skpblk.f new file mode 100644 index 00000000..47c2b0aa --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/skpblk.f @@ -0,0 +1,73 @@ + subroutine skpblk + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer c + integer ngetch + c = ngetch (c) +23000 if (.not.(c .eq. 32 .or. c .eq. 9))goto 23002 +23001 c = ngetch (c) + goto 23000 +23002 continue + call putbak (c) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/squash.f b/unix/boot/spp/rpp/rppfor/squash.f new file mode 100644 index 00000000..d0e654f0 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/squash.f @@ -0,0 +1,104 @@ + subroutine squash (id) + integer id(100) + integer junk, i, j + integer lookup, ludef + integer newid(100), recdid(100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(body .eq. 1 .and. errtbl .ne. 0 .and. ername .eq. 0))got + *o 23000 + if (.not.(lookup (id, junk, errtbl) .eq. 1))goto 23002 + ername = 1 +23002 continue +23000 continue + j = 1 + i=1 +23004 if (.not.(id(i) .ne. -2))goto 23006 + if (.not.(((65.le.id(i).and.id(i).le.90).or.(97.le.id(i).and.id(i) + *.le.122)) .or. (48.le.id(i).and.id(i).le.57)))goto 23007 + newid(j) = id(i) + j = j + 1 +23007 continue +23005 i=i+1 + goto 23004 +23006 continue + newid(j) = -2 + if (.not.(i-1 .lt. 6 .and. i .eq. j))goto 23009 + return +23009 continue + if (.not.(lookup (id, junk, fkwtbl) .eq. 1))goto 23011 + return +23011 continue + if (.not.(ludef (id, recdid, namtbl) .eq. 1))goto 23013 + call scopy (recdid, 1, id, 1) + return +23013 continue + call mapid (newid) + if (.not.(lookup (newid, junk, gentbl) .eq. 1))goto 23015 + call synerr (39HWarning: identifier mapping not unique.) + call uniqid (newid) +23015 continue + call entdef (newid, id, gentbl) + call entdef (id, newid, namtbl) + call scopy (newid, 1, id, 1) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/strdcl.f b/unix/boot/spp/rpp/rppfor/strdcl.f new file mode 100644 index 00000000..5ebcaeba --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/strdcl.f @@ -0,0 +1,170 @@ + subroutine strdcl + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, token (100), dchar (100) + integer gnbtok + integer i, j, k, n, len + integer length, ctoi, lex + integer char(11) + integer dat(6) + integer eoss(3) + data char(1)/105/,char(2)/110/,char(3)/116/,char(4)/101/,char(5)/1 + *03/,char(6)/101/,char(7)/114/,char(8)/42/,char(9)/50/,char(10)/47/ + *,char(11)/-2/ + data dat(1)/100/,dat(2)/97/,dat(3)/116/,dat(4)/97/,dat(5)/32/,dat( + *6)/-2/ + data eoss(1)/48/,eoss(2)/47/,eoss(3)/-2/ + t = gnbtok (token, 100) + if (.not.(t .ne. -9))goto 23000 + call synerr (21Hmissing string token.) +23000 continue + call squash (token) + call outtab + call pbstr (char) +23002 continue + t = gnbtok (dchar, 100) + if (.not.(t .eq. 47))goto 23005 + goto 23004 +23005 continue + call outstr (dchar) +23003 goto 23002 +23004 continue + call outch (32) + call outstr (token) + call addstr (token, sbuf, sbp, 2048) + call addchr (-2, sbuf, sbp, 2048) + if (.not.(gnbtok (token, 100) .ne. 40))goto 23007 + len = length (token) + 1 + if (.not.(token (1) .eq. 39 .or. token (1) .eq. 34))goto 23009 + len = len - 2 +23009 continue + goto 23008 +23007 continue + t = gnbtok (token, 100) + i = 1 + len = ctoi (token, i) + if (.not.(token (i) .ne. -2))goto 23011 + call synerr (20Hinvalid string size.) +23011 continue + if (.not.(gnbtok (token, 100) .ne. 41))goto 23013 + call synerr (20Hmissing right paren.) + goto 23014 +23013 continue + t = gnbtok (token, 100) +23014 continue +23008 continue + call outch (40) + call outnum (len) + call outch (41) + call outdon + if (.not.(token (1) .eq. 39 .or. token (1) .eq. 34))goto 23015 + len = length (token) + token (len) = -2 + call addstr (token (2), sbuf, sbp, 2048) + goto 23016 +23015 continue + call addstr (token, sbuf, sbp, 2048) +23016 continue + call addchr (-2, sbuf, sbp, 2048) + t = lex (token) + call pbstr (token) + if (.not.(t .ne. -75))goto 23017 + i = 1 +23019 if (.not.(i .lt. sbp))goto 23021 + call outtab + call outstr (dat) + k = 1 + j = i + length (sbuf (i)) + 1 +23022 continue + if (.not.(k .gt. 1))goto 23025 + call outch (44) +23025 continue + call outstr (sbuf (i)) + call outch (40) + call outnum (k) + call outch (41) + call outch (47) + if (.not.(sbuf (j) .eq. -2))goto 23027 + goto 23024 +23027 continue + n = sbuf (j) + call outnum (n) + call outch (47) + k = k + 1 +23023 j = j + 1 + goto 23022 +23024 continue + call pbstr (eoss) +23029 continue + t = gnbtok (token, 100) + call outstr (token) +23030 if (.not.(t .eq. 47))goto 23029 +23031 continue + call outdon +23020 i = j + 1 + goto 23019 +23021 continue + sbp = 1 +23017 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/swcode.f b/unix/boot/spp/rpp/rppfor/swcode.f new file mode 100644 index 00000000..22617fdc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/swcode.f @@ -0,0 +1,99 @@ + subroutine swcode (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer tok (100) + integer labgen, gnbtok + lab = labgen (2) + swvnum = swvnum + 1 + swvlev = swvlev + 1 + if (.not.(swvlev .gt. 10))goto 23000 + call baderr (27Hswitches nested too deeply.) +23000 continue + swvstk(swvlev) = swvnum + if (.not.(swlast + 3 .gt. 1000))goto 23002 + call baderr (22Hswitch table overflow.) +23002 continue + swstak (swlast) = swtop + swstak (swlast + 1) = 0 + swstak (swlast + 2) = 0 + swtop = swlast + swlast = swlast + 3 + xfer = 0 + call outtab + call swvar (swvnum) + call outch (61) + call balpar + call outdwe + call outgo (lab) + call indent (1) + xfer = 1 +23004 if (.not.(gnbtok (tok, 100) .eq. 10))goto 23005 + goto 23004 +23005 continue + if (.not.(tok (1) .ne. 123))goto 23006 + call synerr (39Hmissing left brace in switch statement.) + call pbstr (tok) +23006 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/swend.f b/unix/boot/spp/rpp/rppfor/swend.f new file mode 100644 index 00000000..02070f32 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/swend.f @@ -0,0 +1,187 @@ + subroutine swend (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer lb, ub, n, i, j, swn + integer sif(5) + integer slt(10) + integer sgt(5) + integer sgoto(7) + integer seq(5) + integer sge(5) + integer sle(5) + integer sand(6) + data sif(1)/105/,sif(2)/102/,sif(3)/32/,sif(4)/40/,sif(5)/-2/ + data slt(1)/46/,slt(2)/108/,slt(3)/116/,slt(4)/46/,slt(5)/49/,slt( + *6)/46/,slt(7)/111/,slt(8)/114/,slt(9)/46/,slt(10)/-2/ + data sgt(1)/46/,sgt(2)/103/,sgt(3)/116/,sgt(4)/46/,sgt(5)/-2/ + data sgoto(1)/103/,sgoto(2)/111/,sgoto(3)/116/,sgoto(4)/111/,sgoto + *(5)/32/,sgoto(6)/40/,sgoto(7)/-2/ + data seq(1)/46/,seq(2)/101/,seq(3)/113/,seq(4)/46/,seq(5)/-2/ + data sge(1)/46/,sge(2)/103/,sge(3)/101/,sge(4)/46/,sge(5)/-2/ + data sle(1)/46/,sle(2)/108/,sle(3)/101/,sle(4)/46/,sle(5)/-2/ + data sand(1)/46/,sand(2)/97/,sand(3)/110/,sand(4)/100/,sand(5)/46/ + *,sand(6)/-2/ + swn = swvstk(swvlev) + swvlev = max0(0, swvlev - 1) + lb = swstak (swtop + 3) + ub = swstak (swlast - 2) + n = swstak (swtop + 1) + call outgo (lab + 1) + if (.not.(swstak (swtop + 2) .eq. 0))goto 23000 + swstak (swtop + 2) = lab + 1 +23000 continue + xfer = 0 + call indent (-1) + call outcon (lab) + call indent (1) + if (.not.(n .ge. 3 .and. ub - lb + 1 .lt. 2 * n))goto 23002 + if (.not.(lb .ne. 1))goto 23004 + call outtab + call swvar (swn) + call outch (61) + call swvar (swn) + if (.not.(lb .lt. 1))goto 23006 + call outch (43) +23006 continue + call outnum (-lb + 1) + call outdon +23004 continue + if (.not.(swinrg .eq. 0))goto 23008 + call outtab + call outstr (sif) + call swvar (swn) + call outstr (slt) + call swvar (swn) + call outstr (sgt) + call outnum (ub - lb + 1) + call outch (41) + call outch (32) + call outgo (swstak (swtop + 2)) +23008 continue + call outtab + call outstr (sgoto) + j = lb + i = swtop + 3 +23010 if (.not.(i .lt. swlast))goto 23012 +23013 if (.not.(j .lt. swstak (i)))goto 23015 + call outnum (swstak (swtop + 2)) + call outch (44) +23014 j = j + 1 + goto 23013 +23015 continue + j = swstak (i + 1) - swstak (i) +23016 if (.not.(j .ge. 0))goto 23018 + call outnum (swstak (i + 2)) +23017 j = j - 1 + goto 23016 +23018 continue + j = swstak (i + 1) + 1 + if (.not.(i .lt. swlast - 3))goto 23019 + call outch (44) +23019 continue +23011 i = i + 3 + goto 23010 +23012 continue + call outch (41) + call outch (44) + call swvar (swn) + call outdon + goto 23003 +23002 continue + if (.not.(n .gt. 0))goto 23021 + i = swtop + 3 +23023 if (.not.(i .lt. swlast))goto 23025 + call outtab + call outstr (sif) + call swvar (swn) + if (.not.(swstak (i) .eq. swstak (i+1)))goto 23026 + call outstr (seq) + call outnum (swstak (i)) + goto 23027 +23026 continue + call outstr (sge) + call outnum (swstak (i)) + call outstr (sand) + call swvar (swn) + call outstr (sle) + call outnum (swstak (i + 1)) +23027 continue + call outch (41) + call outch (32) + call outgo (swstak (i + 2)) +23024 i = i + 3 + goto 23023 +23025 continue + if (.not.(lab + 1 .ne. swstak (swtop + 2)))goto 23028 + call outgo (swstak (swtop + 2)) +23028 continue +23021 continue +23003 continue + call indent (-1) + call outcon (lab + 1) + swlast = swtop + swtop = swstak (swtop) + swinrg = 0 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/swvar.f b/unix/boot/spp/rpp/rppfor/swvar.f new file mode 100644 index 00000000..948e43ab --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/swvar.f @@ -0,0 +1,21 @@ + subroutine swvar (lab) + integer lab, i, labnum, ndigi0 + call outch (115) + call outch (119) + labnum = lab + ndigi0=0 +23000 if (.not.(labnum .gt. 0))goto 23002 + ndigi0 = ndigi0 + 1 +23001 labnum=labnum/10 + goto 23000 +23002 continue + i=3 +23003 if (.not.(i .le. 6 - ndigi0))goto 23005 + call outch (48) +23004 i=i+1 + goto 23003 +23005 continue + call outnum (lab) + return + end +c ndigi0 ndigits diff --git a/unix/boot/spp/rpp/rppfor/synerr.f b/unix/boot/spp/rpp/rppfor/synerr.f new file mode 100644 index 00000000..818171e5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/synerr.f @@ -0,0 +1,98 @@ + subroutine synerr (msg) + integer msg + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer lc (20) + integer i, junk + integer itoc + integer of(5) + integer errmsg(100) + data of(1)/32/,of(2)/111/,of(3)/102/,of(4)/32/,of(5)/-2/ + data errmsg(1)/69/,errmsg(2)/114/,errmsg(3)/114/,errmsg(4)/111/,er + *rmsg(5)/114/,errmsg(6)/32/,errmsg(7)/111/,errmsg(8)/110/,errmsg(9) + */32/,errmsg(10)/108/,errmsg(11)/105/,errmsg(12)/110/,errmsg(13)/10 + *1/,errmsg(14)/32/,errmsg(15)/-2/ + call putlin (errmsg, 2) + if (.not.(level .ge. 1))goto 23000 + i = level + goto 23001 +23000 continue + i = 1 +23001 continue + junk = itoc (linect (i), lc, 20) + call putlin (lc, 2) + i = fnamp - 1 +23002 if (.not.(i .ge. 1))goto 23004 + if (.not.(fnames (i - 1) .eq. -2 .or. i .eq. 1))goto 23005 + call putlin (of, 2) + call putlin (fnames (i), 2) + goto 23004 +23005 continue +23003 i = i - 1 + goto 23002 +23004 continue + call putch (58, 2) + call putch (32, 2) + call remark (msg) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/thenco.f b/unix/boot/spp/rpp/rppfor/thenco.f new file mode 100644 index 00000000..bb6060d7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/thenco.f @@ -0,0 +1,90 @@ + subroutine thenco (tok, lab) + integer lab, tok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer siferr(20) + integer sifno0(15) + data siferr(1)/105/,siferr(2)/102/,siferr(3)/32/,siferr(4)/40/,sif + *err(5)/46/,siferr(6)/110/,siferr(7)/111/,siferr(8)/116/,siferr(9)/ + *46/,siferr(10)/120/,siferr(11)/101/,siferr(12)/114/,siferr(13)/112 + */,siferr(14)/111/,siferr(15)/112/,siferr(16)/40/,siferr(17)/41/,si + *ferr(18)/41/,siferr(19)/32/,siferr(20)/-2/ + data sifno0(1)/105/,sifno0(2)/102/,sifno0(3)/32/,sifno0(4)/40/,sif + *no0(5)/120/,sifno0(6)/101/,sifno0(7)/114/,sifno0(8)/112/,sifno0(9) + */111/,sifno0(10)/112/,sifno0(11)/40/,sifno0(12)/41/,sifno0(13)/41/ + *,sifno0(14)/32/,sifno0(15)/-2/ + xfer = 0 + call outnum (lab+2) + call outtab + if (.not.(tok .eq. -98))goto 23000 + call outstr (siferr) + goto 23001 +23000 continue + call outstr (sifno0) +23001 continue + call outgo (lab) + esp = esp - 1 + call indent (1) + return + end +c sifno0 sifnoerr +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ulstal.f b/unix/boot/spp/rpp/rppfor/ulstal.f new file mode 100644 index 00000000..fe59090b --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ulstal.f @@ -0,0 +1,69 @@ + subroutine ulstal (name, defn) + integer name (100), defn (100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + call entdef (name, defn, deftbl) + call upper (name) + call entdef (name, defn, deftbl) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/uniqid.f b/unix/boot/spp/rpp/rppfor/uniqid.f new file mode 100644 index 00000000..d843f0eb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/uniqid.f @@ -0,0 +1,116 @@ + subroutine uniqid (id) + integer id (100) + integer i, j, junk, idchl + external index + integer lookup, index, length + integer start (6) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer idch(37) + data idch(1)/48/,idch(2)/49/,idch(3)/50/,idch(4)/51/,idch(5)/52/,i + *dch(6)/53/,idch(7)/54/,idch(8)/55/,idch(9)/56/,idch(10)/57/,idch(1 + *1)/97/,idch(12)/98/,idch(13)/99/,idch(14)/100/,idch(15)/101/,idch( + *16)/102/,idch(17)/103/,idch(18)/104/,idch(19)/105/,idch(20)/106/,i + *dch(21)/107/,idch(22)/108/,idch(23)/109/,idch(24)/110/,idch(25)/11 + *1/,idch(26)/112/,idch(27)/113/,idch(28)/114/,idch(29)/115/,idch(30 + *)/116/,idch(31)/117/,idch(32)/118/,idch(33)/119/,idch(34)/120/,idc + *h(35)/121/,idch(36)/122/,idch(37)/-2/ + i = 1 +23000 if (.not.(id (i) .ne. -2))goto 23002 +23001 i = i + 1 + goto 23000 +23002 continue +23003 if (.not.(i .le. 6))goto 23005 + id (i) = 48 +23004 i = i + 1 + goto 23003 +23005 continue + i = 6 + 1 + id (i) = -2 + id (i - 1) = 48 + if (.not.(lookup (id, junk, gentbl) .eq. 1))goto 23006 + idchl = length (idch) + i = 2 +23008 if (.not.(i .lt. 6))goto 23010 + start (i) = id (i) +23009 i = i + 1 + goto 23008 +23010 continue +23011 continue + i = 6 - 1 +23014 if (.not.(i .gt. 1))goto 23016 + j = mod (index (idch, id (i)), idchl) + 1 + id (i) = idch (j) + if (.not.(id (i) .ne. start (i)))goto 23017 + goto 23016 +23017 continue +23015 i = i - 1 + goto 23014 +23016 continue + if (.not.(i .eq. 1))goto 23019 + call baderr (30Hcannot make identifier unique.) +23019 continue +23012 if (.not.(lookup (id, junk, gentbl) .eq. 0))goto 23011 +23013 continue +23006 continue + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/unstak.f b/unix/boot/spp/rpp/rppfor/unstak.f new file mode 100644 index 00000000..c602dc06 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/unstak.f @@ -0,0 +1,58 @@ + subroutine unstak (sp, lextyp, labval, token) + integer labval(100), lextyp(100) + integer sp, token, type +23000 if (.not.(sp .gt. 1))goto 23002 + type = lextyp(sp) + if (.not.((type .eq. -98 .or. type .eq. -97) .and. token .eq. -86) + *)goto 23003 + goto 23002 +23003 continue + if (.not.(type .eq. -99 .or. type .eq. -98 .or. type .eq. -97))got + *o 23005 + type = 999 +23005 continue + if (.not.(type .eq. 123 .or. type .eq. -92))goto 23007 + goto 23002 +23007 continue + if (.not.(type .eq. 999 .and. token .eq. -87))goto 23009 + goto 23002 +23009 continue + if (.not.(type .eq. 999))goto 23011 + call indent (-1) + call outcon (labval(sp)) + goto 23012 +23011 continue + if (.not.(type .eq. -87 .or. type .eq. -72))goto 23013 + if (.not.(sp .gt. 2))goto 23015 + sp = sp - 1 +23015 continue + if (.not.(type .ne. -72))goto 23017 + call indent (-1) +23017 continue + call outcon (labval(sp) + 1) + goto 23014 +23013 continue + if (.not.(type .eq. -96))goto 23019 + call dostat (labval(sp)) + goto 23020 +23019 continue + if (.not.(type .eq. -95))goto 23021 + call whiles (labval(sp)) + goto 23022 +23021 continue + if (.not.(type .eq. -94))goto 23023 + call fors (labval(sp)) + goto 23024 +23023 continue + if (.not.(type .eq. -93))goto 23025 + call untils (labval(sp), token) +23025 continue +23024 continue +23022 continue +23020 continue +23014 continue +23012 continue +23001 sp=sp-1 + goto 23000 +23002 continue + end diff --git a/unix/boot/spp/rpp/rppfor/untils.f b/unix/boot/spp/rpp/rppfor/untils.f new file mode 100644 index 00000000..050e25fb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/untils.f @@ -0,0 +1,80 @@ + subroutine untils (lab, token) + integer lab, token + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ptoken (100) + integer junk + integer lex + xfer = 0 + call outnum (lab) + if (.not.(token .eq. -70))goto 23000 + junk = lex (ptoken) + call ifgo (lab - 1) + goto 23001 +23000 continue + call outgo (lab - 1) +23001 continue + call indent (-1) + call outcon (lab + 1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/whilec.f b/unix/boot/spp/rpp/rppfor/whilec.f new file mode 100644 index 00000000..1f830d00 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/whilec.f @@ -0,0 +1,72 @@ + subroutine whilec (lab) + integer lab + integer labgen + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + call outcon (0) + lab = labgen (2) + call outnum (lab) + call ifgo (lab + 1) + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/whiles.f b/unix/boot/spp/rpp/rppfor/whiles.f new file mode 100644 index 00000000..baa84531 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/whiles.f @@ -0,0 +1,69 @@ + subroutine whiles (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + call outgo (lab) + call indent (-1) + call outcon (lab + 1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rpprat/Makefile b/unix/boot/spp/rpp/rpprat/Makefile new file mode 100644 index 00000000..b09289f7 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/Makefile @@ -0,0 +1,44 @@ +# Ratfor source for the SPP preprocessor. A TOOLS compatible ratfor compiler +# is required to compile this. The original UNIX ratfor compiler may not do +# the job. + +.r.f: + /usr/local/bin/ratfor $*.r > $*.f + +SRCS= addchr.r allblk.r alldig.r baderr.r balpar.r beginc.r brknxt.r\ + cascod.r caslab.r declco.r deftok.r doarth.r docode.r doif.r\ + doincr.r domac.r dostat.r dosub.r eatup.r elseif.r endcod.r\ + entdef.r entdkw.r entfkw.r entrkw.r entxkw.r errchk.r errgo.r\ + errorc.r evalr.r finit.r forcod.r fors.r getdef.r gettok.r\ + gnbtok.r gocode.r gtok.r ifcode.r iferrc.r ifgo.r ifparm.r\ + indent.r initkw.r labelc.r labgen.r lex.r litral.r lndict.r\ + ludef.r mapid.r ngetch.r ogotos.r otherc.r outch.r outcon.r\ + outdon.r outdwe.r outgo.r outnum.r outstr.r outtab.r parse.r\ + pbnum.r pbstr.r poicod.r push.r putbak.r putchr.r puttok.r\ + ratfor.r relate.r repcod.r retcod.r sdupl.r skpblk.r squash.r\ + strdcl.r swcode.r swend.r swvar.r synerr.r thenco.r ulstal.r\ + uniqid.r unstak.r untils.r whilec.r whiles.r + +FORT= addchr.f allblk.f alldig.f baderr.f balpar.f beginc.f brknxt.f\ + cascod.f caslab.f declco.f deftok.f doarth.f docode.f doif.f\ + doincr.f domac.f dostat.f dosub.f eatup.f elseif.f endcod.f\ + entdef.f entdkw.f entfkw.f entrkw.f entxkw.f errchk.f errgo.f\ + errorc.f evalr.f finit.f forcod.f fors.f getdef.f gettok.f\ + gnbtok.f gocode.f gtok.f ifcode.f iferrc.f ifgo.f ifparm.f\ + indent.f initkw.f labelc.f labgen.f lex.f litral.f lndict.f\ + ludef.f mapid.f ngetch.f ogotos.f otherc.f outch.f outcon.f\ + outdon.f outdwe.f outgo.f outnum.f outstr.f outtab.f parse.f\ + pbnum.f pbstr.f poicod.f push.f putbak.f putchr.f puttok.f\ + ratfor.f relate.f repcod.f retcod.f sdupl.f skpblk.f squash.f\ + strdcl.f swcode.f swend.f swvar.f synerr.f thenco.f ulstal.f\ + uniqid.f unstak.f untils.f whilec.f whiles.f + +# NOTE -- After regenerating the fortran CASLAB.F, comment out the unreachable +# goto on line 32, generated due to a bug in the ratfor. + +fort: $(SRCS) common defs + make fsrc; mv *.f ../rppfor; touch fort + (cd ../rppfor; sed -e 's/ goto 23012/c goto 23012/'\ + < caslab.f > temp; mv temp caslab.f) + +fsrc: $(FORT) diff --git a/unix/boot/spp/rpp/rpprat/addchr.r b/unix/boot/spp/rpp/rpprat/addchr.r new file mode 100644 index 00000000..74695f93 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/addchr.r @@ -0,0 +1,15 @@ +#-h- addchr 254 local 12/01/80 15:53:44 +# addchr - put c in buf (bp) if it fits, increment bp + include defs + + subroutine addchr (c, buf, bp, maxsiz) + integer bp, maxsiz + character c, buf (ARB) + + if (bp > maxsiz) + call baderr ("buffer overflow.") + buf (bp) = c + bp = bp + 1 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/allblk.r b/unix/boot/spp/rpp/rpprat/allblk.r new file mode 100644 index 00000000..34b83451 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/allblk.r @@ -0,0 +1,22 @@ +#-h- allblk 486 local 12/01/80 15:53:44 +# allblk - determine if line consists of all blanks + include defs + +# this routine is called by outdon, and is here to fix +# a bug which sometimes occurs if two or more includes precede the +# first line of executable code. Could not trace down the cause + + integer function allblk (buf) + character buf (ARB) + + integer i + + allblk = YES + for (i = 1; buf (i) != NEWLINE & buf (i) != EOS; i = i + 1) + if (buf (i) != BLANK) { + allblk = NO + break + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/alldig.r b/unix/boot/spp/rpp/rpprat/alldig.r new file mode 100644 index 00000000..bac06161 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/alldig.r @@ -0,0 +1,17 @@ +#-h- alldig 306 local 12/01/80 15:53:45 +# alldig - return YES if str is all digits + include defs + + integer function alldig (str) + character str (ARB) + integer i + + alldig = NO + if (str (1) == EOS) + return + for (i = 1; str (i) != EOS; i = i + 1) + if (!IS_DIGIT(str (i))) + return + alldig = YES + return + end diff --git a/unix/boot/spp/rpp/rpprat/baderr.r b/unix/boot/spp/rpp/rpprat/baderr.r new file mode 100644 index 00000000..51164a8d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/baderr.r @@ -0,0 +1,12 @@ +#-h- baderr 144 local 12/01/80 15:53:45 +# baderr --- report fatal error message, then die + include defs + + subroutine baderr (msg) + + character msg (ARB) +# character*(*) msg + + call synerr (msg) + call endst + end diff --git a/unix/boot/spp/rpp/rpprat/balpar.r b/unix/boot/spp/rpp/rpprat/balpar.r new file mode 100644 index 00000000..8e0388b8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/balpar.r @@ -0,0 +1,40 @@ +#-h- balpar 854 local 12/01/80 15:53:46 +# balpar - copy balanced paren string + include defs + + subroutine balpar + + character t, token (MAXTOK) + character gettok, gnbtok + + integer nlpar + + if (gnbtok (token, MAXTOK) != LPAREN) { + call synerr ("missing left paren.") + return + } + call outstr (token) + nlpar = 1 + repeat { + t = gettok (token, MAXTOK) + if (t == SEMICOL | t == LBRACE | t == RBRACE | t == EOF) { + call pbstr (token) + break + } + if (t == NEWLINE) # delete newlines + token (1) = EOS + else if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == ALPHA) + call squash (token) + # else nothing special + call outstr (token) + } until (nlpar <= 0) + + if (nlpar != 0) + call synerr ("missing parenthesis in condition.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/beginc.r b/unix/boot/spp/rpp/rpprat/beginc.r new file mode 100644 index 00000000..ceb39e4b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/beginc.r @@ -0,0 +1,20 @@ + +include defs + +# BEGINC -- Code that gets executed when the "begin" statement is encountered, +# at the beginning of the executable section of a procedure. + + +subroutine beginc + +integer labgen +include COMMON_BLOCKS + + body = YES # in body of procedure + ername = NO # errchk name not encountered + esp = 0 # error stack pointer + label = FIRST_LABEL # start over with labels + retlab = labgen (1) # label for return stmt + logical_column = 6 + INDENT + col = logical_column +end diff --git a/unix/boot/spp/rpp/rpprat/brknxt.r b/unix/boot/spp/rpp/rpprat/brknxt.r new file mode 100644 index 00000000..154dc31e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/brknxt.r @@ -0,0 +1,45 @@ +#-h- brknxt 1077 local 12/01/80 15:53:46 +# brknxt - generate code for break n and next n; n = 1 is default + include defs + + subroutine brknxt (sp, lextyp, labval, token) + integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token + + integer i, n + integer alldig, ctoi + + character t, ptoken (MAXTOK) + character gnbtok + + include COMMON_BLOCKS + + n = 0 + t = gnbtok (ptoken, MAXTOK) + if (alldig (ptoken) == YES) { # have break n or next n + i = 1 + n = ctoi (ptoken, i) - 1 + } + else if (t != SEMICOL) # default case + call pbstr (ptoken) + for (i = sp; i > 0; i = i - 1) + if (lextyp (i) == LEXWHILE | lextyp (i) == LEXDO + | lextyp (i) == LEXFOR | lextyp (i) == LEXREPEAT) { + if (n > 0) { + n = n - 1 + next # seek proper level + } + else if (token == LEXBREAK) + call outgo (labval (i) + 1) + else + call outgo (labval (i)) + xfer = YES + return + } + + if (token == LEXBREAK) + call synerr ("illegal break.") + else + call synerr ("illegal next.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/cascod.r b/unix/boot/spp/rpp/rpprat/cascod.r new file mode 100644 index 00000000..073dc9a4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/cascod.r @@ -0,0 +1,71 @@ +#-h- cascod 1876 local 12/01/80 15:53:46 +# cascod - generate code for case or default label + include defs + + subroutine cascod (lab, token) + integer lab, token + + include COMMON_BLOCKS + + integer t, l, lb, ub, i, j, junk + integer caslab, labgen, gnbtok + + character tok (MAXTOK) + + if (swtop <= 0) { + call synerr ("illegal case or default.") + return + } + call indent (-1) + call outgo (lab + 1) # terminate previous case + xfer = YES + l = labgen (1) + if (token == LEXCASE) { # case n[,n]... : ... + while (caslab (lb, t) != EOF) { + ub = lb + if (t == MINUS) + junk = caslab (ub, t) + if (lb > ub) { + call synerr ("illegal range in case label.") + ub = lb + } + if (swlast + 3 > MAXSWITCH) + call baderr ("switch table overflow.") + for (i = swtop + 3; i < swlast; i = i + 3) + if (lb <= swstak (i)) + break + else if (lb <= swstak (i+1)) + call synerr ("duplicate case label.") + if (i < swlast & ub >= swstak (i)) + call synerr ("duplicate case label.") + for (j = swlast; j > i; j = j - 1) # insert new entry + swstak (j+2) = swstak (j-1) + swstak (i) = lb + swstak (i + 1) = ub + swstak (i + 2) = l + swstak (swtop + 1) = swstak (swtop + 1) + 1 + swlast = swlast + 3 + if (t == COLON) + break + else if (t != COMMA) + call synerr ("illegal case syntax.") + } + } + else { # default : ... + t = gnbtok (tok, MAXTOK) + if (swstak (swtop + 2) != 0) + call error ("multiple defaults in switch statement.") + else + swstak (swtop + 2) = l + } + + if (t == EOF) + call synerr ("unexpected EOF.") + else if (t != COLON) + call error ("missing colon in case or default label.") + + xfer = NO + call outcon (l) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/caslab.r b/unix/boot/spp/rpp/rpprat/caslab.r new file mode 100644 index 00000000..12d3c0da --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/caslab.r @@ -0,0 +1,48 @@ +include defs + +# caslab - get one case label + +integer function caslab (n, t) + +integer n, t +character tok(MAXTOK) +integer i, s, lev +integer gnbtok, ctoi + + t = gnbtok (tok, MAXTOK) + while (t == NEWLINE) + t = gnbtok (tok, MAXTOK) + + if (t == EOF) + return (t) + + for (lev=0; t == LPAREN; t = gnbtok (tok, MAXTOK)) + lev = lev + 1 + + if (t == MINUS) + s = -1 + else + s = +1 + if (t == MINUS | t == PLUS) + t = gnbtok (tok, MAXTOK) + + if (t != DIGIT) + goto 99 + else { + i = 1 + n = s * ctoi (tok, i) + } + + for (t=gnbtok(tok,MAXTOK); t == RPAREN; t=gnbtok(tok,MAXTOK)) + lev = lev - 1 + if (lev != 0) + goto 99 + + while (t == NEWLINE) + t = gnbtok (tok, MAXTOK) + + return + + 99 call synerr ("Invalid case label.") + n = 0 +end diff --git a/unix/boot/spp/rpp/rpprat/common b/unix/boot/spp/rpp/rpprat/common new file mode 100644 index 00000000..9685729a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/common @@ -0,0 +1,79 @@ +#-h- common 2163 local 12/01/80 15:50:08 +# Common blocks used by the Ratfor preprocessor +# Place on a file called 'common' + + + common /cdefio/ bp, buf (BUFSIZE) + integer bp # next available character; init = 0 + character buf # pushed-back characters + + common /cfname/ fcname (MAXNAME) + character fcname # text of current function name + + common /cfor/ fordep, forstk (MAXFORSTK) + integer fordep # current depth of for statements + character forstk # stack of reinit strings + + common /cgoto/ xfer + integer xfer # YES if just made transfer, NO otherwise + + common /clabel/ label, retlab, memflg, col, logical_column + integer label # next label returned by labgen + integer retlab # label for return code at end of procedure + integer memflg # set to YES after Mem common has been declared + integer col # column where output statement starts + integer logical_column # col = min (maxindent, logical_column) + + common /cline/ dbgout, dbglev, level, linect (NFILES), infile (NFILES), + fnamp, fnames (MAXFNAMES) + integer dbgout # YES if debug (-g) output is desired + integer dbglev # current file level for debug output + integer level # level of file inclusion; init = 1 + integer linect # line count on input file (level); init = 1 + integer infile # file number (level); init infile (1) = STDIN + integer fnamp # next free slot in fnames; init = 2 + character fnames # stack of include names; init fnames (1) = EOS + + common /cmacro/ cp, ep, evalst (EVALSIZE), deftbl + integer cp # current call stack pointer + integer ep # next free position in evalst + character evalst # evaluation stack + pointer deftbl # symbol table holding macro names + + common /coutln/ outp, outbuf (74) + integer outp # last position filled in outbuf; init = 0 + character outbuf # output lines collected here + + common /csbuf/ sbp, sbuf(SBUFSIZE), smem(SZ_SMEM) + integer sbp # next available character position; init = 1 + character sbuf # saved for data statements + character smem # mem declaration + + common /cswtch/ swtop, swlast, swstak(MAXSWITCH), swvnum, swvlev, + swvstk(MAXSWNEST), swinrg + integer swtop # current switch entry; init = 0 + integer swlast # next available position; init = 1 + integer swstak # switch information + integer swvnum # counter for switch variable names; init = 0 + integer swvlev # level pointer for nesting of switches; init = 0 + integer swvstk # stack for the switch variable names + integer swinrg # assert swinrange - disable range checking in next sw. + + common /ckword/ rkwtbl + pointer rkwtbl # symbol table containing Ratfor key words + + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + pointer fkwtbl # a list of long Fortran keywords + pointer namtbl # map of long-form names to short-form names + pointer gentbl # list of generated names + pointer errtbl # symbol table of names to be error checked + pointer xpptbl # table of xpp directives + +common /erchek/ ername, body, esp, errstk(MAXERRSTK) + integer ername # YES if err checked name encountered + integer body # YES when between BEGIN .. END block + integer esp # error stack pointer + integer errstk # error stack (for statement labels) + + DS_DECL(mem, MEMSIZE) +#-t- common 2163 local 12/01/80 15:50:08 diff --git a/unix/boot/spp/rpp/rpprat/declco.r b/unix/boot/spp/rpp/rpprat/declco.r new file mode 100644 index 00000000..7c669e8c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/declco.r @@ -0,0 +1,72 @@ +include defs + +# DECLCO -- Process a declaration (xpp directive). Look up directive in +# the symbol table. If found, output the corresponding Fortran declaration, +# otherwise output the original string. + +subroutine declco (id) + +character id(MAXTOK) +character newid(MAXTOK), tok, tokbl +integer junk, ludef, equal, gettok +include COMMON_BLOCKS +string xptyp XPOINTER +string xpntr "x$pntr" +string xfunc "x$func" +string xsubr "x$subr" +ifdef (IMPNONE, +string impnone "implicit none") + + if (ludef (id, newid, xpptbl) == YES) { + if (equal (id, xpntr) == YES) { + # Pointer declaration. + tokbl = gettok (newid, MAXTOK) + if (tokbl == BLANK) + tok = gettok (newid, MAXTOK) + else + tok = tokbl + + if (tok == XPP_DIRECTIVE & equal (newid, xfunc) == YES) { + # Pointer function. + call outtab + call outstr (xptyp) + junk = ludef (newid, newid, xpptbl) + call outstr (newid) + call eatup + call outdon + + ifdef (IMPNONE, + call outtab + call outstr (impnone) + call outdon) + + call poicod (NO) + + } else { + # Pointer variable. + call pbstr (newid) + call poicod (YES) + } + + } else if (equal (id, xsubr) == YES) { + # Subroutine declaration. + call outtab + call outstr (newid) + call eatup + call outdon + + ifdef (IMPNONE, + call outtab + call outstr (impnone) + call outdon) + + } else { + # Some other declaration. + call outtab + call outstr (newid) + call outch (BLANK) + } + + } else + call synerr ("Invalid x$type type declaration.") +end diff --git a/unix/boot/spp/rpp/rpprat/defs b/unix/boot/spp/rpp/rpprat/defs new file mode 100644 index 00000000..bf040c55 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/defs @@ -0,0 +1,138 @@ +# common definitions for all routines comprising the ratfor preprocessor +#--------------------------------------------------------------- +# The definition STDEFNS defines the file which contains the +# standard definitions to be used when preprocessing a file. +# It is opened and read automatically by the ratfor preprocessor. +# Set STDEFNS to the name of the file in which the standard +# definitions reside. If you don't want the preprocessor to +# automatically open this file, set STDENFS to "". +# +#--------------------------------------------------------------- +# If you want the preprocessor to output upper case only, +# set the following definition: +# +# define (UPPERC,) +# +#--------------------------------------------------------------- +# Some of the buffer sizes and other symbols might have to be +# changed. Especially check the following: +# +# MAXDEF (number of characters in a definition) +# SBUFSIZE (nbr string declarations allowed per module) +# MAXSTRTBL (size of table to buffer string declarations) +# MAXSWITCH (max stack for switch statement) +# +#----------------------------------------------------------------- + + +define (STDEFNS, string defns "") # standard defns file +#define (UPPERC,) # define if Fortran compiler wants upper case +#define (IMPNONE,) # output IMPLICIT NONE in procedures +define (NULL,0) +define (INDENT,3) # number of spaces of indentation +define (MAX_INDENT,30) # maximum column for indentation +define (FIRST_LABEL,100) # first statement label +define (SZ_SPOOLBUF,8) # for breaking continuation cards + +define (RADIX,PERCENT) # % indicates alternate radix +define (TOGGLE,PERCENT) # toggle for literal lines +define (ARGFLAG,DOLLAR) +define (CUTOFF,3) # min nbr of cases to generate branch table + # (for switch statement) +define (DENSITY,2) # reciprocal of density necessary for + # branch table +define (FILLCHAR,DIG0) # used in long-name uniquing +define (MAXIDLENGTH,6) # for Fortran 66 and 77 +define (SZ_SMEM,240) # memory common declarations string + + +# Lexical items (codes are negative to avoid conflict with character values) + +define (LEXBEGIN,-83) +define (LEXBREAK,-79) +define (LEXCASE,-91) +define (LEXDEFAULT,-90) +define (LEXDIGITS,-89) +define (LEXDO,-96) +define (LEXELSE,-87) +define (LEXEND,-82) +define (LEXERRCHK,-84) +define (LEXERROR,-73) +define (LEXFOR,-94) +define (LEXIF,-99) +define (LEXIFELSE,-72) +define (LEXIFERR,-98) +define (LEXIFNOERR,-97) +define (LEXLITERAL,-85) +define (LEXNEXT,-78) +define (LEXOTHER,-80) +define (LEXPOINTER,-88) +define (LEXRBRACE,-74) +define (LEXREPEAT,-93) +define (LEXRETURN,-77) +define (LEXGOTO,-76) +define (LEXSTOP,-71) +define (LEXSTRING,-75) +define (LEXSWITCH,-92) +define (LEXTHEN,-86) +define (LEXUNTIL,-70) +define (LEXWHILE,-95) +define (LSTRIPC,-69) +define (RSTRIPC,-68) +define (LEXDECL,-67) + +define (XPP_DIRECTIVE, -166) + +# Built-in macro functions: + +define (DEFTYPE,-4) +define (MACTYPE,-10) +define (IFTYPE,-11) +define (INCTYPE,-12) +define (SUBTYPE,-13) +define (ARITHTYPE,-14) +define (IFDEFTYPE,-15) +define (IFNOTDEFTYPE,-16) +define (PRAGMATYPE,-17) + + +# Size-limiting definitions: + +define (MEMSIZE,60000) # space allotted to symbol tables and macro text +define (BUFSIZE,4096) # pushback buffer for ngetch and putbak +define (PBPOINT,3192) # point in buffer where pushback begins +define (SBUFSIZE,2048) # buffer for string statements +define (MAXDEF,2048) # max chars in a defn +define (MAXFORSTK,200) # max space for for reinit clauses +define (MAXERRSTK,30) # max nesting of iferr statements +define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) +define (MAXSTACK,100) # max stack depth for parser +define (MAXSWITCH,1000) # max stack for switch statement +define (MAXSWNEST,10) # max nesting of switches in a procedure +define (MAXTOK,100) # max chars in a token +define (NFILES,5) # max number of include file nesting +define (MAXNBRSTR,20) #max nbr string declarations per module +define (CALLSIZE,50) +define (ARGSIZE,100) +define (EVALSIZE,500) + + +# Where to find the common blocks: + +define(COMMON_BLOCKS,"common") + +# Data types, Dynamic Memory common: + +define (XPOINTER,"integer ") + + +# The following external names are redefined to avoid name collisions with +# standard library procedures on some systems. + +define open rfopen +define close rfclos +define flush rfflus +define note rfnote +define seek rfseek +define remove rfrmov +define exit rexit diff --git a/unix/boot/spp/rpp/rpprat/deftok.r b/unix/boot/spp/rpp/rpprat/deftok.r new file mode 100644 index 00000000..af20c35c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/deftok.r @@ -0,0 +1,162 @@ +#-h- deftok 4116 local 12/01/80 15:53:47 +# deftok - get token; process macro calls and invocations + include defs + +# this routine has been disabled to allow defines with parameters to be added + +# character function deftok (token, toksiz) +# character gtok +# integer toksiz +# character defn (MAXDEF), t, token (MAXTOK) +# integer ludef +# include COMMON_BLOCKS +# +# for (t = gtok (token, toksiz); t!=EOF; t = gtok (token, toksiz)) { +# if (t != ALPHA) # non-alpha +# break +# if (ludef (token, defn, deftbl) == NO) # undefined +# break +# if (defn (1) == DEFTYPE) { # get definition +# call getdef (token, toksiz, defn, MAXDEF) +# call entdef (token, defn, deftbl) +# } +# else +# call pbstr (defn) # push replacement onto input +# } +# deftok = t +# if (deftok == ALPHA) # convert to single case +# call fold (token) +# return +# end +# deftok - get token; process macro calls and invocations + + character function deftok (token, toksiz) + character token (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character t, c, defn (MAXDEF), mdefn (MAXDEF) + character gtok + integer equal + + integer ap, argstk (ARGSIZE), callst (CALLSIZE), + nlb, plev (CALLSIZE), ifl + integer ludef, push, ifparm + + string balp "()" + string pswrg "switch_no_range_check" + + cp = 0 + ap = 1 + ep = 1 + for (t = gtok (token, toksiz); t != EOF; t = gtok (token, toksiz)) { + if (t == ALPHA) + if (ludef (token, defn, deftbl) == NO) { + if (cp == 0) + break + else + call puttok (token) + } else if (defn (1) == DEFTYPE) { # process defines directly + call getdef (token, toksiz, defn, MAXDEF) + call entdef (token, defn, deftbl) + } else if (defn (1) == IFDEFTYPE | defn (1) == IFNOTDEFTYPE) { + c = defn (1) + call getdef (token, toksiz, defn, MAXDEF) + ifl = ludef (token, mdefn, deftbl) + if ((ifl == YES & c == IFDEFTYPE) | + (ifl == NO & c == IFNOTDEFTYPE)) + call pbstr (defn) + + } else if (defn(1) == PRAGMATYPE & cp == 0) { # pragma + if (gtok (defn, MAXDEF) == BLANK) { + if (gtok (defn, MAXDEF) == ALPHA) { + if (equal (defn, pswrg) == YES) + swinrg = YES + else + goto 10 + } else { +10 call pbstr (defn) + call putbak (BLANK) + break + } + } else { + call pbstr (defn) + break + } + + } else { + cp = cp + 1 + if (cp > CALLSIZE) + call baderr ("call stack overflow.") + callst (cp) = ap + ap = push (ep, argstk, ap) + call puttok (defn) + call putchr (EOS) + ap = push (ep, argstk, ap) + call puttok (token) + call putchr (EOS) + ap = push (ep, argstk, ap) + t = gtok (token, toksiz) + if (t == BLANK) { # allow blanks before arguments + t = gtok (token, toksiz) + call pbstr (token) + if (t != LPAREN) + call putbak (BLANK) + } + else + call pbstr (token) + if (t != LPAREN) + call pbstr (balp) + else if (ifparm (defn) == NO) + call pbstr (balp) + plev (cp) = 0 + } else if (t == LSTRIPC) { + nlb = 1 + repeat { + t = gtok (token, toksiz) + if (t == LSTRIPC) + nlb = nlb + 1 + else if (t == RSTRIPC) { + nlb = nlb - 1 + if (nlb == 0) + break + } + else if (t == EOF) + call baderr ("EOF in string.") + call puttok (token) + } + } + else if (cp == 0) + break + else if (t == LPAREN) { + if (plev (cp) > 0) + call puttok (token) + plev (cp) = plev (cp) + 1 + } + else if (t == RPAREN) { + plev (cp) = plev (cp) - 1 + if (plev (cp) > 0) + call puttok (token) + else { + call putchr (EOS) + call evalr (argstk, callst (cp), ap - 1) + ap = callst (cp) + ep = argstk (ap) + cp = cp - 1 + } + } + else if (t == COMMA & plev (cp) == 1) { + call putchr (EOS) + ap = push (ep, argstk, ap) + } + else + call puttok (token) + } + + deftok = t + if (t == ALPHA) + call fold (token) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/doarth.r b/unix/boot/spp/rpp/rpprat/doarth.r new file mode 100644 index 00000000..2fe633d5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doarth.r @@ -0,0 +1,30 @@ +#-h- doarth 636 local 12/01/80 15:53:48 +# doarth - do arithmetic operation + include defs + + subroutine doarth (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer k, l + integer ctoi + + character op + + k = argstk (i + 2) + l = argstk (i + 4) + op = evalst (argstk (i + 3)) + if (op == PLUS) + call pbnum (ctoi (evalst, k) + ctoi (evalst, l)) + else if (op == MINUS) + call pbnum (ctoi (evalst, k) - ctoi (evalst, l)) + else if (op == STAR ) + call pbnum (ctoi (evalst, k) * ctoi (evalst, l)) + else if (op == SLASH ) + call pbnum (ctoi (evalst, k) / ctoi (evalst, l)) + else + call remark ('arith error') + + return + end diff --git a/unix/boot/spp/rpp/rpprat/docode.r b/unix/boot/spp/rpp/rpprat/docode.r new file mode 100644 index 00000000..e505f8ee --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/docode.r @@ -0,0 +1,33 @@ +#-h- docode 522 local 12/01/80 15:53:49 +# docode - generate code for beginning of do + include defs + + subroutine docode (lab) + integer lab + + integer labgen + + include COMMON_BLOCKS + + character gnbtok + character lexstr (MAXTOK) + + string sdo "do" + + xfer = NO + call outtab + call outstr (sdo) + call outch (BLANK) + lab = labgen (2) + if (gnbtok (lexstr, MAXTOK) == DIGIT) # check for fortran DO + call outstr (lexstr) + else { + call pbstr (lexstr) + call outnum (lab) + } + call outch (BLANK) + call eatup + call outdwe + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/doif.r b/unix/boot/spp/rpp/rpprat/doif.r new file mode 100644 index 00000000..51495bd2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doif.r @@ -0,0 +1,25 @@ +#-h- doif 458 local 12/01/80 15:53:49 +# doif - select one of two (macro) arguments + include defs + + subroutine doif (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer a2, a3, a4, a5 + integer equal + + if (j - i < 5) + return + a2 = argstk (i + 2) + a3 = argstk (i + 3) + a4 = argstk (i + 4) + a5 = argstk (i + 5) + if (equal (evalst (a2), evalst (a3)) == YES) # subarrays + call pbstr (evalst (a4)) + else + call pbstr (evalst (a5)) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/doincr.r b/unix/boot/spp/rpp/rpprat/doincr.r new file mode 100644 index 00000000..9a8604bf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doincr.r @@ -0,0 +1,17 @@ +#-h- doincr 246 local 12/01/80 15:53:49 +# doincr - increment macro argument by 1 + include defs + + subroutine doincr (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer k + integer ctoi + + k = argstk (i + 2) + call pbnum (ctoi (evalst, k) + 1) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/domac.r b/unix/boot/spp/rpp/rpprat/domac.r new file mode 100644 index 00000000..fe4c1c62 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/domac.r @@ -0,0 +1,18 @@ +#-h- domac 326 local 12/01/80 15:53:49 +# domac - install macro definition in table + include defs + + subroutine domac (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer a2, a3 + + if (j - i > 2) { + a2 = argstk (i + 2) + a3 = argstk (i + 3) + call entdef (evalst (a2), evalst (a3), deftbl) # subarrays + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/dostat.r b/unix/boot/spp/rpp/rpprat/dostat.r new file mode 100644 index 00000000..4a934bad --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/dostat.r @@ -0,0 +1,13 @@ +#-h- dostat 156 local 12/01/80 15:53:50 +# dostat - generate code for end of do statement + include defs + + subroutine dostat (lab) + + integer lab + + call indent (-1) + call outcon (lab) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/dosub.r b/unix/boot/spp/rpp/rpprat/dosub.r new file mode 100644 index 00000000..611bdbaf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/dosub.r @@ -0,0 +1,31 @@ +#-h- dosub 709 local 12/01/80 15:53:50 +# dosub - select macro substring + include defs + + subroutine dosub (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer ap, fc, k, nc + integer ctoi, length + + if (j - i < 3) + return + if (j - i < 4) + nc = MAXTOK + else { + k = argstk (i + 4) + nc = ctoi (evalst, k) # number of characters + } + k = argstk (i + 3) # origin + ap = argstk (i + 2) # target string + fc = ap + ctoi (evalst, k) - 1 # first char of substring + if (fc >= ap & fc < ap + length (evalst (ap))) { # subarrays + k = fc + min (nc, length (evalst (fc))) - 1 + for ( ; k >= fc; k = k - 1) + call putbak (evalst (k)) + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/eatup.r b/unix/boot/spp/rpp/rpprat/eatup.r new file mode 100644 index 00000000..df001caf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/eatup.r @@ -0,0 +1,69 @@ +#-h- eatup 1137 local 12/01/80 15:53:50 +# eatup - process rest of statement; interpret continuations + include defs + + subroutine eatup + + character ptoken (MAXTOK), t, token (MAXTOK) + character gettok + integer nlpar, equal + include COMMON_BLOCKS + string serror "error" + + nlpar = 0 + token(1) = EOS + + repeat { + call outstr (token) + t = gettok (token, MAXTOK) + } until (t != BLANK & t != TAB) + + if (t == ALPHA) { # is it a "call error" stmt? + if (equal (token, serror) == YES) { + # call errorc (token) + # return + + # ERROR statement is now simply error checked like any other + # external procedure, so that it may be used the same way. + ername = YES + } + } + goto 10 + + repeat { + t = gettok (token, MAXTOK) +10 if (t == SEMICOL | t == NEWLINE) + break + if (t == RBRACE | t == LBRACE) { + call pbstr (token) + break + } + if (t == EOF) { + call synerr ("unexpected EOF.") + call pbstr (token) + break + } + if (t == COMMA | t == PLUS | t == MINUS | t == STAR | + (t == SLASH & body == YES) | + t == LPAREN | t == AND | t == BAR | t == BANG | t == TILDE | + t == NOT | t == CARET | t == EQUALS | t == UNDERLINE) { + while (gettok (ptoken, MAXTOK) == NEWLINE) + ; + call pbstr (ptoken) + if (t == UNDERLINE) + token (1) = EOS + } + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == ALPHA) + call squash (token) + call outstr (token) + } until (nlpar < 0) + + if (nlpar != 0) + call synerr ("unbalanced parentheses.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/elseif.r b/unix/boot/spp/rpp/rpprat/elseif.r new file mode 100644 index 00000000..88b1355d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/elseif.r @@ -0,0 +1,13 @@ +#-h- elseif 155 local 12/01/80 15:53:51 +# elseif - generate code for end of if before else + include defs + + subroutine elseif (lab) + integer lab + + call outgo (lab+1) + call indent (-1) + call outcon (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/endcod.r b/unix/boot/spp/rpp/rpprat/endcod.r new file mode 100644 index 00000000..f94636f8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/endcod.r @@ -0,0 +1,36 @@ +include defs + +# ENDCOD -- Code thats gets executed when the END statement is encountered, +# terminating a procedure. + +subroutine endcod (endstr) + +character endstr(1) +include COMMON_BLOCKS +string sepro "call zzepro" +string sret "return" + + if (esp != 0) + call synerr ("Unmatched 'iferr' or 'then' keyword.") + esp = 0 # error stack pointer + body = NO + ername = NO + if (errtbl != NULL) + call rmtabl (errtbl) + errtbl = NULL + memflg = NO # reinit mem decl flag + + if (retlab != NULL) + call outnum (retlab) + call outtab + call outstr (sepro) + call outdon + call outtab + call outstr (sret) + call outdon + + col = 6 + call outtab + call outstr (endstr) + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/entdef.r b/unix/boot/spp/rpp/rpprat/entdef.r new file mode 100644 index 00000000..e9c447ff --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entdef.r @@ -0,0 +1,19 @@ +#-h- entdef 387 local 12/01/80 15:53:51 +# entdef - enter a new symbol definition, discarding any old one + include defs + + subroutine entdef (name, defn, table) + character name (MAXTOK), defn (ARB) + pointer table + + integer lookup + + pointer text + pointer sdupl + + if (lookup (name, text, table) == YES) + call dsfree (text) # this is how to do UNDEFINE, by the way + call enter (name, sdupl (defn), table) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/entdkw.r b/unix/boot/spp/rpp/rpprat/entdkw.r new file mode 100644 index 00000000..6b061075 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entdkw.r @@ -0,0 +1,41 @@ +#-h- entdkw 975 local 12/01/80 15:54:05 +# entdkw --- install macro processor keywords + include defs + + subroutine entdkw + + character deft(2), prag(2) #, inct(2), subt(2), ift(2), art(2), + # ifdft(2), ifndt(2), mact(2) + + string defnam "define" + string prgnam "pragma" +# string macnam "mdefine" +# string incnam "incr" +# string subnam "substr" +# string ifnam "ifelse" +# string arnam "arith" +# string ifdfnm "ifdef" +# string ifndnm "ifnotdef" + + data deft (1), deft (2) /DEFTYPE, EOS/ + data prag (1), prag (2) /PRAGMATYPE, EOS/ +# data mact (1), mact (2) /MACTYPE, EOS/ +# data inct (1), inct (2) /INCTYPE, EOS/ +# data subt (1), subt (2) /SUBTYPE, EOS/ +# data ift (1), ift (2) /IFTYPE, EOS/ +# data art (1), art (2) /ARITHTYPE, EOS/ +# data ifdft (1), ifdft (2) /IFDEFTYPE, EOS/ +# data ifndt (1), ifndt (2) /IFNOTDEFTYPE, EOS/ + + call ulstal (defnam, deft) + call ulstal (prgnam, prag) +# call ulstal (macnam, mact) +# call ulstal (incnam, inct) +# call ulstal (subnam, subt) +# call ulstal (ifnam, ift) +# call ulstal (arnam, art) +# call ulstal (ifdfnm, ifdft) +# call ulstal (ifndnm, ifndt) + +return +end diff --git a/unix/boot/spp/rpp/rpprat/entfkw.r b/unix/boot/spp/rpp/rpprat/entfkw.r new file mode 100644 index 00000000..43174502 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entfkw.r @@ -0,0 +1,14 @@ +include defs + +# entfkw - place Fortran keywords in symbol table. +# Place in the following table any long (> 6 characters) +# keyword that is used by your Fortran compiler: + + +subroutine entfkw + +include COMMON_BLOCKS +string sequiv "equivalence" + + call enter (sequiv, 0, fkwtbl) +end diff --git a/unix/boot/spp/rpp/rpprat/entrkw.r b/unix/boot/spp/rpp/rpprat/entrkw.r new file mode 100644 index 00000000..ec86b9e0 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entrkw.r @@ -0,0 +1,56 @@ +#-h- entrkw 1003 local 12/01/80 15:54:06 +# entrkw --- install Ratfor keywords in symbol table + include defs + + subroutine entrkw + + include COMMON_BLOCKS + + string sif "if" + string selse "else" + string swhile "while" + string sdo "do" + string sbreak "break" + string snext "next" + string sfor "for" + string srept "repeat" + string suntil "until" + string sret "return" + string sstr "string" + string sswtch "switch" + string scase "case" + string sdeflt "default" + string send "end" + string serrchk "errchk" + string siferr "iferr" + string sifnoerr "ifnoerr" + string sthen "then" + string sbegin "begin" + string spoint "pointer" + string sgoto "goto" + + call enter (sif, LEXIF, rkwtbl) + call enter (selse, LEXELSE, rkwtbl) + call enter (swhile, LEXWHILE, rkwtbl) + call enter (sdo, LEXDO, rkwtbl) + call enter (sbreak, LEXBREAK, rkwtbl) + call enter (snext, LEXNEXT, rkwtbl) + call enter (sfor, LEXFOR, rkwtbl) + call enter (srept, LEXREPEAT, rkwtbl) + call enter (suntil, LEXUNTIL, rkwtbl) + call enter (sret, LEXRETURN, rkwtbl) + call enter (sstr, LEXSTRING, rkwtbl) + call enter (sswtch, LEXSWITCH, rkwtbl) + call enter (scase, LEXCASE, rkwtbl) + call enter (sdeflt, LEXDEFAULT, rkwtbl) + call enter (send, LEXEND, rkwtbl) + call enter (serrchk, LEXERRCHK, rkwtbl) + call enter (siferr, LEXIFERR, rkwtbl) + call enter (sifnoerr, LEXIFNOERR, rkwtbl) + call enter (sthen, LEXTHEN, rkwtbl) + call enter (sbegin, LEXBEGIN, rkwtbl) + call enter (spoint, LEXPOINTER, rkwtbl) + call enter (sgoto, LEXGOTO, rkwtbl) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/entxkw.r b/unix/boot/spp/rpp/rpprat/entxkw.r new file mode 100644 index 00000000..d2ec81b2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entxkw.r @@ -0,0 +1,51 @@ + +include defs + +# ENTXKW -- Enter all XPP directives in the symbol table. + +subroutine entxkw + +include COMMON_BLOCKS + +string sbool "x$bool" +string schar "x$char" +string sshort "x$short" +string sint "x$int" +string slong "x$long" +string sreal "x$real" +string sdble "x$dble" +string scplx "x$cplx" +string spntr "x$pntr" +string sfchr "x$fchr" +string sfunc "x$func" +string ssubr "x$subr" +string sextn "x$extn" + +string dbool "logical" +string dchar "integer*2" +string dshort "integer*2" +string dint "integer" +string dlong "integer" +string dpntr "integer" +string dreal "real" +string ddble "double precision" +string dcplx "complex" +string dfchr "character" +string dfunc "function" +string dsubr "subroutine" +string dextn "external" + + call entdef (sbool, dbool, xpptbl) + call entdef (schar, dchar, xpptbl) + call entdef (sshort, dshort, xpptbl) + call entdef (sint, dint, xpptbl) + call entdef (slong, dlong, xpptbl) + call entdef (spntr, dpntr, xpptbl) + call entdef (sreal, dreal, xpptbl) + call entdef (sdble, ddble, xpptbl) + call entdef (scplx, dcplx, xpptbl) + call entdef (sfchr, dfchr, xpptbl) + call entdef (sfunc, dfunc, xpptbl) + call entdef (ssubr, dsubr, xpptbl) + call entdef (sextn, dextn, xpptbl) +end diff --git a/unix/boot/spp/rpp/rpprat/errchk.r b/unix/boot/spp/rpp/rpprat/errchk.r new file mode 100644 index 00000000..4b948936 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errchk.r @@ -0,0 +1,42 @@ +include defs + +# ERRCHK -- Code called to process an ERRCHK declaration. + +subroutine errchk + +character tok, last_tok, gnbtok, token(MAXTOK) +integer ntok +pointer mktabl +include COMMON_BLOCKS +string serrcom1 "logical xerflg, xerpad(84)" +string serrcom2 "common /xercom/ xerflg, xerpad" + + ntok = 0 + tok = 0 + + repeat { + last_tok = tok + tok = gnbtok (token, MAXTOK) + + switch (tok) { + case ALPHA: + if (errtbl == NULL) { + errtbl = mktabl(0) # make empty table + call outtab # declare err flag + call outstr (serrcom1) + call outdon + call outtab # declare err common + call outstr (serrcom2) + call outdon + } + call enter (token, 0, errtbl) # enter keyw in table + case COMMA: + # no action, but required by syntax + case NEWLINE: + if (last_tok != COMMA) + break + default: + call synerr ("Syntax error in ERRCHK declaration.") + } + } +end diff --git a/unix/boot/spp/rpp/rpprat/errgo.r b/unix/boot/spp/rpp/rpprat/errgo.r new file mode 100644 index 00000000..81aa582c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errgo.r @@ -0,0 +1,29 @@ +include defs + +# ERRGO -- Ouput error checking code. + +subroutine errgo + +include COMMON_BLOCKS +string serrchk "if (xerflg) " + + # In the processing of the last line, was an indentifier encountered + # for which error checking is required (named in errchk declaration)? + + if (ername == YES) { + call outtab + if (esp > 0) { # in iferr ... stmt? + # Omit goto if goto statement label number is zero. This + # happens in "iferr (...)" statements. + if (errstk(esp) > 0) { + call outstr (serrchk) + call ogotos (errstk(esp)+2, NO) # "goto lab" + } + } else { + call outstr (serrchk) + call ogotos (retlab, NO) + call outdon + } + ername = NO + } +end diff --git a/unix/boot/spp/rpp/rpprat/errorc.r b/unix/boot/spp/rpp/rpprat/errorc.r new file mode 100644 index 00000000..f0fa6a2f --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errorc.r @@ -0,0 +1,20 @@ + +include defs + +# ERRORC -- Process an error statement. "call error" already processed. + + +subroutine errorc (str) + +character str(1) +include COMMON_BLOCKS + + xfer = YES + call outstr (str) + call balpar # output "(errcod, errmsg)" + ername = NO # just to be safe + call outdon + call outtab + call ogotos (retlab, NO) # always return after error statement + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/evalr.r b/unix/boot/spp/rpp/rpprat/evalr.r new file mode 100644 index 00000000..3752bcd4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/evalr.r @@ -0,0 +1,56 @@ +#-h- evalr 1126 local 12/01/80 15:54:06 +# evalr - expand args i through j: evaluate builtin or push back defn + include defs + + subroutine evalr (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer argno, k, m, n, t, td, in_string, delim + external index + integer index, length + + string digits '0123456789' + + t = argstk (i) + td = evalst (t) + if (td == MACTYPE) + call domac (argstk, i, j) + else if (td == INCTYPE) + call doincr (argstk, i, j) + else if (td == SUBTYPE) + call dosub (argstk, i, j) + else if (td == IFTYPE) + call doif (argstk, i, j) + else if (td == ARITHTYPE) + call doarth (argstk, i, j) + else { + in_string = NO + for (k = t + length (evalst (t)) - 1; k > t; k = k - 1) + if (evalst(k) == SQUOTE | evalst(k) == DQUOTE) { + if (in_string == NO) { + delim = evalst(k) + in_string = YES + } + else + in_string = NO + call putbak (evalst(k)) + } + # Don't expand $arg if in a string. + else if (evalst(k-1) != ARGFLAG | in_string == YES) + call putbak (evalst (k)) + else { + argno = index (digits, evalst (k)) - 1 + if (argno >= 0 & argno < j - i) { + n = i + argno + 1 + m = argstk (n) + call pbstr (evalst (m)) + } + k = k - 1 # skip over $ + } + if (k == t) # do last character + call putbak (evalst (k)) + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/finit.r b/unix/boot/spp/rpp/rpprat/finit.r new file mode 100644 index 00000000..8ca1ecf5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/finit.r @@ -0,0 +1,24 @@ +#-h- finit 432 local 12/01/80 15:54:07 +# finit - initialize for each input file + include defs + + subroutine finit + + include COMMON_BLOCKS + + outp = 0 # output character pointer + level = 1 # file control + linect (1) = 0 + sbp = 1 + fnamp = 2 + fnames (1) = EOS + bp = PBPOINT + buf (bp) = EOS # to force a read on next call to 'ngetch' + fordep = 0 # for stack + fcname (1) = EOS # current function name + swtop = 0 # switch stack + swlast = 1 + swvnum = 0 + swvlev = 0 + return + end diff --git a/unix/boot/spp/rpp/rpprat/forcod.r b/unix/boot/spp/rpp/rpprat/forcod.r new file mode 100644 index 00000000..9d389f5e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/forcod.r @@ -0,0 +1,101 @@ +#-h- forcod 2259 local 12/01/80 15:54:07 +# forcod - beginning of for statement + include defs + + subroutine forcod (lab) + integer lab + + include COMMON_BLOCKS + + character t, token (MAXTOK) + character gettok, gnbtok + + integer i, j, nlpar + integer length, labgen + + string ifnot "if (.not." + string serrchk ".and.(.not.xerflg))) " + + lab = labgen (3) + call outcon (0) + if (gnbtok (token, MAXTOK) != LPAREN) { + call synerr ("missing left paren.") + return + } + if (gnbtok (token, MAXTOK) != SEMICOL) { # real init clause + call pbstr (token) + call outtab + call eatup + call outdwe + } + if (gnbtok (token, MAXTOK) == SEMICOL) # empty condition + call outcon (lab) + else { # non-empty condition + call pbstr (token) + call outnum (lab) + call outtab + call outstr (ifnot) + call outch (LPAREN) + nlpar = 0 + while (nlpar >= 0) { + t = gettok (token, MAXTOK) + if (t == SEMICOL) + break + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == EOF) { + call pbstr (token) + return + } + if (t == ALPHA) + call squash (token) + if (t != NEWLINE & t != UNDERLINE) + call outstr (token) + } + + # name encountered for which error checking is required? + if (ername == YES) + call outstr (serrchk) + else { + call outch (RPAREN) + call outch (RPAREN) + call outch (BLANK) + } + call outgo (lab+2) # error checking below (errgo) + if (nlpar < 0) + call synerr ("invalid for clause.") + } + fordep = fordep + 1 # stack reinit clause + j = 1 + for (i = 1; i < fordep; i = i + 1) # find end + j = j + length (forstk (j)) + 1 + forstk (j) = EOS # null, in case no reinit + nlpar = 0 + t = gnbtok (token, MAXTOK) + call pbstr (token) + while (nlpar >= 0) { + t = gettok (token, MAXTOK) + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == EOF) { + call pbstr (token) + break + } + if (nlpar >= 0 & t != NEWLINE & t != UNDERLINE) { + if (t == ALPHA) + call squash (token) + if (j + length (token) >= MAXFORSTK) + call baderr ("for clause too long.") + call scopy (token, 1, forstk, j) + j = j + length (token) + } + } + lab = lab + 1 # label for next's + call indent (1) + call errgo + return + end diff --git a/unix/boot/spp/rpp/rpprat/fors.r b/unix/boot/spp/rpp/rpprat/fors.r new file mode 100644 index 00000000..5d3692ea --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/fors.r @@ -0,0 +1,29 @@ +#-h- fors 458 local 12/01/80 15:54:08 +# fors - process end of for statement + include defs + + subroutine fors (lab) + integer lab + + include COMMON_BLOCKS + + integer i, j + integer length + + xfer = NO + call outnum (lab) + j = 1 + for (i = 1; i < fordep; i = i + 1) + j = j + length (forstk (j)) + 1 + if (length (forstk (j)) > 0) { + call outtab + call outstr (forstk (j)) + call outdon + } + call outgo (lab - 1) + call indent (-1) + call outcon (lab + 1) + fordep = fordep - 1 + ername = NO + return + end diff --git a/unix/boot/spp/rpp/rpprat/fort b/unix/boot/spp/rpp/rpprat/fort new file mode 100644 index 00000000..e69de29b diff --git a/unix/boot/spp/rpp/rpprat/getdef.r b/unix/boot/spp/rpp/rpprat/getdef.r new file mode 100644 index 00000000..be97b439 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/getdef.r @@ -0,0 +1,62 @@ +#-h- getdef 1634 local 12/01/80 15:54:08 +# getdef (for no arguments) - get name and definition + include defs + + subroutine getdef (token, toksiz, defn, defsiz) + character token (MAXTOK), defn (MAXDEF) + integer toksiz, defsiz + + include COMMON_BLOCKS + + character c, t, ptoken (MAXTOK) + character gtok, ngetch + + integer i, nlpar + + call skpblk + c = gtok (ptoken, MAXTOK) + if (c == LPAREN) + t = LPAREN # define (name, defn) + else { + t = BLANK # define name defn + call pbstr (ptoken) + } + call skpblk + if (gtok (token, toksiz) != ALPHA) + call baderr ("non-alphanumeric name.") + call skpblk + c = gtok (ptoken, MAXTOK) + if (t == BLANK) { # define name defn + call pbstr (ptoken) + i = 1 + repeat { + c = ngetch (c) + if (i > defsiz) + call baderr ("definition too long.") + defn (i) = c + i = i + 1 + } until (c == SHARP | c == NEWLINE | c == EOF) + if (c == SHARP) + call putbak (c) + } + else if (t == LPAREN) { # define (name, defn) + if (c != COMMA) + call baderr ("missing comma in define.") + # else got (name, + nlpar = 0 + for (i = 1; nlpar >= 0; i = i + 1) + if (i > defsiz) + call baderr ("definition too long.") + else if (ngetch (defn (i)) == EOF) + call baderr ("missing right paren.") + else if (defn (i) == LPAREN) + nlpar = nlpar + 1 + else if (defn (i) == RPAREN) + nlpar = nlpar - 1 + # else normal character in defn (i) + } + else + call baderr ("getdef is confused.") + defn (i - 1) = EOS + return + end diff --git a/unix/boot/spp/rpp/rpprat/gettok.r b/unix/boot/spp/rpp/rpprat/gettok.r new file mode 100644 index 00000000..8ae855db --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gettok.r @@ -0,0 +1,90 @@ +#-h- gettok 2076 local 12/01/80 15:54:09 +# gettok - get token. handles file inclusion and line numbers + include defs + +character function gettok (token, toksiz) + +character token (MAXTOK) +integer toksiz +include COMMON_BLOCKS +integer equal +character t, deftok +#character name(MAXNAME), t +#integer i, len, open, length + +string ssubr "x$subr" +string sfunc "x$func" +#string incl "include" + +# for (; level > 0; level = level - 1) { + + gettok = deftok (token, toksiz) + if (gettok != EOF) { + if (gettok == XPP_DIRECTIVE) { + if (equal (token, sfunc) == YES) { + call skpblk + t = deftok (fcname, MAXNAME) + call pbstr (fcname) + if (t != ALPHA) + call synerr ("Missing function name.") + call putbak (BLANK) + swvnum = 0 + swvlev = 0 + return + } else if (equal (token, ssubr) == YES) { + swvnum = 0 + swvlev = 0 + return + } else + return + } + return + } + + token (1) = EOF + token (2) = EOS + gettok = EOF + return +end + + +# -- Includes are now processed elsewhere + +# else if (equal (token, incl) == NO) +# return +# +# # process 'include' statements: +# call skpblk +# t = deftok (name, MAXNAME) +# if (t == SQUOTE | t == DQUOTE) { +# len = length (name) - 1 +# for (i = 1; i < len; i = i + 1) +# name (i) = name (i + 1) +# name (i) = EOS +# } +# i = length (name) + 1 +# if (level >= NFILES) +# call synerr ("includes nested too deeply.") +# else { +# infile (level + 1) = open (name, READ) +# linect (level + 1) = 0 +# if (infile (level + 1) == ERR) +# call synerr ("can't open include.") +# else { +# level = level + 1 +# if (fnamp + i <= MAXFNAMES) { +# call scopy (name, 1, fnames, fnamp) +# fnamp = fnamp + i # push file name stack +# } +# } +# } +# } +# if (level > 1) { # close include file pop file name stack +# call close (infile (level)) +# for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1) +# if (fnames (fnamp - 1) == EOS) +# break +# } + +# } + diff --git a/unix/boot/spp/rpp/rpprat/gnbtok.r b/unix/boot/spp/rpp/rpprat/gnbtok.r new file mode 100644 index 00000000..448a1aad --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gnbtok.r @@ -0,0 +1,19 @@ +#-h- gnbtok 237 local 12/01/80 15:54:09 +# gnbtok - get nonblank token + include defs + + character function gnbtok (token, toksiz) + character token (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character gettok + + call skpblk + repeat { + gnbtok = gettok (token, toksiz) + } until (gnbtok != BLANK) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/gocode.r b/unix/boot/spp/rpp/rpprat/gocode.r new file mode 100644 index 00000000..26e201c4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gocode.r @@ -0,0 +1,25 @@ +include defs + +# GOCODE - generate code for goto statement + +subroutine gocode + +character token (MAXTOK), t +character gnbtok +integer ctoi, i +include COMMON_BLOCKS + + t = gnbtok (token, MAXTOK) + if (t != DIGIT) + call synerr ("Invalid label for goto.") + else { + call outtab + i = 1 + call ogotos (ctoi(token,i), NO) + } + xfer = YES + + for (t=gnbtok(token,MAXTOK); t == NEWLINE; t=gnbtok(token,MAXTOK)) + ; + call pbstr (token) +end diff --git a/unix/boot/spp/rpp/rpprat/gtok.r b/unix/boot/spp/rpp/rpprat/gtok.r new file mode 100644 index 00000000..4cdb3d72 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gtok.r @@ -0,0 +1,161 @@ +include defs + +# gtok - get token for Ratfor + + character function gtok (lexstr, toksiz) + character lexstr (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character c + character ngetch + + integer i +# external index +# integer index + +# string digits "0123456789abcdefghijklmnopqrstuvwxyz" + + c = ngetch (lexstr (1)) + + if (c == BLANK | c == TAB) { + lexstr (1) = BLANK + while (c == BLANK | c == TAB) # compress many blanks to one + c = ngetch (c) + if (c == SHARP) + while (ngetch (c) != NEWLINE) # strip comments + ; + if (c != NEWLINE) + call putbak (c) + else + lexstr (1) = NEWLINE + lexstr (2) = EOS + gtok = lexstr (1) + return + } + + i = 1 + if (IS_LETTER(c)) { # alpha + gtok = ALPHA + if (c == LETX) { # "x$cccc" directive? + c = ngetch (lexstr(2)) + if (c == DOLLAR) { + gtok = XPP_DIRECTIVE + i = 2 + } + else + call putbak (c) + } + + for (; i < toksiz - 2; i=i+1) { + c = ngetch (lexstr(i+1)) + if (!IS_LETTER(c) & !IS_DIGIT(c) & c != UNDERLINE) + break + } + call putbak (c) + + } else if (IS_DIGIT(c)) { # digits + for (i=1; i < toksiz - 2; i=i+1) { + c = ngetch (lexstr (i + 1)) + if (!IS_DIGIT(c)) + break + } + call putbak (c) + gtok = DIGIT + } + +# The following is not needed since XPP does base conversion, and this caused +# fixed point overflow on a Data General machine. +# +# b = c - DIG0 # in case alternate base number +# for (i = 1; i < toksiz - 2; i = i + 1) { +# c = ngetch (lexstr (i + 1)) +# if (!IS_DIGIT(c)) +# break +# b = 10 * b + (c - DIG0) +# } +# if (c == RADIX & b >= 2 & b <= 36) { #n%ddd... +# n = 0 +# repeat { +# d = index (digits, clower (ngetch (c))) - 1 +# if (d < 0) +# break +# n = b * n + d +# } +# call putbak (c) +# i = itoc (n, lexstr, toksiz) +# } +# else +# call putbak (c) +# gtok = DIGIT +# } + + else if (c == LBRACK) { # allow [ for { + lexstr (1) = LBRACE + gtok = LBRACE + } + + else if (c == RBRACK) { # allow ] for } + lexstr (1) = RBRACE + gtok = RBRACE + } + + else if (c == DOLLAR) { # $( and $) now used by macro processor + if (ngetch (lexstr (2)) == LPAREN) { + i = 2 + gtok = LSTRIPC + } + else if (lexstr (2) == RPAREN) { + i = 2 + gtok = RSTRIPC + } + else { + call putbak (lexstr (2)) + gtok = DOLLAR + } + } + + else if (c == SQUOTE | c == DQUOTE) { + gtok = c + for (i = 2; ngetch (lexstr (i)) != lexstr (1); i = i + 1) { + if (lexstr (i) == UNDERLINE) + if (ngetch (c) == NEWLINE) { + while (c == NEWLINE | c == BLANK | c == TAB) + c = ngetch (c) + lexstr (i) = c + } + else + call putbak (c) + if (lexstr (i) == NEWLINE | i >= toksiz - 1) { + call synerr ("missing quote.") + lexstr (i) = lexstr (1) + call putbak (NEWLINE) + break + } + } + } + + else if (c == SHARP) { # strip comments + while (ngetch (lexstr (1)) != NEWLINE) + ; + gtok = NEWLINE + } + + else if (c == GREATER | c == LESS | c == NOT | c == BANG | + c == TILDE | c == CARET | c == EQUALS | c == AND | c == OR) { + call relate (lexstr, i) + gtok = c + } + + else + gtok = c + + if (i >= toksiz - 1) + call synerr ("token too long.") + lexstr (i + 1) = EOS + + # Note: line number accounting is now done in 'ngetch' + + return + end diff --git a/unix/boot/spp/rpp/rpprat/ifcode.r b/unix/boot/spp/rpp/rpprat/ifcode.r new file mode 100644 index 00000000..81855321 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifcode.r @@ -0,0 +1,17 @@ +#-h- ifcode 198 local 12/01/80 15:54:10 +# ifcode - generate initial code for if + include defs + + subroutine ifcode (lab) + integer lab + + include COMMON_BLOCKS + + integer labgen + + xfer = NO + lab = labgen (2) + call ifgo (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/iferrc.r b/unix/boot/spp/rpp/rpprat/iferrc.r new file mode 100644 index 00000000..4fd77154 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/iferrc.r @@ -0,0 +1,85 @@ +include defs + +# IFERRC - Generate initial code for an IFERR statement. Used to provide +# error recovery for a statement or compound statement. + +subroutine iferrc (lab, sense) + +integer lab, sense +integer labgen, nlpar +character t, gettok, gnbtok, token(MAXTOK) +include COMMON_BLOCKS +string errpsh "call xerpsh" +string siferr "if (.not.xerpop()) " +string sifnoerr "if (xerpop()) " + + xfer = NO + lab = labgen (3) + + call outtab # "call errpsh" + call outstr (errpsh) + call outdon + + switch (gnbtok (token, MAXTOK)) { # "iferr (" or "iferr {" + case LPAREN: + call outtab + case LBRACE: + call pbstr (token) + esp = esp + 1 + if (esp >= MAXERRSTK) # not likely + call baderr ("Iferr statements nested too deeply.") + errstk(esp) = lab + return + default: + call synerr ("Missing left paren.") + return + } + + nlpar = 1 # process "iferr (.." + token(1) = EOS + + # Push handler on error stack temporarily so that "iferr (call error.." + # can be handled properly. + esp = esp + 1 + if (esp >= MAXERRSTK) # not likely + call baderr ("Iferr statements nested too deeply.") + errstk(esp) = 0 + + repeat { # output the statement + call outstr (token) + t = gettok (token, MAXTOK) + if (t == SEMICOL | t == LBRACE | t == RBRACE | t == EOF) { + call pbstr (token) + break + } + if (t == NEWLINE) # delete newlines + token (1) = EOS + else if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + else if (t == SEMICOL) { + call outdon + call outtab + } else if (t == ALPHA) + call squash (token) + # else nothing special + } until (nlpar <= 0) + + esp = esp - 1 + ername = NO # ignore errchk + if (nlpar != 0) + call synerr ("Missing parenthesis in condition.") + else + call outdon + + call outtab # "if (errpop())" + if (sense == 1) + call outstr (siferr) + else + call outstr (sifnoerr) + call outgo (lab) # "... goto lab" + + call indent (1) + return +end diff --git a/unix/boot/spp/rpp/rpprat/ifgo.r b/unix/boot/spp/rpp/rpprat/ifgo.r new file mode 100644 index 00000000..da0e6647 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifgo.r @@ -0,0 +1,23 @@ +include defs + +# IFGO - generate "if (.not.(...)) goto lab" + +subroutine ifgo (lab) + +integer lab +include COMMON_BLOCKS +string ifnot "if (.not." +string serrchk ".and.(.not.xerflg)) " + + call outtab # get to column 7 + call outstr (ifnot) # " if (.not. " + call balpar # collect and output condition + if (ername == YES) # add error checking? + call outstr (serrchk) + else { + call outch (RPAREN) # " ) " + call outch (BLANK) + } + call outgo (lab) # " goto lab " + call errgo +end diff --git a/unix/boot/spp/rpp/rpprat/ifparm.r b/unix/boot/spp/rpp/rpprat/ifparm.r new file mode 100644 index 00000000..b2b5f706 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifparm.r @@ -0,0 +1,31 @@ +#-h- ifparm 689 local 12/01/80 15:54:11 +# ifparm - determines if the defined symbol has arguments in its + include defs +# definition. This effects how the macro is expanded. + + integer function ifparm (strng) + character strng (ARB) + + character c + + external index + integer i, index, type + + c = strng (1) + if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | + c == MACTYPE) + ifparm = YES + else { + ifparm = NO + for (i = 1; index (strng (i), ARGFLAG) > 0; ) { + i = i + index (strng (i), ARGFLAG) # i points at char after ARGFLAG + if (type (strng (i)) == DIGIT) + andif (type (strng (i + 1)) != DIGIT) { + ifparm = YES + break + } + } + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/indent.r b/unix/boot/spp/rpp/rpprat/indent.r new file mode 100644 index 00000000..e119c773 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/indent.r @@ -0,0 +1,12 @@ +include defs + +# INDENT -- Indent the output listing. + +subroutine indent (nlevels) + +integer nlevels +include COMMON_BLOCKS + + logical_column = logical_column + (nlevels * INDENT) + col = max(6, min(MAX_INDENT, logical_column)) +end diff --git a/unix/boot/spp/rpp/rpprat/initkw.r b/unix/boot/spp/rpp/rpprat/initkw.r new file mode 100644 index 00000000..c03bf2f2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/initkw.r @@ -0,0 +1,34 @@ +#-h- initkw 549 local 12/01/80 15:54:11 +# initkw - initialize tables and important global variables + include defs + + subroutine initkw + + include COMMON_BLOCKS + + pointer mktabl + + call dsinit (MEMSIZE) + deftbl = mktabl (1) # symbol table for definitions + call entdkw + rkwtbl = mktabl (1) # symbol table for Ratfor key words + call entrkw + fkwtbl = mktabl (0) # symbol table for Fortran key words + call entfkw + namtbl = mktabl (1) # symbol table for long identifiers + xpptbl = mktabl (1) # symbol table for xpp directives + call entxkw + gentbl = mktabl (0) # symbol table for generated identifiers + errtbl = NULL # table of names to be error checked + + label = FIRST_LABEL # starting statement label + smem(1) = EOS # haven't read in "mem.com" file yet + body = NO # not in procedure body to start + dbgout = NO # disable debug output by default + dbglev = 0 # file level if debug enabled + memflg = NO # haven't declared mem common yet + swinrg = NO # default range checking for switches + col = 6 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/labelc.r b/unix/boot/spp/rpp/rpprat/labelc.r new file mode 100644 index 00000000..86421d9b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/labelc.r @@ -0,0 +1,19 @@ +#-h- labelc 404 local 12/01/80 15:54:12 +# labelc - output statement number + include defs + + subroutine labelc (lexstr) + character lexstr (ARB) + + include COMMON_BLOCKS + + integer length, l + + xfer = NO # can't suppress goto's now + l = length (lexstr) + if (l >= 3 & l < 4) # possible conflict with pp-generated labels + call synerr ("Warning: statement labels 100 and above are reserved.") + call outstr (lexstr) + call outtab + return + end diff --git a/unix/boot/spp/rpp/rpprat/labgen.r b/unix/boot/spp/rpp/rpprat/labgen.r new file mode 100644 index 00000000..f110e963 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/labgen.r @@ -0,0 +1,13 @@ +#-h- labgen 189 local 12/01/80 15:54:12 +# labgen - generate n consecutive labels, return first one + include defs + + integer function labgen (n) + integer n + + include COMMON_BLOCKS + + labgen = label + label = label + (n / 10 + 1) * 10 + return + end diff --git a/unix/boot/spp/rpp/rpprat/lex.r b/unix/boot/spp/rpp/rpprat/lex.r new file mode 100644 index 00000000..bc8f7a27 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/lex.r @@ -0,0 +1,49 @@ +#-h- lex 543 local 12/01/80 15:54:12 +# lex - return lexical type of token + include defs + + integer function lex (lexstr) + character lexstr (MAXTOK) + + include COMMON_BLOCKS + + character gnbtok, t, c + + integer lookup, n + string sdefault "default" + + for (lex = gnbtok (lexstr, MAXTOK); lex == NEWLINE; + lex = gnbtok (lexstr, MAXTOK)) + ; + + if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE) + return + if (lex == DIGIT) + lex = LEXDIGITS + else if (lex == TOGGLE) + lex = LEXLITERAL + else if (lex == XPP_DIRECTIVE) + lex = LEXDECL + else if (lookup (lexstr, lex, rkwtbl) == YES) { + if (lex == LEXDEFAULT) { # "default:" + n = -1 + repeat { + c = ngetch (c) + n = n + 1 + } until (c != BLANK & c != TAB) + call putbak (c) + + t = gnbtok (lexstr, MAXTOK) + call pbstr (lexstr) + if (n > 0) + call putbak (BLANK) + call scopy (sdefault, 1, lexstr, 1) + if (t != COLON) + lex = LEXOTHER + } + } + else + lex = LEXOTHER + + return + end diff --git a/unix/boot/spp/rpp/rpprat/litral.r b/unix/boot/spp/rpp/rpprat/litral.r new file mode 100644 index 00000000..e9106559 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/litral.r @@ -0,0 +1,20 @@ +#-h- litral 316 local 12/01/80 15:54:13 +# litral - process literal Fortran line + include defs + + subroutine litral + + include COMMON_BLOCKS + + character ngetch + + # Finish off any left-over characters + if (outp > 0) + call outdwe + + for (outp = 1; ngetch (outbuf (outp)) != NEWLINE; outp = outp + 1) + ; + outp = outp - 1 + call outdwe + return + end diff --git a/unix/boot/spp/rpp/rpprat/lndict.r b/unix/boot/spp/rpp/rpprat/lndict.r new file mode 100644 index 00000000..42cf8d6a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/lndict.r @@ -0,0 +1,30 @@ +#-h- lndict 678 local 12/01/80 15:54:13 +# lndict - output long-name dictionary as a debugging aid + include defs + +subroutine lndict + +character sym (MAXTOK), c +ifdef (UPPERC, character cupper) +integer sctabl, length +pointer posn, locn +include COMMON_BLOCKS + + posn = 0 + while (sctabl (namtbl, sym, locn, posn) != EOF) + if (length(sym) > MAXIDLENGTH) { + ifdef (UPPERC, call outch (BIGC)) + ifnotdef (UPPERC, call outch (LETC)) + call outtab + for (; mem (locn) != EOS; locn = locn + 1) { + c = mem (locn) # kluge for people with LOGICAL*1 characters + ifdef (UPPERC, c = cupper (c)) + call outch (c) + } + call outch (BLANK) + call outch (BLANK) + call outstr (sym) + call outdon + } + return +end diff --git a/unix/boot/spp/rpp/rpprat/ludef.r b/unix/boot/spp/rpp/rpprat/ludef.r new file mode 100644 index 00000000..45876968 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ludef.r @@ -0,0 +1,29 @@ +#-h- ludef 495 local 12/01/80 15:54:29 +# ludef --- look up a defined identifier, return its definition + include defs + + integer function ludef (id, defn, table) + character id (ARB), defn (ARB) + pointer table + + include COMMON_BLOCKS + + integer i + integer lookup + + pointer locn + + ludef = lookup (id, locn, table) + if (ludef == YES) { + i = 1 + for (; mem (locn) != EOS; locn = locn + 1) { + defn (i) = mem (locn) + i = i + 1 + } + defn (i) = EOS + } + else + defn (1) = EOS + + return + end diff --git a/unix/boot/spp/rpp/rpprat/mapid.r b/unix/boot/spp/rpp/rpprat/mapid.r new file mode 100644 index 00000000..106a9335 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/mapid.r @@ -0,0 +1,19 @@ + +include defs + +# MAPID -- Map a long identifier. The new identifier is formed by +# concatenating the first MAXIDLENGTH-1 characters and the last character. + + +subroutine mapid (name) + +character name(MAXTOK) +integer i + + for (i=1; name(i) != EOS; i=i+1) + ; + if (i-1 > MAXIDLENGTH) { + name(MAXIDLENGTH) = name(i-1) + name(MAXIDLENGTH+1) = EOS + } +end diff --git a/unix/boot/spp/rpp/rpprat/ngetch.r b/unix/boot/spp/rpp/rpprat/ngetch.r new file mode 100644 index 00000000..26dce4de --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ngetch.r @@ -0,0 +1,34 @@ +#-h- ngetch 442 local 12/01/80 15:54:30 +# ngetch - get a (possibly pushed back) character + include defs + + character function ngetch (c) + character c + + include COMMON_BLOCKS + + integer getlin, n, i + + if (buf (bp) == EOS) + if (getlin (buf (PBPOINT), infile (level)) == EOF) + c = EOF + else { + c = buf (PBPOINT) + bp = PBPOINT + 1 + if (c == SHARP) { #check for "#!# nn" directive + if (buf(bp) == BANG & buf(bp+1) == SHARP) { + n = 0 + for (i=bp+3; buf(i) >= DIG0 & buf(i) <= DIG9; i=i+1) + n = n * 10 + buf(i) - DIG0 + linect (level) = n - 1 + } + } + linect (level) = linect (level) + 1 + } + else { + c = buf (bp) + bp = bp + 1 + } + + return (c) + end diff --git a/unix/boot/spp/rpp/rpprat/ogotos.r b/unix/boot/spp/rpp/rpprat/ogotos.r new file mode 100644 index 00000000..e20e7df0 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ogotos.r @@ -0,0 +1,20 @@ + +include defs + +# OGOTOS - Output "goto n", unconditionally. + + +subroutine ogotos (n, error_check) + +integer n, error_check +include COMMON_BLOCKS +string sgoto "goto " + + call outtab + call outstr (sgoto) + call outnum (n) + if (error_check == YES) + call outdwe + else + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/otherc.r b/unix/boot/spp/rpp/rpprat/otherc.r new file mode 100644 index 00000000..9a8451b8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/otherc.r @@ -0,0 +1,18 @@ +#-h- otherc 284 local 12/01/80 15:54:30 +# otherc - output ordinary Fortran statement + include defs + + subroutine otherc (lexstr) + character lexstr(ARB) + + include COMMON_BLOCKS + + xfer = NO + call outtab + if (IS_LETTER(lexstr (1))) + call squash (lexstr) + call outstr (lexstr) + call eatup + call outdwe + return + end diff --git a/unix/boot/spp/rpp/rpprat/outch.r b/unix/boot/spp/rpp/rpprat/outch.r new file mode 100644 index 00000000..f7dfa99e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outch.r @@ -0,0 +1,51 @@ +include defs + +# outch - put one character into output buffer + +subroutine outch (c) + +character c, splbuf(SZ_SPOOLBUF+1) +integer i, ip, op, index +include COMMON_BLOCKS +external index +string break_chars " ),.+-*/(" + + # Process a continuation card. Try to break the card at a whitespace + # division, operator, or punctuation mark. + + if (outp >= 72) { + if (index (break_chars, c) > 0) # find break point + ip = outp + else { + for (ip=outp; ip >= 1; ip=ip-1) { + if (index (break_chars, outbuf(ip)) > 0) + break + } + } + + if (ip != outp & (outp-ip) < SZ_SPOOLBUF) { + op = 1 + for (i=ip+1; i <= outp; i=i+1) { # save chars + splbuf(op) = outbuf(i) + op = op + 1 + } + splbuf(op) = EOS + outp = ip + } else + splbuf(1) = EOS + + call outdon + + for (op=1; op < col; op=op+1) + outbuf(op) = BLANK + outbuf(6) = STAR + outp = col + for (ip=1; splbuf(ip) != EOS; ip=ip+1) { + outp = outp + 1 + outbuf(outp) = splbuf(ip) + } + } + + outp = outp + 1 # output character + outbuf(outp) = c +end diff --git a/unix/boot/spp/rpp/rpprat/outcon.r b/unix/boot/spp/rpp/rpprat/outcon.r new file mode 100644 index 00000000..90d5e636 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outcon.r @@ -0,0 +1,21 @@ +#-h- outcon 332 local 12/01/80 15:54:31 +# outcon - output "n continue" + include defs + + subroutine outcon (n) + integer n + + include COMMON_BLOCKS + + string contin "continue" + + xfer = NO + if (n <= 0 & outp == 0) + return # don't need unlabeled continues + if (n > 0) + call outnum (n) + call outtab + call outstr (contin) + call outdon + return + end diff --git a/unix/boot/spp/rpp/rpprat/outdon.r b/unix/boot/spp/rpp/rpprat/outdon.r new file mode 100644 index 00000000..5ea969bb --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outdon.r @@ -0,0 +1,58 @@ +#-h- outdon 257 local 12/01/80 15:54:31 +# outdon - finish off an output line + include defs + + subroutine outdon + + include COMMON_BLOCKS + + integer allblk + integer itoc, ip, op, i + character obuf(80) + string s_line "#line " + + # If dbgout is enabled output the "#line" statement. + if (dbgout == YES) { + if (body == YES | dbglev != level) { + op = 1 + for (ip=1; s_line(ip) != EOS; ip=ip+1) { + obuf(op) = s_line(ip) + op = op + 1 + } + + op = op + itoc (linect, obuf(op), 80-op+1) + obuf(op) = BLANK + op = op + 1 + obuf(op) = DQUOTE + op = op + 1 + + for (i=fnamp-1; i >= 1; i=i-1) + if (fnames(i-1) == EOS | i == 1) { # print file name + for (ip=i; fnames(ip) != EOS; ip=ip+1) { + obuf(op) = fnames(ip) + op = op + 1 + } + break + } + + obuf(op) = DQUOTE + op = op + 1 + obuf(op) = NEWLINE + op = op + 1 + obuf(op) = EOS + op = op + 1 + + call putlin (obuf, STDOUT) + dbglev = level + } + } + + # Output the program statement. + outbuf (outp + 1) = NEWLINE + outbuf (outp + 2) = EOS + if (allblk (outbuf) == NO) + call putlin (outbuf, STDOUT) + outp = 0 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/outdwe.r b/unix/boot/spp/rpp/rpprat/outdwe.r new file mode 100644 index 00000000..d6ef22ce --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outdwe.r @@ -0,0 +1,13 @@ + +include defs + +# OUTDWE -- (outdon with error checking). +# Called by code generation routines to output a line of code, +# possibly followed by an error checking instruction. + + +subroutine outdwe + + call outdon + call errgo +end diff --git a/unix/boot/spp/rpp/rpprat/outgo.r b/unix/boot/spp/rpp/rpprat/outgo.r new file mode 100644 index 00000000..d4f54faa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outgo.r @@ -0,0 +1,13 @@ +#-h- outgo 239 local 12/01/80 15:54:31 +# outgo - output "goto n" + include defs + +subroutine outgo (n) + +integer n +include COMMON_BLOCKS + + if (xfer == YES) + return + call ogotos (n, NO) +end diff --git a/unix/boot/spp/rpp/rpprat/outnum.r b/unix/boot/spp/rpp/rpprat/outnum.r new file mode 100644 index 00000000..5286971e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outnum.r @@ -0,0 +1,24 @@ +#-h- outnum 381 local 12/01/80 15:54:32 +# outnum - output decimal number + include defs + + subroutine outnum (n) + integer n + + character chars (MAXCHARS) + + integer i, m + + m = iabs (n) + i = 0 + repeat { + i = i + 1 + chars (i) = mod (m, 10) + DIG0 + m = m / 10 + } until (m == 0 | i >= MAXCHARS) + if (n < 0) + call outch (MINUS) + for ( ; i > 0; i = i - 1) + call outch (chars (i)) + return + end diff --git a/unix/boot/spp/rpp/rpprat/outstr.r b/unix/boot/spp/rpp/rpprat/outstr.r new file mode 100644 index 00000000..248bb39c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outstr.r @@ -0,0 +1,33 @@ +#-h- outstr 687 local 12/01/80 15:54:32 +# outstr - output string; handles quoted literals + include defs + + subroutine outstr (str) + character str (ARB) + + character c + ifdef (UPPERC, character cupper) + + integer i, j + + for (i = 1; str (i) != EOS; i = i + 1) { + c = str (i) + if (c != SQUOTE & c != DQUOTE) { + # produce upper case fortran, if desired + ifdef (UPPERC, + c = cupper (c) + ) + call outch (c) + } + else { + i = i + 1 + for (j = i; str (j) != c; j = j + 1) # find end + ; + call outnum (j - i) + call outch (BIGH) + for ( ; i < j; i = i + 1) + call outch (str (i)) + } + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/outtab.r b/unix/boot/spp/rpp/rpprat/outtab.r new file mode 100644 index 00000000..94f38c69 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outtab.r @@ -0,0 +1,12 @@ +#-h- outtab 140 local 12/01/80 15:54:32 +# outtab - get past column 6 + include defs + + subroutine outtab + + include COMMON_BLOCKS + + while (outp < col) + call outch (BLANK) + return + end diff --git a/unix/boot/spp/rpp/rpprat/parse.r b/unix/boot/spp/rpp/rpprat/parse.r new file mode 100644 index 00000000..676ee759 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/parse.r @@ -0,0 +1,144 @@ +include defs + +# PARSE - parse Ratfor source program + +subroutine parse + +include COMMON_BLOCKS +character lexstr(MAXTOK) +integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token, i, t +integer lex +logical push_stack + + sp = 1 + lextyp(1) = EOF + + for (token = lex(lexstr); token != EOF; token = lex(lexstr)) { + push_stack = .false. + + switch (token) { + case LEXIF: + call ifcode (lab) + push_stack = .true. + case LEXIFERR: + call iferrc (lab, 1) + push_stack = .true. + case LEXIFNOERR: + call iferrc (lab, 0) + push_stack = .true. + case LEXDO: + call docode (lab) + push_stack = .true. + case LEXWHILE: + call whilec (lab) + push_stack = .true. + case LEXFOR: + call forcod (lab) + push_stack = .true. + case LEXREPEAT: + call repcod (lab) + push_stack = .true. + case LEXSWITCH: + call swcode (lab) + push_stack = .true. + case LEXCASE, LEXDEFAULT: + for (i=sp; i > 0; i=i-1) # find for most recent switch + if (lextyp(i) == LEXSWITCH) + break + if (i == 0) + call synerr ("illegal case or default.") + else + call cascod (labval (i), token) + case LEXDIGITS: + call labelc (lexstr) + push_stack = .true. + case LEXELSE: + t = lextyp(sp) + if (t == LEXIF | t == LEXIFERR | t == LEXIFNOERR) + call elseif (labval(sp)) + else + call synerr ("Illegal else.") + + t = lex (lexstr) # check for "else if" + call pbstr (lexstr) + if (t == LEXIF | t == LEXIFERR | t == LEXIFNOERR) { + call indent (-1) # cancel out indent +1 + token = LEXIFELSE # prevent -indent at end + } + push_stack = .true. + case LEXTHEN: + if (lextyp(sp) == LEXIFERR | lextyp(sp) == LEXIFNOERR) { + call thenco (lextyp(sp), labval(sp)) + lab = labval(sp) + token = lextyp(sp) + sp = sp - 1 # cancel out subsequent push + } else + call synerr ("Illegal 'then' clause in iferr statement.") + push_stack = .true. + case LEXLITERAL: + call litral + case LEXERRCHK: + call errchk + case LEXBEGIN: + call beginc + case LEXEND: + call endcod (lexstr) + if (sp != 1) { + call synerr ("Missing right brace or 'begin'.") + sp = 1 + } + default: + if (token == LBRACE) + push_stack = .true. + else if (token == LEXDECL) + call declco (lexstr) + } + + if (push_stack) { + if (body == NO) { + call synerr ("Missing 'begin' keyword.") + call beginc + } + sp = sp + 1 # beginning of statement + if (sp > MAXSTACK) + call baderr ("Stack overflow in parser.") + lextyp(sp) = token # stack type and value + labval(sp) = lab + + } else if (token != LEXCASE & token != LEXDEFAULT) { + if (token == RBRACE) + token = LEXRBRACE + + switch (token) { + case LEXOTHER: + call otherc (lexstr) + case LEXBREAK, LEXNEXT: + call brknxt (sp, lextyp, labval, token) + case LEXRETURN: + call retcod + case LEXGOTO: + call gocode + case LEXSTRING: + if (body == NO) + call strdcl + else + call otherc (lexstr) + case LEXRBRACE: + if (lextyp(sp) == LBRACE) + sp = sp - 1 + else if (lextyp(sp) == LEXSWITCH) { + call swend (labval(sp)) + sp = sp - 1 + } else + call synerr ("Illegal right brace.") + } + + token = lex (lexstr) # peek at next token + call pbstr (lexstr) + call unstak (sp, lextyp, labval, token) + } + } + + if (sp != 1) + call synerr ("unexpected EOF.") +end diff --git a/unix/boot/spp/rpp/rpprat/pbnum.r b/unix/boot/spp/rpp/rpprat/pbnum.r new file mode 100644 index 00000000..e77b5db6 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/pbnum.r @@ -0,0 +1,20 @@ +#-h- pbnum 304 local 12/01/80 15:54:33 +# pbnum - convert number to string, push back on input + include defs + + subroutine pbnum (n) + integer n + + integer m, num + integer mod + + string digits '0123456789' + + num = n + repeat { + m = mod (num, 10) + call putbak (digits (m + 1)) + num = num / 10 + } until (num == 0) + return + end diff --git a/unix/boot/spp/rpp/rpprat/pbstr.r b/unix/boot/spp/rpp/rpprat/pbstr.r new file mode 100644 index 00000000..9c2234de --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/pbstr.r @@ -0,0 +1,69 @@ +include defs + +# PBSTR -- Push string back onto input. + +subroutine pbstr (s) + +character s(ARB) # string to be pushed back. +integer lenstr, i +integer length + +#begin + lenstr = length (s) + + # We are called to push back tokens returned by GTOK, which converts + # the ratfor relational operators >, >=, &, etc. into their Fortran + # equivalents .gt., .ge., .and., and so on. This conversion must be + # reversed in the push back to prevent macro expansion from operating + # on the strings "gt", "ge, "and", etc. This is a stupid way to + # handle this but this ratfor code (which was free) is a hopeless mess + # already anyhow. + + if (s(1) == PERIOD & s(lenstr) == PERIOD) + if (lenstr == 4) { + if (s(2) == LETG) { + if (s(3) == LETT) { # .gt. + call putbak (GREATER) + return + } else if (s(3) == LETE) { # .ge. + # Note chars are pushed back in + # reverse order. + call putbak (EQUALS) + call putbak (GREATER) + return + } + } else if (s(2) == LETL) { + if (s(3) == LETT) { # .lt. + call putbak (LESS) + return + } else if (s(3) == LETE) { # .le. + call putbak (EQUALS) + call putbak (LESS) + return + } + } else if (s(2) == LETE & s(3) == LETQ) { + call putbak (EQUALS) # .eq. + call putbak (EQUALS) + return + } else if (s(2) == LETN & s(3) == LETE) { + call putbak (EQUALS) # .ne. + call putbak (BANG) + return + } else if (s(2) == LETO & s(3) == LETR) { + call putbak (OR) # .or. + return + } + } else if (lenstr == 5) { + if (s(2) == LETN & s(3) == LETO & s(4) == LETT) { + call putbak (BANG) # .not. + return + } else if (s(2) == LETA & s(3) == LETN & s(4) == LETD) { + call putbak (AND) # .and. + return + } + } + + # Push back an arbitrary string. + for (i=lenstr; i > 0; i=i-1) + call putbak (s(i)) +end diff --git a/unix/boot/spp/rpp/rpprat/poicod.r b/unix/boot/spp/rpp/rpprat/poicod.r new file mode 100644 index 00000000..7b31bf80 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/poicod.r @@ -0,0 +1,56 @@ +include defs + +# POICOD -- Called to process a declaration of type "pointer". + +subroutine poicod (declare_variable) + +integer declare_variable +include COMMON_BLOCKS +string spointer XPOINTER + +# Fortran declarations for the MEM common. +string p1 "logical Memb(1)" +string p2 "integer*2 Memc(1)" +string p3 "integer*2 Mems(1)" +string p4 "integer Memi(1)" +string p5 "integer Meml(1)" +string p6 "real Memr(1)" +string p7 "double precision Memd(1)" +string p8 "complex Memx(1)" +string p9 "equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx)" +string pa "common /Mem/ Memd" + + # Output declarations only once per procedure declarations section. + # The flag memflg is cleared when processing of a procedure begins. + + if (memflg == NO) { + call poidec (p1) + call poidec (p2) + call poidec (p3) + call poidec (p4) + call poidec (p5) + call poidec (p6) + call poidec (p7) + call poidec (p8) + call poidec (p9) + call poidec (pa) + memflg = YES + } + + if (declare_variable == YES) { + call outtab + call outstr (spointer) + } +end + + +# POIDEC -- Output a poicod declaration statement. + +subroutine poidec (str) + +character str + + call outtab + call outstr (str) + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/push.r b/unix/boot/spp/rpp/rpprat/push.r new file mode 100644 index 00000000..7d0c3374 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/push.r @@ -0,0 +1,13 @@ +#-h- push 249 local 12/01/80 15:54:34 +# push - push ep onto argstk, return new pointer ap + include defs + + integer function push (ep, argstk, ap) + integer ap, argstk (ARGSIZE), ep + + if (ap > ARGSIZE) + call baderr ('arg stack overflow.') + argstk (ap) = ep + push = ap + 1 + return + end diff --git a/unix/boot/spp/rpp/rpprat/putbak.r b/unix/boot/spp/rpp/rpprat/putbak.r new file mode 100644 index 00000000..b88a3f11 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/putbak.r @@ -0,0 +1,18 @@ +#-h- putbak 254 local 12/01/80 15:54:34 +# putbak - push character back onto input + include defs + + subroutine putbak (c) + character c + + include COMMON_BLOCKS + + if (bp <= 1) + call baderr ("too many characters pushed back.") + else { + bp = bp - 1 + buf (bp) = c + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/putchr.r b/unix/boot/spp/rpp/rpprat/putchr.r new file mode 100644 index 00000000..b39eeadf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/putchr.r @@ -0,0 +1,15 @@ +#-h- putchr 233 local 12/01/80 15:54:34 +# putchr - put single char into eval stack + include defs + + subroutine putchr (c) + character c + + include COMMON_BLOCKS + + if (ep > EVALSIZE) + call baderr ('evaluation stack overflow.') + evalst (ep) = c + ep = ep + 1 + return + end diff --git a/unix/boot/spp/rpp/rpprat/puttok.r b/unix/boot/spp/rpp/rpprat/puttok.r new file mode 100644 index 00000000..2cdcf6d2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/puttok.r @@ -0,0 +1,13 @@ +#-h- puttok 198 local 12/01/80 15:54:34 +# puttok-put token into eval stack + include defs + + subroutine puttok (str) + character str (MAXTOK) + + integer i + + for (i = 1; str (i) != EOS; i = i + 1) + call putchr (str (i)) + return + end diff --git a/unix/boot/spp/rpp/rpprat/ratfor.r b/unix/boot/spp/rpp/rpprat/ratfor.r new file mode 100644 index 00000000..f2f847fd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ratfor.r @@ -0,0 +1,70 @@ +#-h- ratfor 4496 local 12/01/80 15:53:43 +# Ratfor preprocessor + include defs + + subroutine ratfor + +# DRIVER(ratfor) Not used; RPP has a C main. + + include COMMON_BLOCKS + + integer i, n + integer getarg, open + + character arg (FILENAMESIZE) + + STDEFNS # define standard definitions file + + call initkw # initialize variables + + # Read file containing standard definitions + # If this isn't desired, define (STDEFNS,"") + + if (defns (1) != EOS) { + infile (1) = open (defns, READ) + if (infile (1) == ERR) + call remark ("can't open standard definitions file.") + else { + call finit + call parse + call close (infile (1)) + } + } + + n = 1 + for (i=1; getarg(i,arg,FILENAMESIZE) != EOF; i=i+1) { + n = n + 1 + call query ("usage: ratfor [-g] [files] >outfile.") + if (arg(1) == MINUS & arg(2) == LETG & arg(3) == EOS) { + dbgout = YES + next + } else if (arg(1) == MINUS & arg(2) == EOS) { + infile(1) = STDIN + call finit + } else { + infile(1) = open (arg, READ) + if (infile(1) == ERR) { + call cant (arg) + } else { #save file name for error messages + call finit + call scopy (arg, 1, fnames, 1) + for (fnamp=1; fnames(fnamp) != EOS; fnamp=fnamp+1) + if (fnames(fnamp) == PERIOD & fnames(fnamp+1) == LETR) + fnames(fnamp+1) = LETX + } + } + call parse + if (infile (1) != STDIN) + call close (infile (1)) + } + + if (n == 1) { # no files given on command line, use STDIN + infile (1) = STDIN + call finit + call parse + } + + call lndict + +# DRETURN + end diff --git a/unix/boot/spp/rpp/rpprat/relate.r b/unix/boot/spp/rpp/rpprat/relate.r new file mode 100644 index 00000000..50a04025 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/relate.r @@ -0,0 +1,59 @@ +#-h- relate 1276 local 12/01/80 15:54:35 +# relate - convert relational shorthands into long form + include defs + + subroutine relate (token, last) + character token (ARB) + integer last + + character ngetch + + integer length + + if (ngetch (token (2)) != EQUALS) { + call putbak (token (2)) + token (3) = LETT + } + else + token (3) = LETE + token (4) = PERIOD + token (5) = EOS + token (6) = EOS # for .not. and .and. + if (token (1) == GREATER) + token (2) = LETG + else if (token (1) == LESS) + token (2) = LETL + else if (token (1) == NOT | token (1) == BANG | + token (1) == CARET | token (1) == TILDE) { + if (token (2) != EQUALS) { + token (3) = LETO + token (4) = LETT + token (5) = PERIOD + } + token (2) = LETN + } + else if (token (1) == EQUALS) { + if (token (2) != EQUALS) { + token (2) = EOS + last = 1 + return + } + token (2) = LETE + token (3) = LETQ + } + else if (token (1) == AND) { + token (2) = LETA + token (3) = LETN + token (4) = LETD + token (5) = PERIOD + } + else if (token (1) == OR) { + token (2) = LETO + token (3) = LETR + } + else # can't happen + token (2) = EOS + token (1) = PERIOD + last = length (token) + return + end diff --git a/unix/boot/spp/rpp/rpprat/repcod.r b/unix/boot/spp/rpp/rpprat/repcod.r new file mode 100644 index 00000000..e2fd40aa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/repcod.r @@ -0,0 +1,16 @@ +#-h- repcod 262 local 12/01/80 15:54:35 +# repcod - generate code for beginning of repeat + include defs + + subroutine repcod (lab) + integer lab + + integer labgen + + call outcon (0) # in case there was a label + lab = labgen (3) + call outcon (lab) + lab = lab + 1 # label to go on next's + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/retcod.r b/unix/boot/spp/rpp/rpprat/retcod.r new file mode 100644 index 00000000..3490016d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/retcod.r @@ -0,0 +1,30 @@ +#-h- retcod 580 local 12/01/80 15:54:35 +# retcod - generate code for return + include defs + + subroutine retcod + + character token (MAXTOK), t + character gnbtok + include COMMON_BLOCKS + + t = gnbtok (token, MAXTOK) + if (t != NEWLINE & t != SEMICOL & t != RBRACE) { + call pbstr (token) + call outtab + call scopy (fcname, 1, token, 1) + call squash (token) + call outstr (token) + call outch (BLANK) + call outch (EQUALS) + call outch (BLANK) + call eatup + call outdon + } + else if (t == RBRACE) + call pbstr (token) + call outtab + call ogotos (retlab, NO) + xfer = YES + return + end diff --git a/unix/boot/spp/rpp/rpprat/sdupl.r b/unix/boot/spp/rpp/rpprat/sdupl.r new file mode 100644 index 00000000..968bfebd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/sdupl.r @@ -0,0 +1,25 @@ +#-h- sdupl 374 local 12/01/80 15:55:03 +# sdupl --- duplicate a string in dynamic storage space + include defs + + pointer function sdupl (str) + character str (ARB) + + DS_DECL(mem, MEMSIZE) + + integer i + integer length + + pointer j + pointer dsget + + j = dsget (length (str) + 1) + sdupl = j + for (i = 1; str (i) != EOS; i = i + 1) { + mem (j) = str (i) + j = j + 1 + } + mem (j) = EOS + + return + end diff --git a/unix/boot/spp/rpp/rpprat/skpblk.r b/unix/boot/spp/rpp/rpprat/skpblk.r new file mode 100644 index 00000000..3badc3e9 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/skpblk.r @@ -0,0 +1,17 @@ +#-h- skpblk 247 local 12/01/80 15:55:04 +# skpblk - skip blanks and tabs in current input file + include defs + + subroutine skpblk + + include COMMON_BLOCKS + + character c + character ngetch + + for (c = ngetch (c); c == BLANK | c == TAB; c = ngetch (c)) + ; + + call putbak (c) + return + end diff --git a/unix/boot/spp/rpp/rpprat/squash.r b/unix/boot/spp/rpp/rpprat/squash.r new file mode 100644 index 00000000..9990fe1a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/squash.r @@ -0,0 +1,53 @@ +include defs + +# SQUASH - convert a long or special identifier into a Fortran variable + +subroutine squash (id) + +character id(MAXTOK) +integer junk, i, j +integer lookup, ludef +character newid(MAXTOK), recdid(MAXTOK) +include COMMON_BLOCKS + + # identify names for which error checking is to be performed + if (body == YES & errtbl != NULL & ername == NO) + if (lookup (id, junk, errtbl) == YES) + ername = YES + + j = 1 + for (i=1; id(i) != EOS; i=i+1) # copy, delete '_' + if (IS_LETTER(id(i)) | IS_DIGIT(id(i))) { + newid(j) = id(i) + j = j + 1 + } + newid(j) = EOS + + # done if ordinary (short) Fortran variable + if (i-1 < MAXIDLENGTH & i == j) + return + +# Otherwise, the identifier (1) is longer than Fortran allows, +# (2) contains special characters (_ or .), or (3) is the maximum +# length permitted by the Fortran compiler. The first two cases +# obviously call for name conversion; the last case may require conversion +# to avoid accidental conflicts with automatically generated names. + + if (lookup (id, junk, fkwtbl) == YES) # Fortran key word? + return # (must be treated as reserved) + + if (ludef (id, recdid, namtbl) == YES) { # have we seen this before? + call scopy (recdid, 1, id, 1) + return + } + + call mapid (newid) # try standard mapping + if (lookup (newid, junk, gentbl) == YES) { + call synerr ("Warning: identifier mapping not unique.") + call uniqid (newid) + } + call entdef (newid, id, gentbl) + + call entdef (id, newid, namtbl) # record it for posterity + call scopy (newid, 1, id, 1) # substitute it for the old one +end diff --git a/unix/boot/spp/rpp/rpprat/strdcl.r b/unix/boot/spp/rpp/rpprat/strdcl.r new file mode 100644 index 00000000..03b04afc --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/strdcl.r @@ -0,0 +1,96 @@ +#-h- strdcl 2575 local 12/01/80 15:55:05 +# strdcl - generate code for string declaration + include defs + + subroutine strdcl + + include COMMON_BLOCKS + + character t, token (MAXTOK), dchar (MAXTOK) + character gnbtok + + integer i, j, k, n, len + integer length, ctoi, lex + + string char "integer*2/" + string dat "data " + string eoss "0/" + + t = gnbtok (token, MAXTOK) + if (t != ALPHA) + call synerr ("missing string token.") + call squash (token) + call outtab + call pbstr (char) # use defined meaning of "character" + repeat { + t = gnbtok (dchar, MAXTOK) + if (t == SLASH) + break + call outstr (dchar) + } + call outch (BLANK) # separator in declaration + call outstr (token) + call addstr (token, sbuf, sbp, SBUFSIZE) # save for later + call addchr (EOS, sbuf, sbp, SBUFSIZE) + if (gnbtok (token, MAXTOK) != LPAREN) { # make size same as initial value + len = length (token) + 1 + if (token (1) == SQUOTE | token (1) == DQUOTE) + len = len - 2 + } + else { # form is string name (size) init + t = gnbtok (token, MAXTOK) + i = 1 + len = ctoi (token, i) + if (token (i) != EOS) + call synerr ("invalid string size.") + if (gnbtok (token, MAXTOK) != RPAREN) + call synerr ("missing right paren.") + else + t = gnbtok (token, MAXTOK) + } + call outch (LPAREN) + call outnum (len) + call outch (RPAREN) + call outdon + if (token (1) == SQUOTE | token (1) == DQUOTE) { + len = length (token) + token (len) = EOS + call addstr (token (2), sbuf, sbp, SBUFSIZE) + } + else + call addstr (token, sbuf, sbp, SBUFSIZE) + call addchr (EOS, sbuf, sbp, SBUFSIZE) + t = lex (token) # peek at next token + call pbstr (token) + if (t != LEXSTRING) { # dump accumulated data statements + for (i = 1; i < sbp; i = j + 1) { + call outtab + call outstr (dat) + k = 1 + for (j = i + length (sbuf (i)) + 1; ; j = j + 1) { + if (k > 1) + call outch (COMMA) + call outstr (sbuf (i)) + call outch (LPAREN) + call outnum (k) + call outch (RPAREN) + call outch (SLASH) + if (sbuf (j) == EOS) + break + n = sbuf (j) + call outnum (n) + call outch (SLASH) + k = k + 1 + } + call pbstr (eoss) # use defined meaning of EOS + repeat { + t = gnbtok (token, MAXTOK) + call outstr (token) + } until (t == SLASH) + call outdon + } + sbp = 1 + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/swcode.r b/unix/boot/spp/rpp/rpprat/swcode.r new file mode 100644 index 00000000..348f8de3 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swcode.r @@ -0,0 +1,44 @@ +#-h- swcode 746 local 12/01/80 15:55:06 +# swcode - generate code for beginning of switch statement + include defs + + subroutine swcode (lab) + integer lab + + include COMMON_BLOCKS + + character tok (MAXTOK) + + integer labgen, gnbtok + + lab = labgen (2) + swvnum = swvnum + 1 + swvlev = swvlev + 1 + if (swvlev > MAXSWNEST) + call baderr ("switches nested too deeply.") + swvstk(swvlev) = swvnum + + if (swlast + 3 > MAXSWITCH) + call baderr ("switch table overflow.") + swstak (swlast) = swtop + swstak (swlast + 1) = 0 + swstak (swlast + 2) = 0 + swtop = swlast + swlast = swlast + 3 + xfer = NO + call outtab # Innn=(e) + call swvar (swvnum) + call outch (EQUALS) + call balpar + call outdwe + call outgo (lab) # goto L + call indent (1) + xfer = YES + while (gnbtok (tok, MAXTOK) == NEWLINE) + ; + if (tok (1) != LBRACE) { + call synerr ("missing left brace in switch statement.") + call pbstr (tok) + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/swend.r b/unix/boot/spp/rpp/rpprat/swend.r new file mode 100644 index 00000000..86088ddd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swend.r @@ -0,0 +1,106 @@ +#-h- swend 2714 local 12/01/80 15:55:07 +# swend - finish off switch statement; generate dispatch code + include defs + + subroutine swend (lab) + integer lab + + include COMMON_BLOCKS + + integer lb, ub, n, i, j, swn + + string sif "if (" + string slt ".lt.1.or." + string sgt ".gt." + string sgoto "goto (" + string seq ".eq." + string sge ".ge." + string sle ".le." + string sand ".and." + + swn = swvstk(swvlev) #get switch variable number, SWnnnn + swvlev = max(0, swvlev - 1) + + lb = swstak (swtop + 3) + ub = swstak (swlast - 2) + n = swstak (swtop + 1) + call outgo (lab + 1) # terminate last case + if (swstak (swtop + 2) == 0) + swstak (swtop + 2) = lab + 1 # default default label + xfer = NO + call indent (-1) + call outcon (lab) # L continue + call indent (1) + if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table + if (lb != 1) { # L Innn=Innn-lb+1 + call outtab + call swvar (swn) + call outch (EQUALS) + call swvar (swn) + if (lb < 1) + call outch (PLUS) + call outnum (-lb + 1) + call outdon + } + if (swinrg == NO) { + call outtab # if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default + call outstr (sif) + call swvar (swn) + call outstr (slt) + call swvar (swn) + call outstr (sgt) + call outnum (ub - lb + 1) + call outch (RPAREN) + call outch (BLANK) + call outgo (swstak (swtop + 2)) + } + call outtab # goto (....),Innn + call outstr (sgoto) + j = lb + for (i = swtop + 3; i < swlast; i = i + 3) { + for ( ; j < swstak (i); j = j + 1) { # fill in vacancies + call outnum (swstak (swtop + 2)) + call outch (COMMA) + } + for (j = swstak (i + 1) - swstak (i); j >= 0; j = j - 1) + call outnum (swstak (i + 2)) # fill in range + j = swstak (i + 1) + 1 + if (i < swlast - 3) + call outch (COMMA) + } + call outch (RPAREN) + call outch (COMMA) + call swvar (swn) + call outdon + } + else if (n > 0) { # output linear search form + for (i = swtop + 3; i < swlast; i = i + 3) { + call outtab # if (Innn + call outstr (sif) + call swvar (swn) + if (swstak (i) == swstak (i+1)) { + call outstr (seq) # .eq.... + call outnum (swstak (i)) + } + else { + call outstr (sge) # .ge.lb.and.Innn.le.ub + call outnum (swstak (i)) + call outstr (sand) + call swvar (swn) + call outstr (sle) + call outnum (swstak (i + 1)) + } + call outch (RPAREN) # ) goto ... + call outch (BLANK) + call outgo (swstak (i + 2)) + } + if (lab + 1 != swstak (swtop + 2)) + call outgo (swstak (swtop + 2)) + } + call indent (-1) + call outcon (lab + 1) # L+1 continue + swlast = swtop # pop switch stack + swtop = swstak (swtop) + swinrg = NO + return + end diff --git a/unix/boot/spp/rpp/rpprat/swvar.r b/unix/boot/spp/rpp/rpprat/swvar.r new file mode 100644 index 00000000..df8da344 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swvar.r @@ -0,0 +1,22 @@ +#-h- swvar 157 local 12/01/80 15:55:08 +# swvar - output switch variable SWnnnn, where nnnn = lab +# (modified aug82 dct to permit declaration of switch variable) + + include defs + + subroutine swvar (lab) + integer lab, i, labnum, ndigits + + ifnotdef (UPPERC, call outch (LETS)) + ifdef (UPPERC, call outch (BIGS)) + ifnotdef (UPPERC, call outch (LETW)) + ifdef (UPPERC, call outch (BIGW)) + + labnum = lab + for (ndigits=0; labnum > 0; labnum=labnum/10) + ndigits = ndigits + 1 + for (i=3; i <= 6 - ndigits; i=i+1) + call outch (DIG0) + call outnum (lab) + return + end diff --git a/unix/boot/spp/rpp/rpprat/synerr.r b/unix/boot/spp/rpp/rpprat/synerr.r new file mode 100644 index 00000000..80bee91b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/synerr.r @@ -0,0 +1,37 @@ +#-h- synerr 703 local 12/01/80 15:55:08 +# synerr --- report non-fatal error + include defs + + subroutine synerr (msg) + + character msg +# character*(*) msg + + include COMMON_BLOCKS + character lc (MAXCHARS) + + integer i, junk + integer itoc + + string of " of " + string errmsg "Error on line " + + call putlin (errmsg, ERROUT) + if (level >= 1) + i = level + else + i = 1 # for EOF errors + junk = itoc (linect (i), lc, MAXCHARS) + call putlin (lc, ERROUT) + for (i = fnamp - 1; i >= 1; i = i - 1) + if (fnames (i - 1) == EOS | i == 1) { # print file name + call putlin (of, ERROUT) + call putlin (fnames (i), ERROUT) + break + } + + call putch (COLON, ERROUT) + call putch (BLANK, ERROUT) + call remark (msg) + return + end diff --git a/unix/boot/spp/rpp/rpprat/thenco.r b/unix/boot/spp/rpp/rpprat/thenco.r new file mode 100644 index 00000000..1b4a812e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/thenco.r @@ -0,0 +1,25 @@ + +include defs + +# THENCO -- Generate code for the "then" part of a compound IFERR statement. + + +subroutine thenco (tok, lab) + +integer lab, tok +include COMMON_BLOCKS +string siferr "if (.not.xerpop()) " +string sifnoerr "if (xerpop()) " + + xfer = NO + call outnum (lab+2) + call outtab + if (tok == LEXIFERR) + call outstr (siferr) + else + call outstr (sifnoerr) + call outgo (lab) + esp = esp - 1 # pop error stack + call indent (1) + return +end diff --git a/unix/boot/spp/rpp/rpprat/ulstal.r b/unix/boot/spp/rpp/rpprat/ulstal.r new file mode 100644 index 00000000..bff4e19e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ulstal.r @@ -0,0 +1,15 @@ +#-h- ulstal 268 local 12/01/80 15:55:09 +# ulstal - install lower and upper case versions of symbol + include defs + + subroutine ulstal (name, defn) + character name (ARB), defn (ARB) + + include COMMON_BLOCKS + + call entdef (name, defn, deftbl) + call upper (name) + call entdef (name, defn, deftbl) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/uniqid.r b/unix/boot/spp/rpp/rpprat/uniqid.r new file mode 100644 index 00000000..6187fa86 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/uniqid.r @@ -0,0 +1,49 @@ +#-h- uniqid 1825 local 12/01/80 15:55:09 +# uniqid - convert an identifier to one never before seen + include defs + +subroutine uniqid (id) + +character id (MAXTOK) +integer i, j, junk, idchl +external index +integer lookup, index, length +character start (MAXIDLENGTH) +include COMMON_BLOCKS +string idch "0123456789abcdefghijklmnopqrstuvwxyz" # legal id characters + + # Pad the identifer out to length 6 with FILLCHARs: + for (i = 1; id (i) != EOS; i = i + 1) + ; + for (; i <= MAXIDLENGTH; i = i + 1) + id (i) = FILLCHAR + i = MAXIDLENGTH + 1 + id (i) = EOS + id (i - 1) = FILLCHAR + + # Look it up in the table of generated names. If it's not there, + # it's unique. If it is there, it has been generated previously; + # modify it and try again. Assume this procedure always succeeds, + # since to fail implies there are very, very many identifiers in + # the symbol table. + # Note that we must preserve the first and last characters of the + # id, so as not to disturb implicit typing and to provide a flag + # to catch potentially conflicting user-defined identifiers without + # a lookup. + + if (lookup (id, junk, gentbl) == YES) { # (not very likely) + idchl = length (idch) + for (i = 2; i < MAXIDLENGTH; i = i + 1) + start (i) = id (i) + repeat { # until we get a unique id + for (i = MAXIDLENGTH - 1; i > 1; i = i - 1) { + j = mod (index (idch, id (i)), idchl) + 1 + id (i) = idch (j) + if (id (i) != start (i)) + break + } + if (i == 1) + call baderr ("cannot make identifier unique.") + } until (lookup (id, junk, gentbl) == NO) + } +end diff --git a/unix/boot/spp/rpp/rpprat/unstak.r b/unix/boot/spp/rpp/rpprat/unstak.r new file mode 100644 index 00000000..ec8a6eef --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/unstak.r @@ -0,0 +1,42 @@ +include defs + +# unstak - unstack at end of statement + +define IFSTMT 999 + + +subroutine unstak (sp, lextyp, labval, token) + +integer labval(MAXSTACK), lextyp(MAXSTACK) +integer sp, token, type + + for (; sp > 1; sp=sp-1) { + type = lextyp(sp) + if ((type == LEXIFERR | type == LEXIFNOERR) & token == LEXTHEN) + break + if (type == LEXIF | type == LEXIFERR | type == LEXIFNOERR) + type = IFSTMT + if (type == LBRACE | type == LEXSWITCH) + break + if (type == IFSTMT & token == LEXELSE) + break + + if (type == IFSTMT) { + call indent (-1) + call outcon (labval(sp)) + } else if (type == LEXELSE | type == LEXIFELSE) { + if (sp > 2) + sp = sp - 1 + if (type != LEXIFELSE) + call indent (-1) + call outcon (labval(sp) + 1) + } else if (type == LEXDO) + call dostat (labval(sp)) + else if (type == LEXWHILE) + call whiles (labval(sp)) + else if (type == LEXFOR) + call fors (labval(sp)) + else if (type == LEXREPEAT) + call untils (labval(sp), token) + } +end diff --git a/unix/boot/spp/rpp/rpprat/untils.r b/unix/boot/spp/rpp/rpprat/untils.r new file mode 100644 index 00000000..b784fab5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/untils.r @@ -0,0 +1,26 @@ +#-h- untils 397 local 12/01/80 15:55:11 +# untils - generate code for until or end of repeat + include defs + + subroutine untils (lab, token) + integer lab, token + + include COMMON_BLOCKS + + character ptoken (MAXTOK) + + integer junk + integer lex + + xfer = NO + call outnum (lab) + if (token == LEXUNTIL) { + junk = lex (ptoken) + call ifgo (lab - 1) + } + else + call outgo (lab - 1) + call indent (-1) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/whilec.r b/unix/boot/spp/rpp/rpprat/whilec.r new file mode 100644 index 00000000..5dc0fd01 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/whilec.r @@ -0,0 +1,17 @@ +#-h- whilec 262 local 12/01/80 15:55:11 +# whilec - generate code for beginning of while + include defs + + subroutine whilec (lab) + + integer lab + integer labgen + include COMMON_BLOCKS + + call outcon (0) # unlabeled continue, in case there was a label + lab = labgen (2) + call outnum (lab) + call ifgo (lab + 1) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/whiles.r b/unix/boot/spp/rpp/rpprat/whiles.r new file mode 100644 index 00000000..af5679fa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/whiles.r @@ -0,0 +1,14 @@ +#-h- whiles 148 local 12/01/80 15:55:12 +# whiles - generate code for end of while + include defs + + subroutine whiles (lab) + + integer lab + include COMMON_BLOCKS + + call outgo (lab) + call indent (-1) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/test.r b/unix/boot/spp/rpp/test.r new file mode 100644 index 00000000..7bafd871 --- /dev/null +++ b/unix/boot/spp/rpp/test.r @@ -0,0 +1,212 @@ + + + + +define ARB 999999999 +define ERR -1 +define EOF -2 +define BOF -3 +define EOT -4 +define BOFL BOF +define EOFL EOF +define EOS 0 +define NO 0 +define YES 1 +define OK 0 +define NULL 0 + + +define READ_ONLY 1 +define READ_WRITE 2 +define WRITE_ONLY 3 +define APPEND 4 +define NEW_FILE 5 +define TEMP_FILE 6 +define NEW_COPY 7 +define NEW_IMAGE 5 +define NEW_STRUCT 5 +define NEW_TAPE 5 +define TEXT_FILE 11 +define BINARY_FILE 12 +define DIRECTORY_FILE 13 +define STATIC_FILE 14 +define SPOOL_FILE (-2) +define RANDOM 1 +define SEQUENTIAL 2 +define CLIN 1 +define CLOUT 2 +define STDIN 3 +define STDOUT 4 +define STDERR 5 +define STDGRAPH 6 +define STDIMAGE 7 +define STDPLOT 8 + + + +define SZ_BOOL 2 +define SZ_CHAR 1 +define SZ_SHORT 1 +define SZ_INT 2 +define SZ_LONG 2 +define SZ_REAL 2 +define SZ_DOUBLE 4 +define SZ_COMPLEX 4 +define SZ_POINTER 2 +define SZ_STRUCT 2 +define SZ_USHORT 1 +define SZ_FNAME 255 +define SZ_PATHNAME 511 +define SZ_LINE 1023 +define SZ_COMMAND 2047 + +define SZ_MII_SHORT 1 +define SZ_MII_LONG 2 +define SZ_MII_REAL 2 +define SZ_MII_DOUBLE 4 +define SZ_MII_INT SZ_MII_LONG + +define SZ_INT32 2 +define SZ_LONG32 2 +define SZ_STRUCT32 2 + +define TY_BOOL 1 +define TY_CHAR 2 +define TY_SHORT 3 +define TY_INT 4 +define TY_LONG 5 +define TY_REAL 6 +define TY_DOUBLE 7 +define TY_COMPLEX 8 +define TY_POINTER 9 +define TY_STRUCT 10 +define TY_USHORT 11 +define TY_UBYTE 12 + + +define INDEFS (-32767) +define INDEFL (-2147483647) +define INDEFI INDEFL +define INDEFR 1.6e38 +define INDEFD 1.6d308 +define INDEFX (INDEF,INDEF) +define INDEF INDEFR + +define IS_INDEFS (($1)==INDEFS) +define IS_INDEFL (($1)==INDEFL) +define IS_INDEFI (($1)==INDEFI) +define IS_INDEFR (($1)==INDEFR) +define IS_INDEFD (($1)==INDEFD) +define IS_INDEFX (real($1)==INDEFR) +define IS_INDEF (($1)==INDEFR) + + +define P2C ((($1)-1)*2+1) +define P2S ((($1)-1)*2+1) +define P2L ($1) +define P2R ($1) +define P2D ((($1)-1)/2+1) +define P2X ((($1)-1)/2+1) + +define P2P ($1) + + + + + + + + + + + + +define access xfaccs +define calloc xcallc +define close xfcloe +define delete xfdele +define error xerror +define flush xffluh +define getc xfgetc +define getchar xfgetr +define malloc xmallc +define mfree xmfree +define mktemp xmktep +define note xfnote +define open xfopen +define poll xfpoll +define printf xprinf +define putc xfputc +define putchar xfputr +define qsort xqsort +define read xfread +define realloc xrealc +define seek xfseek +define sizeof xsizef +define strcat xstrct +define strcmp xstrcp +define strcpy xstrcy +define strlen xstrln +define ungetc xfungc +define write xfwrie +define fatal xfatal +define fchdir xfchdr +define fscan xfscan +define getopt xgtopt +define getpid xgtpid +define getuid xgtuid +define rename xfrnam +define reset xreset +define scan xxscan + + + + + + +define IS_UPPER ($1>=65&$1<=90) +define IS_LOWER ($1>=97&$1<=122) +define IS_DIGIT ($1>=48&$1<=57) +define IS_PRINT ($1>=32&$1<127) +define IS_CNTRL ($1>0&$1<32) +define IS_ASCII ($1>0&$1<=127) +define IS_ALPHA (IS_UPPER($1)|IS_LOWER($1)) +define IS_ALNUM (IS_ALPHA($1)|IS_DIGIT($1)) +define IS_WHITE ($1==32|$1==9) +define TO_UPPER ($1+65-97) +define TO_LOWER ($1+97-65) +define TO_INTEG ($1-48) +define TO_DIGIT ($1+48) + +#!# 2 + + + + + + + + + + + + + + + + + +x$subr t_hello () + +x$short ST0001(14) +save +x$int iyy +data (ST0001(iyy),iyy= 1, 8) /104,101,108,108,111, 44, 32,119/ +data (ST0001(iyy),iyy= 9,14) /111,114,108,100, 10, 0/ +begin +#!# 10 + + call printf (ST0001) +end + + diff --git a/unix/boot/spp/rpp/x b/unix/boot/spp/rpp/x new file mode 100644 index 00000000..007b82a6 --- /dev/null +++ b/unix/boot/spp/rpp/x @@ -0,0 +1,18 @@ + + +x$subr t_foo () +x$int i +x$long l +x$pntr p +x$pntr p2 + +save +begin +#!# 7 + + i = 1 + l = 1 + p = 1 +end + + diff --git a/unix/boot/spp/test.x b/unix/boot/spp/test.x new file mode 100644 index 00000000..1c1d6c71 --- /dev/null +++ b/unix/boot/spp/test.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# Test program. + +task hello = t_hello + +procedure t_hello() + +begin + call printf ("hello, world\n") +end diff --git a/unix/boot/spp/xc.c b/unix/boot/spp/xc.c new file mode 100644 index 00000000..73079c58 --- /dev/null +++ b/unix/boot/spp/xc.c @@ -0,0 +1,1970 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "xpp.h" +#include "../bootProto.h" + +#define NOKNET +#define import_kernel +#define import_knames +#include + +#if defined(LINUX) || defined(BSD) +# ifdef SOLARIS +# undef SOLARIS +# endif +#endif + +/* + * XC -- Main entry point of the XC compiler front-end used by the IRAF + * system. + */ + +#define VERSION "IRAFNET XC V2.4 Jan 21 2010" + +#define ERR (-1) +#define EOS '\0' +#define YES 1 +#define NO 0 +#define MAXFLAG 64 /* maximum option flags */ +#define MAXFILE 1024 /* maximum files on cmdline */ +#define SZ_CMDBUF 4096 /* maximum command buffer */ +#define SZ_BUFFER 4096 /* library names, flags */ +#define SZ_LIBBUF 4096 /* full library names */ +#define SZ_FNAME 255 +#define SZ_PATHNAME 511 +#define SZ_PKGENV 256 +#define DEF_PKGENV "iraf" + +#ifdef MACOSX +#define CCOMP "cc" /* C compiler (also .s etc.) */ +#define LINKER "cc" /* Linking utility */ +#else +#define CCOMP "gcc" /* C compiler (also .s etc.) */ +#define LINKER "gcc" /* Linking utility */ +#endif +#define F77COMP "f77" /* Fortran compiler */ +#define DEBUGFLAG 'g' /* host flag for -x */ +#define USEF2C 1 /* use Fortran to C trans. */ + +#define LIBCINCLUDES "hlib$libc/" /* IRAF LIBC include dir */ +#define LOCALBINDIR "/usr/local/bin/" /* standard local BIN */ +#define SYSBINDIR "/usr/bin/" /* special system BIN */ + +#define XPP "xpp.e" +#define RPP "rpp.e" +#define EDSYM "edsym.e" +#define SHIMAGE "S.e" +#define LIBMAIN "libmain.o" +#define SHARELIB "libshare.a" +#define IRAFLIB1 "libex.a" +#define IRAFLIB2 "libsys.a" +#define IRAFLIB3 "libvops.a" +#define IRAFLIB4 "libos.a" +#define IRAFLIB5 "libVO.a" +#define IRAFLIB6 "libcfitsio.a" + +#ifdef LINUX +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ +#ifndef LINUXPPC +#ifndef LINUX64 + "", /* 3 -lcompat */ +#endif +#else + "-lg2c", /* 3 */ +#endif + "-lpthread", /* 4 */ + "-lm", /* 5 */ + "-lrt", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +#ifdef BSD +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lcompat", /* 3 */ + "", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +#ifdef MACOSX +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lcurl", /* 3 */ + "", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O3", /* 0 */ + 0}; /* EOF */ + +/* As of Dec2007 there remains an unexplained optimizer bug in +** the system which has the effect of disabling FPE handling on +** Mac Intel/PPC systems. For the moment, we'll disable the optimization +** until this is better understood or fixed in future GCC versions. +*/ +int nopt_flags = 0; /* No. optimizer flags */ + +#else +#ifdef SOLARIS +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lsocket", /* 3 */ + "-lnsl", /* 4 */ + "-lintl", /* 5 */ + "-ldl", /* 6 */ + "-lelf", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +#ifdef CYGWIN +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lcompat", /* 3 */ + "", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +char *fortlib[] = { "-lU77", /* 0 (host progs) */ + "-lm", /* 1 */ + "-lF77", /* 2 */ + "-lI77", /* 3 */ + "-lm", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#endif +#endif +#endif +#endif +#endif + +#ifdef BSD +#define F_STATIC "-static" +#define F_SHARED "-shared" +#else +#ifdef MACOSX +#define F_STATIC "-static" +#define F_SHARED "-shared" +#else +#ifdef LINUX +#define F_STATIC "-Wl,-Bstatic" +#define F_SHARED "-Wl,-Bdynamic" +#else +#ifdef SOLARIS +#define F_STATIC "-Wl,-Bstatic" +#define F_SHARED "-Wl,-Bdynamic" +#endif +#endif +#endif +#endif + +#define isxfile(str) (getextn(str) == 'x') +#define isffile(str) (getextn(str) == 'f') +#define iscfile(str) (getextn(str) == 'c') +#define issfile(str) (getextn(str) == 's') +#define isefile(str) (getextn(str) == 'e') +#define isafile(str) (getextn(str) == 'a') +#define isofile(str) (getextn(str) == 'o') +#define ispfile(str) (getextn(str) == 'P') /* func prototypes */ + + +#ifdef SOLARIS +#ifdef X86 +int usesharelib = NO; +int noedsym = YES; +#else +int usesharelib = YES; +int noedsym = NO; +#endif + +#else +#ifdef SHLIB +int usesharelib = YES; +int noedsym = NO; +#else +int usesharelib = NO; +int noedsym = YES; +#endif +#endif + +int stripexe = NO; +int notvsym = NO; +int noshsym = NO; +int errflag = NO; +int objflags = NO; +int keepfort = NO; +int mkobject = YES; +int mktask = YES; +int optimize = YES; +int cflagseen = NO; +int nfileargs = 0; +int link_static = NO; +int link_nfs = NO; +int debug = NO; +int dbgout = NO; +int hostprog = NO; +int voslibs = YES; +int nolibc = NO; +int usef2c = YES; +int useg95 = NO; +int userincs = NO; +#ifdef LINUXPPC +int useg2c = YES; +#else +int useg2c = NO; +#endif +int host_c_main = NO; + +char ccomp[SZ_FNAME] = CCOMP; +char f77comp[SZ_FNAME] = F77COMP; +char linker[SZ_FNAME] = LINKER; +char f2cpath[SZ_FNAME] = "/usr/bin/f2c"; +char g77path[SZ_FNAME] = "/usr/bin/g77"; + +char outfile[SZ_FNAME] = ""; +char tempfile[SZ_FNAME] = ""; +char *lflags[MAXFLAG+1]; +char *lfiles[MAXFILE+1]; /* all files */ +char *hlibs[MAXFILE+1]; /* host libraries */ +char *lxfiles[MAXFILE+1]; /* .x files */ +char *lffiles[MAXFILE+1]; /* .f files */ +char buffer[SZ_BUFFER+1]; +char libbuf[SZ_LIBBUF+1]; +char *bp = buffer; +char *libp = libbuf; +char *pkgenv = NULL; +char *pkglibs = NULL; +char v_pkgenv[SZ_PKGENV+1]; +int nflags, nfiles, nhlibs, nxfiles, nffiles; +long sig_int, sig_quit, sig_hup, sig_term; +char *shellname = "/bin/sh"; +int foreigndefs = NO; +char *foreign_defsfile = ""; +char *irafarch = ""; /* IRAFARCH string */ +char floatoption[32] = ""; /* f77 arch flag, if any */ +int pid; + + +/** + * External procedure declarations. + */ +extern void ZZSTRT (void); +extern void ZZSTOP (void); + +/** + * Local procedure declarations. + */ +static char *mkfname (char *i_fname); +static int addflags (char *flag, char *arglist[], int *p_nargs); +static char *iraflib (char *libref); +static void printargs (char *cmd, char *arglist[], int nargs); +static void xtof (char *file); +static int getextn (char *fname); +static void chdot (char *fname, char dotchar); + +static int run (char *task, char *argv[]); +static int sys (char *cmd); + +static void done (int k); +static void enbint (SIGFUNC handler); +static void interrupt (void); +static int await (int waitpid); +static void rmfiles (void); + +static void fatalstr (char *s1, char *s2); +static void fatal (char *s); + +static int isv13 (void); +static char *findexe (char *prog, char *dir); + + + + +/** + * MAIN -- Execution begins here. Interpret command line arguments and + * pass commands to UNIX to execute the various passes, i.e.: + * + * xpp SPP to modified-ratfor + * rpp modified-ratfor to Fortran + * f77 UNIX fortran compiler + * cc compile other sources, link if desired + * + * The Fortran source is left behind if the -F flag is given. The IRAF root + * directory must either be given on the command line as "-r pathname" or in + * the environment as the variable "irafdir". + */ +int +main (int argc, char *argv[]) +{ + int i, j, nargs, ncomp; + char *arglist[MAXFILE+MAXFLAG+10]; + char *arg, *ip, *s; + int status, noperands; + + /* Initialization. */ + ZZSTRT(); + isv13(); + +#if defined(LINUX) || defined(BSD) || defined(X86) || defined(MACOSX) + if (os_sysfile ("f77.sh", f77comp, SZ_FNAME) < 0) { + strcpy (f77comp, "f77"); + usef2c = 0; + } else + usef2c = 1; + if (os_sysfile ("f2c.e", tempfile, SZ_FNAME) > 0) + strcpy (f2cpath, tempfile); +#else + strcpy (f77comp, "f77"); +#endif + + nflags = nfiles = nhlibs = nxfiles = nffiles = 0; + + sig_int = (long) signal (SIGINT, SIG_IGN) & 01; + sig_quit = (long) signal (SIGQUIT, SIG_IGN) & 01; + sig_hup = (long) signal (SIGHUP, SIG_IGN) & 01; + sig_term = (long) signal (SIGTERM, SIG_IGN) & 01; + + enbint ((SIGFUNC)interrupt); + pid = getpid(); + + /* Load any XC related environment definitions. + */ + if ((s = os_getenv ("XC-CC")) || (s = os_getenv ("XC_CC"))) + strcpy (ccomp, s); + if ((s = os_getenv ("XC-F77")) || (s = os_getenv ("XC_F77"))) { + strcpy (f77comp, s); + usef2c = (strncmp (f77comp, "f77", 3) == 0 ? 1 : 0); + useg95 = (strncmp (f77comp, "g95", 3) == 0 ? 1 : 0); + } + if ((s = os_getenv ("XC-LINKER")) || (s = os_getenv ("XC_LINKER"))) + strcpy (linker, s); + + + + /* Always load the default IRAF package environment. */ + loadpkgenv (DEF_PKGENV); + + /* Count the number of file arguments. Load the environment for + * any packages named on the command line. + */ + pkgenv = NULL; + v_pkgenv[0] = EOS; + for (i=1, nfileargs=0; argv[i] != NULL; i++) + if (argv[i][0] != '-') + nfileargs++; + else if (strcmp (argv[i], "-p") == 0 && argv[i+1]) { + loadpkgenv (argv[++i]); + strcat (v_pkgenv, v_pkgenv[0] ? " -p " : "-p "); + strcat (v_pkgenv, argv[i]); + pkgenv = v_pkgenv; + } + + /* If no package environment was specified see if the user has + * specified a default package in their user environment. + */ + if (!pkgenv) { + char *s, u_pkgenv[SZ_PKGENV+1]; + char *pkgname, *ip; + + if ((s = os_getenv ("PKGENV"))) { + strcpy (ip = u_pkgenv, s); + while (*ip) { + while (isspace(*ip)) + ip++; + pkgname = ip; + while (*ip && !isspace(*ip)) + ip++; + if (*ip) + *ip++ = EOS; + + if (pkgname[0]) { + loadpkgenv (pkgname); + strcat (v_pkgenv, v_pkgenv[0] ? " -p " : "-p "); + strcat (v_pkgenv, pkgname); + pkgenv = v_pkgenv; + } + } + } + } + + /* Process command line options, make file lists. + * Convert ".x" files to ".f". + */ + for (i=1; (arg = argv[i]) != NULL; i++) { + if (arg[0] == '-') { + switch (arg[1]) { + case '/': + /* Pass flag on without further interpretation. + * "-/foo" -> "-foo" + * "-//foo" -> "foo" + */ + lflags[nflags] = bp; + ip = &arg[2]; + if (*ip == '/') + ip++; + else + *bp++ = '-'; + + while ((*bp++ = *ip++)) + ; + + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + break; + + case 'D': + /* Pass a -D flag on to the host compiler. + */ + lflags[nflags] = bp; + for (ip = &arg[0]; (*bp++ = *ip++); ) + ; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + break; + + case 'I': + /* Pass a -I flag on to the host compiler. + * A special case is "-Inolibc" which disables automatic + * inclusion of the IRAF LIBC includes (hlib$libc). + */ + if (strcmp (&arg[2], "nolibc") == 0) + nolibc++; + else { + lflags[nflags] = bp; + *bp++ = arg[0]; + *bp++ = arg[1]; + strcpy (bp, vfn2osfn (&arg[2], 0)); + bp += strlen (bp) + 1; + + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + } + break; + + case 'l': + case 'L': + /* Library file (-llib) or library directory (-Ldir) + * reference. + */ + if ((lfiles[nfiles] = iraflib (arg)) == NULL) { + hlibs[nhlibs] = arg; + nhlibs++; + } else + nfiles++; + if (nfiles > MAXFILE || nhlibs > MAXFILE) + fatal ("Too many files"); + + objflags = YES; + mkobject = YES; + mktask = YES; + break; + + case 'o': + /* Set output file name. + */ + if ((arg = argv[++i]) == NULL) + i--; + else + strcpy (outfile, arg); + mkobject = YES; + mktask = YES; + objflags = YES; + break; + + case 'p': + /* Ignore since the -p args were already processed above. + */ + i++; + break; + + case 'r': + /* Not used anymore */ + if ((arg = argv[++i]) == EOS) + i--; + break; + + case 'h': + /* Host program: do not link in IRAF main or search + * standard IRAF libraries unless explicitly referenced + * on command line. + */ + voslibs = 0; + /* fall through */ + + case 'H': + /* Link a host program, but include the VOS libraries. + */ + hostprog++; + noedsym++; + nolibc++; + break; + + case 'G': + /* Force a program to link w/ libg2c.a instead of libf2c.a + */ + useg2c++; + break; + + case 'A': + /* Force arch-specific include files. + */ + userincs++; + break; + + case 'C': + /* Link a host program which has a C main. We may need + * to tweak the command line as a special case here since + * we normally assume Fortran sources. This is currently + * only needed for host C programs under LinuxPPC. + */ + host_c_main++; + break; + + case 'V': + /* Print XC version identification. + */ + fprintf (stderr, "%s\n", VERSION); + fflush (stderr); + break; + + default: + if (strcmp (&arg[1], "Nh") == 0) { + if ((arg = argv[++i]) == EOS) + i--; + else { + foreigndefs++; + foreign_defsfile = arg; + continue; + } + } + + lflags[nflags] = bp; + *bp++ = '-'; + + /* Process list of flags without arguments, e.g. "-xyz" + * which is the same as "-x -y -z". + */ + for (ip = &arg[1]; *ip != EOS; ip++) + if (*ip == 'c') { + mkobject = YES; + mktask = NO; + objflags = YES; + cflagseen = YES; + + } else if (*ip == 'd') { + debug++; + } else if (*ip == 'q') { + optimize = NO; + } else if (*ip == 'O') { + optimize = YES; + + } else if (*ip == 'F' || *ip == 'f') { + keepfort = YES; + if (objflags == NO) { + mkobject = NO; + mktask = NO; + } + } else if (*ip == 'x') { + dbgout++; + optimize = NO; + *bp++ = DEBUGFLAG; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + } else if (*ip == 'z') { + usesharelib = NO; + } else if (*ip == 'e') { + noedsym = YES; + } else if (*ip == 't') { + notvsym = YES; + } else if (*ip == 'T') { + noshsym = YES; + } else if (*ip == 's') { + stripexe = YES; + goto passflag; + } else if (*ip == 'N') { + /* "NFS" link option. Generate the output temp + * file in /tmp during the link, then move it to + * the output directory in one operation when done. + * For cases such as linking in an NFS-mounted + * directory, where all the NFS i/o may slow the + * link down excessively. + */ + link_nfs = YES; + } else { +passflag: mkobject = YES; + if (!cflagseen) + mktask = YES; + *bp++ = *ip; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + } + + if (bp - lflags[nflags] <= 1) { + lflags[nflags] = NULL; + bp--; + } else { + *bp++ = EOS; + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + } + } + + } else { + char *ip, *op, *last_dot; + + /* Get default name for output executable file, if not given + * as arg. The default extension is ".e". + */ + if (outfile[0] == EOS) { + last_dot = NULL; + for (ip=arg, op=outfile; (*op = *ip++) != EOS; op++) + if (*op == '.') + last_dot = op; + if (last_dot != NULL) + *last_dot = EOS; + strcat (outfile, ".e"); + } + + /* Munge filename if file is a library. */ + if (isafile(arg) && (s = iraflib(arg))) + arg = s; + + if (access (arg,0) == -1) { + fprintf (stderr, "Warning: file `%s' not found\n", arg); + fflush (stderr); + } else { + lfiles[nfiles++] = arg; + if (nfiles > MAXFILE) + fatal ("Too many files"); + + if (isxfile (arg)) { + xtof (arg); + if (errflag & (XPP_BADXFILE | XPP_COMPERR)) { + nfiles--; + errflag &= ~(XPP_BADXFILE | XPP_COMPERR); + } + } else if (isffile (arg)) { + lffiles[nffiles++] = arg; + if (nffiles > MAXFILE) + fatal ("too many files"); + } else if (isefile (arg)) + fatal ("no .e files permitted in file list"); + } + } + } + + if (!mkobject) { + if (debug) { + fprintf (stderr, "quit, fortran only\n"); + fflush (stderr); + } + ZZSTOP(); + exit (errflag); + } + + /* Add -I to lflags for each directory in the pkglibs + * package library list. pkglibs is a comma delimited list of VFN + * directory names formed by loading the core system and layered + * package environments. + */ + if ((pkglibs = os_getenv ("pkglibs"))) { + char *ip, *op, *vp, fname[SZ_FNAME]; + + for (ip=pkglibs; *ip; ) { + while (*ip && (isspace(*ip) || *ip == ',')) + ip++; + for (op=fname; *ip && !(isspace (*ip) || *ip == ','); ) + *op++ = *ip++; + *op++ = EOS; + if (*fname == EOS) + break; + + /* Omit the LIBC includes if -Inolibc was specified. */ + if (! (nolibc && strcmp (fname, LIBCINCLUDES) == 0)) { + lflags[nflags] = bp; + *bp++ = '-'; + *bp++ = 'I'; + for (vp=vfn2osfn(fname,0); (*bp++ = *vp++); ) + ; + if (*(bp-2) == '/') { + --bp; + *(bp-1) = EOS; + } + + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + } + + while (*ip && (isspace(*ip) || *ip == ',')) + ip++; + } + } + + /* Now check for any alternative compiler definitions or commandline + * flags which will affect out link line. Some systems like LinuxPPC + * will require use of -lg2c even though we can continue to use the + * hlib$f77.sh the fortran compiler script on that system. + */ + if (useg2c || strncmp (f77comp, "g77", 3) == 0) { + fortlib[0] = fortlib[1] = "-lg2c"; + } + + +#ifdef sun + /* Determine if any special architecture dependent compilation flags + * are needed. For the Sun V1.3 compiler, since FLOAT_OPTION is no + * longer supported, we look for IRAFARCH and generate the -f68881 + * or -ffpa compiler switches automatically if we are compiling on a + * Sun-3 and no -/f* has already been specified on the command line. + */ + if (!floatoption[0] && (irafarch = os_getenv("IRAFARCH"))) + if (irafarch[0] == 'f') + sprintf (floatoption, "-%s", irafarch); +#endif + /* Compile all F77 source files with F77 to produce object code. + * This compilation is separate from that used for the '.x' files, + * because we do not want to use the UNIX "-u" flag (requires that + * everything be declared) for raw Fortran files. + */ + nargs = 0; + arglist[nargs++] = f77comp; + arglist[nargs++] = "-c"; + if (usef2c == YES) { + arglist[nargs++] = "-f2c"; + arglist[nargs++] = f2cpath; + } + +#ifdef MACOSX + if (useg95 == 0) { + if ((irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + } + } +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#if (defined(BSD)) + arglist[nargs++] = "-m32"; +#endif + +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif +#ifdef sun + if (floatoption[0]) + arglist[nargs++] = floatoption; +#endif + if (optimize) { + for (i=0; i < nopt_flags; i++) + arglist[nargs++] = opt_flags[i]; + } + + /* Add the user-defined flags last so they can override the + * hardwired options. + */ + if ((s = os_getenv("XC-FFLAGS")) || (s = os_getenv("XC_FFLAGS"))) + addflags (s, arglist, &nargs); + + for (i=0; i < nflags; i++) + arglist[nargs++] = lflags[i]; + + for (i=0; i < nffiles; i++) + arglist[nargs++] = lffiles[i]; + arglist[nargs] = NULL; + + if (i > 0) { + if (debug) + printargs (f77comp, arglist, nargs); + status = run (f77comp, arglist); +#ifdef LINUX + /* This kludge is to work around a bug in the F2C based F77 script + * on Linux, which returns an exit status of 4 when successfully + * compiling a Fortran file. + */ + if (status == 4) + status = 0; +#endif + errflag += status; + } + + + /* Compile the remaining Fortran source files with F77 to produce + * object code. + */ + nargs = 0; + arglist[nargs++] = f77comp; + arglist[nargs++] = "-c"; + arglist[nargs++] = "-u"; + arglist[nargs++] = "-x"; + if (usef2c == YES) { + arglist[nargs++] = "-f2c"; + arglist[nargs++] = f2cpath; + } + +#ifdef MACOSX + if (useg95 == 0) { + if ((irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + + } + } +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#if (defined(BSD)) + arglist[nargs++] = "-m32"; +#endif + +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif +#ifdef sun + if (floatoption[0]) + arglist[nargs++] = floatoption; +#endif + if (optimize) { + for (i=0; i < nopt_flags; i++) + arglist[nargs++] = opt_flags[i]; + } + + /* Add the user-defined flags last so they can override the + * hardwired options. + */ + if ((s = os_getenv("XC-FFLAGS")) || (s = os_getenv("XC_FFLAGS"))) + addflags (s, arglist, &nargs); + + for (i=0; i < nflags; i++) + arglist[nargs++] = lflags[i]; + + /* Make list of files to be compiled. Do not include F77 files, + * as they were already compiled above. + */ + for (i=0, noperands=0; i < nfiles; i++) { + for (j=0; j < nffiles && lffiles[j] != lfiles[i]; j++) + ; + if (j >= nffiles && isffile (lfiles[i])) { + arglist[nargs++] = lfiles[i]; + noperands++; + } + } + arglist[nargs] = NULL; + + if (noperands > 0) { + if (debug) + printargs (f77comp, arglist, nargs); + status = run (f77comp, arglist); +#ifdef LINUX + /* This kludge is to work around a bug in the F2C based F77 script + * on Linux, which returns an exit status of 4 when successfully + * compiling a Fortran file. + */ + if (status == 4) + status = 0; +#endif + errflag += status; + } + + + /* Compile the remaining non-Fortran source files with CC to produce + * object code. + */ + nargs = 0; + arglist[nargs++] = ccomp; + arglist[nargs++] = "-c"; + +#ifdef MACH64 + arglist[nargs++] = "-DMACH64"; /* needed for zmain.c */ +#endif +#ifdef LINUX64 + arglist[nargs++] = "-DLINUX64"; /* needed for zmain.c */ +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#ifdef LINUX + arglist[nargs++] = "-DLINUX"; +#ifdef REDHAT + arglist[nargs++] = "-DREDHAT"; +#endif +#ifdef LINUXPPC + arglist[nargs++] = "-DLINUXPPC"; +#endif + arglist[nargs++] = "-DPOSIX"; + arglist[nargs++] = "-DSYSV"; +#endif + +#ifdef BSD + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-DBSD"; +#endif + +#ifdef MACOSX + arglist[nargs++] = "-DMACOSX"; + if (useg95 == 0) { + if ((irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + + } + } +#endif + +#ifdef SOLARIS + arglist[nargs++] = "-DSOLARIS"; +#ifdef X86 + arglist[nargs++] = "-DX86"; +#endif + arglist[nargs++] = "-DPOSIX"; + arglist[nargs++] = "-DSYSV"; +#endif + +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif + +#ifdef sun + if (floatoption[0]) + arglist[nargs++] = floatoption; +#endif + if (optimize) { + for (i=0; i < nopt_flags; i++) + arglist[nargs++] = opt_flags[i]; + } + + /* Add the user-defined flags last so they can override the + * hardwired options. + */ + if ((s = os_getenv("XC-CFLAGS")) || (s = os_getenv("XC_CFLAGS"))) + addflags (s, arglist, &nargs); + + for (i=0; i < nflags; i++) + arglist[nargs++] = lflags[i]; + + /* Make list of files to be compiled. Only C and assembler files + * are included. + */ + for (i=0, noperands=0; i < nfiles; i++) { + if (iscfile (lfiles[i]) || issfile (lfiles[i])) { + arglist[nargs++] = lfiles[i]; + noperands++; + } + } + arglist[nargs] = NULL; + + if (noperands > 0) { + if (debug) + printargs (ccomp, arglist, nargs); + errflag += run (ccomp, arglist); + } + + + /* If "-c" (compile only), or there was a compiler error, do not + * proceed with the link. + */ + if (!mktask || cflagseen || errflag) + done (errflag); + + + /* Link the object files and libraries to produce the "-o" task. + */ + nargs = 0; + arglist[nargs++] = linker; + if ((s = os_getenv("XC-LFLAGS")) || (s = os_getenv("XC_LFLAGS"))) + addflags (s, arglist, &nargs); + +#ifdef MACOSX + if (useg95 == 0 && (irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + } +#endif + +#ifdef SOLARIS + arglist[nargs++] = "-Wl,-t"; +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-Wl,--defsym,mem_=0"; +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#if (defined(BSD)) + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-L/usr/lib32"; + arglist[nargs++] = "-B/usr/lib32"; +#endif +#ifdef NEED_GCC_SPECS + { char gcc_specs[SZ_PATHNAME]; + static char cmd[SZ_CMDBUF]; + + if (os_sysfile ("gcc-specs", gcc_specs, SZ_PATHNAME) < 0) + arglist[nargs++] = "/iraf/iraf/unix/bin/gcc-specs"; + sprintf (cmd, "-specs=%s", gcc_specs); + arglist[nargs++] = cmd; + } +#endif +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif + arglist[nargs++] = "-o"; + + if (link_nfs) { + sprintf (tempfile, "/tmp/T_%s.XXXXXX", outfile); +#ifdef LINUX + mkstemp (tempfile); +#else + mktemp (tempfile); +#endif + } else + sprintf (tempfile, "T_%s", outfile); + arglist[nargs++] = tempfile; + + ncomp = 0; + for (i=0; i < nfiles; i++) + if (*(ip = lfiles[i]) != '-') { + while (*ip++ != EOS) + ; + while (*--ip != '.' && ip >= lfiles[i]) + ; + if (*ip == '.') + switch (ip[1]) { + case 'f': + case 'r': + case 'c': + case 's': + case 'e': + ip[1] = 'o'; + ncomp++; + } + } + + /* Link options. */ + link_static = 0; + for (i=0; i < nflags; i++) { + arglist[nargs++] = lflags[i]; + if (strcmp (lflags[i], F_STATIC) == 0) + link_static = 1; + else if (strcmp (lflags[i], F_SHARED) == 0) + link_static = 0; + } + +#ifdef sun + /* Need to pass -f to CC for the C libraries. */ + if (floatoption[0]) + arglist[nargs++] = floatoption; + + /* If we are using the V1.3 Sun Fortran compiler, the V1.3 "f77" + * should be a symbolic link pointing to the BIN directory for the + * new compiler. Construct the path to this directory and put it + * out as a -Ldir flag on the link line to ensure that the library + * is searched for linking. + */ + if (isv13()) { + char libpath[SZ_PATHNAME]; + char dir[SZ_PATHNAME], *path; + char *pp, *ip, *op, *s; + int n; + + path = findexe ("f77", dir); + + strcpy (libpath, "-L"); + strcpy (libpath+2, dir); + for (op=libpath; *op; op++) + ; + if ((n = readlink (path, op, 128)) > 0) { + op[n] = EOS; + + for (ip=op; *ip; ip++) + if (*ip == '/') + op = ip; + *op = EOS; + + /* Search, e.g., /usr/lang/SC0.0/ffpa first if Sun-3. */ + if (floatoption[0]) { + s = floatoption + 1; + *op = '/'; + strcpy (op+1, s); + strcpy (libp, libpath); + libp += strlen (pp = libp) + 1; + arglist[nargs++] = pp; + } + + /* Search /usr/lang/SC0.0 (or whatever). */ + *op = EOS; + strcpy (libp, libpath); + libp += strlen (pp = libp) + 1; + arglist[nargs++] = pp; + } + } +#endif + + /* File to link. */ + for (i=0; i < nfiles; i++) + arglist[nargs++] = lfiles[i]; + + /* Libraries to link against. + */ + if (hostprog) { +#ifdef LINUXPPC + /* LinuxPPC (YellowDog anyway) requires this library to resolve + * the MAIN__ generated by the fortran program statement into + * the 'main'. + */ + if (host_c_main == 0) + arglist[nargs++] = "-lfrtbegin"; +#else + if (!isv13()) + arglist[nargs++] = mkfname (fortlib[0]); +#endif + } else + arglist[nargs++] = mkfname (LIBMAIN); + + if (voslibs) { + if (usesharelib) { + arglist[nargs++] = mkfname (SHARELIB); + arglist[nargs++] = mkfname (IRAFLIB4); + arglist[nargs++] = mkfname (IRAFLIB5); + arglist[nargs++] = mkfname (IRAFLIB6); + } else { + arglist[nargs++] = mkfname (IRAFLIB1); + arglist[nargs++] = mkfname (IRAFLIB2); + arglist[nargs++] = mkfname (IRAFLIB3); + arglist[nargs++] = mkfname (IRAFLIB4); + arglist[nargs++] = mkfname (IRAFLIB5); + arglist[nargs++] = mkfname (IRAFLIB6); + } + } + + /* Host libraries, searched after iraf libraries. */ + for (i=0; i < nhlibs; i++) + arglist[nargs++] = hlibs[i]; + + /* The remaining system libraries depend upon which version of + * the SunOS compiler we are using. The V1.3 compilers use only + * -lF77 and -lm. + */ + if (isv13()) { + addflags (fortlib[2], arglist, &nargs); + addflags (fortlib[4], arglist, &nargs); + } else { + addflags (fortlib[1], arglist, &nargs); + addflags (fortlib[2], arglist, &nargs); + addflags (fortlib[3], arglist, &nargs); + addflags (fortlib[4], arglist, &nargs); + addflags (fortlib[5], arglist, &nargs); + addflags (fortlib[6], arglist, &nargs); + addflags (fortlib[7], arglist, &nargs); + addflags (fortlib[8], arglist, &nargs); + addflags (fortlib[9], arglist, &nargs); + } + arglist[nargs] = NULL; + + if (ncomp) { + fprintf (stderr, "link:\n"); + fflush (stderr); + } + if (debug) + printargs (linker, arglist, nargs); + + /* If the link is successful, replace the old executable with the + * new one. Do not delete the bad executable if the link fails, + * as we might want to examine its symbol table. + */ + if ((status = run (linker, arglist)) == 0) { + unlink (outfile); + + if (link_nfs) { + char command[1024]; + sprintf (command, "/bin/cp -f %s %s", tempfile, outfile); + if (debug) + printargs (command, NULL, 0); + status = sys (command); + } else + link (tempfile, outfile); + + /* Force the mode of the file. */ + chmod (outfile, 0755); + + unlink (tempfile); + } + errflag += status; + + /* If we are linking against the iraf shared library and symbol editing + * has not been disabled, edit the symbol table of the new executable + * to provide symbols within the shared image. + */ + if (usesharelib && !noedsym && !stripexe) { + char shlib[SZ_PATHNAME+1]; + char edsym[SZ_PATHNAME+1]; + char command[SZ_CMDBUF]; + + /* The os_sysfile(SHIMAGE) below assumes the existence of a file + * entry "S.e" in the directory containing the real shared image + * "S.e". We can't easily look directly for S.e because + * the process symbol table and image has to be examined to + * determine the shared image version number. + */ + if (os_sysfile (SHIMAGE, shlib, SZ_PATHNAME) > 0) { + if (os_sysfile (EDSYM, edsym, SZ_PATHNAME) > 0) { + sprintf (command, "%s %s %s", edsym, outfile, shlib); + if (noshsym) + strcat (command, " -T"); + else if (notvsym) + strcat (command, " -t"); + status = sys (command); + } + } + } + errflag += status; + done (errflag); + + return (0); +} + + +/* MKFNAME -- Make the UNIX pathname of an IRAF library file. Use os_sysfile + * the get the vfn of the library file, so that we do not have to know what + * system directory the library file is in. + */ +static char * +mkfname (char *i_fname) +{ + char fname[SZ_PATHNAME+1]; + char *oname; + + /* Library referenced as -lXXX */ + if (strncmp (i_fname, "-l", 2) == 0) { + sprintf (fname, "lib%s.a", &i_fname[2]); + if ((oname = iraflib (fname))) + return (oname); + else + return (i_fname); + } + + /* Must be a library filename or pathname */ + strcpy (fname, i_fname); + if ((oname = iraflib (fname))) + strcpy (libp, oname); + else + strcpy (libp, fname); + + oname = libp; + libp += strlen (libp) + 1; + + return (oname); +} + + +/* ADDFLAGS -- Add one or more flags to an argument list. Ignore null flags, + * separate multiple flags on whitespace. + */ +static int +addflags (char *flag, char *arglist[], int *p_nargs) +{ + register int i, len, nargs = *p_nargs; + char *fp, *fs, lflag[SZ_FNAME]; + + if (flag && *flag) { + + for (fp = flag; *fp; ) { + while (*fp && isspace(*fp)) /* skip leading space */ + fp++; + for (i=0; *fp && !isspace(*fp); ) /* collect flag */ + lflag[i++] = *fp++; + lflag[i] = '\0'; + len = strlen (lflag); + strcpy ((fs = malloc(len+1)), lflag); + + if (strcmp (lflag, F_STATIC) == 0) { + link_static = 1; + } else if (strcmp (lflag, F_SHARED) == 0) { + link_static = 0; +#if defined(LINUX) || defined(BSD) || defined(X86) || defined(MACOSX) + } else if ((strcmp (lflag, "-lf2c") == 0) || + (strcmp (lflag, "-lcompat") == 0)) { + /* Use the IRAF version of libf2c.a or libcompat.a, + * not the host version which may or may not be present. + */ + arglist[nargs++] = mkfname (lflag); + *p_nargs = nargs; + return (1); + } +#endif +#ifdef SOLARIS + else if (strcmp (lflag, "-ldl") == 0) { + /* This beastie has to be linked dynamic on Solaris, but + * we don't want to have to know this everywhere so we do + * it automatically there. + */ + if (link_static) + arglist[nargs++] = F_SHARED; + arglist[nargs++] = fs; + if (link_static) + arglist[nargs++] = F_STATIC; + *p_nargs = nargs; + return (1); + } +#endif + arglist[nargs++] = fs; + } + + *p_nargs = nargs; + return (1); + } + + return (0); +} + + +/* IRAFLIB -- Determine if "libname" is an IRAF library. If so return + * the pathname of the library, else return NULL. + */ +static char * +iraflib (char *libref) +{ + register char *ip, *op; + char savename[SZ_PATHNAME+1]; + char libname[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + char path[SZ_PATHNAME+1]; + int foundit, dbg = dbgout; + char *absname; + + strcpy (savename, libref); + + /* If dbgout is enabled try the debug library first, but fall back + * to the normal library if thie debug library is not found. + */ +again: + if (strncmp (libref, "-l", 2) == 0) { + sprintf (libname, "lib%s.a", libref+2); + libref = libname; + goto again; + } else + strcpy (libname, libref); + + /* Position IP to EOS. */ + for (ip=libref; *ip; ip++) + ; + + if (!(*(ip-2) == '.' && *(ip-1) == 'a')) { + /* Not a library file, leave it alone. + */ + strcpy (fname, libref); + + } else { + /* Normalize the library file name, "libXXX[_p].a". + */ + for (ip=libref, op=fname; (*op = *ip); op++, ip++) + ; + if ((*(op-2) == '.' && *(op-1) == 'a')) { + *(op-2) = '\0'; + op -= 2; + } else + op -= 1; + + if (dbg && !(*(op-2) == '_' && *(op-1) == 'p')) { + *op++ = '_'; + *op++ = 'p'; + } + *op++ = '.'; + *op++ = 'a'; + *op++ = '\0'; + } + + foundit = 0; + if (access (fname, 0) == 0) { + strcpy (path, fname); + foundit++; + } else { + if (os_sysfile (fname, path, SZ_PATHNAME) > 0) + foundit++; + } + + if (foundit) { + strcpy (absname=bp, vfn2osfn (path, 0)); + bp += strlen (absname) + 1; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of space for library names"); + if (debug > 1) + fprintf (stderr, "iraflib: %s -> %s\n", savename, absname); + return (absname); + } else if (dbg) { + dbg = 0; + goto again; + } else { + if (debug > 1) + fprintf (stderr, "iraflib: %s -> %s\n", savename, savename); + return (NULL); + } +} + + +/* PRINTARGS -- Echo a UNIX command on the standard error output. + */ +static void +printargs (char *cmd, char *arglist[], int nargs) +{ + int i; + + fputs (cmd, stderr); + for (i=1; i < nargs; i++) + fprintf (stderr, " %s", arglist[i]); + putc ('\n', stderr); + fflush (stderr); +} + + +/* XTOF -- Convert a ".x" file into a ".f" file, i.e., call up the preprocessor + * to translate an SPP file into Fortran. + */ +static void +xtof (char *file) +{ + static char xpp_path[SZ_PATHNAME+1], rpp_path[SZ_PATHNAME+1]; + char cmdbuf[SZ_CMDBUF], fname[SZ_FNAME]; +#if defined(LINUX64) || defined(MACH64) + char iraf_h[SZ_PATHNAME]; +#endif + + + lxfiles[nxfiles++] = file; + if (nxfiles > MAXFILE) + fatal ("too many files"); + + if (nfileargs > 1 || mkobject) { + fprintf (stderr, "%s:\n", file); + fflush (stderr); + } + + if (!xpp_path[0]) + if (os_sysfile (XPP, xpp_path, SZ_PATHNAME) <= 0) + strcpy (xpp_path, XPP); + + if (userincs) { + if (pkgenv) + sprintf (cmdbuf, "%s %s -A -R %s", xpp_path, pkgenv, file); + else + sprintf (cmdbuf, "%s -A -R %s", xpp_path, file); + } else { + if (pkgenv) + sprintf (cmdbuf, "%s %s -R %s", xpp_path, pkgenv, file); + else + sprintf (cmdbuf, "%s -R %s", xpp_path, file); + } + + + /* Include a custom 64-bit iraf.h file. + */ +#if defined(LINUX64) || defined(MACH64) + memset (iraf_h, 0, SZ_PATHNAME); + + if (os_sysfile ("iraf.h", iraf_h, SZ_PATHNAME) <= 0) + strcpy (iraf_h, "iraf.h"); + strcat (cmdbuf, " -h "); + strcat (cmdbuf, iraf_h); +#else + if (foreigndefs) { + strcat (cmdbuf, " -h "); + strcat (cmdbuf, foreign_defsfile); + } +#endif + + errflag |= sys (cmdbuf); + chdot (file, 'r'); + + strcpy (fname, file); + chdot (fname, 'f'); + + if (!rpp_path[0]) + if (os_sysfile (RPP, rpp_path, SZ_PATHNAME) <= 0) + strcpy (rpp_path, RPP); + sprintf (cmdbuf, "%s %s%s >%s", + rpp_path, dbgout ? "-g " : "", file, fname); + if (!(errflag & XPP_BADXFILE)) + errflag |= sys (cmdbuf); + + unlink (file); /* remove ".r" file */ + chdot (file, 'f'); /* change name to ".f" */ +} + + +/* GETEXTN -- Get a one letter extension from a file name (BPS 07.23.96) + */ +static int +getextn (char *fname) +{ + register char *ip, *dot; + int ch; + + for (ip=fname, dot=NULL; *ip != EOS; ip++) + if (*ip == '.') + dot = ip; + + if (dot == NULL || *(dot+2) != EOS) { + ch = EOS; + } else { + ch = *(dot+1); + } + + return (ch); +} + + +/* CHDOT -- Change the filename extension, i.e., the single character + * following the "." at the end of the filename, to the indicated character. + */ +static void +chdot (char *fname, char dotchar) +{ + char *p; + + p = fname; + while (*p++ != EOS) + ; + while (*--p != '.' && p >= fname) + ; + *(p+1) = dotchar; +} + + +/* RUN -- Send a command to UNIX and return the execution status to our + * caller at the completion of the command. + */ +static int +run (char *task, char *argv[]) +{ + int waitpid; + pid_t fork(); + char path[SZ_PATHNAME]; + + if ((waitpid = fork()) == 0) { + enbint (SIG_DFL); + + execvp (task, argv); /* use user PATH for search */ + strcpy (path, SYSBINDIR); + strcat (path, task); + execv (path, argv); /* look in SYSBINDIR */ + strcpy (path, LOCALBINDIR); + strcat (path, task); + execv (path, argv); /* look in LOCALBINDIR */ + + fatalstr ("Cannot execute %s", task); + } + + return (await (waitpid)); +} + + +/* + * Task execution and interrupt handling routines, + * taken with minor modifications the F77 driver. + */ + + +/* SYS -- Execute a general UNIX command passed as a string. The command may + * contain i/o redirection metacharacters. The full path of the command to + * be executed should be given (and always is in the case of XC). + */ +static int +sys (char *cmd) +{ + register char *ip; + char *argv[256]; + char *inname, *outname; + int append; + int waitpid; + int argc; + + if (debug) { + fprintf (stderr, "debug: %s\n", cmd); + fflush (stderr); + } + + inname = NULL; + outname = NULL; + append = NO; + argc = 0; + + /* Parse command string into argv array, inname, and outname. + */ + ip = cmd; + while (isspace (*ip)) + ++ip; + while (*ip) { + if (*ip == '<') + inname = ip+1; + else if (*ip == '>') { + if (ip[1] == '>') { + append = YES; + outname = ip+2; + } else { + append = NO; + outname = ip+1; + } + } else + argv[argc++] = ip; + while ( !isspace (*ip) && *ip != '\0' ) + ++ip; + if (*ip) { + *ip++ = '\0'; + while (isspace (*ip)) + ++ip; + } + } + + if (argc <= 0) /* no command */ + return (-1); + argv[argc] = 0; + + /* Execute the command. */ + if ((waitpid = fork()) == 0) { + if (inname) + freopen (inname, "r", stdin); + if (outname) + freopen (outname, (append ? "a" : "w"), stdout); + enbint (SIG_DFL); + + execv (argv[0], argv); + fatalstr ("Cannot execute %s", argv[0]); + } + + return (await (waitpid)); +} + + +/* DONE -- Called at process shutdown to cleanup. Primary action is to delete + * the intermediate Fortran files, unless the -F flag was given on the command + * line. + */ +static void +done (int k) +{ + static int recurs = NO; + + if (recurs == NO) { + recurs = YES; + if (!keepfort) + rmfiles(); + } + + ZZSTOP(); + exit (k); +} + + +/* ENBINT -- Post an exception handler function to be executed if any sort + * of interrupt occurs. + */ +static void +enbint (SIGFUNC handler) +{ + if (sig_int == 0) + signal (SIGINT, handler); + if (sig_quit == 0) + signal (SIGQUIT, handler); + if (sig_hup == 0) + signal (SIGHUP, handler); + if (sig_term == 0) + signal (SIGTERM, handler); +} + + +/* INTERRUPT -- Exception handler, called if an interrupt is received + * during compilation. + */ +static void +interrupt (void) +{ + done (2); +} + + +/* AWAIT -- Wait for an asynchronous child process to terminate. + */ +static int +await (int waitpid) +{ + int w, status; + + enbint (SIG_IGN); + while ((w = wait (&status)) != waitpid) + if (w == -1) + fatal ("bad wait code"); + enbint ((SIGFUNC)interrupt); + if (status & 0377) { + if (status != SIGINT) { + fprintf (stderr, "Termination code %d", status); + fflush (stderr); + } + done (2); + } + return (status>>8); +} + + +/* RMFILES -- Delete all of the ".f" intermediate Fortran files. + */ +static void +rmfiles (void) +{ + int i; + + for (i=0; i < nxfiles; i++) { + chdot (lxfiles[i], 'f'); + unlink (lxfiles[i]); + } +} + + +/* FATALSTR -- Fatal error with an sprintf format and one string argument. + */ +static void +fatalstr (char *s1, char *s2) +{ + char out[SZ_CMDBUF]; + + sprintf (out, s1, s2); + fatal (out); +} + + +/* FATAL -- A fatal error has occurred. Print error message and terminate + * process execution. + */ +static void +fatal (char *s) +{ + fprintf (stderr, "Fatal compiler error: %s\n", s); + fflush (stderr); + done (1); +} + + +/* ISV13 -- Test if we are using the version 1.3 Sun Fortran compiler. + * There is no simple, reliable way to do this. The heuristic used is + * to first locate the "f77" we will use, then see if there is a file + * named "f77-1.3*" in the same directory. + */ +static int +isv13 (void) +{ + static int v13 = -1; + struct dirent *dp; + char dir[SZ_PATHNAME]; + char *name; + DIR *dirp; + +return (0); +#ifdef SOLARIS + return (v13 = 0); +#else + + if (v13 != -1) + return (v13); + + if (findexe ("f77", dir) && (dirp = opendir(dir)) != NULL) { + while ((dp = readdir(dirp))) { + /* Actually, we don't want to be too picky about the + * version number of this won't work for future versions, + * so just match up to the version number. + */ + name = dp->d_name; + if (!strncmp (name, "f77-1.3", 4) && isdigit(name[4])) { + closedir (dirp); + return (v13 = 1); + } + } + closedir (dirp); + } + + return (v13 = 0); +#endif +} + + +/* FINDEXE -- Search for the named file and return the path if found, else + * NULL. If "dir" is non-NULL the directory in which the file resides is + * returned in the string buffer pointed to. The user's PATH is searched, + * followed by SYSBINDIR, then LOCALBINDIR. + */ +static char * +findexe ( + char *prog, /* file to search for */ + char *dir /* pointer to output string buf, or NULL */ +) +{ + register char *ip, *op; + static char path[SZ_PATHNAME]; + char dirpath[SZ_PATHNAME]; + char *dp = dir ? dir : dirpath; + char *pathp; + + /* Look for the program in the directories in the user's path. + */ + ip = pathp = os_getenv ("PATH"); + while (*ip) { + for (op=dp; *ip && (*op = *ip++) != ':'; op++) + ; + *op++ = '/'; + *op++ = EOS; + strcpy (path, dp); + strcat (path, prog); + if (access (path, 0) != -1) + return (path); + } + + /* Look in SYSBINDIR. */ + strcpy (dp, SYSBINDIR); + strcpy (path, dp); + strcat (path, prog); + + if (access (path, 0) != -1) { + static char envpath[8192]; + char *oldpath; + + /* Add SYSBINDIR to the user's path. This is required to + * use the V1.3 compiler. Note that this code should only be + * executed once, since the next time findexe is called the + * SYSBINDIR directory will be in the default path, above. + */ + if ((oldpath = pathp)) { + sprintf (envpath, "PATH=%s:%s", SYSBINDIR, oldpath); + putenv (envpath); + } + + return (path); + } + + /* Look in LOCALBINDIR. */ + strcpy (dp, LOCALBINDIR); + strcpy (path, dp); + strcat (path, prog); + if (access (path, 0) != -1) + return (path); + + /* Not found. */ + return (NULL); +} diff --git a/unix/boot/spp/xc.hlp b/unix/boot/spp/xc.hlp new file mode 100644 index 00000000..0e941b82 --- /dev/null +++ b/unix/boot/spp/xc.hlp @@ -0,0 +1,197 @@ +.help xc Oct89 softools +.ih +NAME +xc -- portable IRAF compile/link utility +.ih +USAGE +xc [flags] files +.ih +FLAGS +.ls 10 -a +To support VMS link options file. Next file is taken to be the VMS name +of a link options file. This is primarily for using long lists of files +or libraries and not for actual VMS Linker options, since XC adds continuation +characters where it believes it is appropriate. +.le +.ls 10 -C +Tells fortran to do array bound and other checking. +By default no checking is done. From DCL fortran usually +does array and overflow checking which is not used here. +.le +.ls 10 -c +Tells \fIxc\fR not to link, i.e., not to create an executable. +.le +.ls 10 -d +Causes debug messages to be printed during execution. +.le +.ls 10 -F, -f +Do not delete the Fortran translation of an SPP source file. +.le +.ls 10 -g +Generates debugging information and (for VMS), links in the debugger. +.le +.ls 10 -h +Causes the executable to be linked as a host program, i.e., without the +IRAF main and without searching the IRAF libraries, unless explicitly +referenced on the command line. Used to compile and link host (e.g., Fortran) +programs which may or may not reference the IRAF libraries. +.le +.ls 10 -i2 +Tells fortran to use I*2 by default. +.le +.ls 10 -i4 +Tells fortran to use I*4 by default. +.le +.ls 10 -l\fIlib\fR +This tells the linker which libraries besides the standard +ones to include. These must be either on the current +directory, or in an IRAF system library (lib$ or hlib$). +The library specification must be immediately after the option as in +"-lxtools". No other option may follow the 'l' option in the same +argument as in -lxtoolsO. +.le +.ls 10 -L +Creates a list file. VMS specific. +.le +.ls 10 -M, -m +Tells the linker to create a link map. +.le +.ls 10 -n +Not really supported under VMS since "normal" users +cannot install images. In Unix this is just a link +option to make a shareable image. +.le +.ls 10 -N +Same as -z for VMS. +.le +.ls 10 -Nh [filename] +This tells xpp that the foreign definitions in the +file specified should be used in preference to +standard include files. +.le +.ls 10 -o +This flag redirects the output of the compile if used in +conjunction with -c option or specifies where the executable +or object is to be placed. If not given the first file +name is used to obtain the name for the executable or +object. +.le +.ls 10 -O +Optimize object code produced; this is now the default, but this switch +is still provided for backwards compatibility. +.le +.ls 10 -p pkgname +Load the package environment for the named external package, e.g., +"xc -c -p noao file.x". If the same package is always specified +the environment variable or logical name PKGENV may be defined at the +host level to accomplish the same thing. The package name \fImust\fR +be specified when doing software development in an external or layered +package. +.le +.ls 10 -P +Check portability. This should be used all of the time in IRAF, +but the VMS C compiler forces the use of non-standard +constructs in some cases. Also and get +complaints for the above reason. This may be used and probably +should when working with Fortran due to Dec non-standard +extension. +.le +.ls 10 -q +Disable optimization. Opposite of -O. Object code will be optimized +by default. +.le +.ls 10 -s +Strips all symbols and debugging information. +.le +.ls 10 -S +Same as -s for VMS. +.le +.ls 10 -v +Verbose mode. Causes messages to be printed during execution telling +what the \fIxc\fR program is doing. +.le +.ls 10 -w +Suppress warnings. +.le +.ls 10 -X, -x +Compile and link for debugging. In VMS/IRAF, links in the VMS debugger +and symbols. +.le +.ls 10 -z +Create a non-shareable image (default). +.le +.ih +DESCRIPTION +XC is a machine independent utility for compiling and linking IRAF +tasks or files. The XC utility may also be used to compile and/or link +non-IRAF files and tasks. The VMS version of XC supports all of the +important flags except -D which VMS C doesn't support in any way. +It can be used to generate fortran from xpp or ratfor code, to compile any +number of files, and then link them if desired. XC accepts and maps IRAF +virtual filenames, but since it is a standalone bootstrap utility the +environment is not passed, hence logical directories cannot be used. + +The following extensions are supported by the VMS version of xc: +.x, .r, .f, .ftn, .for, .c, .mar, .s, .o, .obj, .a, .olb, .e, .exe. +It is suggested that everyone stick with the iraf virtual file name extensions. +These are : .x, .r, .f, .c, .s, .o, .a, .e. The mapping of these to their +VMS counterparts is: + +.ks +.nf + .x -> .x SPP code + .r -> .r Ratfor code + .f -> .for Fortran code + .c -> .c C code + .s -> .mar Macro assembler code + .o -> .obj Object module + .a -> .olb Library file + .e -> .exe Executable Image +.fi +.ke + + +XC is available both in the CL, via the foreign task interface, and as +a standalone DCL callable task. Usage is equivalent in either case. Upper +case flags must be quoted to be recognized (the upper case flags will be +done away with at some point). +.ih +EXAMPLES +Any upper case flags in the following examples must be doubly quoted in +the CL, singly quoted in VMS, to make it to XC without VMS mapping +everything to one case. Omit the "-x" flag on a UNIX system. + +1. Compile and link the source file "mytask.x" to produce the executable +"mytask.e". + + cl> xc mytask.x + +2. Translate the file "file.x" into Fortran. + + cl> xc -f file.x + +3. Compile but do not link "mytask.x" and the support file "util.x". + + cl> xc -c file.x util.x + +4. Now link these for debugging. + + cl> xc -x file.o util.o + +5. Link the same files without the VMS debug stuff, but link in the library +-ldeboor (the DeBoor spline routines) as well. + + cl> xc file.o util.o -ldeboor + +XC is often combined with \fImkpkg\fR to automatically maintain large packages +or libraries. +.ih +BUGS +The -S flag should generate assembler +output but does not presently do so in the VMS version. All case sensitive +switches should be done away with in both the UNIX and VMS versions of the +utility. +.ih +SEE ALSO +mkpkg, generic +.endhelp diff --git a/unix/boot/spp/xpp.h b/unix/boot/spp/xpp.h new file mode 100644 index 00000000..c240bf6a --- /dev/null +++ b/unix/boot/spp/xpp.h @@ -0,0 +1,12 @@ +/* XPP error codes. + */ +#define XPP_COMPERR 101 /* compiler error */ +#define XPP_BADXFILE 102 /* cannot open .x file */ +#define XPP_SYNTAX 104 /* language error */ + + +/* String type codes. + */ +#define STR_INLINE 0 +#define STR_DEFINE 1 +#define STR_DECL 2 diff --git a/unix/boot/spp/xpp/README b/unix/boot/spp/xpp/README new file mode 100644 index 00000000..6f5b7b9f --- /dev/null +++ b/unix/boot/spp/xpp/README @@ -0,0 +1,6 @@ +XPP -- First pass of the SPP preprocessor. + + This directory contains the Lex and C sources for the first pass of the +preprocessor for the IRAF SPP (subset preprocessor) language. XPP takes as +input an SPP source file and produces as output a text file which is further +processed by RPP (the second pass) to produce Fortran. diff --git a/unix/boot/spp/xpp/decl.c b/unix/boot/spp/xpp/decl.c new file mode 100644 index 00000000..b5c64774 --- /dev/null +++ b/unix/boot/spp/xpp/decl.c @@ -0,0 +1,565 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include "xpp.h" + +#define import_spp +#include + +#ifndef SZ_SBUF +#define SZ_SBUF 4096 /* max chars in proc. decls. */ +#endif +#define SZ_TOKEN 63 /* max chars in a token */ +#define MAX_SYMBOLS 300 /* max symbol table entries */ +#define SPMAX (&sbuf[SZ_SBUF-1]) +#define UNDECL 0 + +/* + * DECL.C -- A package of routines for parsing argument lists and declarations + * and generating the Fortran (actually, RPP) declarations required to compile + * a procedure. The main functions of this package at present are to remove + * arbitrary limitations on the ordering of argument declarations imposed by + * Fortran, and to perform various compile time checks on all declarations. + * Specifically, we allow scalar arguments to be used to dimension array + * arguments before the scalar arguments are declared, and we check for + * multiple declarations of the same object. + * + * Package Externals: + * + * d_newproc (name, type) process procedure declaration + * d_declaration (typestr) process typed declaration statement + * d_codegen (fp) output declarations for sym table + * d_runtime (text) return any runtime initialization text + * + * *symbol = d_enter (symbol, dtype, flags) + * *symbol = d_lookup (symbol) + * + * The external procedures YY_INPUT() and YY_UNPUT() are called to get/putpack + * characters from the input. + */ + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ + +struct symbol { + char *s_name; /* symbol name */ + char *s_dimstr; /* dimension string if array */ + short s_dtype; /* datatype (0 until declared) */ + short s_flags; /* type flags */ +}; + +#define S_ARGUMENT 001 /* symbol is an argument */ +#define S_ARRAY 002 /* symbol is an array */ +#define S_FUNCTION 004 /* symbol is a function() */ +#define S_EXTERN 010 /* symbol is an external */ + +static char sbuf[SZ_SBUF+1]; /* string buffer */ +static char *nextch = sbuf; /* next location in sbuf */ +static char procname[SZ_FNAME+1]; /* procedure name */ +static int proctype; /* procedure type if function */ +static struct symbol sym[MAX_SYMBOLS]; /* symbol table */ +static int nsym = 0; /* number of symbols */ + +struct symbol *d_enter(); +struct symbol *d_lookup(); + +extern void error (int errcode, char *errmsg); +extern void xpp_warn (char *warnmsg); +extern int yy_input (void); +extern void yy_unput (char ch); + + +void d_newproc (char *name, int dtype); +int d_declaration (int dtype); +void d_codegen (register FILE *fp); +void d_runtime (char *text); +void d_makedecl (struct symbol *sp, FILE *fp); +struct symbol *d_enter (char *name, int dtype, int flags); +struct symbol *d_lookup (char *name); +void d_chksbuf (void); +int d_gettok (char *tokstr, int maxch); +void d_declfunc (struct symbol *sp, FILE *fp); + + + + +/* D_NEWPROC -- Process a procedure declaration. The name of the procedure + * is passed as the single argument. The input stream is left positioned + * with the ( of the argument list as the next token (if present). INPUT is + * called repeatedly to read the remainder of the declaration, which may span + * several lines. The symbol table is cleared whenever a new procedure + * declaration is started. + */ +void +d_newproc (name, dtype) +char *name; /* procedure name */ +int dtype; /* procedure type (0 if subr) */ +{ + register int token; + char tokstr[SZ_TOKEN+1]; + + + + /* Print procedure name to keep the user amused in case the file + * is large and the machine slow. + */ + fprintf (stderr, " %s:\n", name); + fflush (stderr); + + strncpy (procname, name, SZ_FNAME); + proctype = dtype; + nextch = sbuf; + nsym = 0; + + /* Check for null argument list. */ + if (d_gettok(tokstr,SZ_TOKEN) != '(') + return; + + /* Process the argument list. + */ + while ((token = d_gettok(tokstr,SZ_TOKEN)) != ')') { + if (isalpha(token)) { + /* Enter argument name into the symbol table. + */ + if (d_lookup (tokstr) != NULL) { + char lbuf[200]; + sprintf (lbuf, "%s.%s multiply declared", + procname, tokstr); + xpp_warn (lbuf); + } else + d_enter (tokstr, UNDECL, S_ARGUMENT); + } else if (token == '\n') { + linenum[istkptr]++; + continue; + } else if (token == ',') { + continue; + } else + error (XPP_SYNTAX, "bad syntax in procedure argument list"); + } +} + + +/* D_DECLARATION -- Process a declaration statement. This is any statement + * of the form + * + * type obj1, obj2, ..., objn + * + * ignoring comments and newlines following commas. The recognized types are + * + * bool, char, short, int, long, real, double, complex, pointer, extern + * + * If "obj" is followed by "()" the function type bit is set. If followed + * by "[...]" the array bit is set and the dimension string is accumulated, + * converting [] into (), adding 1 for char arrays, etc. in the process. + * Each OBJ identifier is entered into the symbol table with its attributes. + */ +int +d_declaration (int dtype) +{ + register struct symbol *sp = NULL; + register char ch; + int token, ndim; + char tokstr[SZ_TOKEN+1]; + + while ((token = d_gettok(tokstr,SZ_TOKEN)) != '\n') { + if (isalpha(token)) { + +#ifdef CYGWIN + { if (strncmp ("procedure", tokstr, 9) == 0) { +/* + extern char *yytext; + pushcontext (PROCSTMT); + d_gettok (yytext, SZ_TOKEN-1); + d_newproc (yytext, dtype); +*/ + pushcontext (PROCSTMT); + d_gettok (tokstr, SZ_TOKEN-1); + d_newproc (tokstr, dtype); + return (1); + } + } +#endif + + /* Enter argument or variable name into the symbol table. + * If symbol is already in table it must be an argument + * or we have a multiple declaration. + */ + if ((sp = d_lookup (tokstr)) != NULL) { + if (dtype == XTY_EXTERN) + sp->s_flags |= S_EXTERN; + else if (sp->s_flags & S_ARGUMENT && sp->s_dtype == UNDECL) + sp->s_dtype = dtype; + else { + char lbuf[200]; + sprintf (lbuf, "%s.%s multiply declared", + procname, tokstr); + xpp_warn (lbuf); + } + } else + sp = d_enter (tokstr, dtype, 0); + + /* Check for trailing () or []. + */ + token = d_gettok (tokstr, SZ_TOKEN); + + switch (token) { + case ',': + case '\n': + yy_unput (token); + continue; + + case '(': + /* Function declaration. + */ + if ((token = d_gettok(tokstr,SZ_TOKEN)) != ')') { + yy_unput (token); + error (XPP_SYNTAX, + "missing right paren in function declaration"); + } + sp->s_flags |= S_FUNCTION; + continue; + + case '[': + /* Array declaration. Turn [] into (), add space for EOS + * if char array, set array bit for operand in symbol table. + */ + sp->s_dimstr = nextch; + *nextch++ = '('; + ndim = 1; + + while ((ch = yy_input()) != ']' && ch > 0) { + if (ch == '\n') { + yy_unput (ch); + error (XPP_SYNTAX, + "missing right bracket in array declaration"); + break; + } else if (ch == ',') { + /* Add one char for the EOS in the first axis of + * a multidimensional char array. + */ + if (ndim == 1 && dtype == TY_CHAR) + *nextch++ = '+', *nextch++ = '1'; + *nextch++ = ','; + ndim++; + } else if (ch == 'A') { + /* Turn [ARB] into [*] for array arguments. */ + if ((ch = yy_input()) == 'R') { + if ((ch = yy_input()) == 'B') { + *nextch++ = '*'; + ndim++; + if (!(sp->s_flags & S_ARGUMENT)) { + error (XPP_SYNTAX, + "local variable dimensioned ARB"); + break; + } + } else { + *nextch++ = 'A'; + *nextch++ = 'R'; + yy_unput (ch); + } + } else { + *nextch++ = 'A'; + yy_unput (ch); + } + } else + *nextch++ = ch; + } + + if (ndim == 1 && dtype == TY_CHAR) + *nextch++ = '+', *nextch++ = '1'; + + *nextch++ = ')'; + *nextch++ = '\0'; + d_chksbuf(); + + sp->s_flags |= S_ARRAY; + break; + + default: + error (XPP_SYNTAX, "declaration syntax error"); + } + + } else if (token == ',') { + /* Check for implied continuation on the next line. + */ + do { + ch = yy_input(); + } while (ch == ' ' || ch == '\t'); + + if (ch == '\n') + linenum[istkptr]++; + else + yy_unput (ch); + + } else if (sp && (sp->s_flags & S_ARGUMENT)) { + error (XPP_SYNTAX, "bad syntax in procedure argument list"); + } else + error (XPP_SYNTAX, "declaration syntax error"); + } + + yy_unput ('\n'); + + return (0); +} + + +/* D_CODEGEN -- Output the RPP declarations for all symbol table entries. + * Declare scalar arguments first, followed by array arguments, followed + * by nonarguments. + */ +void +d_codegen (fp) +register FILE *fp; +{ + register struct symbol *sp; + register struct symbol *top = &sym[nsym-1]; + extern char *type_decl[]; + int col; + + /* Declare the procedure itself. + */ + if (proctype) { + fputs (type_decl[proctype], fp); + fputs (" x$func ", fp); + } else + fputs ("x$subr ", fp); + + fputs (procname, fp); + fputs (" ", fp); + + /* Output the argument list. Keep track of the approximate line length + * and break line if it gets too long for the second pass. + */ + fputs ("(", fp); + col = strlen(procname) + 9; + + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) { + if (sp > sym) { + fputs (", ", fp); + col += 2; + } + col += strlen (sp->s_name); + if (col >= 78) { + fputs ("\n\t", fp); + col = strlen (sp->s_name) + 1; + } + fputs (sp->s_name, fp); + } + fputs (")\n", fp); + + /* Declare scalar arguments. */ + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) + if (!(sp->s_flags & S_ARRAY)) + d_makedecl (sp, fp); + + /* Declare vector arguments. */ + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) + if (sp->s_flags & S_ARRAY) + d_makedecl (sp, fp); + + /* Declare local variables and externals. */ + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) + continue; + else if (sp->s_flags & S_FUNCTION) + d_declfunc (sp, fp); + else + d_makedecl (sp, fp); +} + + +/* D_RUNTIME -- Return any runtime procedure initialization statements, + * i.e., statements to be executed at runtime when a procedure is entered, + * in the given output buffer. + */ +void +d_runtime (char *text) +{ + /* For certain types of functions, ensure that the function value + * is initialized to a legal value, in case the procedure is exited + * without returning a value (e.g., during error processing). + */ + switch (proctype) { + case XTY_REAL: + case XTY_DOUBLE: + sprintf (text, "\t%s = 0\n", procname); + break; + default: + text[0] = EOS; + break; + } +} + + +/* D_MAKEDECL -- Output a single RPP symbol declaration. Each declaration + * is output on a separate line. + */ +void +d_makedecl (sp, fp) +register struct symbol *sp; /* symbol table entry */ +register FILE *fp; /* output file */ +{ + extern char *type_decl[]; + + if (sp->s_dtype != UNDECL) { + fputs (type_decl[sp->s_dtype], fp); + fputs ("\t", fp); + fputs (sp->s_name, fp); + if (sp->s_flags & S_ARRAY) + fputs (sp->s_dimstr, fp); + fputs ("\n", fp); + } + + if (sp->s_flags & S_EXTERN) { + fputs (type_decl[XTY_EXTERN], fp); + fputs ("\t", fp); + fputs (sp->s_name, fp); + fputs ("\n", fp); + } +} + + +/* D_ENTER -- Add a symbol to the symbol table. Return a pointer to the + * new symbol. + */ +struct symbol * +d_enter (name, dtype, flags) +char *name; /* symbol name */ +int dtype; /* data type code */ +int flags; /* flag bits */ +{ + register struct symbol *sp; + + + sp = &sym[nsym]; + nsym++; + if (nsym > MAX_SYMBOLS) + error (XPP_COMPERR, "too many declarations in procedure"); + + sp->s_name = strcpy (nextch, name); + nextch += strlen(name) + 1; + d_chksbuf(); + + sp->s_dimstr = NULL; + sp->s_dtype = dtype; + sp->s_flags = flags; + + return (sp); +} + + +/* D_LOOKUP -- Lookup a symbol in the symbol table. Return a pointer to the + * symbol table entry. + */ +struct symbol * +d_lookup (name) +char *name; /* symbol name */ +{ + register struct symbol *sp; + register struct symbol *top = &sym[nsym-1]; + + for (sp=sym; sp <= top; sp++) + if (sp->s_name[0] == name[0]) + if (strcmp (sp->s_name, name) == 0) + return (sp); + + return (NULL); +} + + +/* D_CHKSBUF -- Check for overflow on the string buffer. + */ +void +d_chksbuf() +{ + if (nextch > SPMAX) + error (XPP_COMPERR, "decl string buffer overflow"); +} + + +/* D_GETTOK -- Get the next token from the input stream. Return the integer + * value of the first character of the token as the function value. EOF + * is an error in this application, not a token. + */ +int +d_gettok (tokstr, maxch) +char *tokstr; /* receives token string */ +int maxch; /* max chars to token string */ +{ + register char *op = tokstr; + register int ch, n; + + + + /* Skip whitespace and comments to first char of next token. + */ + do { + ch = yy_input(); + } while (ch == ' ' || ch == '\t'); + + if (ch == '#') { + /* Skip a comment. + */ + while ((ch = yy_input()) != '\n' && ch > 0) + ; + } + + if (ch <= 0) + error (XPP_SYNTAX, "unexpected EOF"); + + *op++ = ch; + n = maxch - 1; + + if (isalpha (ch)) { + /* Identifer. + */ + while ((ch = yy_input()) > 0) + if (isalnum(ch) || ch == '_') { + *op++ = ch; + if (--n <= 0) + error (XPP_SYNTAX, "identifier too long"); + } else { + yy_unput (ch); + break; + } + + } else if (isdigit (ch)) { + /* Number. + */ + while ((ch = yy_input()) > 0) + if (isdigit(ch)) { + *op++ = ch; + if (--n <= 0) + error (XPP_SYNTAX, "number too long"); + } else { + yy_unput (ch); + break; + } + + } + + *op++ = '\0'; + if (ch <= 0) + error (XPP_SYNTAX, "unexpected EOF"); + + return (tokstr[0]); +} + + +/* D_DECLFUNC -- Declare a function. This module is provided to allow + * for any special treatment required for certain types of function + * declarations. + */ +void +d_declfunc (sp, fp) +register struct symbol *sp; +FILE *fp; +{ + d_makedecl (sp, fp); +} diff --git a/unix/boot/spp/xpp/lex.sed b/unix/boot/spp/xpp/lex.sed new file mode 100644 index 00000000..b0b35fd7 --- /dev/null +++ b/unix/boot/spp/xpp/lex.sed @@ -0,0 +1,9 @@ +/int nstr; extern int yyprevious;/a\ +if (yyin==NULL) yyin = stdin;\ +if (yyout==NULL) yyout = stdout; +/{stdin}/c\ +FILE *yyin, *yyout; +s/"stdio.h"// +s/YYLMAX 200/YYLMAX 8192/ +s/static int input/int input/g +s/static void yyunput/void yyunput/g diff --git a/unix/boot/spp/xpp/lexyy.c b/unix/boot/spp/xpp/lexyy.c new file mode 100644 index 00000000..c79ba67d --- /dev/null +++ b/unix/boot/spp/xpp/lexyy.c @@ -0,0 +1,2932 @@ + +#line 3 "lex.yy.c" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 +#define YY_FLEX_SUBMINOR_VERSION 35 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include +#include +#include +#include + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have . Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +typedef uint64_t flex_uint64_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; +#endif /* ! C99 */ + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#endif /* ! FLEXINT_H */ + +#ifdef __cplusplus + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +/* C99 requires __STDC__ to be defined as 1. */ +#if defined (__STDC__) + +#define YY_USE_CONST + +#endif /* defined (__STDC__) */ +#endif /* ! __cplusplus */ + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN (yy_start) = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START (((yy_start) - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart(yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#define YY_BUF_SIZE 16384 +#endif + +/* The state buf must be large enough to hold one state per character in the main buffer. + */ +#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +extern yy_size_t yyleng; + +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + + /* Note: We specifically omit the test for yy_rule_can_match_eol because it requires + * access to the local variable yy_act. Since yyless() is a macro, it would break + * existing scanners that call yyless() from OUTSIDE yylex. + * One obvious solution it to make yy_act a global. I tried that, and saw + * a 5% performance hit in a non-yylineno scanner, because yy_act is + * normally declared as a register variable-- so it is not worth it. + */ + #define YY_LESS_LINENO(n) \ + do { \ + yy_size_t yyl;\ + for ( yyl = n; yyl < yyleng; ++yyl )\ + if ( yytext[yyl] == '\n' )\ + --yylineno;\ + }while(0) + +/* Return all but the first "n" matched characters back to the input stream. */ +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + *yy_cp = (yy_hold_char); \ + YY_RESTORE_YY_MORE_OFFSET \ + (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, (yytext_ptr) ) + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + yy_size_t yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +/* Stack of input buffers. */ +static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ +static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ +static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + * + * Returns the top of the stack, or NULL. + */ +#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ + ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ + : NULL) + +/* Same as previous macro, but useful when we know that the buffer stack is not + * NULL or when we need an lvalue. For internal use only. + */ +#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; +static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */ +yy_size_t yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 0; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart (FILE *input_file ); +void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE yy_create_buffer (FILE *file,int size ); +void yy_delete_buffer (YY_BUFFER_STATE b ); +void yy_flush_buffer (YY_BUFFER_STATE b ); +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ); +void yypop_buffer_state (void ); + +static void yyensure_buffer_stack (void ); +static void yy_load_buffer_state (void ); +static void yy_init_buffer (YY_BUFFER_STATE b,FILE *file ); + +#define YY_FLUSH_BUFFER yy_flush_buffer(YY_CURRENT_BUFFER ) + +YY_BUFFER_STATE yy_scan_buffer (char *base,yy_size_t size ); +YY_BUFFER_STATE yy_scan_string (yyconst char *yy_str ); +YY_BUFFER_STATE yy_scan_bytes (yyconst char *bytes,yy_size_t len ); + +void *yyalloc (yy_size_t ); +void *yyrealloc (void *,yy_size_t ); +void yyfree (void * ); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! YY_CURRENT_BUFFER ){ \ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! YY_CURRENT_BUFFER ){\ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) + +/* Begin user sect3 */ + +typedef unsigned char YY_CHAR; + +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; + +typedef int yy_state_type; + +#define YY_FLEX_LEX_COMPAT +extern int yylineno; + +int yylineno = 1; + +extern char yytext[]; + +static yy_state_type yy_get_previous_state (void ); +static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); +static int yy_get_next_buffer (void ); +static void yy_fatal_error (yyconst char msg[] ); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + (yytext_ptr) = yy_bp; \ + yyleng = (yy_size_t) (yy_cp - yy_bp); \ + (yy_hold_char) = *yy_cp; \ + *yy_cp = '\0'; \ + if ( yyleng + (yy_more_offset) >= YYLMAX ) \ + YY_FATAL_ERROR( "token too large, exceeds YYLMAX" ); \ + yy_flex_strncpy( &yytext[(yy_more_offset)], (yytext_ptr), yyleng + 1 ); \ + yyleng += (yy_more_offset); \ + (yy_prev_more_offset) = (yy_more_offset); \ + (yy_more_offset) = 0; \ + (yy_c_buf_p) = yy_cp; + +#define YY_NUM_RULES 44 +#define YY_END_OF_BUFFER 45 +/* This struct is not used in this scanner, + but its presence is necessary. */ +struct yy_trans_info + { + flex_int32_t yy_verify; + flex_int32_t yy_nxt; + }; +static yyconst flex_int16_t yy_acclist[275] = + { 0, + 45, 44, 43, 44, 41, 44, 25, 44, 44, 32, + 44, 44, 44, 44, 44, 44, 28, 44, 28, 44, + 38, 44, 39, 44, 28, 44, 28, 44, 36, 44, + 44, 37, 44, 44, 26, 44, 44, 44, 28, 44, + 28, 44, 28, 44, 28, 44, 28, 44, 28, 44, + 28, 44, 28, 44, 28, 44, 28, 44, 28, 44, + 34, 33, 40, 42, 30, 31, 30, 28, 28, 28, + 31, 28, 28, 35, 26, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + + 28, 28, 28, 28,16405, 28, 28, 28,16388, 28, + 28, 28, 28, 28, 28, 28, 29, 28, 28,16405, + 28, 28, 28, 28,16385, 28,16386, 28, 28,16407, + 28, 28, 8213, 8213, 28, 28, 28, 8196, 8196, 28, + 28,16389, 28, 28, 28,16390, 28, 28, 28,16397, + 29, 28, 28,16407,16397, 16, 28, 28, 28,16401, + 8193, 8193, 28, 8194, 8194, 28, 28, 8215, 8215, 28, + 28, 28, 28, 28, 8197, 8197, 28, 28, 28, 8198, + 8198, 28, 28,16387, 28, 8205, 8205, 28, 29, 28, + 28,16408,16401, 28, 28, 8209, 8209, 28, 28, 28, + + 16404, 28,16391, 28,16394, 28, 28, 28, 8195, 8195, + 28, 28,16406, 29, 28, 8216, 8216, 28,16404,16406, + 16404, 14, 28, 28, 28,16392, 8212, 8212, 8212, 28, + 8199, 8199, 28, 8202, 8202, 28, 28, 28,16393, 28, + 8214, 8214, 28, 28, 14, 28, 8200, 8200, 28, 27, + 8201, 8201, 28, 28, 28,16396, 15, 28, 28,16395, + 16396, 8204, 8204, 28, 15,16395, 19, 8203, 8204, 8203, + 8204, 28, 8203, 18 + } ; + +static yyconst flex_int16_t yy_accept[285] = + { 0, + 1, 1, 1, 2, 3, 5, 7, 9, 10, 12, + 13, 14, 15, 16, 17, 19, 21, 23, 25, 27, + 29, 31, 32, 34, 35, 37, 38, 39, 41, 43, + 45, 47, 49, 51, 53, 55, 57, 59, 61, 62, + 63, 64, 64, 65, 65, 65, 65, 65, 65, 66, + 67, 68, 69, 70, 72, 73, 74, 75, 75, 75, + 75, 75, 75, 75, 75, 75, 75, 75, 76, 76, + 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, + 86, 87, 88, 89, 90, 91, 92, 93, 94, 94, + 94, 95, 96, 96, 96, 96, 96, 96, 96, 96, + + 96, 96, 96, 96, 97, 98, 99, 100, 101, 102, + 103, 104, 106, 107, 108, 110, 111, 112, 113, 114, + 115, 116, 117, 118, 119, 120, 120, 120, 120, 120, + 121, 121, 121, 121, 121, 121, 121, 122, 123, 124, + 126, 128, 129, 131, 132, 133, 134, 136, 137, 138, + 139, 141, 143, 144, 145, 147, 148, 149, 151, 152, + 152, 153, 154, 154, 154, 154, 155, 155, 155, 155, + 155, 156, 156, 157, 158, 159, 161, 162, 164, 165, + 167, 168, 169, 171, 172, 173, 174, 175, 176, 178, + 179, 180, 181, 183, 185, 186, 187, 189, 190, 190, + + 191, 193, 193, 193, 194, 194, 194, 194, 194, 194, + 195, 196, 197, 199, 200, 202, 204, 206, 207, 208, + 209, 210, 212, 214, 215, 216, 217, 219, 219, 219, + 220, 220, 220, 221, 222, 224, 225, 227, 228, 229, + 231, 232, 234, 235, 237, 238, 240, 241, 242, 244, + 245, 246, 246, 246, 246, 247, 248, 250, 250, 250, + 250, 251, 252, 254, 255, 257, 257, 257, 259, 259, + 262, 263, 265, 266, 267, 268, 268, 270, 273, 274, + 274, 274, 275, 275 + } ; + +static yyconst flex_int32_t yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 4, 1, 5, 6, 7, 8, 9, 10, 11, + 12, 13, 1, 14, 1, 15, 1, 16, 16, 16, + 16, 16, 16, 16, 17, 18, 18, 19, 20, 21, + 1, 1, 1, 1, 22, 23, 24, 25, 26, 22, + 27, 27, 28, 27, 27, 29, 30, 31, 27, 32, + 27, 33, 27, 34, 27, 27, 27, 35, 27, 27, + 36, 1, 37, 1, 38, 1, 39, 40, 41, 42, + + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, + 53, 54, 48, 55, 56, 57, 58, 48, 59, 60, + 48, 48, 61, 62, 63, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst flex_int32_t yy_meta[64] = + { 0, + 1, 2, 3, 2, 1, 1, 4, 1, 1, 1, + 1, 1, 1, 1, 1, 5, 5, 5, 1, 1, + 1, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 1, 1, 5, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 1, 1, 1 + } ; + +static yyconst flex_int16_t yy_base[295] = + { 0, + 0, 62, 390, 1555, 1555, 1555, 1555, 380, 1555, 358, + 364, 65, 104, 58, 149, 0, 1555, 1555, 313, 308, + 1555, 304, 1555, 208, 0, 53, 319, 333, 29, 30, + 41, 26, 311, 309, 32, 318, 33, 321, 1555, 1555, + 1555, 104, 1555, 356, 0, 0, 84, 115, 0, 1555, + 1555, 0, 250, 0, 305, 310, 1555, 0, 314, 324, + 311, 50, 301, 300, 296, 293, 310, 0, 305, 302, + 337, 298, 289, 302, 289, 282, 294, 279, 294, 278, + 56, 282, 286, 279, 289, 274, 271, 253, 305, 119, + 266, 249, 298, 259, 246, 258, 259, 259, 246, 243, + + 241, 252, 245, 86, 247, 243, 237, 237, 251, 242, + 248, 310, 244, 236, 373, 239, 231, 241, 231, 225, + 232, 229, 123, 234, 230, 115, 223, 230, 216, 0, + 211, 219, 212, 209, 210, 202, 228, 222, 200, 436, + 499, 199, 562, 195, 196, 1555, 0, 190, 186, 1555, + 0, 625, 186, 198, 688, 183, 187, 751, 129, 137, + 196, 191, 210, 204, 182, 0, 181, 174, 188, 178, + 0, 177, 1555, 204, 193, 814, 1555, 0, 1555, 0, + 183, 1555, 0, 182, 181, 171, 180, 1555, 0, 178, + 178, 1555, 0, 877, 173, 1555, 0, 132, 138, 159, + + 940, 192, 180, 0, 170, 169, 166, 162, 163, 176, + 178, 1555, 0, 143, 1003, 1066, 1129, 158, 145, 141, + 1555, 0, 1192, 183, 142, 1555, 0, 167, 168, 97, + 150, 134, 0, 0, 0, 158, 1255, 1555, 155, 0, + 1555, 0, 1555, 0, 156, 1318, 133, 1555, 0, 138, + 1555, 136, 174, 108, 130, 1555, 0, 166, 178, 181, + 1555, 1555, 0, 109, 1381, 119, 82, 0, 185, 1444, + 1555, 0, 1555, 0, 1555, 81, 1555, 0, 1555, 64, + 36, 1555, 1555, 1504, 1510, 1516, 1522, 1526, 1530, 1534, + 1538, 1542, 1545, 1550 + + } ; + +static yyconst flex_int16_t yy_def[295] = + { 0, + 283, 1, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 13, 284, 284, 283, 283, 284, 284, + 283, 283, 283, 283, 285, 283, 283, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 283, 283, + 283, 283, 283, 286, 13, 14, 283, 14, 48, 283, + 283, 284, 284, 284, 284, 284, 283, 24, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 285, 283, 283, + 284, 284, 284, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 286, 283, + 284, 284, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 283, 284, 284, 283, 283, 283, 283, 287, + 283, 283, 283, 283, 283, 283, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 283, 284, 284, 284, 283, + 284, 284, 284, 284, 284, 284, 284, 284, 283, 283, + 284, 284, 283, 283, 283, 288, 283, 283, 283, 283, + 289, 283, 283, 284, 284, 284, 283, 284, 283, 284, + 284, 283, 284, 284, 284, 284, 284, 283, 284, 284, + 284, 283, 284, 284, 284, 283, 284, 283, 283, 284, + + 284, 283, 283, 290, 283, 283, 283, 283, 283, 284, + 284, 283, 284, 284, 284, 284, 284, 284, 284, 284, + 283, 284, 284, 283, 284, 283, 284, 283, 283, 291, + 283, 283, 292, 291, 284, 284, 284, 283, 293, 284, + 283, 284, 283, 284, 284, 284, 284, 283, 284, 284, + 283, 283, 283, 283, 284, 283, 284, 293, 293, 283, + 283, 283, 284, 284, 284, 283, 283, 284, 283, 284, + 283, 284, 283, 294, 283, 283, 283, 284, 283, 283, + 283, 283, 0, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283 + + } ; + +static yyconst flex_int16_t yy_nxt[1619] = + { 0, + 4, 4, 5, 4, 6, 7, 4, 4, 8, 9, + 10, 4, 11, 12, 4, 13, 13, 14, 4, 12, + 4, 15, 15, 15, 15, 15, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 17, 18, 4, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 19, 16, 20, 16, 16, 16, 16, + 21, 22, 23, 24, 40, 24, 42, 43, 42, 25, + 44, 72, 26, 46, 46, 74, 27, 79, 86, 76, + 48, 73, 75, 77, 83, 80, 84, 90, 95, 87, + 282, 56, 96, 78, 69, 28, 114, 283, 239, 90, + + 239, 29, 30, 31, 32, 42, 43, 42, 33, 44, + 137, 34, 115, 138, 281, 35, 36, 37, 38, 45, + 45, 46, 47, 280, 274, 48, 49, 48, 48, 48, + 48, 48, 48, 283, 123, 123, 123, 159, 50, 163, + 199, 160, 164, 51, 198, 198, 198, 198, 198, 198, + 273, 270, 199, 224, 224, 224, 258, 260, 258, 260, + 261, 268, 267, 50, 53, 53, 53, 258, 266, 258, + 53, 53, 53, 53, 53, 260, 261, 260, 261, 269, + 265, 269, 260, 54, 260, 261, 269, 264, 269, 275, + 255, 254, 253, 252, 261, 251, 250, 159, 247, 246, + + 245, 261, 237, 236, 235, 234, 233, 232, 54, 58, + 231, 58, 230, 229, 276, 228, 225, 223, 59, 220, + 219, 218, 217, 216, 215, 214, 211, 210, 209, 208, + 207, 206, 205, 204, 203, 202, 201, 200, 195, 194, + 191, 60, 190, 187, 186, 185, 184, 61, 181, 62, + 63, 176, 175, 174, 64, 173, 172, 171, 170, 169, + 168, 65, 167, 66, 67, 53, 53, 53, 166, 165, + 162, 53, 53, 53, 53, 53, 161, 158, 157, 156, + 155, 154, 153, 152, 54, 149, 148, 145, 144, 143, + 142, 141, 140, 139, 136, 135, 134, 133, 132, 131, + + 130, 129, 128, 127, 126, 125, 124, 43, 122, 54, + 146, 146, 146, 146, 146, 146, 147, 146, 146, 146, + 146, 146, 146, 146, 146, 121, 120, 119, 146, 146, + 146, 118, 117, 116, 113, 112, 111, 110, 109, 108, + 107, 106, 105, 104, 103, 146, 146, 102, 101, 100, + 99, 98, 97, 94, 93, 69, 92, 91, 43, 88, + 85, 82, 81, 71, 70, 57, 56, 55, 41, 40, + 146, 146, 146, 150, 150, 150, 150, 150, 150, 151, + 150, 150, 150, 150, 150, 150, 150, 150, 39, 283, + 283, 150, 150, 150, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 150, 150, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 150, 150, 150, 177, 177, 177, 177, + 177, 177, 178, 177, 177, 177, 177, 177, 177, 177, + 177, 283, 283, 283, 177, 177, 177, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 177, 177, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 177, 177, 177, 179, + + 179, 179, 179, 179, 179, 180, 179, 179, 179, 179, + 179, 179, 179, 179, 283, 283, 283, 179, 179, 179, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 179, 179, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 179, + 179, 179, 182, 182, 182, 182, 182, 182, 183, 182, + 182, 182, 182, 182, 182, 182, 182, 283, 283, 283, + 182, 182, 182, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 182, 182, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 182, 182, 182, 188, 188, 188, 188, 188, + 188, 189, 188, 188, 188, 188, 188, 188, 188, 188, + 283, 283, 283, 188, 188, 188, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 188, 188, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 188, 188, 188, 192, 192, + 192, 192, 192, 192, 193, 192, 192, 192, 192, 192, + + 192, 192, 192, 283, 283, 283, 192, 192, 192, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 192, 192, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 192, 192, + 192, 196, 196, 196, 196, 196, 196, 197, 196, 196, + 196, 196, 196, 196, 196, 196, 283, 283, 283, 196, + 196, 196, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 196, 196, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 196, 196, 196, 212, 212, 212, 212, 212, 212, + 213, 212, 212, 212, 212, 212, 212, 212, 212, 283, + 283, 283, 212, 212, 212, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 212, + 212, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 212, 212, 212, 221, 221, 221, + 221, 221, 221, 222, 221, 221, 221, 221, 221, 221, + 221, 221, 283, 283, 283, 221, 221, 221, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 221, 221, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 221, 221, 221, + 226, 226, 226, 226, 226, 226, 227, 226, 226, 226, + 226, 226, 226, 226, 226, 283, 283, 283, 226, 226, + 226, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 226, 226, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 226, 226, 226, 238, 239, 238, 239, 238, 238, 240, + 238, 238, 238, 238, 238, 238, 238, 238, 283, 283, + 283, 238, 238, 238, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 238, 238, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 238, 238, 238, 241, 241, 241, 241, + 241, 241, 242, 241, 241, 241, 241, 241, 241, 241, + 241, 283, 283, 283, 241, 241, 241, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 241, 241, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 241, 241, 241, 243, + 243, 243, 243, 243, 243, 244, 243, 243, 243, 243, + 243, 243, 243, 243, 283, 283, 283, 243, 243, 243, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 243, 243, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 243, + 243, 243, 248, 248, 248, 248, 248, 248, 249, 248, + + 248, 248, 248, 248, 248, 248, 248, 283, 283, 283, + 248, 248, 248, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 248, 248, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 248, 248, 248, 256, 256, 256, 256, 256, + 256, 257, 256, 256, 256, 256, 256, 256, 256, 256, + 283, 283, 283, 256, 256, 256, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 256, 256, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 256, 256, 256, 262, 262, + 262, 262, 262, 262, 263, 262, 262, 262, 262, 262, + 262, 262, 262, 283, 283, 283, 262, 262, 262, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 262, 262, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 262, 262, + 262, 271, 271, 271, 271, 271, 271, 272, 271, 271, + 271, 271, 271, 271, 271, 271, 283, 283, 283, 271, + + 271, 271, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 271, 271, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 271, 271, 271, 277, 277, 277, 277, 277, 277, + 278, 277, 277, 277, 277, 277, 277, 277, 277, 283, + 283, 283, 277, 277, 277, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 277, + 277, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 277, 277, 277, 52, 52, 52, + 68, 68, 283, 68, 68, 68, 89, 89, 89, 89, + 89, 89, 146, 146, 146, 146, 182, 182, 182, 182, + 196, 196, 196, 196, 212, 212, 212, 212, 238, 238, + 238, 238, 248, 248, 248, 248, 259, 283, 283, 259, + 279, 279, 279, 279, 3, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283 + } ; + +static yyconst flex_int16_t yy_chk[1619] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 2, 26, 2, 12, 12, 12, 2, + 12, 29, 2, 14, 14, 30, 2, 32, 37, 31, + 14, 29, 30, 31, 35, 32, 35, 47, 62, 37, + 281, 37, 62, 31, 26, 2, 81, 14, 230, 47, + + 230, 2, 2, 2, 2, 42, 42, 42, 2, 42, + 104, 2, 81, 104, 280, 2, 2, 2, 2, 13, + 13, 13, 13, 276, 267, 13, 13, 13, 13, 13, + 48, 48, 48, 48, 90, 90, 90, 123, 13, 126, + 160, 123, 126, 13, 159, 159, 159, 198, 198, 198, + 266, 264, 160, 199, 199, 199, 239, 245, 239, 245, + 245, 255, 254, 13, 15, 15, 15, 258, 252, 258, + 15, 15, 15, 15, 15, 253, 245, 253, 253, 259, + 250, 259, 260, 15, 260, 260, 269, 247, 269, 269, + 236, 232, 231, 229, 253, 228, 225, 224, 220, 219, + + 218, 260, 214, 211, 210, 209, 208, 207, 15, 24, + 206, 24, 205, 203, 269, 202, 200, 195, 24, 191, + 190, 187, 186, 185, 184, 181, 175, 174, 172, 170, + 169, 168, 167, 165, 164, 163, 162, 161, 157, 156, + 154, 24, 153, 149, 148, 145, 144, 24, 142, 24, + 24, 139, 138, 137, 24, 136, 135, 134, 133, 132, + 131, 24, 129, 24, 24, 53, 53, 53, 128, 127, + 125, 53, 53, 53, 53, 53, 124, 122, 121, 120, + 119, 118, 117, 116, 53, 114, 113, 111, 110, 109, + 108, 107, 106, 105, 103, 102, 101, 100, 99, 98, + + 97, 96, 95, 94, 93, 92, 91, 89, 88, 53, + 112, 112, 112, 112, 112, 112, 112, 112, 112, 112, + 112, 112, 112, 112, 112, 87, 86, 85, 112, 112, + 112, 84, 83, 82, 80, 79, 78, 77, 76, 75, + 74, 73, 72, 71, 70, 112, 112, 69, 67, 66, + 65, 64, 63, 61, 60, 59, 56, 55, 44, 38, + 36, 34, 33, 28, 27, 22, 20, 19, 11, 10, + 112, 112, 112, 115, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 8, 3, + 0, 115, 115, 115, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 115, 115, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 115, 115, 115, 140, 140, 140, 140, + 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, + 140, 0, 0, 0, 140, 140, 140, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 140, 140, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 140, 140, 140, 141, + + 141, 141, 141, 141, 141, 141, 141, 141, 141, 141, + 141, 141, 141, 141, 0, 0, 0, 141, 141, 141, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 141, 141, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 141, + 141, 141, 143, 143, 143, 143, 143, 143, 143, 143, + 143, 143, 143, 143, 143, 143, 143, 0, 0, 0, + 143, 143, 143, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 143, 143, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 143, 143, 143, 152, 152, 152, 152, 152, + 152, 152, 152, 152, 152, 152, 152, 152, 152, 152, + 0, 0, 0, 152, 152, 152, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 152, 152, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 152, 152, 152, 155, 155, + 155, 155, 155, 155, 155, 155, 155, 155, 155, 155, + + 155, 155, 155, 0, 0, 0, 155, 155, 155, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 155, 155, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 155, 155, + 155, 158, 158, 158, 158, 158, 158, 158, 158, 158, + 158, 158, 158, 158, 158, 158, 0, 0, 0, 158, + 158, 158, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 158, 158, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 158, 158, 158, 176, 176, 176, 176, 176, 176, + 176, 176, 176, 176, 176, 176, 176, 176, 176, 0, + 0, 0, 176, 176, 176, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 176, + 176, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 176, 176, 176, 194, 194, 194, + 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, + 194, 194, 0, 0, 0, 194, 194, 194, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 194, 194, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 194, 194, 194, + 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, + 201, 201, 201, 201, 201, 0, 0, 0, 201, 201, + 201, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 201, 201, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 201, 201, 201, 215, 215, 215, 215, 215, 215, 215, + 215, 215, 215, 215, 215, 215, 215, 215, 0, 0, + 0, 215, 215, 215, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 215, 215, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 215, 215, 215, 216, 216, 216, 216, + 216, 216, 216, 216, 216, 216, 216, 216, 216, 216, + 216, 0, 0, 0, 216, 216, 216, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 216, 216, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 216, 216, 216, 217, + 217, 217, 217, 217, 217, 217, 217, 217, 217, 217, + 217, 217, 217, 217, 0, 0, 0, 217, 217, 217, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 217, 217, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 217, + 217, 217, 223, 223, 223, 223, 223, 223, 223, 223, + + 223, 223, 223, 223, 223, 223, 223, 0, 0, 0, + 223, 223, 223, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 223, 223, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 223, 223, 223, 237, 237, 237, 237, 237, + 237, 237, 237, 237, 237, 237, 237, 237, 237, 237, + 0, 0, 0, 237, 237, 237, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 237, 237, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 237, 237, 237, 246, 246, + 246, 246, 246, 246, 246, 246, 246, 246, 246, 246, + 246, 246, 246, 0, 0, 0, 246, 246, 246, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 246, 246, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 246, 246, + 246, 265, 265, 265, 265, 265, 265, 265, 265, 265, + 265, 265, 265, 265, 265, 265, 0, 0, 0, 265, + + 265, 265, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 265, 265, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 265, 265, 265, 270, 270, 270, 270, 270, 270, + 270, 270, 270, 270, 270, 270, 270, 270, 270, 0, + 0, 0, 270, 270, 270, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 270, + 270, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 270, 270, 270, 284, 284, 284, + 285, 285, 0, 285, 285, 285, 286, 286, 286, 286, + 286, 286, 287, 287, 287, 287, 288, 288, 288, 288, + 289, 289, 289, 289, 290, 290, 290, 290, 291, 291, + 291, 291, 292, 292, 292, 292, 293, 0, 0, 293, + 294, 294, 294, 294, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283 + } ; + +/* Table of booleans, true if rule could match eol. */ +static yyconst flex_int32_t yy_rule_can_match_eol[45] = + { 0, +1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0, 0, + 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 1, 0, }; + +extern int yy_flex_debug; +int yy_flex_debug = 0; + +static yy_state_type *yy_state_buf=0, *yy_state_ptr=0; +static char *yy_full_match; +static int yy_lp; +static int yy_looking_for_trail_begin = 0; +static int yy_full_lp; +static int *yy_full_state; +#define YY_TRAILING_MASK 0x2000 +#define YY_TRAILING_HEAD_MASK 0x4000 +#define REJECT \ +{ \ +*yy_cp = (yy_hold_char); /* undo effects of setting up yytext */ \ +yy_cp = (yy_full_match); /* restore poss. backed-over text */ \ +(yy_lp) = (yy_full_lp); /* restore orig. accepting pos. */ \ +(yy_state_ptr) = (yy_full_state); /* restore orig. state */ \ +yy_current_state = *(yy_state_ptr); /* restore curr. state */ \ +++(yy_lp); \ +goto find_rule; \ +} + +static int yy_more_offset = 0; +static int yy_prev_more_offset = 0; +#define yymore() ((yy_more_offset) = yy_flex_strlen( yytext )) +#define YY_NEED_STRLEN +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET \ + { \ + (yy_more_offset) = (yy_prev_more_offset); \ + yyleng -= (yy_more_offset); \ + } +#ifndef YYLMAX +#define YYLMAX 8192 +#endif + +char yytext[YYLMAX]; +char *yytext_ptr; +#line 1 "xpp.l" +#line 2 "xpp.l" + +#include +#include +#include "xpp.h" +#include "../../bootProto.h" +#include "xppProto.h" + +#define import_spp +#include + + +#include "xpp.h" + +/* + * Lexical definition for the first pass of the IRAF subset preprocessor. + * This program is a horrible kludge but will suffice until there is time + * to build something better. + */ + +#undef output /* undefine LEX output macro -- we use proc */ +#undef ECHO /* ditto echo */ +#define ECHO outstr (yytext) + +#define OCTAL 8 +#define HEX 16 +#define CHARCON 1 + +#ifdef YYLMAX +#undef YYLMAX +#endif +#define YYLMAX YY_BUF_SIZE + +YY_BUFFER_STATE include_stack[MAX_INCLUDE]; + + +extern FILE *istk[]; +extern char fname[MAX_INCLUDE][SZ_PATHNAME]; +extern char *machdefs[]; +extern int hbindefs, foreigndefs; + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ +extern int str_idnum; /* for ST0000 string names */ +extern int nbrace; /* count of braces */ +extern int nswitch; /* number of "switch" stmts */ +extern int errflag; /* set if compiler error */ +extern int errchk; /* sef if error checking */ +extern int context; /* lexical context flags */ +extern int ntasks; +static int dtype; /* set if typed procedure */ + +extern char *vfn2osfn(); +extern void skipnl (void); + + +void typespec (int typecode); +void process_task_statement (void); + +void do_include (void); +int yywrap (void); +int yy_input (void); +void yy_unput (char ch); + + +#line 1053 "lex.yy.c" + +#define INITIAL 0 + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +static int yy_init_globals (void ); + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int yylex_destroy (void ); + +int yyget_debug (void ); + +void yyset_debug (int debug_flag ); + +YY_EXTRA_TYPE yyget_extra (void ); + +void yyset_extra (YY_EXTRA_TYPE user_defined ); + +FILE *yyget_in (void ); + +void yyset_in (FILE * in_str ); + +FILE *yyget_out (void ); + +void yyset_out (FILE * out_str ); + +yy_size_t yyget_leng (void ); + +char *yyget_text (void ); + +int yyget_lineno (void ); + +void yyset_lineno (int line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap (void ); +#else +extern int yywrap (void ); +#endif +#endif + + void yyunput (int c,char *buf_ptr ); + +#ifndef yytext_ptr +static void yy_flex_strncpy (char *,yyconst char *,int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * ); +#endif + +#ifndef YY_NO_INPUT + +#ifdef __cplusplus +static int yyinput (void ); +#else +int input (void ); +#endif + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ + { \ + int c = '*'; \ + yy_size_t n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else \ + { \ + errno=0; \ + while ( (result = fread(buf, 1, max_size, yyin))==0 && ferror(yyin)) \ + { \ + if( errno != EINTR) \ + { \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + break; \ + } \ + errno=0; \ + clearerr(yyin); \ + } \ + }\ +\ + +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* end tables serialization structures and prototypes */ + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int yylex (void); + +#define YY_DECL int yylex (void) +#endif /* !YY_DECL */ + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + if ( yyleng > 0 ) \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = \ + (yytext[yyleng - 1] == '\n'); \ + YY_USER_ACTION + +/** The main scanner function which does all the work. + */ +YY_DECL +{ + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 79 "xpp.l" + + +#line 1241 "lex.yy.c" + + if ( !(yy_init) ) + { + (yy_init) = 1; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + /* Create the reject buffer large enough to save one state per allowed character. */ + if ( ! (yy_state_buf) ) + (yy_state_buf) = (yy_state_type *)yyalloc(YY_STATE_BUF_SIZE ); + if ( ! (yy_state_buf) ) + YY_FATAL_ERROR( "out of dynamic memory in yylex()" ); + + if ( ! (yy_start) ) + (yy_start) = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! YY_CURRENT_BUFFER ) { + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_load_buffer_state( ); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = (yy_c_buf_p); + + /* Support of yytext. */ + *yy_cp = (yy_hold_char); + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); + + (yy_state_ptr) = (yy_state_buf); + *(yy_state_ptr)++ = yy_current_state; + +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 284 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + *(yy_state_ptr)++ = yy_current_state; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 1555 ); + +yy_find_action: + yy_current_state = *--(yy_state_ptr); + (yy_lp) = yy_accept[yy_current_state]; +goto find_rule; /* Shut up GCC warning -Wall */ +find_rule: /* we branch to this label when backing up */ + for ( ; ; ) /* until we find what rule we matched */ + { + if ( (yy_lp) && (yy_lp) < yy_accept[yy_current_state + 1] ) + { + yy_act = yy_acclist[(yy_lp)]; + if ( yy_act & YY_TRAILING_HEAD_MASK || + (yy_looking_for_trail_begin) ) + { + if ( yy_act == (yy_looking_for_trail_begin) ) + { + (yy_looking_for_trail_begin) = 0; + yy_act &= ~YY_TRAILING_HEAD_MASK; + break; + } + } + else if ( yy_act & YY_TRAILING_MASK ) + { + (yy_looking_for_trail_begin) = yy_act & ~YY_TRAILING_MASK; + (yy_looking_for_trail_begin) |= YY_TRAILING_HEAD_MASK; + (yy_full_match) = yy_cp; + (yy_full_state) = (yy_state_ptr); + (yy_full_lp) = (yy_lp); + } + else + { + (yy_full_match) = yy_cp; + (yy_full_state) = (yy_state_ptr); + (yy_full_lp) = (yy_lp); + break; + } + ++(yy_lp); + goto find_rule; + } + --yy_cp; + yy_current_state = *--(yy_state_ptr); + (yy_lp) = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + + if ( yy_act != YY_END_OF_BUFFER && yy_rule_can_match_eol[yy_act] ) + { + yy_size_t yyl; + for ( yyl = (yy_prev_more_offset); yyl < yyleng; ++yyl ) + if ( yytext[yyl] == '\n' ) + + yylineno++; +; + } + +do_action: /* This label is used only to access EOF actions. */ + + switch ( yy_act ) + { /* beginning of action switch */ +case 1: +/* rule 1 can match eol */ +YY_RULE_SETUP +#line 81 "xpp.l" +typespec (XTY_BOOL); + YY_BREAK +case 2: +/* rule 2 can match eol */ +YY_RULE_SETUP +#line 82 "xpp.l" +typespec (XTY_CHAR); + YY_BREAK +case 3: +/* rule 3 can match eol */ +YY_RULE_SETUP +#line 83 "xpp.l" +typespec (XTY_SHORT); + YY_BREAK +case 4: +/* rule 4 can match eol */ +YY_RULE_SETUP +#line 84 "xpp.l" +typespec (XTY_INT); + YY_BREAK +case 5: +/* rule 5 can match eol */ +YY_RULE_SETUP +#line 85 "xpp.l" +typespec (XTY_LONG); + YY_BREAK +case 6: +/* rule 6 can match eol */ +YY_RULE_SETUP +#line 86 "xpp.l" +typespec (XTY_REAL); + YY_BREAK +case 7: +/* rule 7 can match eol */ +YY_RULE_SETUP +#line 87 "xpp.l" +typespec (XTY_DOUBLE); + YY_BREAK +case 8: +/* rule 8 can match eol */ +YY_RULE_SETUP +#line 88 "xpp.l" +typespec (XTY_COMPLEX); + YY_BREAK +case 9: +/* rule 9 can match eol */ +YY_RULE_SETUP +#line 89 "xpp.l" +typespec (XTY_POINTER); + YY_BREAK +case 10: +/* rule 10 can match eol */ +YY_RULE_SETUP +#line 90 "xpp.l" +typespec (XTY_EXTERN); + YY_BREAK +case 11: +/* rule 11 can match eol */ +YY_RULE_SETUP +#line 92 "xpp.l" +{ + /* Subroutine declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, 0); + } + YY_BREAK +case 12: +/* rule 12 can match eol */ +YY_RULE_SETUP +#line 99 "xpp.l" +{ + /* Function declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, dtype); + setline(); + } + YY_BREAK +case 13: +/* rule 13 can match eol */ +YY_RULE_SETUP +#line 107 "xpp.l" +{ if (context & BODY) + ECHO; + else { + process_task_statement(); + setline(); + } + } + YY_BREAK +case 14: +YY_RULE_SETUP +#line 114 "xpp.l" +put_dictionary(); + YY_BREAK +case 15: +YY_RULE_SETUP +#line 115 "xpp.l" +put_interpreter(); + YY_BREAK +case 16: +YY_RULE_SETUP +#line 116 "xpp.l" +{ + skip_helpblock(); + setline(); + } + YY_BREAK +case 17: +/* rule 17 can match eol */ +YY_RULE_SETUP +#line 120 "xpp.l" +{ + begin_code(); + setline(); + } + YY_BREAK +case 18: +YY_RULE_SETUP +#line 124 "xpp.l" +{ + macro_redef(); + setline(); + } + YY_BREAK +case 19: +YY_RULE_SETUP +#line 128 "xpp.l" +{ + str_enter(); + } + YY_BREAK +case 20: +/* rule 20 can match eol */ +YY_RULE_SETUP +#line 131 "xpp.l" +{ + pushcontext (DEFSTMT); + ECHO; + } + YY_BREAK +case 21: +/* rule 21 can match eol */ +YY_RULE_SETUP +#line 135 "xpp.l" +{ + end_code(); + setline(); + } + YY_BREAK +case 22: +/* rule 22 can match eol */ +YY_RULE_SETUP +#line 139 "xpp.l" +{ + (context & BODY) ? ECHO + : do_string ('"', STR_DECL); + } + YY_BREAK +case 23: +/* rule 23 can match eol */ +YY_RULE_SETUP +#line 143 "xpp.l" +{ + if (!(context & BODY)) + pushcontext (DATASTMT); + ECHO; + } + YY_BREAK +case 24: +/* rule 24 can match eol */ +YY_RULE_SETUP +#line 149 "xpp.l" +{ + ECHO; + if (context & BODY) + nswitch++; + } + YY_BREAK +case 25: +YY_RULE_SETUP +#line 155 "xpp.l" +skipnl(); + YY_BREAK +case 26: +YY_RULE_SETUP +#line 156 "xpp.l" +ECHO; + YY_BREAK +case 27: +YY_RULE_SETUP +#line 158 "xpp.l" +do_include(); + YY_BREAK +case 28: +YY_RULE_SETUP +#line 160 "xpp.l" +mapident(); + YY_BREAK +case 29: +YY_RULE_SETUP +#line 162 "xpp.l" +hms (yytext); + YY_BREAK +case 30: +YY_RULE_SETUP +#line 163 "xpp.l" +int_constant (yytext, OCTAL); + YY_BREAK +case 31: +YY_RULE_SETUP +#line 164 "xpp.l" +int_constant (yytext, HEX); + YY_BREAK +case 32: +YY_RULE_SETUP +#line 165 "xpp.l" +int_constant (yytext, CHARCON); + YY_BREAK +case 33: +YY_RULE_SETUP +#line 167 "xpp.l" +{ + if (context & (BODY|PROCSTMT)) + ECHO; + } + YY_BREAK +case 34: +YY_RULE_SETUP +#line 172 "xpp.l" +output ('&'); + YY_BREAK +case 35: +YY_RULE_SETUP +#line 173 "xpp.l" +output ('|'); + YY_BREAK +case 36: +YY_RULE_SETUP +#line 175 "xpp.l" +{ + ECHO; + nbrace++; + } + YY_BREAK +case 37: +YY_RULE_SETUP +#line 179 "xpp.l" +{ + ECHO; + nbrace--; + } + YY_BREAK +case 38: +YY_RULE_SETUP +#line 183 "xpp.l" +output ('('); + YY_BREAK +case 39: +YY_RULE_SETUP +#line 184 "xpp.l" +output (')'); + YY_BREAK +case 40: +YY_RULE_SETUP +#line 186 "xpp.l" +do_hollerith(); + YY_BREAK +case 41: +YY_RULE_SETUP +#line 188 "xpp.l" +{ + if (context & BODY) + do_string ('"', STR_INLINE); + else + ECHO; + } + YY_BREAK +case 42: +/* rule 42 can match eol */ +YY_RULE_SETUP +#line 195 "xpp.l" +{ + /* If statement is continued do not pop + * the context. + */ + ECHO; + linenum[istkptr]++; + } + YY_BREAK +case 43: +/* rule 43 can match eol */ +YY_RULE_SETUP +#line 203 "xpp.l" +{ + /* End of newline and end of statement. + */ + ECHO; + linenum[istkptr]++; + popcontext(); + } + YY_BREAK +case 44: +YY_RULE_SETUP +#line 211 "xpp.l" +ECHO; + YY_BREAK +#line 1680 "lex.yy.c" + case YY_STATE_EOF(INITIAL): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = (yy_hold_char); + YY_RESTORE_YY_MORE_OFFSET + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between YY_CURRENT_BUFFER and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + YY_CURRENT_BUFFER_LVALUE->yy_input_file = yyin; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++(yy_c_buf_p); + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = (yy_c_buf_p); + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_END_OF_FILE: + { + (yy_did_buffer_switch_on_eof) = 0; + + if ( yywrap( ) ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = + (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + (yy_c_buf_p) = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ +} /* end of yylex */ + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ +static int yy_get_next_buffer (void) +{ + register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; + register char *source = (yytext_ptr); + register int number_to_move, i; + int ret_val; + + if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; + + else + { + yy_size_t num_to_read = + YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ + + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); + + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), + (yy_n_chars), num_to_read ); + + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + if ( (yy_n_chars) == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart(yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { + /* Extend the array by 50%, plus the number we really need. */ + yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) yyrealloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); + if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); + } + + (yy_n_chars) += number_to_move; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; + + (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; + + return ret_val; +} + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + + static yy_state_type yy_get_previous_state (void) +{ + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); + + (yy_state_ptr) = (yy_state_buf); + *(yy_state_ptr)++ = yy_current_state; + + for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 284 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + *(yy_state_ptr)++ = yy_current_state; + } + + return yy_current_state; +} + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) +{ + register int yy_is_jam; + + register YY_CHAR yy_c = 1; + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 284 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 283); + if ( ! yy_is_jam ) + *(yy_state_ptr)++ = yy_current_state; + + return yy_is_jam ? 0 : yy_current_state; +} + + void yyunput (int c, register char * yy_bp ) +{ + register char *yy_cp; + + yy_cp = (yy_c_buf_p); + + /* undo effects of setting up yytext */ + *yy_cp = (yy_hold_char); + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register yy_size_t number_to_move = (yy_n_chars) + 2; + register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; + register char *source = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; + + while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + if ( c == '\n' ){ + --yylineno; + } + + (yytext_ptr) = yy_bp; + (yy_hold_char) = *yy_cp; + (yy_c_buf_p) = yy_cp; +} + +#ifndef YY_NO_INPUT +#ifdef __cplusplus + static int yyinput (void) +#else + int input (void) +#endif + +{ + int c; + + *(yy_c_buf_p) = (yy_hold_char); + + if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + /* This was really a NUL. */ + *(yy_c_buf_p) = '\0'; + + else + { /* need more input */ + yy_size_t offset = (yy_c_buf_p) - (yytext_ptr); + ++(yy_c_buf_p); + + switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart(yyin ); + + /*FALLTHROUGH*/ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap( ) ) + return 0; + + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = (yytext_ptr) + offset; + break; + } + } + } + + c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ + *(yy_c_buf_p) = '\0'; /* preserve yytext */ + (yy_hold_char) = *++(yy_c_buf_p); + + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = (c == '\n'); + if ( YY_CURRENT_BUFFER_LVALUE->yy_at_bol ) + + yylineno++; +; + + return c; +} +#endif /* ifndef YY_NO_INPUT */ + +/** Immediately switch to a different input stream. + * @param input_file A readable stream. + * + * @note This function does not reset the start condition to @c INITIAL . + */ + void yyrestart (FILE * input_file ) +{ + + if ( ! YY_CURRENT_BUFFER ){ + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_init_buffer(YY_CURRENT_BUFFER,input_file ); + yy_load_buffer_state( ); +} + +/** Switch to a different input buffer. + * @param new_buffer The new input buffer. + * + */ + void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ) +{ + + /* TODO. We should be able to replace this entire function body + * with + * yypop_buffer_state(); + * yypush_buffer_state(new_buffer); + */ + yyensure_buffer_stack (); + if ( YY_CURRENT_BUFFER == new_buffer ) + return; + + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + YY_CURRENT_BUFFER_LVALUE = new_buffer; + yy_load_buffer_state( ); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + (yy_did_buffer_switch_on_eof) = 1; +} + +static void yy_load_buffer_state (void) +{ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; + yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file; + (yy_hold_char) = *(yy_c_buf_p); +} + +/** Allocate and initialize an input buffer state. + * @param file A readable stream. + * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. + * + * @return the allocated buffer state. + */ + YY_BUFFER_STATE yy_create_buffer (FILE * file, int size ) +{ + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yyalloc(b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer(b,file ); + + return b; +} + +/** Destroy the buffer. + * @param b a buffer created with yy_create_buffer() + * + */ + void yy_delete_buffer (YY_BUFFER_STATE b ) +{ + + if ( ! b ) + return; + + if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ + YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yyfree((void *) b->yy_ch_buf ); + + yyfree((void *) b ); +} + +#ifndef __cplusplus +extern int isatty (int ); +#endif /* __cplusplus */ + +/* Initializes or reinitializes a buffer. + * This function is sometimes called more than once on the same buffer, + * such as during a yyrestart() or at EOF. + */ + static void yy_init_buffer (YY_BUFFER_STATE b, FILE * file ) + +{ + int oerrno = errno; + + yy_flush_buffer(b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + + /* If b is the current buffer, then yy_init_buffer was _probably_ + * called from yyrestart() or through yy_get_next_buffer. + * In that case, we don't want to reset the lineno or column. + */ + if (b != YY_CURRENT_BUFFER){ + b->yy_bs_lineno = 1; + b->yy_bs_column = 0; + } + + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; + + errno = oerrno; +} + +/** Discard all buffered characters. On the next scan, YY_INPUT will be called. + * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. + * + */ + void yy_flush_buffer (YY_BUFFER_STATE b ) +{ + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == YY_CURRENT_BUFFER ) + yy_load_buffer_state( ); +} + +/** Pushes the new state onto the stack. The new state becomes + * the current state. This function will allocate the stack + * if necessary. + * @param new_buffer The new state. + * + */ +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ) +{ + if (new_buffer == NULL) + return; + + yyensure_buffer_stack(); + + /* This block is copied from yy_switch_to_buffer. */ + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + /* Only push if top exists. Otherwise, replace top. */ + if (YY_CURRENT_BUFFER) + (yy_buffer_stack_top)++; + YY_CURRENT_BUFFER_LVALUE = new_buffer; + + /* copied from yy_switch_to_buffer. */ + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; +} + +/** Removes and deletes the top of the stack, if present. + * The next element becomes the new top. + * + */ +void yypop_buffer_state (void) +{ + if (!YY_CURRENT_BUFFER) + return; + + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + if ((yy_buffer_stack_top) > 0) + --(yy_buffer_stack_top); + + if (YY_CURRENT_BUFFER) { + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; + } +} + +/* Allocates the stack if it does not exist. + * Guarantees space for at least one push. + */ +static void yyensure_buffer_stack (void) +{ + yy_size_t num_to_alloc; + + if (!(yy_buffer_stack)) { + + /* First allocation is just for 2 elements, since we don't know if this + * scanner will even need a stack. We use 2 instead of 1 to avoid an + * immediate realloc on the next call. + */ + num_to_alloc = 1; + (yy_buffer_stack) = (struct yy_buffer_state**)yyalloc + (num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); + + (yy_buffer_stack_max) = num_to_alloc; + (yy_buffer_stack_top) = 0; + return; + } + + if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ + + /* Increase the buffer to prepare for a possible push. */ + int grow_size = 8 /* arbitrary grow size */; + + num_to_alloc = (yy_buffer_stack_max) + grow_size; + (yy_buffer_stack) = (struct yy_buffer_state**)yyrealloc + ((yy_buffer_stack), + num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + /* zero only the new slots.*/ + memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); + (yy_buffer_stack_max) = num_to_alloc; + } +} + +/** Setup the input buffer state to scan directly from a user-specified character buffer. + * @param base the character buffer + * @param size the size in bytes of the character buffer + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_buffer (char * base, yy_size_t size ) +{ + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer(b ); + + return b; +} + +/** Setup the input buffer state to scan a string. The next call to yylex() will + * scan from a @e copy of @a str. + * @param yystr a NUL-terminated string to scan + * + * @return the newly allocated buffer state object. + * @note If you want to scan bytes that may contain NUL values, then use + * yy_scan_bytes() instead. + */ +YY_BUFFER_STATE yy_scan_string (yyconst char * yystr ) +{ + + return yy_scan_bytes(yystr,strlen(yystr) ); +} + +/** Setup the input buffer state to scan the given bytes. The next call to yylex() will + * scan from a @e copy of @a bytes. + * @param bytes the byte buffer to scan + * @param len the number of bytes in the buffer pointed to by @a bytes. + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len ) +{ + YY_BUFFER_STATE b; + char *buf; + yy_size_t n, i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = _yybytes_len + 2; + buf = (char *) yyalloc(n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < _yybytes_len; ++i ) + buf[i] = yybytes[i]; + + buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer(buf,n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; +} + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +static void yy_fatal_error (yyconst char* msg ) +{ + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); +} + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + yytext[yyleng] = (yy_hold_char); \ + (yy_c_buf_p) = yytext + yyless_macro_arg; \ + (yy_hold_char) = *(yy_c_buf_p); \ + *(yy_c_buf_p) = '\0'; \ + yyleng = yyless_macro_arg; \ + } \ + while ( 0 ) + +/* Accessor methods (get/set functions) to struct members. */ + +/** Get the current line number. + * + */ +int yyget_lineno (void) +{ + + return yylineno; +} + +/** Get the input stream. + * + */ +FILE *yyget_in (void) +{ + return yyin; +} + +/** Get the output stream. + * + */ +FILE *yyget_out (void) +{ + return yyout; +} + +/** Get the length of the current token. + * + */ +yy_size_t yyget_leng (void) +{ + return yyleng; +} + +/** Get the current token. + * + */ + +char *yyget_text (void) +{ + return yytext; +} + +/** Set the current line number. + * @param line_number + * + */ +void yyset_lineno (int line_number ) +{ + + yylineno = line_number; +} + +/** Set the input stream. This does not discard the current + * input buffer. + * @param in_str A readable stream. + * + * @see yy_switch_to_buffer + */ +void yyset_in (FILE * in_str ) +{ + yyin = in_str ; +} + +void yyset_out (FILE * out_str ) +{ + yyout = out_str ; +} + +int yyget_debug (void) +{ + return yy_flex_debug; +} + +void yyset_debug (int bdebug ) +{ + yy_flex_debug = bdebug ; +} + +static int yy_init_globals (void) +{ + /* Initialization is the same as for the non-reentrant scanner. + * This function is called from yylex_destroy(), so don't allocate here. + */ + + /* We do not touch yylineno unless the option is enabled. */ + yylineno = 1; + + (yy_buffer_stack) = 0; + (yy_buffer_stack_top) = 0; + (yy_buffer_stack_max) = 0; + (yy_c_buf_p) = (char *) 0; + (yy_init) = 0; + (yy_start) = 0; + + (yy_state_buf) = 0; + (yy_state_ptr) = 0; + (yy_full_match) = 0; + (yy_lp) = 0; + +/* Defined in main.c */ +#ifdef YY_STDINIT + yyin = stdin; + yyout = stdout; +#else + yyin = (FILE *) 0; + yyout = (FILE *) 0; +#endif + + /* For future reference: Set errno on error, since we are called by + * yylex_init() + */ + return 0; +} + +/* yylex_destroy is for both reentrant and non-reentrant scanners. */ +int yylex_destroy (void) +{ + + /* Pop the buffer stack, destroying each element. */ + while(YY_CURRENT_BUFFER){ + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + yypop_buffer_state(); + } + + /* Destroy the stack itself. */ + yyfree((yy_buffer_stack) ); + (yy_buffer_stack) = NULL; + + yyfree ( (yy_state_buf) ); + (yy_state_buf) = NULL; + + /* Reset the globals. This is important in a non-reentrant scanner so the next time + * yylex() is called, initialization will occur. */ + yy_init_globals( ); + + return 0; +} + +/* + * Internal utility routines. + */ + +#ifndef yytext_ptr +static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) +{ + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; +} +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * s ) +{ + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; +} +#endif + +void *yyalloc (yy_size_t size ) +{ + return (void *) malloc( size ); +} + +void *yyrealloc (void * ptr, yy_size_t size ) +{ + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); +} + +void yyfree (void * ptr ) +{ + free( (char *) ptr ); /* see yyrealloc() for (char *) cast */ +} + +#define YYTABLES_NAME "yytables" + +#line 211 "xpp.l" + + + + +/* TYPESPEC -- Context dependent processing of a type specifier. If in the + * declarations section, process a declarations statement. If in procedure + * body or in a define statement, map the type specifier identifer and output + * the mapped value (intrinsic function name). Otherwise we must be in global + * space, and the type spec begins a function declaration; save the datatype + * code for d_newproc(). + */ +void +typespec (typecode) +int typecode; +{ + if (context & DECL) + d_declaration (typecode); + else if (context & (BODY|DEFSTMT)) + mapident(); + else + dtype = typecode; +} + + + +/* PROCESS_TASK_STATEMENT -- Parse the TASK statement. The task statement + * is replaced by the "sys_runtask" procedure (sysruk), which is called by + * the IRAF main to run a task, or to print the dictionary (cmd "?"). + * The source for the basic sys_runtask procedure is in "lib$sysruk.x". + * We process the task statement into some internal tables, then open the + * sysruk.x file as an include file. Special macros therein are + * replaced by the taskname dictionary as processing continues. + */ +void +process_task_statement() +{ + char ch; + + if (ntasks > 0) { /* only one task statement permitted */ + error (XPP_SYNTAX, "Only one TASK statement permitted per file"); + return; + } + + /* Process the task statement into the TASK_LIST structure. + */ + if (parse_task_statement() == ERR) { + error (XPP_SYNTAX, "Syntax error in TASK statement"); + while ((ch = input()) != EOF && ch != '\n') + ; + unput ('\n'); + return; + } + + /* Open RUNTASK ("lib$sysruk.x") as an include file. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + istkptr--; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + strcpy (fname[istkptr], IRAFLIB); + strcat (fname[istkptr], RUNTASK); + if ((yyin = fopen (vfn2osfn (fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot read lib$sysruk.x"); + return; + } + + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of the include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer(yyin,YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* DO_INCLUDE -- Process an include statement, i.e., eat up the include + * statement, push the current input file on a stack, and open the new file. + * System include files are referenced as "", other files as "file". + */ +void +do_include() +{ + char *p, delim, *rindex(); + char hfile[SZ_FNAME+1], *op; + int root_len; + + + /* Push current input file status on the input file stack istk. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + --istkptr; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + /* If filespec "", call os_sysfile to get the pathname of the + * system include file. + */ + if (yytext[yyleng-1] == '<') { + + for (op=hfile; (*op = input()) != EOF; op++) + if (*op == '\n') { + --istkptr; + error (XPP_SYNTAX, "missing > delim in include statement"); + return; + } else if (*op == '>') + break; + + *op = EOS; + + if (os_sysfile (hfile, fname[istkptr], SZ_PATHNAME) == ERR) { + --istkptr; + error (XPP_COMPERR, "cannot find include file"); + return; + } + + } else { + /* Prepend pathname leading to the file in which the current + * include statement was found. Compiler may not have been run + * from the directory containing the source and include file. + */ + if (!hbindefs) { + if ((p = rindex (fname[istkptr-1], '/')) == NULL) + root_len = 0; + else + root_len = p - fname[istkptr-1] + 1; + strncpy (fname[istkptr], fname[istkptr-1], root_len); + + } else { + if ((p = vfn2osfn (HBIN_INCLUDES, 0))) { + root_len = strlen (p); + strncpy (fname[istkptr], p, root_len); + } else { + --istkptr; + error (XPP_COMPERR, "cannot find hbin$ directory"); + return; + } + } + fname[istkptr][root_len] = EOS; + + delim = '"'; + + /* Advance to end of whatever is in the file name string. + */ + for (p=fname[istkptr]; *p != EOS; p++) + ; + /* Concatenate name of referenced file. + */ + while ((*p = input()) != delim) { + if (*p == '\n' || *p == EOF) { + --istkptr; + error (XPP_SYNTAX, "bad include file name"); + return; + } + p++; + } + *p = EOS; + } + + /* If the foreign defs option is in effect, the machine dependent defs + * for a foreign machine are given by a substitute "iraf.h" file named + * on the command line. This foreign machine header file includes + * not only the iraf.h for the foreign machine, but the equivalent of + * all the files named in the array of strings "machdefs". Ignore any + * attempts to include any of these files since they have already been + * included in the foreign definitions header file. + */ + if (foreigndefs) { + char sysfile[SZ_PATHNAME]; + char **files; + + /* + for (files=machdefs; *files != NULL; files++) { + */ + for (files=machdefs; **files; files++) { + memset (sysfile, 0, SZ_PATHNAME); + strcpy (sysfile, HOSTLIB); + strcat (sysfile, *files); + if (strcmp (sysfile, fname[istkptr]) == 0) { + --istkptr; + return; + } + } + } + + if ((yyin = fopen (vfn2osfn(fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot open include file"); + return; + } + + /* Keep track of the line number within the include file. */ + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer(yyin,YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* YYWRAP -- Called by LEX when end of file is reached. If input stack is + * not empty, close off include file and continue on in old file. Return + * nonzero when the stack is empty, i.e., when we reach the end of the + * main file. + */ +int +yywrap() +{ + /* The last line of a file is not necessarily newline terminated. + * Output a newline just in case. + */ + fprintf (yyout, "\n"); + + if (istkptr <= 0) { + /* ALL DONE with main file. + */ + return (1); + + } else { + /* End of include file. Pop old input file and set line number + * for error messages. + */ + fclose (yyin); + /* yyin = istk[--istkptr]; */ + istkptr--; + + yypop_buffer_state (); + if ( !YY_CURRENT_BUFFER ) + yyterminate (); + + if (istkptr == 0) + setline(); + return (0); + } +} + + + +/* YY_INPUT -- Get a character from the input stream. + */ +int +yy_input () +{ + return (input()); +} + + +/* YY_UNPUT -- Put a character back into the input stream. + */ +void +yy_unput (ch) +char ch; +{ + unput(ch); +} + diff --git a/unix/boot/spp/xpp/mkpkg.sh b/unix/boot/spp/xpp/mkpkg.sh new file mode 100644 index 00000000..d6972000 --- /dev/null +++ b/unix/boot/spp/xpp/mkpkg.sh @@ -0,0 +1,15 @@ +# Make the first pass (XPP) of the SPP language compiler. + +find xpp.l -newer lexyy.c -exec rm lexyy.c \; +if test -f lexyy.c; then\ + $CC -c $HSI_CF lexyy.c;\ +else\ + lex xpp.l;\ + sed -f lex.sed lex.yy.c > lexyy.c; rm lex.yy.c;\ + $CC -c $HSI_CF lexyy.c;\ +fi + +$CC -c $HSI_CF xppmain.c xppcode.c decl.c +$CC $HSI_LF xppmain.o lexyy.o xppcode.o decl.o $HSI_LIBS -o xpp.e +mv -f xpp.e ../../../hlib +rm *.o diff --git a/unix/boot/spp/xpp/xpp.h b/unix/boot/spp/xpp/xpp.h new file mode 100644 index 00000000..2fde825d --- /dev/null +++ b/unix/boot/spp/xpp/xpp.h @@ -0,0 +1,94 @@ +/* XPP error codes. + */ +#define XPP_OK OSOK /* no problems */ +#define XPP_COMPERR 101 /* compiler error */ +#define XPP_BADXFILE 102 /* cannot open .x file */ +#define XPP_SYNTAX 104 /* language error */ + + + +#define F77 /* Fortran 77 target compiler? */ + +#define IRAFLIB "iraf$lib/" +#define HOSTLIB "host$hlib/" +#define HBIN_INCLUDES "hbin$arch_includes/" + + +/* Size limiting definitions. + */ +#define MAX_TASKS 100 /* max no. of tasks we can handle */ +#define SZ_OBUF 131072 /* buffers procedure body */ +#define SZ_DBUF 8192 /* for errchk, common, ect. decls */ +#define SZ_SBUF 8192 /* buffers text of strings */ +#define MAX_STRINGS 256 /* max strings in a procedure */ +#define MAX_INCLUDE 5 /* maximum nesting of includes */ +#define MIN_REALPREC 7 /* used by HMS */ +#define SZ_NUMBUF 32 /* for numeric constants */ +#define SZ_STBUF 4096 /* text of defined strings */ +#define MAX_DEFSTR 128 /* max defined strings */ + +#define RUNTASK "sysruk.x" +#define OCTAL 8 +#define DECIMAL 10 +#define HEX 16 +#define CHARCON 1 +#define SEXAG 2 + + +/* Contexts. + */ +#define GLOBAL 01 +#define DECL 02 +#define BODY 04 +#define DEFSTMT 010 +#define DATASTMT 020 +#define PROCSTMT 040 + +/* String type codes. + */ +#define STR_INLINE 0 +#define STR_DEFINE 1 +#define STR_DECL 2 + +/* SPP keywords. The datatype keywords bool through pointer must be assigned + * the lowest numbers. + */ +#define XTY_BOOL 1 +#define XTY_CHAR 2 +#define XTY_SHORT 3 +#define XTY_INT 4 +#define XTY_LONG 5 +#define XTY_REAL 6 +#define XTY_DOUBLE 7 +#define XTY_COMPLEX 8 +#define XTY_POINTER 9 +#define XTY_PROC 10 +#define XTY_TRUE 11 +#define XTY_FALSE 12 +#define XTY_IFERR 13 +#define XTY_IFNOERR 14 +#define XTY_EXTERN 15 +#define XTY_ERROR 16 +#define MAX_KEY 16 + +/* RPP type keywords (must match type codes above). + */ +#define RPP_TYPES {\ + "",\ + "x$bool",\ + "x$short", /* MACHDEP */\ + "x$short",\ + "x$int",\ + "x$long",\ + "x$real",\ + "x$dble",\ + "x$cplx",\ + "x$pntr",\ + "x$fcn",\ + ".true.",\ + ".false.",\ + "iferr",\ + "ifnoerr",\ + "x$extn",\ + "error"\ +} diff --git a/unix/boot/spp/xpp/xpp.l b/unix/boot/spp/xpp/xpp.l new file mode 100644 index 00000000..554c38dc --- /dev/null +++ b/unix/boot/spp/xpp/xpp.l @@ -0,0 +1,476 @@ +%{ + +#include +#include +#include "xpp.h" +#include "../../bootProto.h" +#include "xppProto.h" + +#define import_spp +#include + + +#include "xpp.h" + +/* + * Lexical definition for the first pass of the IRAF subset preprocessor. + * This program is a horrible kludge but will suffice until there is time + * to build something better. + */ + +#undef output /* undefine LEX output macro -- we use proc */ +#undef ECHO /* ditto echo */ +#define ECHO outstr (yytext) + +#define OCTAL 8 +#define HEX 16 +#define CHARCON 1 + +#ifdef YYLMAX +#undef YYLMAX +#endif +#define YYLMAX YY_BUF_SIZE + +YY_BUFFER_STATE include_stack[MAX_INCLUDE]; + + +extern FILE *istk[]; +extern char fname[MAX_INCLUDE][SZ_PATHNAME]; +extern char *machdefs[]; +extern int hbindefs, foreigndefs; + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ +extern int str_idnum; /* for ST0000 string names */ +extern int nbrace; /* count of braces */ +extern int nswitch; /* number of "switch" stmts */ +extern int errflag; /* set if compiler error */ +extern int errchk; /* sef if error checking */ +extern int context; /* lexical context flags */ +extern int ntasks; +static int dtype; /* set if typed procedure */ + +extern char *vfn2osfn(); +extern void skipnl (void); + + +void typespec (int typecode); +void process_task_statement (void); + +void do_include (void); +int yywrap (void); +int yy_input (void); +void yy_unput (char ch); + + +%} + +D [0-9] +O [0-7] +S [ 0-6]{D} +X [0-9A-F] +W [ \t] +NI [^a-zA-Z0-9_] + +%a 5000 +%o 9000 +%k 500 + +%% + +^"bool"/{NI} typespec (XTY_BOOL); +^"char"/{NI} typespec (XTY_CHAR); +^"short"/{NI} typespec (XTY_SHORT); +^"int"/{NI} typespec (XTY_INT); +^"long"/{NI} typespec (XTY_LONG); +^"real"/{NI} typespec (XTY_REAL); +^"double"/{NI} typespec (XTY_DOUBLE); +^"complex"/{NI} typespec (XTY_COMPLEX); +^"pointer"/{NI} typespec (XTY_POINTER); +^"extern"/{NI} typespec (XTY_EXTERN); + +^{W}*"procedure"/{NI} { + /* Subroutine declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, 0); + } + +"procedure"/{NI} { + /* Function declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, dtype); + setline(); + } + +^{W}*"task"/{NI} { if (context & BODY) + ECHO; + else { + process_task_statement(); + setline(); + } + } +^{W}*"TN$DECL" put_dictionary(); +^{W}*"TN$INTERP" put_interpreter(); +^".""help" { + skip_helpblock(); + setline(); + } +^{W}*"begin"/{NI} { + begin_code(); + setline(); + } +^{W}*"define"{W}+[A-Z0-9_]+{W}+Memr { + macro_redef(); + setline(); + } +^{W}*"define"{W}+[A-Z0-9_]+{W}+\" { + str_enter(); + } +^{W}*("(")?"define"/{NI} { + pushcontext (DEFSTMT); + ECHO; + } +^{W}*"end"/{NI} { + end_code(); + setline(); + } +^{W}*"string"/{NI} { + (context & BODY) ? ECHO + : do_string ('"', STR_DECL); + } +^{W}*"data"/{NI} { + if (!(context & BODY)) + pushcontext (DATASTMT); + ECHO; + } + +"switch"/{NI} { + ECHO; + if (context & BODY) + nswitch++; + } + +"#" skipnl(); +^"%"[^\n]* ECHO; + +^{W}*"include"{W}*(\"|<) do_include(); + +[a-zA-Z][a-zA-Z0-9_$]* mapident(); + +{D}+":"{S}(":"{S})?("."{D}*)? hms (yytext); +{O}+("B"|"b") int_constant (yytext, OCTAL); +{X}+("X"|"x") int_constant (yytext, HEX); +\' int_constant (yytext, CHARCON); + +"()" { + if (context & (BODY|PROCSTMT)) + ECHO; + } + +"&&" output ('&'); +"||" output ('|'); + +"{" { + ECHO; + nbrace++; + } +"}" { + ECHO; + nbrace--; + } +"[" output ('('); +"]" output (')'); + +\*\" do_hollerith(); + +\" { + if (context & BODY) + do_string ('"', STR_INLINE); + else + ECHO; + } + +(","|";"){W}*("#"[^\n]*)?"\n" { + /* If statement is continued do not pop + * the context. + */ + ECHO; + linenum[istkptr]++; + } + +"\n" { + /* End of newline and end of statement. + */ + ECHO; + linenum[istkptr]++; + popcontext(); + } + +%% + + +/* TYPESPEC -- Context dependent processing of a type specifier. If in the + * declarations section, process a declarations statement. If in procedure + * body or in a define statement, map the type specifier identifer and output + * the mapped value (intrinsic function name). Otherwise we must be in global + * space, and the type spec begins a function declaration; save the datatype + * code for d_newproc(). + */ +void +typespec (typecode) +int typecode; +{ + if (context & DECL) + d_declaration (typecode); + else if (context & (BODY|DEFSTMT)) + mapident(); + else + dtype = typecode; +} + + + +/* PROCESS_TASK_STATEMENT -- Parse the TASK statement. The task statement + * is replaced by the "sys_runtask" procedure (sysruk), which is called by + * the IRAF main to run a task, or to print the dictionary (cmd "?"). + * The source for the basic sys_runtask procedure is in "lib$sysruk.x". + * We process the task statement into some internal tables, then open the + * sysruk.x file as an include file. Special macros therein are + * replaced by the taskname dictionary as processing continues. + */ +void +process_task_statement() +{ + char ch; + + if (ntasks > 0) { /* only one task statement permitted */ + error (XPP_SYNTAX, "Only one TASK statement permitted per file"); + return; + } + + /* Process the task statement into the TASK_LIST structure. + */ + if (parse_task_statement() == ERR) { + error (XPP_SYNTAX, "Syntax error in TASK statement"); + while ((ch = input()) != EOF && ch != '\n') + ; + unput ('\n'); + return; + } + + /* Open RUNTASK ("lib$sysruk.x") as an include file. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + istkptr--; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + strcpy (fname[istkptr], IRAFLIB); + strcat (fname[istkptr], RUNTASK); + if ((yyin = fopen (vfn2osfn (fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot read lib$sysruk.x"); + return; + } + + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of the include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer( yyin, YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* DO_INCLUDE -- Process an include statement, i.e., eat up the include + * statement, push the current input file on a stack, and open the new file. + * System include files are referenced as "", other files as "file". + */ +void +do_include() +{ + char *p, delim, *rindex(); + char hfile[SZ_FNAME+1], *op; + int root_len; + + + /* Push current input file status on the input file stack istk. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + --istkptr; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + /* If filespec "", call os_sysfile to get the pathname of the + * system include file. + */ + if (yytext[yyleng-1] == '<') { + + for (op=hfile; (*op = input()) != EOF; op++) + if (*op == '\n') { + --istkptr; + error (XPP_SYNTAX, "missing > delim in include statement"); + return; + } else if (*op == '>') + break; + + *op = EOS; + + if (os_sysfile (hfile, fname[istkptr], SZ_PATHNAME) == ERR) { + --istkptr; + error (XPP_COMPERR, "cannot find include file"); + return; + } + + } else { + /* Prepend pathname leading to the file in which the current + * include statement was found. Compiler may not have been run + * from the directory containing the source and include file. + */ + if (!hbindefs) { + if ((p = rindex (fname[istkptr-1], '/')) == NULL) + root_len = 0; + else + root_len = p - fname[istkptr-1] + 1; + strncpy (fname[istkptr], fname[istkptr-1], root_len); + + } else { + if ((p = vfn2osfn (HBIN_INCLUDES, 0))) { + root_len = strlen (p); + strncpy (fname[istkptr], p, root_len); + } else { + --istkptr; + error (XPP_COMPERR, "cannot find hbin$ directory"); + return; + } + } + fname[istkptr][root_len] = EOS; + + delim = '"'; + + /* Advance to end of whatever is in the file name string. + */ + for (p=fname[istkptr]; *p != EOS; p++) + ; + /* Concatenate name of referenced file. + */ + while ((*p = input()) != delim) { + if (*p == '\n' || *p == EOF) { + --istkptr; + error (XPP_SYNTAX, "bad include file name"); + return; + } + p++; + } + *p = EOS; + } + + /* If the foreign defs option is in effect, the machine dependent defs + * for a foreign machine are given by a substitute "iraf.h" file named + * on the command line. This foreign machine header file includes + * not only the iraf.h for the foreign machine, but the equivalent of + * all the files named in the array of strings "machdefs". Ignore any + * attempts to include any of these files since they have already been + * included in the foreign definitions header file. + */ + if (foreigndefs) { + char sysfile[SZ_PATHNAME]; + char **files; + + /* + for (files=machdefs; *files != NULL; files++) { + */ + for (files=machdefs; **files; files++) { + memset (sysfile, 0, SZ_PATHNAME); + strcpy (sysfile, HOSTLIB); + strcat (sysfile, *files); + if (strcmp (sysfile, fname[istkptr]) == 0) { + --istkptr; + return; + } + } + } + + if ((yyin = fopen (vfn2osfn(fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot open include file"); + return; + } + + /* Keep track of the line number within the include file. */ + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer( yyin, YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* YYWRAP -- Called by LEX when end of file is reached. If input stack is + * not empty, close off include file and continue on in old file. Return + * nonzero when the stack is empty, i.e., when we reach the end of the + * main file. + */ +int +yywrap() +{ + /* The last line of a file is not necessarily newline terminated. + * Output a newline just in case. + */ + fprintf (yyout, "\n"); + + if (istkptr <= 0) { + /* ALL DONE with main file. + */ + return (1); + + } else { + /* End of include file. Pop old input file and set line number + * for error messages. + */ + fclose (yyin); + /* yyin = istk[--istkptr]; */ + istkptr--; + + yypop_buffer_state (); + if ( !YY_CURRENT_BUFFER ) + yyterminate (); + + if (istkptr == 0) + setline(); + return (0); + } +} + + + +/* YY_INPUT -- Get a character from the input stream. + */ +int +yy_input () +{ + return (input()); +} + + +/* YY_UNPUT -- Put a character back into the input stream. + */ +void +yy_unput (ch) +char ch; +{ + unput(ch); +} diff --git a/unix/boot/spp/xpp/xpp.l.orig b/unix/boot/spp/xpp/xpp.l.orig new file mode 100644 index 00000000..f5c7a375 --- /dev/null +++ b/unix/boot/spp/xpp/xpp.l.orig @@ -0,0 +1,188 @@ +%{ + +#include "xpp.h" + +/* + * Lexical definition for the first pass of the IRAF subset preprocessor. + * This program is a horrible kludge but will suffice until there is time + * to build something better. + */ + +#undef output /* undefine LEX output macro -- we use proc */ +#undef ECHO /* ditto echo */ +#define ECHO outstr (yytext) + +#define OCTAL 8 +#define HEX 16 +#define CHARCON 1 + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ +extern int str_idnum; /* for ST0000 string names */ +extern int nbrace; /* count of braces */ +extern int nswitch; /* number of "switch" stmts */ +extern int errflag; /* set if compiler error */ +extern int errchk; /* sef if error checking */ +extern int context; /* lexical context flags */ +static int dtype; /* set if typed procedure */ + +%} + +D [0-9] +O [0-7] +S [ 0-6]{D} +X [0-9A-F] +W [ \t] +NI [^a-zA-Z0-9_] + +%a 5000 +%o 9000 +%k 500 + +%% + +^"bool"/{NI} typespec (XTY_BOOL); +^"char"/{NI} typespec (XTY_CHAR); +^"short"/{NI} typespec (XTY_SHORT); +^"int"/{NI} typespec (XTY_INT); +^"long"/{NI} typespec (XTY_LONG); +^"real"/{NI} typespec (XTY_REAL); +^"double"/{NI} typespec (XTY_DOUBLE); +^"complex"/{NI} typespec (XTY_COMPLEX); +^"pointer"/{NI} typespec (XTY_POINTER); +^"extern"/{NI} typespec (XTY_EXTERN); + +^{W}*"procedure"/{NI} { + /* Subroutine declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, 0); + } + +"procedure"/{NI} { + /* Function declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, dtype); + } + +^{W}*"task"/{NI} { if (context & BODY) + ECHO; + else { + process_task_statement(); + setline(); + } + } +^{W}*"TN$DECL" put_dictionary(); +^{W}*"TN$INTERP" put_interpreter(); +^".""help" { + skip_helpblock(); + setline(); + } + +^{W}*"begin"/{NI} { + begin_code(); + setline(); + } +^{W}*"define"{W}+[A-Z0-9_]+{W}+\" { + str_enter(); + } +^{W}*("(")?"define"/{NI} { + pushcontext (DEFSTMT); + ECHO; + } +^{W}*"end"/{NI} { + end_code(); + } +^{W}*"string"/{NI} { + (context & BODY) ? ECHO + : do_string ('"', STR_DECL); + } +^{W}*"data"/{NI} { + if (!(context & BODY)) + pushcontext (DATASTMT); + ECHO; + } + +"switch"/{NI} { + ECHO; + if (context & BODY) + nswitch++; + } + +"#" skipnl(); +^"%"[^\n]* ECHO; + +^{W}*"include"{W}*(\"|<) do_include(); + +[a-zA-Z][a-zA-Z0-9_$]* mapident(); + +{D}+":"{S}(":"{S})?("."{D}*)? hms (yytext); +{O}+("B"|"b") int_constant (yytext, OCTAL); +{X}+("X"|"x") int_constant (yytext, HEX); +\' int_constant (yytext, CHARCON); + +"()" { + if (context & (BODY|PROCSTMT)) + ECHO; + } + +"&&" output ('&'); +"||" output ('|'); + +"{" { + ECHO; + nbrace++; + } +"}" { + ECHO; + nbrace--; + } +"[" output ('('); +"]" output (')'); + +\*\" do_hollerith(); + +\" { + if (context & BODY) + do_string ('"', STR_INLINE); + else + ECHO; + } + +(","|";"){W}*("#"[^\n]*)?"\n" { + /* If statement is continued do not pop + * the context. + */ + ECHO; + linenum[istkptr]++; + } + +"\n" { + /* End of newline and end of statement. + */ + ECHO; + linenum[istkptr]++; + popcontext(); + } + +%% + + +/* TYPESPEC -- Context dependent processing of a type specifier. If in the + * declarations section, process a declarations statement. If in procedure + * body or in a define statement, map the type specifier identifer and output + * the mapped value (intrinsic function name). Otherwise we must be in global + * space, and the type spec begins a function declaration; save the datatype + * code for d_newproc(). + */ +typespec (typecode) +int typecode; +{ + if (context & DECL) + d_declaration (typecode); + else if (context & (BODY|DEFSTMT)) + mapident(); + else + dtype = typecode; +} diff --git a/unix/boot/spp/xpp/xppProto.h b/unix/boot/spp/xpp/xppProto.h new file mode 100644 index 00000000..073aa585 --- /dev/null +++ b/unix/boot/spp/xpp/xppProto.h @@ -0,0 +1,55 @@ + +/* decl.c */ +void d_newproc (char *name, int dtype); +int d_declaration (int dtype); +void d_codegen (register FILE *fp); +void d_runtime (char *text); +//void d_makedecl (struct symbol *sp, FILE *fp); +struct symbol *d_enter (char *name, int dtype, int flags); +struct symbol *d_lookup (char *name); +void d_chksbuf (void); +int d_gettok (char *tokstr, int maxch); +//void d_declfunc (struct symbol *sp, FILE *fp); + + +/* xppcode.c */ +void setcontext (int new_context); +void pushcontext (int new_context); +int popcontext (void); +void hashtbl (void); +int findkw (void); +void mapident (void); +void str_enter (void); +char *str_fetch (register char *strname); +void macro_redef (void); +void setline (void); +void output (char ch); + +void do_type (int type); +void do_char (void); +void skip_helpblock (void); +int parse_task_statement (void); +int get_task (char *task_name, char *proc_name, int maxch); +int get_name (char *outstr, int maxch); +int nextch (void); +void put_dictionary (void); +void put_interpreter (void); +void outstr (char *string); +void begin_code (void); +void end_code (void); +void init_strings (void); +//void write_string_data_statement (struct string *s); +void do_string (char delim, int strtype); +void do_hollerith (void); +void sbuf_check (void); + +char *str_uniqid (void); +void traverse (char delim); +void error (int errcode, char *errmsg); +void xpp_warn (char *warnmsg); +long accum (int base, char **strp); + +int charcon (char *string); +void int_constant (char *string, int base); +void hms (char *number); + diff --git a/unix/boot/spp/xpp/xppcode.c b/unix/boot/spp/xpp/xppcode.c new file mode 100644 index 00000000..e083cb27 --- /dev/null +++ b/unix/boot/spp/xpp/xppcode.c @@ -0,0 +1,1826 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include "xpp.h" +#include "../../bootProto.h" + +#define import_spp +#include + +/* + * C code for the first pass of the IRAF subset preprocessor (SPP). + * The decision to initially organize the SPP compiler into two passes was + * made to permit maximum use of the existing raftor preprocessor, which is + * the basis for the second pass of the SPP. Eventually the two passes + * should be combined into a single program. Most of the operations performed + * by the first pass (XPP) should be performed AFTER macro substitution, + * rather than before as is the case in the current implementation, which + * processes macros in the second pass (RPP). + * + * Beware that this is not a very good program which was not carefully + * designed and which was never intended to have a long lifetime. The next + * step is to replace the two passes by a single program which is functionally + * very similar, but which is more carefully engineered and which is written + * in the SPP language calling IRAF file i/o. Eventually a true compiler + * will be written, providing many new features, i.e., structures and pointers, + * automatic storage class, mapped arrays, enhanced i/o support, and good + * compile time error checking. This compiler will also feature a table driven + * code generator (generating primitive Fortran statements), which will provide + * greater machine independence. + */ + + +extern char *vfn2osfn(); + +/* Escape sequence characters and their binary equivalents. + */ +char *esc_ch = "ntfr\\\"'"; +char *esc_val = "\n\t\f\r\\\"\'"; + +/* External and internal data stuctures. We need access to the LEX i/o + * buffers because we use the LEX i/o macros, which provide pushback, + * because we must change the streams to process includes, and so on. + * These definitions are VERY Lex dependent. + */ +extern char yytext[]; /* LEX character buffer */ +extern int yyleng; /* length of string in yytext */ +extern FILE *yyin, *yyout; /* LEX input, output files */ + +extern char yytchar, *yysptr, yysbuf[]; +extern int yylineno; + +#define U(x) x +/* +#define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10\ +?(yylineno++,yytchar):yytchar)==EOF?0:yytchar) +#define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;} +*/ + +extern int input(); +extern void yyunput(); +extern void d_codegen (register FILE *fp); +extern void d_runtime (char *text); + +extern char *yytext_ptr; +#define unput(c) yyunput( c, (yytext_ptr) ) + + + +int context = GLOBAL; /* lexical context variable */ +extern int hbindefs, foreigndefs; +char *machdefs[] = { "mach.h", "config.h", "" }; + +/* The task structure is used for TASK declarations. Since this is a + * throwaway program we do not bother with dynamic storage allocation, + * which would remove the limit on the number of tasks in a task statment. + */ +struct task { + char *task_name; /* logical task name */ + char *proc_name; /* name of procedure */ + short name_offset; /* offset of name in dictionary */ +}; + +/* The string structure is used for STRING declarations and for inline + * strings. Strings are stored in a fixed size, statically allocated + * string buffer. + */ +struct string { + char *str_name; /* name of string */ + char *str_text; /* ptr to text of string */ + short str_length; /* length of string */ +}; + +struct task task_list[MAX_TASKS]; +struct string string_list[MAX_STRINGS]; + +FILE *istk[MAX_INCLUDE]; /* stack for input file descriptors */ +int linenum[MAX_INCLUDE]; /* line numbers in files */ +char fname[MAX_INCLUDE][SZ_PATHNAME];/* file names */ +int istkptr = 0; /* istk pointer */ + +char obuf[SZ_OBUF]; /* buffer for body of procedure */ +char dbuf[SZ_DBUF]; /* buffer for misc proc. decls. */ +char sbuf[SZ_SBUF]; /* string buffer */ +char *sp = sbuf; /* string buffer pointer */ +char *op = obuf; /* pointer in output buffer */ +char *dp = dbuf; /* pointer in decls buffer */ +int nstrings = 0; /* number of strings so far */ +int strloopdecl; /* data dummy do index declared? */ + +int ntasks = 0; /* number of tasks in interpreter */ +int str_idnum = 0; /* for generating unique string names */ +int nbrace = 0; /* must be zero when "end" is reached */ +int nswitch = 0; /* number switch stmts in procedure */ +int errflag; +int errhand = NO; /* set if proc employs error handler */ +int errchk = NO; /* set if proc employs error checking */ + + +void skipnl (void); +void setcontext (int new_context); +void pushcontext (int new_context); +int popcontext (void); +void hashtbl (void); +int findkw (void); +void mapident (void); +void str_enter (void); +char *str_fetch (register char *strname); +void macro_redef (void); +void setline (void); +void output (char ch); + +void do_type (int type); +void do_char (void); +void skip_helpblock (void); +int parse_task_statement (void); +int get_task (char *task_name, char *proc_name, int maxch); +int get_name (char *outstr, int maxch); +int nextch (void); +void put_dictionary (void); +void put_interpreter (void); +void outstr (char *string); +void begin_code (void); +void end_code (void); +void init_strings (void); +void write_string_data_statement (struct string *s); +void do_string (char delim, int strtype); +void do_hollerith (void); +void sbuf_check (void); + +char *str_uniqid (void); +void traverse (char delim); +void error (int errcode, char *errmsg); +void xpp_warn (char *warnmsg); +long accum (int base, char **strp); + +int charcon (char *string); +void int_constant (char *string, int base); +void hms (char *number); + + + +/* SKIPNL -- Skip to newline, e.g., when a comment is encountered. + */ +void +skipnl (void) +{ + int c; + while ((c=input()) != '\n') + ; + unput ('\n'); +} + + +/* + * CONTEXT -- Package for setting, saving, and restoring the lexical context. + * The action of the preprocessor in some cases depends upon the context, i.e., + * what type of statement we are processing, whether we are in global space, + * within a procedure, etc. + */ + +#define MAX_CONTEXT 5 /* max nesting of context */ + +int cntxstk[MAX_CONTEXT]; /* for saving context */ +int cntxsp = 0; /* save stack pointer */ + + +/* SETCONTEXT -- Set the context. Clears any saved context. + */ +void +setcontext (int new_context) +{ + context = new_context; + cntxsp = 0; +} + + +/* PUSHCONTEXT -- Push a temporary context. + */ +void +pushcontext (int new_context) +{ + cntxstk[cntxsp++] = context; + context = new_context; + + if (cntxsp > MAX_CONTEXT) + error (XPP_COMPERR, "save context stack overflow"); +} + + +/* POPCONTEXT -- Pop the former context. If the current context is PROCSTMT + * (just finished compiling a procedure statement) then set the context to DECL + * to indicate that we are entering the declarations section of a procedure. + */ +int +popcontext (void) +{ + if (context & PROCSTMT) { + context = DECL; + if (cntxsp > 0) + --cntxsp; + } else if (cntxsp > 0) + context = cntxstk[--cntxsp]; + + return (context); +} + + +/* Keyword table. The simple hashing scheme requires that the keywords appear + * in the table in sorted order. + */ +#define LEN_KWTBL 18 + +struct { + char *keyw; /* keyword name string */ + short opcode; /* opcode from above definitions */ + short nelem; /* number of table elements to skip if + * to get to next character class. + */ +} kwtbl[] = { + { "FALSE", XTY_FALSE, 0 }, + { "TRUE", XTY_TRUE, 0 }, + { "bool", XTY_BOOL, 0 }, + { "char", XTY_CHAR, 1 }, + { "complex", XTY_COMPLEX, 0 }, + { "double", XTY_DOUBLE, 0 }, + { "error", XTY_ERROR, 1 }, + { "extern", XTY_EXTERN, 0 }, + { "false", XTY_FALSE, 0 }, + { "iferr", XTY_IFERR, 2 }, + { "ifnoerr", XTY_IFNOERR, 1 }, + { "int", XTY_INT, 0 }, + { "long", XTY_LONG, 0 }, + { "pointer", XTY_POINTER, 1 }, + { "procedure", XTY_PROC, 0 }, + { "real", XTY_REAL, 0 }, + { "short", XTY_SHORT, 0 }, + { "true", XTY_TRUE, 0 }, +}; + +/* short kwindex[30]; simple alphabetic hash index */ +/* #define CINDEX(ch) (isupper(ch)?ch-'A':ch-'a') */ + +#define MAXCH 128 +short kwindex[MAXCH]; /* simple alphabetic hash index */ +#define CINDEX(ch) (ch) + + +/* HASHTBL -- Hash the keyword table. Initializes the "kwindex" hash table. + * For each character in the alphabet, the index gives the index into the + * sorted keyword table. If there is no keyword name beginning with the index + * character, the index entry is set to -1. + */ +void +hashtbl (void) +{ + int i, j; + + for (i=j=0; i <= MAXCH; i++) { + if (i == CINDEX (kwtbl[j].keyw[0])) { + kwindex[i] = j; + j = min (LEN_KWTBL-1, j + kwtbl[j].nelem + 1); + } else + kwindex[i] = -1; + } +} + + +/* FINDKW -- Lookup an indentifier in the keyword table. Return the opcode + * of the keyword, or ERR if no match. + */ +int +findkw (void) +{ + register char ch, *p, *q; + int i, ilimit; + + if (kwindex[0] == 0) + hashtbl(); + + i = CINDEX (yytext[0]); + if (i < 0 || i >= MAXCH || (i = kwindex[i]) < 0) + return (ERR); + ilimit = i + kwtbl[i].nelem; + + for (; i <= ilimit; i++) { + p = kwtbl[i].keyw + 1; + q = yytext + 1; + + for (; *p != EOS; q++, p++) { + ch = *q; + /* 5DEC95 - Don't case convert keywords. + if (isupper (ch)) + ch = tolower (ch); + */ + if (*p != ch) + break; + } + if (*p == EOS && *q == EOS) + return (kwtbl[i].opcode); + } + return (ERR); +} + + +/* MAPIDENT -- Lookup an identifier in the keyword table. If the identifier is + * not a keyword, output it as is. If a datatype keyword, the action depends + * on whether we are in a procedure body or not (i.e., whether the keyword + * begins a declaration or is a type coercion function). Most of the other + * keywords are mapped into special x$.. identifiers for further processing + * by the second pass. + */ +void +mapident (void) +{ + int i, findkw(); + char *str_fetch(); + register char *ip, *op; + + /* If not keyword and not defined string, output as is. The first + * char must be upper case for the name to be recognized as that of + * a defined string. If we are processing a "define" macro expansion + * is disabled. + */ + if ((i = findkw()) == ERR) { + if (!isupper(yytext[0]) || (context & DEFSTMT) || + (ip = str_fetch (yytext)) == NULL) { + + outstr (yytext); + return; + + } else { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + do_string ('"', STR_DEFINE); + return; + } + } + + /* If datatype keyword, call do_type. */ + if (i <= XTY_POINTER) { + do_type (i); + return; + } + + switch (i) { + case XTY_TRUE: + outstr (".true."); + break; + case XTY_FALSE: + outstr (".false."); + break; + case XTY_IFERR: + case XTY_IFNOERR: + outstr (yytext); + errhand = YES; + errchk = YES; + break; + case XTY_ERROR: + outstr (yytext); + errchk = YES; + break; + + case XTY_EXTERN: + /* UNREACHABLE (due to decl.c additions). + */ + outstr ("x$extn"); + break; + + default: + error (XPP_COMPERR, "Keyword lookup error"); + } +} + + +char st_buf[SZ_STBUF]; +char *st_next = st_buf; + +struct st_def { + char *st_name; + char *st_value; +} st_list[MAX_DEFSTR]; + +int st_nstr = 0; + +/* STR_ENTER -- Enter a defined string into the string table. The string + * table is a kludge to provide the capability to define strings in SPP. + * The problem is that XPP handles strings but RPP handles macros, hence + * strings cannot be defined. We get around this by recognizing defines + * of the form 'define NAME "..."'. If a macro with a quoted value is + * encounted we are called to enter the name and the string into the + * table. LOOKUP, above, subsequently searches the table for defined + * strings. The name must be upper case or the table will not be searched. + * + * N.B.: we are called by the lexical analyser with 'define name "' in + * yytext. The next input() will return the first char of the string. + */ +void +str_enter (void) +{ + register char *ip, *op, ch; + register struct st_def *s; + register int n; + char name[SZ_FNAME+1]; + + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Do not accept statement unless the name is upper case. + */ + if (!isupper (*ip)) { + outstr (yytext); + return; + } + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op = EOS; + + /* Check for a redefinition. */ + for (n=st_nstr, s=st_list, ch=name[0]; --n >= 0; s++) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, name) == 0) + break; + } + + /* Make a new entry?. */ + if (n < 0) { + s = &st_list[st_nstr++]; + if (st_nstr >= MAX_DEFSTR) + error (XPP_COMPERR, "Too many defined strings"); + + /* Put defined NAME in string buffer. */ + for (s->st_name = st_next, (ip=name); (*st_next++ = *ip++); ) + ; + } + + /* Put value in string buffer. + */ + s->st_value = st_next; + traverse ('"'); + for (ip=yytext; (*st_next++ = *ip++) != EOS; ) + ; + *st_next++ = EOS; + + if (st_next - st_buf >= SZ_STBUF) + error (XPP_COMPERR, "Too many defined strings"); +} + + +/* STR_FETCH -- Search the defined string table for the named string + * parameter and return a pointer to the string if found, NULL otherwise. + */ +char * +str_fetch (register char *strname) +{ + register struct st_def *s = st_list; + register int n = st_nstr; + register char ch = strname[0]; + + while (--n >= 0) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, strname) == 0) + return (s->st_value); + s++; + } + + return (NULL); +} + + +/* MACRO_REDEF -- Redefine the macro to automatically add a P2 macro + * to struct definitions. + */ +void +macro_redef (void) +{ + register int nb=0; + register char *ip, *op, ch; + char name[SZ_FNAME]; + char value[SZ_LINE]; + + + outstr ("define\t"); + memset (name, 0, SZ_FNAME); + memset (value, 0, SZ_LINE); + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op = EOS; + outstr (name); + outstr ("\t"); + + + /* Modify value. + */ + op = value; + while ( (ch = input()) != EOF ) { + if (ch == '\n') { + break; + } else if (ch == '#') { /* eat a comment */ + while ((ch = input()) != '\n') + ; + break; + + + } else { + if (ch == '[') { + nb++; + if (nb > 1) *op++ = '('; + } else if (ch == ']') { + nb--; + if (nb <= 0) + break; + else + *op++ = ')'; + } else if (nb >= 1) + *op++ = ch; + } + } + + outstr ("Memr("); + if (strcmp (value, "$1") == 0) { +#if defined(MACH64) && defined(AUTO_P2R) + char *emsg[SZ_LINE]; + int strict = 0; +#endif + + /* A macro such as "Memr[$1]" which is typically used as a + * shorthand for an array allocated as TY_REAL and not a part + * of a struct, however it might also be the first element of + * a struct. In this case, print a warning so it can be checked + * manually and just pass it through. + */ +#if defined(MACH64) && defined(AUTO_P2R) + memset (emsg, 0, SZ_LINE); + sprintf (emsg, + "Error in %s: line %d: ambiguous Memr for '%s' needs P2R/P2P", + fname[istkptr], linenum[istkptr], name); + if (strict) + error (XPP_COMPERR, emsg); + else + fprintf (stderr, "%s\n", emsg); +#endif + outstr (value); + + } else if (strncmp ("Mem", value, 3) == 0 || isupper (value[0])) { + /* In this case we assume a complex macro using some other + * Mem element or an upper-case macro. These are again used + * typically as a shorthand and use pointers directly, so pass + * it through unchanged. + */ + outstr (value); + + } else { + /* Assume it's part of a struct, e.g. "Memr[$1+N]". + * + * FIXME -- We should really be more careful to check the syntax. + fprintf (stderr, "INFO %s line %d: ", + fname[istkptr], linenum[istkptr]); + fprintf (stderr, "adding P2R macro for '%s'\n", name); + */ +#if defined(MACH64) && defined(AUTO_P2R) + if (value[0] == '$') { + outstr ("P2R("); + outstr (value); + outstr (")"); + } else + outstr (value); +#else + outstr (value); +#endif + } + outstr (")\n"); + + linenum[istkptr]++; +} + + +/* SETLINE -- Set the file line number. Used by the first pass to set + * line number after processing an include file and in various other + * places. Necessary to get correct line numbers in error messages from + * the second pass. + */ +void +setline (void) +{ + char msg[20]; + + if (istkptr == 0) { /* not in include file */ + sprintf (msg, "#!# %d\n", linenum[istkptr] - 1); + outstr (msg); + } +} + + +/* OUTPUT -- Output a character. If we are processing the body of a procedure + * or a data statement, put the character into the output buffer. Otherwise + * put the character to the output file. + * + * NOTE -- the redirection logic shown below is duplicated in OUTSTR. + */ +void +output (char ch) +{ + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + *op++ = ch; + if (op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + *dp++ = ch; + if (dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + putc (ch, yyout); + } +} + + +/* Datatype keywords for declarations. The special x$.. keywords are + * for communication with the second pass. Note that this table is machine + * dependent, since it maps char into type short. + */ +char *type_decl[] = RPP_TYPES; + + +/* Intrinsic functions used for type coercion. These mappings are machine + * dependent (MACHDEP). If your machine has INTEGER*2 and INTEGER*4, and + * integer cannot be passed as an argument when a short or long is expected, + * and your compiler has INT2 and INT4 type coercion intrinsic functions, + * you should use those here instead of INT (which happens to work for a VAX). + * If you cannot pass an int when a short is expected (i.e., IBM), and you + * do not have an INT2 intrinsic function, you should provide an external + * INTEGER*2 function called "int2" and use that for type coercion. Note + * that it will then be necessary to have the preprocessor automatically + * generate a declaration for the function. This nonsense will all go away + * when we set up a proper table driven code generator!! + */ +char *intrinsic_function[] = { + "", /* table is one-indexed */ + "(0 != ", /* bool(expr) */ + "int", /* char(expr) */ + "int", /* short(expr) */ + "int", /* int(expr) */ + "int", /* long(expr) */ + "real", /* real(expr) */ + "dble", /* double(expr) */ + "cmplx", /* complex(expr) */ + "int" /* pointer(expr) */ +}; + + +/* DO_TYPE -- Process a datatype keyword. The type of processing depends + * on whether we are called when processing a declaration or an expression. + * In expressions, the datatype keyword is the type coercion intrinsic + * function. DEFINE statements are a special case; we treat them as + * expressions, since macros containing datatype keywords are used in + * expressions more than in declarations. This is a kludge until the problem + * is properly resolved by processing macros BEFORE code generation. + * In the current implementation, macros are handled by the second pass (RPP). + */ +void +do_type (int type) +{ + char ch; + + if (context & (BODY|DEFSTMT)) { + switch (type) { + case XTY_BOOL: + for (ch=input(); ch == ' ' || ch == '\t'; ch=input()) + ; + if (ch != '(') + error (XPP_SYNTAX, "Illegal boolean expr"); + outstr (intrinsic_function[type]); + return; + + case XTY_CHAR: + case XTY_SHORT: + case XTY_INT: + case XTY_LONG: + case XTY_REAL: + case XTY_DOUBLE: + case XTY_COMPLEX: + case XTY_POINTER: + outstr (intrinsic_function[type]); + return; + + default: + error (XPP_SYNTAX, "Illegal type coercion"); + } + + } else { + /* UNREACHABLE when in declarations section of a procedure. + */ + fprintf (yyout, "%s", type_decl[type]); + } +} + + +/* DO_CHAR -- Process a char array declaration. Add "+1" to the first + * dimension to allow space for the EOS. Called after LEX has recognized + * "char name[". If we reach the closing ']', convert it into a right paren + * for the second pass. + */ +void +do_char (void) +{ + char ch; + + for (ch=input(); ch != ',' && ch != ']'; ch=input()) + if (ch == '\n' || ch == EOS) { + error (XPP_SYNTAX, "Missing comma or ']' in char declaration"); + unput ('\n'); + return; + } else + output (ch); + + outstr ("+1"); + if (ch == ']') + output (')'); + else + output (ch); +} + + +/* SKIP_HELPBLOCK -- Skip over a help block (documentation section). + */ +void +skip_helpblock (void) +{ + char ch; + + + /* fgets() no longer works with FLEX + while (fgets (yytext, SZ_LINE, yyin) != NULL) { + if (istkptr == 0) + linenum[istkptr]++; + + if (yytext[0] == '.' && (yytext[1] == 'e' || yytext[1] == 'E')) { + yytext[8] = EOS; + if (strcmp (&yytext[1], "endhelp") == 0 || + strcmp (&yytext[1], "ENDHELP") == 0) + break; + } + } + */ + + while ( (ch = input()) != EOF ) { + if (ch == '.') { /* check for ".endhelp" */ + ch = input (); + if (ch == 'e' || ch == 'E') { + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + break; + } else + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + + } else if (ch == '\n') { /* skip line */ + ; + } else { + for (ch=input(); ch != '\n' && ch != EOS; ch=input()) + ; + } + if (istkptr == 0) + linenum[istkptr]++; + } +} + + +/* PARSE_TASK_STATEMENT -- Parse the task statement, building up a list + * of task_name/procedure_name structures in the "task_list" array. + * + * task task1, task2, task3=proc3, task4, ... + * + * Task names are placed in the string buffer as one big string, with EOS + * delimiters between the names. This "dictionary" string is converted + * into a data statement at "end_code" time, along with any other strings + * in the runtask procedure. The procedure names, which may differ from + * the task names, are saved in the upper half of the output buffer. We can + * do this because we know that the runtask procedure is small and will not + * come close to filling up the output buffer, which buffers only the body + * of the procedure currently being processed. + * N.B.: Upon entry, the input is left positioned to just past the "task" + * keyword. + */ +int +parse_task_statement (void) +{ + register struct task *tp; + register char ch, *ip; + char task_name[SZ_FNAME], proc_name[SZ_FNAME]; + int name_offset; + + /* Set global pointers to where we put task and proc name strings. + */ + sp = sbuf; + op = &obuf[SZ_OBUF/2]; + name_offset = 1; + + for (ntasks=0; ntasks < MAX_TASKS; ntasks++) { + /* Process "taskname" or "taskname=procname". There must be + * at least one task name in the declaration. + */ + if (get_task (task_name, proc_name, SZ_FNAME) == ERR) + return (ERR); + + /* Set up the task declaration structure, and copy name strings + * into the string buffers. + */ + tp = &task_list[ntasks]; + tp->task_name = sp; + tp->proc_name = op; + tp->name_offset = name_offset; + name_offset += strlen (task_name) + 1; + + for (ip=task_name; (*sp++ = *ip++) != EOS; ) + if (sp >= &sbuf[SZ_SBUF]) + goto err; + for (ip=proc_name; (*op++ = *ip++) != EOS; ) + if (op >= &obuf[SZ_OBUF]) + goto err; + + /* If the next character is a comma, skip it and a newline if + * one follows and continue processing. If the next character is + * a newline, we are done. Any other character is an error. + * Note that nextch skips whitespace and comments. + */ + ch = nextch(); + if (ch == ',') { + if ((ch = nextch()) != '\n') + unput (ch); + } else if (ch == '\n') { + linenum[istkptr]++; + ntasks++; /* end of task statement */ + break; + } else + return (ERR); + } + + if (ntasks >= MAX_TASKS) { +err: error (XPP_COMPERR, "too many tasks in task statement"); + return (ERR); + } + + /* Set up the task name dictionary string so that it gets output + * as a data statement when the runtask procedure is output. + */ + string_list[0].str_name = "dict"; + string_list[0].str_text = sbuf; + string_list[0].str_length = (sp - sbuf); + nstrings = 1; + + /* Leave the output buffer pointer pointing to the first half of + * the buffer. + */ + op = obuf; + return (OK); +} + + +/* GET_TASK -- Process a single task declaration of the form "taskname" or + * "taskname = procname". + */ +int +get_task (char *task_name, char *proc_name, int maxch) +{ + register char ch; + + /* Get task name. + */ + if (get_name (task_name, maxch) == ERR) + return (ERR); + + /* Get proc name if given, otherwise the procedure name is assumed + * to be the same as the task name. + */ + if ((ch = nextch()) == '=') { + if (get_name (proc_name, maxch) == ERR) + return (ERR); + } else { + unput (ch); + strncpy (proc_name, task_name, maxch); + } + + return (XOK); +} + + +/* GET_NAME -- Extract identifier from input, placing in the output string. + * ERR is returned if the output string overflows, or if the token is not + * a legal identifier. + */ +int +get_name (char *outstr, int maxch) +{ + register char ch, *op; + register int nchars; + + unput ((ch = nextch())); /* skip leading whitespace */ + + for (nchars=0, op=outstr; nchars < maxch; nchars++) { + ch = input(); + if (isalpha(ch)) { + if (isupper(ch)) + *op++ = tolower(ch); + else + *op++ = ch; + } else if ((isdigit(ch) && nchars > 0) || ch == '_' || ch == '$') { + *op++ = ch; + } else { + *op++ = EOS; + unput (ch); + return (nchars > 0 ? XOK : ERR); + } + } + + return (ERR); +} + + +/* NEXTCH -- Get next nonwhite character from the input stream. Ignore + * comments. Newline is not considered whitespace. + */ +int +nextch (void) +{ + register char ch; + + while ((ch = input()) != EOF) { + if (ch == '#') { /* discard comment */ + while ((ch = input()) != '\n') + ; + return (ch); + } else if (ch != ' ' && ch != '\t') + return (ch); + } + return (EOF); +} + + +/* PUT_DICTIONARY -- We are called when the keyword TN$DECL is encountered, + * i.e., while processing "sysruk.x". This should only happen after the + * task statement has been successfully processed. Our function is to replace + * the TN$DECL macro by the declarations for the DP and DICT structures. + * DP is an integer array giving the offsets of the task name strings in DICT, + * the dictionary string buffer. + */ +#define NDP_PERLINE 8 /* num DP data elements per line */ + +void +put_dictionary (void) +{ + register struct task *tp; + char buf[SZ_LINE]; + int i, j, offset; + + /* Discard anything found on line after the TN$DECL, which is only + * recognized as the first token on the line. + */ + while (input() != '\n') + ; + unput ('\n'); + + /* Output the data statements required to initialize the DP array. + * These statements are spooled into the output buffer and not output + * until all declarations have been processed, since the Fortran std + * requires that data statements follow declarations. + */ + pushcontext (DATASTMT); + tp = task_list; + + for (j=0; j <= ntasks; j += NDP_PERLINE) { + if (!strloopdecl++) { + pushcontext (DECL); + sprintf (buf, "%s\tiyy\n", type_decl[TY_INT]); + outstr (buf); + popcontext(); + } + + sprintf (buf, "data\t(dp(iyy),iyy=%2d,%2d)\t/", + j+1, min (j+NDP_PERLINE, ntasks+1)); + outstr (buf); + + for (i=j; i < j+NDP_PERLINE && i <= ntasks; i++) { + offset = (tp++)->name_offset; + if (i >= ntasks) + sprintf (buf, "%2d/\n", XEOS); + else if (i == j + NDP_PERLINE - 1) + sprintf (buf, "%4d/\n", offset==EOS ? XEOS: offset); + else + sprintf (buf, "%4d,", offset==EOS ? XEOS: offset); + outstr (buf); + } + } + + popcontext(); + + /* Output type declarations for the DP and DICT arrays. The string + * descriptor for string 0 (dict) was prepared when the TASK statement + * was processed. + */ + sprintf (buf, "%s\tdp(%d)\n", type_decl[XTY_INT], ntasks + 1); + outstr (buf); + sprintf (buf, "%s\tdict(%d)\n", type_decl[XTY_CHAR], + string_list[0].str_length); + outstr (buf); +} + + +/* PUT_INTERPRETER -- Output the statements necessary to scan the dictionary + * for a task and call the associated procedure. We are called when the + * keyword TN$INTERP is encountered in the input stream. + */ +void +put_interpreter (void) +{ + char lbuf[SZ_LINE]; + int i; + + while (input() != '\n') /* discard rest of line */ + ; + unput ('\n'); + + for (i=0; i < ntasks; i++) { + sprintf (lbuf, "\tif (streq (task, dict(dp(%d)))) {\n", i+1); + outstr (lbuf); + sprintf (lbuf, "\t call %s\n", task_list[i].proc_name); + outstr (lbuf); + sprintf (lbuf, "\t return (OK)\n"); + outstr (lbuf); + sprintf (lbuf, "\t}\n"); + outstr (lbuf); + } +} + + +/* OUTSTR -- Output a string. Depending on the context, the string will + * either go direct to the output file, or will be buffered in the output + * buffer. + */ +void +outstr (char *string) +{ + register char *ip; + + + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + for (ip=string; (*op++ = *ip++) != EOS; ) + ; + if (--op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + for (ip=string; (*dp++ = *ip++) != EOS; ) + ; + if (--dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + fputs (string, yyout); + } +} + + +/* BEGIN_CODE -- Code that gets executed when the keyword BEGIN is encountered, + * i.e., when we begin processing the executable part of a procedure + * declaration. + */ +void +begin_code (void) +{ + char text[1024]; + + /* If we are already processing the body of a procedure, we probably + * have a missing END. + */ + if (context & BODY) + xpp_warn ("Unmatched BEGIN statement"); + + /* Set context flag noting that we are processing the body of a + * procedure. Output the BEGIN statement, for the benefit of the + * second pass (RPP), which needs to know where the procedure body + * begins. + */ + setcontext (BODY); + d_runtime (text); outstr (text); + outstr ("begin\n"); + linenum[istkptr]++; + + /* Initialization. */ + nbrace = 0; + nswitch = 0; + str_idnum = 1; + errhand = NO; + errchk = NO; +} + + +/* END_CODE -- Code that gets executed when the keyword END is encountered + * in the input. If error checking is used in the procedure, we must declare + * the boolean function XERPOP. If any switches are employed, we must declare + * the switch variables. Next we format and output data statements for any + * strings encountered while processing the procedure body. If the procedure + * being processed is sys_runtask, the task name dictionary string is also + * output. Finally, we output the spooled procedure body, followed by and END + * statement for the benefit of the second pass. + */ +void +end_code (void) +{ + int i; + + /* If the END keyword is encountered outside of the body of a + * procedure, we leave it alone. + */ + if (!(context & BODY)) { + outstr (yytext); + return; + } + + /* Output argument and local variable declarations (see decl.c). + * Note d_enter may have been called during processing of the body + * of a procedure to make entries in the symbol table for intrinsic + * functions, switch variables, etc. (this is not currently done). + */ + d_codegen (yyout); + + setcontext (GLOBAL); + + /* Output declarations for error checking and switches. All variables + * and functions must be declared. + */ + if (errhand) + fprintf (yyout, "x$bool xerpop\n"); + if (errchk) + fprintf (yyout, "errchk error, erract\n"); + errhand = NO; + errchk = NO; + + if (nswitch) { /* declare switch variables */ + fprintf (yyout, "%s\t", type_decl[XTY_INT]); + for (i=1; i < nswitch; i++) + fprintf (yyout, "SW%04d,", i); + fprintf (yyout, "SW%04d\n", i); + } + + /* Output any miscellaneous declarations. These include ERRCHK and + * COMMON declarations - anything not a std type declaration or a + * data statement declaration. + */ + *dp++ = EOS; + fputs (dbuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_DBUF; ) dbuf[i++] = '\0'; } + dp = dbuf; + + /* Output the SAVE statement, which must come after all declarations + * and before any DATA statements. + */ + fputs ("save\n", yyout); + + /* Output data statements to initialize character strings, followed + * by any runtime procedure entry initialization statments, followed + * by the spooled text in the output buffer, followed by the END. + * Clear the string and output buffers. Any user data statements + * will already have been moved into the output buffer, and they + * will come out at the end of the declarations section regardless + * of where they were given in the declarations section. Data stmts + * are not permitted in the procedure body. + */ + init_strings(); + *op++ = EOS; + fputs (obuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_OBUF; ) obuf[i++] = '\0'; } + fputs ("end\n", yyout); fflush (yyout); + + op = obuf; + *op = EOS; + sp = sbuf; + + if (nbrace != 0) { + error (XPP_SYNTAX, "Unmatched brace"); + nbrace = 0; + } +} + + +#define BIG_STRING 9 +#define NPERLINE 8 + +/* INIT_STRINGS -- Output data statements to initialize all strings in a + * procedure ("string" declarations, inline strings, and the runtask + * dictionary). Strings are implemented as integer arrays, using the + * smallest integer datatype provided by the host Fortran compiler, usually + * INTEGER*2 (XTY_CHAR). + */ +void +init_strings (void) +{ + register int str; + + if (nstrings) + for (str=0; str < nstrings && !strloopdecl; str++) + if (string_list[str].str_length >= BIG_STRING) { + fprintf (yyout, "%s\tiyy\n", type_decl[XTY_INT]); + strloopdecl++; + } + + for (str=0; str < nstrings; str++) + write_string_data_statement (&string_list[str]); + + sp = sbuf; /* clear string buffer */ + nstrings = 0; + strloopdecl = 0; +} + + +/* WRITE_STRING_DATA_STATEMENT -- Output data statement to initialize a single + * string. If short string, output a simple whole-array data statement + * that fits all on one line. Large strings are initialized with multiple + * data statements, each of which initializes a section of the string + * using a dummy subscript. This is thought to be more portable than + * a single large data statement with continuation, because the number of + * continuation cards permitted in a data statement depends on the compiler. + * The loop variable in an implied do loop in a data statement must be declared + * on some compilers (crazy but true). Determine if we will be generating any + * implied dos and declare the variable if so. + */ +void +write_string_data_statement (struct string *s) +{ + register int i, len; + register char *ip; + char ch, *name; + int j; + + name = s->str_name; + ip = s->str_text; + len = s->str_length; + + if (len < BIG_STRING) { + fprintf (yyout, "data\t%s\t/", name); + for (i=0; i < len-1; i++) { + if ((ch = *ip++) == EOS) + fprintf (yyout, "%3d,", XEOS); + else + fprintf (yyout, "%3d,", ch); + } + fprintf (yyout, "%2d/\n", XEOS); + + } else { + for (j = 0; j < len; j += NPERLINE) { + fprintf (yyout, "data\t(%s(iyy),iyy=%2d,%2d)\t/", + name, j+1, min(j+NPERLINE, len)); + for (i=j; i < j+NPERLINE; i++) { + if (i >= len-1) { + fprintf (yyout, "%2d/\n", XEOS); + return; + } else if (i == j+NPERLINE-1) { + fprintf (yyout, "%3d/\n", ip[i]==EOS ? XEOS: ip[i]); + } else + fprintf (yyout, "%3d,", ip[i]==EOS ? XEOS: ip[i]); + } + } + } +} + + +/* DO_STRING -- Process a STRING declaration or inline string. Add a new + * string descriptor to the string list, copy text of string into sbuf, + * save name of string array in sbuf. If inline string, manufacture the + * name of the string array. + */ +void +do_string ( + char delim, /* char which delimits string */ + int strtype /* string type */ +) +{ + register char ch, *ip; + register struct string *s; + int readstr = 1; + char *str_uniqid(); + + /* If we run out of space for string storage, print error message, + * dump string decls out early, clear buffer and continue processing. + */ + if (nstrings >= MAX_STRINGS) { + error (XPP_COMPERR, "Too many strings in procedure"); + init_strings(); + } + + s = &string_list[nstrings]; + + switch (strtype) { + + case STR_INLINE: + case STR_DEFINE: + /* Inline strings are implemented as Fortran arrays; generate a + * dummy name for the array and set up the descriptor. + * Defined strings are inline strings, but the name of the text of + * the string is already in yytext when we are called. + */ + s->str_name = sp; + for (ip = str_uniqid(); (*sp++ = *ip++) != EOS; ) + ; + sbuf_check(); + break; + + case STR_DECL: + /* String declaration. Read in name of string, used as name of + * Fortran array. + */ + ch = nextch(); /* skip whitespace */ + if (!isalpha (ch)) + goto sterr; + s->str_name = sp; + *sp++ = ch; + + /* Get rest of string name identifier. */ + while ((ch = input()) != EOF) { + if (isalnum(ch) || ch == '_') { + *sp++ = ch; + sbuf_check(); + } else if (ch == '\n') { +sterr: error (XPP_SYNTAX, "String declaration syntax"); + while (input() != '\n') + ; + unput ('\n'); + return; + } else { + *sp++ = EOS; + break; + } + } + + /* Advance to the ' or " string delimiter, in preparation for + * processing the string itself. If syntax error occurs, skip + * to newline to avoid spurious error messages. If the string + * is not quoted the string value field is taken to be the name + * of a string DEFINE. + */ + delim = nextch(); + + if (!(delim == '"' || delim == '\'')) { + register char *ip, *op; + int ch; + char *str_fetch(); + + /* Fetch name of defined macro into yytext. + */ + op = yytext; + *op++ = delim; + while ((ch = input()) != EOF) + if (isalnum(ch) || ch == '_') + *op++ = ch; + else + break; + unput (ch); + *op = EOS; + + /* Fetch body of string into yytext. + */ + if ((ip = str_fetch (yytext)) != NULL) { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + readstr = 0; + } else { + error (XPP_SYNTAX, + "Undefined macro referenced in string declaration"); + } + } + + break; + } + + /* Get the text of the string. Process escape sequences. String may + * not span multiple lines. In the case of a defined string, the text + * of the string will already be in yytext. + */ + s->str_text = sp; + if (readstr && strtype != STR_DEFINE) + traverse (delim); /* process string into yytext */ + strcpy (sp, yytext); + sp += yyleng + 1; + s->str_length = yyleng + 1; + sbuf_check(); + + /* Output array declaration for string. We want the declaration to + * go into the miscellaneous declarations buffer, so toggle the + * the context to DECL before calling OUTSTR. + */ + { + char lbuf[SZ_LINE]; + + pushcontext (DECL); + sprintf (lbuf, "%s\t%s(%d)\n", type_decl[XTY_CHAR], s->str_name, + s->str_length); + outstr (lbuf); + popcontext(); + } + + /* If inline string, replace the quoted string by the name of the + * string variable. This text goes into the output buffer, rather + * than directly to the output file as is the case with the declaration + * above. + */ + if (strtype == STR_INLINE || strtype == STR_DEFINE) + outstr (s->str_name); + + if (++nstrings >= MAX_STRINGS) + error (XPP_COMPERR, "Too many strings in procedure"); +} + + +/* DO_HOLLERITH -- Process and output a Fortran string. If the output + * compiler is Fortran 77, we output a quoted string; otherwise we output + * a hollerith string. Fortran (packed) strings appear in the SPP source + * as in the statement 'call_f77_sub (arg, *"any string", arg)'. Escape + * sequences are not recognized. + */ +void +do_hollerith (void) +{ + register char *op; + char strbuf[SZ_LINE], outbuf[SZ_LINE]; + int len; + + /* Read the string into strbuf. */ + for (op=strbuf, len=0; (*op = input()) != '"'; op++, len++) + if (*op == '\n' || *op == EOF) + break; + if (*op == '\n') + error (XPP_COMPERR, "Packed string not delimited"); + else + *op = EOS; /* delete delimiter */ + +#ifdef F77 + sprintf (outbuf, "\'%s\'", strbuf); +#else + sprintf (outbuf, "%dH%s", i, strbuf); +#endif + + outstr (outbuf); +} + + +/* SBUF_CHECK -- Check to see that the string buffer has not overflowed. + * It is a fatal error if it does. + */ +void +sbuf_check (void) +{ + if (sp >= &sbuf[SZ_SBUF]) { + error (XPP_COMPERR, "String buffer overflow"); + _exit (1); + } +} + + +/* STR_UNIQID -- Generate a unit identifier name for an inline string. + */ +char * +str_uniqid (void) +{ + static char id[] = "ST0000"; + + sprintf (&id[2], "%04d", str_idnum++); + return (id); +} + + +/* 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. + */ +void +traverse (char delim) +{ + register char *op, *cp, ch; + 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 */ + unput ('\n'); + xpp_warn ("Newline while processing string"); + break; + + } else if (*op == '\\') { + if ((*op = input()) == EOF) { + break; + } else if (*op == '\n') { + --op; /* explicit continuation */ + 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 = EOS; + yyleng = (op - yytext); +} + + +/* ERROR -- Output an error message and set exit flag so that no linking occurs. + * Do not abort compiler, however, because it is better to keep going and + * find all the errors in a single compilation. + */ +void +error (int errcode, char *errmsg) +{ + fprintf (stderr, "Error on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], errmsg); + fflush (stderr); + errflag |= errcode; +} + + +/* WARN -- Output a warning message. Do not set exit flag since this is only + * a warning message; linking should occur if there are not any more serious + * errors. + */ +void +xpp_warn (char *warnmsg) +{ + fprintf (stderr, "Warning on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], warnmsg); + fflush (stderr); +} + + +/* ACCUM -- Code for conversion of numeric constants to decimal. Convert a + * character string to a binary integer constant, doing the conversion in the + * indicated base. + */ +long +accum (int base, char **strp) +{ + register char *ip; + long sum; + char digit; + + sum = 0; + ip = *strp; + + switch (base) { + case OCTAL: + case DECIMAL: + for (digit = *ip++; isdigit (digit); digit = *ip++) + sum = sum * base + (digit - '0'); + *strp = ip - 1; + break; + case HEX: + while ((digit = *ip++) != EOF) { + if (isdigit (digit)) + sum = sum * base + (digit - '0'); + else if (digit >= 'a' && digit <= 'f') + sum = sum * base + (digit - 'a' + 10); + else if (digit >= 'A' && digit <= 'F') + sum = sum * base + (digit - 'A' + 10); + else { + *strp = ip; + break; + } + } + break; + default: + error (XPP_COMPERR, "Accum: unknown numeric base"); + return (ERR); + } + + return (sum); +} + + +/* CHARCON -- Convert a character constant to a binary integer value. + * The regular escape sequences are recognized; numeric values are assumed + * to be octal. + */ +int +charcon (char *string) +{ + register char *ip, ch; + char *cc, *index(); + char *nump; + + ip = string + 1; /* skip leading apostrophe */ + ch = *ip++; + + /* Handle '\c' and '\0dd' notations. + */ + if (ch == '\\') { + if ((cc = index (esc_ch, *ip)) != NULL) { + return (esc_val[cc-esc_ch]); + } else if (isdigit (*ip)) { + nump = ip; + return (accum (OCTAL, &nump)); + } else + return (ch); + } else { + /* Regular characters, i.e., 'c'; just return ASCII value of char. + */ + return (ch); + } +} + + +/* INT_CONSTANT -- Called to decode an integer constant, i.e., a decimal, hex, + * octal, or sexagesimal number, or a character constant. The numeric string + * is converted in the indicated base and replaced by its decimal value. + */ +void +int_constant (char *string, int base) +{ + char decimal_constant[SZ_NUMBUF], *p; + long accum(), value; + int i; + + p = string; + i = strlen (string); + + switch (base) { + case DECIMAL: + value = accum (10, &p); + break; + case SEXAG: + value = accum (10, &p); + break; + case OCTAL: + value = accum (8, &p); + break; + case HEX: + value = accum (16, &p); + break; + + case CHARCON: + while ((p[i] = input()) != EOF) { + if (p[i] == '\n') { + error (XPP_SYNTAX, "Undelimited character constant"); + return; + } else if (p[i] == '\\') { + p[++i] = input(); + i++; + continue; + } else if (p[i] == '\'') + break; + i += 1; + } + value = charcon (p); + break; + + default: + error (XPP_COMPERR, "Unknown numeric base for integer conversion"); + value = ERR; + } + + /* Output the decimal value of the integer constant. We are simply + * replacing the SPP constant by a decimal constant. + */ + sprintf (decimal_constant, "%ld", value); + outstr (decimal_constant); +} + + +/* HMS -- Convert number in HMS format into a decimal constant, and output + * in that form. Successive : separated fields are scaled to 1/60 th of + * the preceeding field. Thus "12:30" is equivalent to "12.5". Some care + * is taken to preserve the precision of the number. + */ +void +hms (char *number) +{ + char cvalue[SZ_NUMBUF], *ip; + int bvalue, ndigits; + long scale = 10000000; + long units = 1; + long value = 0; + + for (ndigits=0, ip=number; *ip; ip++) + if (isdigit (*ip)) + ndigits++; + + /* Get the unscaled base value part of the number. */ + ip = number; + bvalue = accum (DECIMAL, &ip); + + /* Convert any sexagesimal encoded fields. */ + while (*ip == ':') { + ip++; + units *= 60; + value += (accum (DECIMAL, &ip) * scale / units); + } + + /* Convert the fractional part of the number, if any. + */ + if (*ip++ == '.') + while (isdigit (*ip)) { + units *= 10; + value += (*ip++ - '0') * scale / units; + } + + /* Format the output number. */ + if (ndigits > MIN_REALPREC) + sprintf (cvalue, "%d.%ldD0", bvalue, value); + else + sprintf (cvalue, "%d.%ld", bvalue, value); + cvalue[ndigits+1] = '\0'; + + /* Print the translated number. */ + outstr (cvalue); +} + + +/* + * Revision history (when i remembered) -- + * + * 14-Dec-82: Changed hms conversion, to produce degrees or hours, + * rather than seconds (lex pattern, add hms, delete ':' + * action from accum). + * + * 10-Mar-83 Broke C code and Lex code into separate files. + * Added support for error handling. + * Added additional type coercion functions. + * + * 20-Mar-83 Modified processing of TASK stmt to use file inclusion + * to read the RUNTASK file, making it possible to maintain + * the IRAF main as a .x file, rather than as a .r file. + * + * Dec-83 Fixed bug in processing of TASK stmt which prevented + * compilation of processes with many tasks. Added many + * comments and cleaned up the code a bit. + */ diff --git a/unix/boot/spp/xpp/xppcode.c.bak b/unix/boot/spp/xpp/xppcode.c.bak new file mode 100644 index 00000000..6db614bb --- /dev/null +++ b/unix/boot/spp/xpp/xppcode.c.bak @@ -0,0 +1,1705 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include "xpp.h" + +#define import_spp +#include + +/* + * C code for the first pass of the IRAF subset preprocessor (SPP). + * The decision to initially organize the SPP compiler into two passes was + * made to permit maximum use of the existing raftor preprocessor, which is + * the basis for the second pass of the SPP. Eventually the two passes + * should be combined into a single program. Most of the operations performed + * by the first pass (XPP) should be performed AFTER macro substitution, + * rather than before as is the case in the current implementation, which + * processes macros in the second pass (RPP). + * + * Beware that this is not a very good program which was not carefully + * designed and which was never intended to have a long lifetime. The next + * step is to replace the two passes by a single program which is functionally + * very similar, but which is more carefully engineered and which is written + * in the SPP language calling IRAF file i/o. Eventually a true compiler + * will be written, providing many new features, i.e., structures and pointers, + * automatic storage class, mapped arrays, enhanced i/o support, and good + * compile time error checking. This compiler will also feature a table driven + * code generator (generating primitive Fortran statements), which will provide + * greater machine independence. + */ + + +extern char *vfn2osfn(); + +/* Escape sequence characters and their binary equivalents. + */ +char *esc_ch = "ntfr\\\"'"; +char *esc_val = "\n\t\f\r\\\"\'"; + +/* External and internal data stuctures. We need access to the LEX i/o + * buffers because we use the LEX i/o macros, which provide pushback, + * because we must change the streams to process includes, and so on. + * These definitions are VERY Lex dependent. + */ +extern char yytext[]; /* LEX character buffer */ +extern int yyleng; /* length of string in yytext */ +extern FILE *yyin, *yyout; /* LEX input, output files */ + +extern char yytchar, *yysptr, yysbuf[]; +extern int yylineno; + +#define U(x) x +/* +#define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10\ +?(yylineno++,yytchar):yytchar)==EOF?0:yytchar) +#define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;} +*/ + +extern int input(); +extern void yyunput(); +extern char *yytext_ptr; +#define unput(c) yyunput( c, (yytext_ptr) ) + + + +int context = GLOBAL; /* lexical context variable */ +extern int hbindefs, foreigndefs; +char *machdefs[] = { "mach.h", "config.h", "" }; + +/* The task structure is used for TASK declarations. Since this is a + * throwaway program we do not bother with dynamic storage allocation, + * which would remove the limit on the number of tasks in a task statment. + */ +struct task { + char *task_name; /* logical task name */ + char *proc_name; /* name of procedure */ + short name_offset; /* offset of name in dictionary */ +}; + +/* The string structure is used for STRING declarations and for inline + * strings. Strings are stored in a fixed size, statically allocated + * string buffer. + */ +struct string { + char *str_name; /* name of string */ + char *str_text; /* ptr to text of string */ + short str_length; /* length of string */ +}; + +struct task task_list[MAX_TASKS]; +struct string string_list[MAX_STRINGS]; + +FILE *istk[MAX_INCLUDE]; /* stack for input file descriptors */ +int linenum[MAX_INCLUDE]; /* line numbers in files */ +char fname[MAX_INCLUDE][SZ_PATHNAME];/* file names */ +int istkptr = 0; /* istk pointer */ + +char obuf[SZ_OBUF]; /* buffer for body of procedure */ +char dbuf[SZ_DBUF]; /* buffer for misc proc. decls. */ +char sbuf[SZ_SBUF]; /* string buffer */ +char *sp = sbuf; /* string buffer pointer */ +char *op = obuf; /* pointer in output buffer */ +char *dp = dbuf; /* pointer in decls buffer */ +int nstrings = 0; /* number of strings so far */ +int strloopdecl; /* data dummy do index declared? */ + +int ntasks = 0; /* number of tasks in interpreter */ +int str_idnum = 0; /* for generating unique string names */ +int nbrace = 0; /* must be zero when "end" is reached */ +int nswitch = 0; /* number switch stmts in procedure */ +int errflag; +int errhand = NO; /* set if proc employs error handler */ +int errchk = NO; /* set if proc employs error checking */ + + +/* SKIPNL -- Skip to newline, e.g., when a comment is encountered. + */ +skipnl() +{ + int c; + while ((c=input()) != '\n') + ; + unput ('\n'); +} + + +/* + * CONTEXT -- Package for setting, saving, and restoring the lexical context. + * The action of the preprocessor in some cases depends upon the context, i.e., + * what type of statement we are processing, whether we are in global space, + * within a procedure, etc. + */ + +#define MAX_CONTEXT 5 /* max nesting of context */ + +int cntxstk[MAX_CONTEXT]; /* for saving context */ +int cntxsp = 0; /* save stack pointer */ + + +/* SETCONTEXT -- Set the context. Clears any saved context. + */ +setcontext (new_context) +int new_context; +{ + context = new_context; + cntxsp = 0; +} + + +/* PUSHCONTEXT -- Push a temporary context. + */ +pushcontext (new_context) +int new_context; +{ + cntxstk[cntxsp++] = context; + context = new_context; + + if (cntxsp > MAX_CONTEXT) + error (XPP_COMPERR, "save context stack overflow"); +} + + +/* POPCONTEXT -- Pop the former context. If the current context is PROCSTMT + * (just finished compiling a procedure statement) then set the context to DECL + * to indicate that we are entering the declarations section of a procedure. + */ +popcontext() +{ + if (context & PROCSTMT) { + context = DECL; + if (cntxsp > 0) + --cntxsp; + } else if (cntxsp > 0) + context = cntxstk[--cntxsp]; + + return (context); +} + + +/* Keyword table. The simple hashing scheme requires that the keywords appear + * in the table in sorted order. + */ +#define LEN_KWTBL 18 + +struct { + char *keyw; /* keyword name string */ + short opcode; /* opcode from above definitions */ + short nelem; /* number of table elements to skip if + * to get to next character class. + */ +} kwtbl[] = { + "FALSE", XTY_FALSE, 0, + "TRUE", XTY_TRUE, 0, + "bool", XTY_BOOL, 0, + "char", XTY_CHAR, 1, + "complex", XTY_COMPLEX, 0, + "double", XTY_DOUBLE, 0, + "error", XTY_ERROR, 1, + "extern", XTY_EXTERN, 0, + "false", XTY_FALSE, 0, + "iferr", XTY_IFERR, 2, + "ifnoerr", XTY_IFNOERR, 1, + "int", XTY_INT, 0, + "long", XTY_LONG, 0, + "pointer", XTY_POINTER, 1, + "procedure", XTY_PROC, 0, + "real", XTY_REAL, 0, + "short", XTY_SHORT, 0, + "true", XTY_TRUE, 0, + }; + +/* short kwindex[30]; simple alphabetic hash index */ +/* #define CINDEX(ch) (isupper(ch)?ch-'A':ch-'a') */ + +#define MAXCH 128 +short kwindex[MAXCH]; /* simple alphabetic hash index */ +#define CINDEX(ch) (ch) + + +/* HASHTBL -- Hash the keyword table. Initializes the "kwindex" hash table. + * For each character in the alphabet, the index gives the index into the + * sorted keyword table. If there is no keyword name beginning with the index + * character, the index entry is set to -1. + */ +hashtbl() +{ + int i, j; + + for (i=j=0; i <= MAXCH; i++) { + if (i == CINDEX (kwtbl[j].keyw[0])) { + kwindex[i] = j; + j = min (LEN_KWTBL-1, j + kwtbl[j].nelem + 1); + } else + kwindex[i] = -1; + } +} + + +/* FINDKW -- Lookup an indentifier in the keyword table. Return the opcode + * of the keyword, or ERR if no match. + */ +findkw() +{ + register char ch, *p, *q; + int i, ilimit; + + if (kwindex[0] == 0) + hashtbl(); + + i = CINDEX (yytext[0]); + if (i < 0 || i >= MAXCH || (i = kwindex[i]) < 0) + return (ERR); + ilimit = i + kwtbl[i].nelem; + + for (; i <= ilimit; i++) { + p = kwtbl[i].keyw + 1; + q = yytext + 1; + + for (; *p != EOS; q++, p++) { + ch = *q; + /* 5DEC95 - Don't case convert keywords. + if (isupper (ch)) + ch = tolower (ch); + */ + if (*p != ch) + break; + } + if (*p == EOS && *q == EOS) + return (kwtbl[i].opcode); + } + return (ERR); +} + + +/* MAPIDENT -- Lookup an identifier in the keyword table. If the identifier is + * not a keyword, output it as is. If a datatype keyword, the action depends + * on whether we are in a procedure body or not (i.e., whether the keyword + * begins a declaration or is a type coercion function). Most of the other + * keywords are mapped into special x$.. identifiers for further processing + * by the second pass. + */ +mapident() +{ + int i, findkw(); + char *str_fetch(); + register char *ip, *op; + + /* If not keyword and not defined string, output as is. The first + * char must be upper case for the name to be recognized as that of + * a defined string. If we are processing a "define" macro expansion + * is disabled. + */ + if ((i = findkw()) == ERR) { + if (!isupper(yytext[0]) || (context & DEFSTMT) || + (ip = str_fetch (yytext)) == NULL) { + + outstr (yytext); + return; + + } else { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + do_string ('"', STR_DEFINE); + return; + } + } + + /* If datatype keyword, call do_type. */ + if (i <= XTY_POINTER) { + do_type (i); + return; + } + + switch (i) { + case XTY_TRUE: + outstr (".true."); + break; + case XTY_FALSE: + outstr (".false."); + break; + case XTY_IFERR: + case XTY_IFNOERR: + outstr (yytext); + errhand = YES; + errchk = YES; + break; + case XTY_ERROR: + outstr (yytext); + errchk = YES; + break; + + case XTY_EXTERN: + /* UNREACHABLE (due to decl.c additions). + */ + outstr ("x$extn"); + break; + + default: + error (XPP_COMPERR, "Keyword lookup error"); + } +} + + +char st_buf[SZ_STBUF]; +char *st_next = st_buf; + +struct st_def { + char *st_name; + char *st_value; +} st_list[MAX_DEFSTR]; + +int st_nstr = 0; + +/* STR_ENTER -- Enter a defined string into the string table. The string + * table is a kludge to provide the capability to define strings in SPP. + * The problem is that XPP handles strings but RPP handles macros, hence + * strings cannot be defined. We get around this by recognizing defines + * of the form 'define NAME "..."'. If a macro with a quoted value is + * encounted we are called to enter the name and the string into the + * table. LOOKUP, above, subsequently searches the table for defined + * strings. The name must be upper case or the table will not be searched. + * + * N.B.: we are called by the lexical analyser with 'define name "' in + * yytext. The next input() will return the first char of the string. + */ +str_enter() +{ + register char *ip, *op, ch; + register struct st_def *s; + register int n; + char name[SZ_FNAME+1]; + + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Do not accept statement unless the name is upper case. + */ + if (!isupper (*ip)) { + outstr (yytext); + return; + } + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op = EOS; + + /* Check for a redefinition. */ + for (n=st_nstr, s=st_list, ch=name[0]; --n >= 0; s++) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, name) == 0) + break; + } + + /* Make a new entry?. */ + if (n < 0) { + s = &st_list[st_nstr++]; + if (st_nstr >= MAX_DEFSTR) + error (XPP_COMPERR, "Too many defined strings"); + + /* Put defined NAME in string buffer. */ + for (s->st_name = st_next, ip=name; *st_next++ = *ip++; ) + ; + } + + /* Put value in string buffer. + */ + s->st_value = st_next; + traverse ('"'); + for (ip=yytext; (*st_next++ = *ip++) != EOS; ) + ; + *st_next++ = EOS; + + if (st_next - st_buf >= SZ_STBUF) + error (XPP_COMPERR, "Too many defined strings"); +} + + +/* STR_FETCH -- Search the defined string table for the named string + * parameter and return a pointer to the string if found, NULL otherwise. + */ +char * +str_fetch (strname) +register char *strname; +{ + register struct st_def *s = st_list; + register int n = st_nstr; + register char ch = strname[0]; + + while (--n >= 0) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, strname) == 0) + return (s->st_value); + s++; + } + + return (NULL); +} + + +/* MACRO_REDEF -- Redefine the macro to automatically add a P2 macro + * to struct definitions. + */ +macro_redef () +{ + register int n; + register char *ip, *op, ch; + char name[SZ_FNAME]; + char value[SZ_LINE]; + + + outstr ("define\t"); + memset (name, 0, SZ_FNAME); + memset (value, 0, SZ_LINE); + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op++ = '\t'; + *op = EOS; + outstr (name); + + + /* Modify value. + */ + outstr ("Memr(P2R"); + while ( (ch = input()) != EOF ) { + if (ch == '\n') { + break; + } else if (ch == '#') { /* eat a comment */ + while ((ch = input()) != '\n') + ; + break; + } else if (ch == '[') { + outstr ("("); + } else if (ch == ']') { + outstr (")"); + } else { + char chr[2]; + chr[0] = ch; chr[1] = '\0'; + outstr (chr); + } + } + + outstr (")\n"); + linenum[istkptr]++; +} + + +/* SETLINE -- Set the file line number. Used by the first pass to set + * line number after processing an include file and in various other + * places. Necessary to get correct line numbers in error messages from + * the second pass. + */ +setline() +{ + char msg[20]; + + if (istkptr == 0) { /* not in include file */ + sprintf (msg, "#!# %d\n", linenum[istkptr] - 1); + outstr (msg); + } +} + + +/* OUTPUT -- Output a character. If we are processing the body of a procedure + * or a data statement, put the character into the output buffer. Otherwise + * put the character to the output file. + * + * NOTE -- the redirection logic shown below is duplicated in OUTSTR. + */ +output (ch) +char ch; +{ + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + *op++ = ch; + if (op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + *dp++ = ch; + if (dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + putc (ch, yyout); + } +} + + +/* Datatype keywords for declarations. The special x$.. keywords are + * for communication with the second pass. Note that this table is machine + * dependent, since it maps char into type short. + */ +char *type_decl[] = RPP_TYPES; + + +/* Intrinsic functions used for type coercion. These mappings are machine + * dependent (MACHDEP). If your machine has INTEGER*2 and INTEGER*4, and + * integer cannot be passed as an argument when a short or long is expected, + * and your compiler has INT2 and INT4 type coercion intrinsic functions, + * you should use those here instead of INT (which happens to work for a VAX). + * If you cannot pass an int when a short is expected (i.e., IBM), and you + * do not have an INT2 intrinsic function, you should provide an external + * INTEGER*2 function called "int2" and use that for type coercion. Note + * that it will then be necessary to have the preprocessor automatically + * generate a declaration for the function. This nonsense will all go away + * when we set up a proper table driven code generator!! + */ +char *intrinsic_function[] = { + "", /* table is one-indexed */ + "(0 != ", /* bool(expr) */ + "int", /* char(expr) */ + "int", /* short(expr) */ + "int", /* int(expr) */ + "int", /* long(expr) */ + "real", /* real(expr) */ + "dble", /* double(expr) */ + "cmplx", /* complex(expr) */ + "int" /* pointer(expr) */ +}; + + +/* DO_TYPE -- Process a datatype keyword. The type of processing depends + * on whether we are called when processing a declaration or an expression. + * In expressions, the datatype keyword is the type coercion intrinsic + * function. DEFINE statements are a special case; we treat them as + * expressions, since macros containing datatype keywords are used in + * expressions more than in declarations. This is a kludge until the problem + * is properly resolved by processing macros BEFORE code generation. + * In the current implementation, macros are handled by the second pass (RPP). + */ +do_type (type) +int type; +{ + char ch; + + if (context & (BODY|DEFSTMT)) { + switch (type) { + case XTY_BOOL: + for (ch=input(); ch == ' ' || ch == '\t'; ch=input()) + ; + if (ch != '(') + error (XPP_SYNTAX, "Illegal boolean expr"); + outstr (intrinsic_function[type]); + return; + + case XTY_CHAR: + case XTY_SHORT: + case XTY_INT: + case XTY_LONG: + case XTY_REAL: + case XTY_DOUBLE: + case XTY_COMPLEX: + case XTY_POINTER: + outstr (intrinsic_function[type]); + return; + + default: + error (XPP_SYNTAX, "Illegal type coercion"); + } + + } else { + /* UNREACHABLE when in declarations section of a procedure. + */ + fprintf (yyout, type_decl[type]); + } +} + + +/* DO_CHAR -- Process a char array declaration. Add "+1" to the first + * dimension to allow space for the EOS. Called after LEX has recognized + * "char name[". If we reach the closing ']', convert it into a right paren + * for the second pass. + */ +do_char() +{ + char ch; + + for (ch=input(); ch != ',' && ch != ']'; ch=input()) + if (ch == '\n' || ch == EOS) { + error (XPP_SYNTAX, "Missing comma or ']' in char declaration"); + unput ('\n'); + return; + } else + output (ch); + + outstr ("+1"); + if (ch == ']') + output (')'); + else + output (ch); +} + + +/* SKIP_HELPBLOCK -- Skip over a help block (documentation section). + */ +skip_helpblock() +{ + char ch; + + + /* fgets() no longer works with FLEX + while (fgets (yytext, SZ_LINE, yyin) != NULL) { + if (istkptr == 0) + linenum[istkptr]++; + + if (yytext[0] == '.' && (yytext[1] == 'e' || yytext[1] == 'E')) { + yytext[8] = EOS; + if (strcmp (&yytext[1], "endhelp") == 0 || + strcmp (&yytext[1], "ENDHELP") == 0) + break; + } + } + */ + + while ( (ch = input()) != EOF ) { + if (ch == '.') { /* check for ".endhelp" */ + ch = input (); + if (ch == 'e' || ch == 'E') { + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + break; + } else + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + + } else if (ch == '\n') { /* skip line */ + ; + } else { + for (ch=input(); ch != '\n' && ch != EOS; ch=input()) + ; + } + if (istkptr == 0) + linenum[istkptr]++; + } +} + + +/* PARSE_TASK_STATEMENT -- Parse the task statement, building up a list + * of task_name/procedure_name structures in the "task_list" array. + * + * task task1, task2, task3=proc3, task4, ... + * + * Task names are placed in the string buffer as one big string, with EOS + * delimiters between the names. This "dictionary" string is converted + * into a data statement at "end_code" time, along with any other strings + * in the runtask procedure. The procedure names, which may differ from + * the task names, are saved in the upper half of the output buffer. We can + * do this because we know that the runtask procedure is small and will not + * come close to filling up the output buffer, which buffers only the body + * of the procedure currently being processed. + * N.B.: Upon entry, the input is left positioned to just past the "task" + * keyword. + */ +parse_task_statement() +{ + register struct task *tp; + register char ch, *ip; + char task_name[SZ_FNAME], proc_name[SZ_FNAME]; + int name_offset; + + /* Set global pointers to where we put task and proc name strings. + */ + sp = sbuf; + op = &obuf[SZ_OBUF/2]; + name_offset = 1; + + for (ntasks=0; ntasks < MAX_TASKS; ntasks++) { + /* Process "taskname" or "taskname=procname". There must be + * at least one task name in the declaration. + */ + if (get_task (task_name, proc_name, SZ_FNAME) == ERR) + return (ERR); + + /* Set up the task declaration structure, and copy name strings + * into the string buffers. + */ + tp = &task_list[ntasks]; + tp->task_name = sp; + tp->proc_name = op; + tp->name_offset = name_offset; + name_offset += strlen (task_name) + 1; + + for (ip=task_name; (*sp++ = *ip++) != EOS; ) + if (sp >= &sbuf[SZ_SBUF]) + goto err; + for (ip=proc_name; (*op++ = *ip++) != EOS; ) + if (op >= &obuf[SZ_OBUF]) + goto err; + + /* If the next character is a comma, skip it and a newline if + * one follows and continue processing. If the next character is + * a newline, we are done. Any other character is an error. + * Note that nextch skips whitespace and comments. + */ + ch = nextch(); + if (ch == ',') { + if ((ch = nextch()) != '\n') + unput (ch); + } else if (ch == '\n') { + linenum[istkptr]++; + ntasks++; /* end of task statement */ + break; + } else + return (ERR); + } + + if (ntasks >= MAX_TASKS) { +err: error (XPP_COMPERR, "too many tasks in task statement"); + return (ERR); + } + + /* Set up the task name dictionary string so that it gets output + * as a data statement when the runtask procedure is output. + */ + string_list[0].str_name = "dict"; + string_list[0].str_text = sbuf; + string_list[0].str_length = (sp - sbuf); + nstrings = 1; + + /* Leave the output buffer pointer pointing to the first half of + * the buffer. + */ + op = obuf; + return (OK); +} + + +/* GET_TASK -- Process a single task declaration of the form "taskname" or + * "taskname = procname". + */ +get_task (task_name, proc_name, maxch) +char *task_name; +char *proc_name; +int maxch; +{ + register char ch; + + /* Get task name. + */ + if (get_name (task_name, maxch) == ERR) + return (ERR); + + /* Get proc name if given, otherwise the procedure name is assumed + * to be the same as the task name. + */ + if ((ch = nextch()) == '=') { + if (get_name (proc_name, maxch) == ERR) + return (ERR); + } else { + unput (ch); + strncpy (proc_name, task_name, maxch); + } + + return (XOK); +} + + +/* GET_NAME -- Extract identifier from input, placing in the output string. + * ERR is returned if the output string overflows, or if the token is not + * a legal identifier. + */ +get_name (outstr, maxch) +char *outstr; +int maxch; +{ + register char ch, *op; + register int nchars; + + unput ((ch = nextch())); /* skip leading whitespace */ + + for (nchars=0, op=outstr; nchars < maxch; nchars++) { + ch = input(); + if (isalpha(ch)) { + if (isupper(ch)) + *op++ = tolower(ch); + else + *op++ = ch; + } else if ((isdigit(ch) && nchars > 0) || ch == '_' || ch == '$') { + *op++ = ch; + } else { + *op++ = EOS; + unput (ch); + return (nchars > 0 ? XOK : ERR); + } + } + + return (ERR); +} + + +/* NEXTCH -- Get next nonwhite character from the input stream. Ignore + * comments. Newline is not considered whitespace. + */ +nextch() +{ + register char ch; + + while ((ch = input()) != EOF) { + if (ch == '#') { /* discard comment */ + while ((ch = input()) != '\n') + ; + return (ch); + } else if (ch != ' ' && ch != '\t') + return (ch); + } + return (EOF); +} + + +/* PUT_DICTIONARY -- We are called when the keyword TN$DECL is encountered, + * i.e., while processing "sysruk.x". This should only happen after the + * task statement has been successfully processed. Our function is to replace + * the TN$DECL macro by the declarations for the DP and DICT structures. + * DP is an integer array giving the offsets of the task name strings in DICT, + * the dictionary string buffer. + */ +#define NDP_PERLINE 8 /* num DP data elements per line */ + +put_dictionary() +{ + register struct task *tp; + char buf[SZ_LINE]; + int i, j, offset; + + /* Discard anything found on line after the TN$DECL, which is only + * recognized as the first token on the line. + */ + while (input() != '\n') + ; + unput ('\n'); + + /* Output the data statements required to initialize the DP array. + * These statements are spooled into the output buffer and not output + * until all declarations have been processed, since the Fortran std + * requires that data statements follow declarations. + */ + pushcontext (DATASTMT); + tp = task_list; + + for (j=0; j <= ntasks; j += NDP_PERLINE) { + if (!strloopdecl++) { + pushcontext (DECL); + sprintf (buf, "%s\tiyy\n", type_decl[TY_INT]); + outstr (buf); + popcontext(); + } + + sprintf (buf, "data\t(dp(iyy),iyy=%2d,%2d)\t/", + j+1, min (j+NDP_PERLINE, ntasks+1)); + outstr (buf); + + for (i=j; i < j+NDP_PERLINE && i <= ntasks; i++) { + offset = (tp++)->name_offset; + if (i >= ntasks) + sprintf (buf, "%2d/\n", XEOS); + else if (i == j + NDP_PERLINE - 1) + sprintf (buf, "%4d/\n", offset==EOS ? XEOS: offset); + else + sprintf (buf, "%4d,", offset==EOS ? XEOS: offset); + outstr (buf); + } + } + + popcontext(); + + /* Output type declarations for the DP and DICT arrays. The string + * descriptor for string 0 (dict) was prepared when the TASK statement + * was processed. + */ + sprintf (buf, "%s\tdp(%d)\n", type_decl[XTY_INT], ntasks + 1); + outstr (buf); + sprintf (buf, "%s\tdict(%d)\n", type_decl[XTY_CHAR], + string_list[0].str_length); + outstr (buf); +} + + +/* PUT_INTERPRETER -- Output the statements necessary to scan the dictionary + * for a task and call the associated procedure. We are called when the + * keyword TN$INTERP is encountered in the input stream. + */ +put_interpreter() +{ + char lbuf[SZ_LINE]; + int i; + + while (input() != '\n') /* discard rest of line */ + ; + unput ('\n'); + + for (i=0; i < ntasks; i++) { + sprintf (lbuf, "\tif (streq (task, dict(dp(%d)))) {\n", i+1); + outstr (lbuf); + sprintf (lbuf, "\t call %s\n", task_list[i].proc_name); + outstr (lbuf); + sprintf (lbuf, "\t return (OK)\n"); + outstr (lbuf); + sprintf (lbuf, "\t}\n"); + outstr (lbuf); + } +} + + +/* OUTSTR -- Output a string. Depending on the context, the string will + * either go direct to the output file, or will be buffered in the output + * buffer. + */ +outstr (string) +char *string; +{ + register char *ip; + + + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + for (ip=string; (*op++ = *ip++) != EOS; ) + ; + if (--op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + for (ip=string; (*dp++ = *ip++) != EOS; ) + ; + if (--dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + fputs (string, yyout); + } +} + + +/* BEGIN_CODE -- Code that gets executed when the keyword BEGIN is encountered, + * i.e., when we begin processing the executable part of a procedure + * declaration. + */ +begin_code() +{ + char text[1024]; + + /* If we are already processing the body of a procedure, we probably + * have a missing END. + */ + if (context & BODY) + xpp_warn ("Unmatched BEGIN statement"); + + /* Set context flag noting that we are processing the body of a + * procedure. Output the BEGIN statement, for the benefit of the + * second pass (RPP), which needs to know where the procedure body + * begins. + */ + setcontext (BODY); + d_runtime (text); outstr (text); + outstr ("begin\n"); + linenum[istkptr]++; + + /* Initialization. */ + nbrace = 0; + nswitch = 0; + str_idnum = 1; + errhand = NO; + errchk = NO; +} + + +/* END_CODE -- Code that gets executed when the keyword END is encountered + * in the input. If error checking is used in the procedure, we must declare + * the boolean function XERPOP. If any switches are employed, we must declare + * the switch variables. Next we format and output data statements for any + * strings encountered while processing the procedure body. If the procedure + * being processed is sys_runtask, the task name dictionary string is also + * output. Finally, we output the spooled procedure body, followed by and END + * statement for the benefit of the second pass. + */ +end_code() +{ + int i; + + /* If the END keyword is encountered outside of the body of a + * procedure, we leave it alone. + */ + if (!(context & BODY)) { + outstr (yytext); + return; + } + + /* Output argument and local variable declarations (see decl.c). + * Note d_enter may have been called during processing of the body + * of a procedure to make entries in the symbol table for intrinsic + * functions, switch variables, etc. (this is not currently done). + */ + d_codegen (yyout); + + setcontext (GLOBAL); + + /* Output declarations for error checking and switches. All variables + * and functions must be declared. + */ + if (errhand) + fprintf (yyout, "x$bool xerpop\n"); + if (errchk) + fprintf (yyout, "errchk error, erract\n"); + errhand = NO; + errchk = NO; + + if (nswitch) { /* declare switch variables */ + fprintf (yyout, "%s\t", type_decl[XTY_INT]); + for (i=1; i < nswitch; i++) + fprintf (yyout, "SW%04d,", i); + fprintf (yyout, "SW%04d\n", i); + } + + /* Output any miscellaneous declarations. These include ERRCHK and + * COMMON declarations - anything not a std type declaration or a + * data statement declaration. + */ + *dp++ = EOS; + fputs (dbuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_DBUF; ) dbuf[i++] = '\0'; } + dp = dbuf; + + /* Output the SAVE statement, which must come after all declarations + * and before any DATA statements. + */ + fputs ("save\n", yyout); + + /* Output data statements to initialize character strings, followed + * by any runtime procedure entry initialization statments, followed + * by the spooled text in the output buffer, followed by the END. + * Clear the string and output buffers. Any user data statements + * will already have been moved into the output buffer, and they + * will come out at the end of the declarations section regardless + * of where they were given in the declarations section. Data stmts + * are not permitted in the procedure body. + */ + init_strings(); + *op++ = EOS; + fputs (obuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_OBUF; ) obuf[i++] = '\0'; } + fputs ("end\n", yyout); fflush (yyout); + + op = obuf; + *op = EOS; + sp = sbuf; + + if (nbrace != 0) { + error (XPP_SYNTAX, "Unmatched brace"); + nbrace = 0; + } +} + + +#define BIG_STRING 9 +#define NPERLINE 8 + +/* INIT_STRINGS -- Output data statements to initialize all strings in a + * procedure ("string" declarations, inline strings, and the runtask + * dictionary). Strings are implemented as integer arrays, using the + * smallest integer datatype provided by the host Fortran compiler, usually + * INTEGER*2 (XTY_CHAR). + */ +init_strings() +{ + register int str; + + if (nstrings) + for (str=0; str < nstrings && !strloopdecl; str++) + if (string_list[str].str_length >= BIG_STRING) { + fprintf (yyout, "%s\tiyy\n", type_decl[XTY_INT]); + strloopdecl++; + } + + for (str=0; str < nstrings; str++) + write_string_data_statement (&string_list[str]); + + sp = sbuf; /* clear string buffer */ + nstrings = 0; + strloopdecl = 0; +} + + +/* WRITE_STRING_DATA_STATEMENT -- Output data statement to initialize a single + * string. If short string, output a simple whole-array data statement + * that fits all on one line. Large strings are initialized with multiple + * data statements, each of which initializes a section of the string + * using a dummy subscript. This is thought to be more portable than + * a single large data statement with continuation, because the number of + * continuation cards permitted in a data statement depends on the compiler. + * The loop variable in an implied do loop in a data statement must be declared + * on some compilers (crazy but true). Determine if we will be generating any + * implied dos and declare the variable if so. + */ +write_string_data_statement (s) +struct string *s; +{ + register int i, len; + register char *ip; + char ch, *name; + int j; + + name = s->str_name; + ip = s->str_text; + len = s->str_length; + + if (len < BIG_STRING) { + fprintf (yyout, "data\t%s\t/", name); + for (i=0; i < len-1; i++) { + if ((ch = *ip++) == EOS) + fprintf (yyout, "%3d,", XEOS); + else + fprintf (yyout, "%3d,", ch); + } + fprintf (yyout, "%2d/\n", XEOS); + + } else { + for (j = 0; j < len; j += NPERLINE) { + fprintf (yyout, "data\t(%s(iyy),iyy=%2d,%2d)\t/", + name, j+1, min(j+NPERLINE, len)); + for (i=j; i < j+NPERLINE; i++) { + if (i >= len-1) { + fprintf (yyout, "%2d/\n", XEOS); + return; + } else if (i == j+NPERLINE-1) { + fprintf (yyout, "%3d/\n", ip[i]==EOS ? XEOS: ip[i]); + } else + fprintf (yyout, "%3d,", ip[i]==EOS ? XEOS: ip[i]); + } + } + } +} + + +/* DO_STRING -- Process a STRING declaration or inline string. Add a new + * string descriptor to the string list, copy text of string into sbuf, + * save name of string array in sbuf. If inline string, manufacture the + * name of the string array. + */ +do_string (delim, strtype) +char delim; /* char which delimits string */ +int strtype; /* string type */ +{ + register char ch, *ip; + register struct string *s; + int readstr = 1; + char *str_uniqid(); + + /* If we run out of space for string storage, print error message, + * dump string decls out early, clear buffer and continue processing. + */ + if (nstrings >= MAX_STRINGS) { + error (XPP_COMPERR, "Too many strings in procedure"); + init_strings(); + } + + s = &string_list[nstrings]; + + switch (strtype) { + + case STR_INLINE: + case STR_DEFINE: + /* Inline strings are implemented as Fortran arrays; generate a + * dummy name for the array and set up the descriptor. + * Defined strings are inline strings, but the name of the text of + * the string is already in yytext when we are called. + */ + s->str_name = sp; + for (ip = str_uniqid(); (*sp++ = *ip++) != EOS; ) + ; + sbuf_check(); + break; + + case STR_DECL: + /* String declaration. Read in name of string, used as name of + * Fortran array. + */ + ch = nextch(); /* skip whitespace */ + if (!isalpha (ch)) + goto sterr; + s->str_name = sp; + *sp++ = ch; + + /* Get rest of string name identifier. */ + while ((ch = input()) != EOF) { + if (isalnum(ch) || ch == '_') { + *sp++ = ch; + sbuf_check(); + } else if (ch == '\n') { +sterr: error (XPP_SYNTAX, "String declaration syntax"); + while (input() != '\n') + ; + unput ('\n'); + return; + } else { + *sp++ = EOS; + break; + } + } + + /* Advance to the ' or " string delimiter, in preparation for + * processing the string itself. If syntax error occurs, skip + * to newline to avoid spurious error messages. If the string + * is not quoted the string value field is taken to be the name + * of a string DEFINE. + */ + delim = nextch(); + + if (!(delim == '"' || delim == '\'')) { + register char *ip, *op; + int ch; + char *str_fetch(); + + /* Fetch name of defined macro into yytext. + */ + op = yytext; + *op++ = delim; + while ((ch = input()) != EOF) + if (isalnum(ch) || ch == '_') + *op++ = ch; + else + break; + unput (ch); + *op = EOS; + + /* Fetch body of string into yytext. + */ + if ((ip = str_fetch (yytext)) != NULL) { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + readstr = 0; + } else { + error (XPP_SYNTAX, + "Undefined macro referenced in string declaration"); + } + } + + break; + } + + /* Get the text of the string. Process escape sequences. String may + * not span multiple lines. In the case of a defined string, the text + * of the string will already be in yytext. + */ + s->str_text = sp; + if (readstr && strtype != STR_DEFINE) + traverse (delim); /* process string into yytext */ + strcpy (sp, yytext); + sp += yyleng + 1; + s->str_length = yyleng + 1; + sbuf_check(); + + /* Output array declaration for string. We want the declaration to + * go into the miscellaneous declarations buffer, so toggle the + * the context to DECL before calling OUTSTR. + */ + { + char lbuf[SZ_LINE]; + + pushcontext (DECL); + sprintf (lbuf, "%s\t%s(%d)\n", type_decl[XTY_CHAR], s->str_name, + s->str_length); + outstr (lbuf); + popcontext(); + } + + /* If inline string, replace the quoted string by the name of the + * string variable. This text goes into the output buffer, rather + * than directly to the output file as is the case with the declaration + * above. + */ + if (strtype == STR_INLINE || strtype == STR_DEFINE) + outstr (s->str_name); + + if (++nstrings >= MAX_STRINGS) + error (XPP_COMPERR, "Too many strings in procedure"); +} + + +/* DO_HOLLERITH -- Process and output a Fortran string. If the output + * compiler is Fortran 77, we output a quoted string; otherwise we output + * a hollerith string. Fortran (packed) strings appear in the SPP source + * as in the statement 'call_f77_sub (arg, *"any string", arg)'. Escape + * sequences are not recognized. + */ +do_hollerith() +{ + register char *op; + char strbuf[SZ_LINE], outbuf[SZ_LINE]; + int len; + + /* Read the string into strbuf. */ + for (op=strbuf, len=0; (*op = input()) != '"'; op++, len++) + if (*op == '\n' || *op == EOF) + break; + if (*op == '\n') + error (XPP_COMPERR, "Packed string not delimited"); + else + *op = EOS; /* delete delimiter */ + +#ifdef F77 + sprintf (outbuf, "\'%s\'", strbuf); +#else + sprintf (outbuf, "%dH%s", i, strbuf); +#endif + + outstr (outbuf); +} + + +/* SBUF_CHECK -- Check to see that the string buffer has not overflowed. + * It is a fatal error if it does. + */ +sbuf_check() +{ + if (sp >= &sbuf[SZ_SBUF]) { + error (XPP_COMPERR, "String buffer overflow"); + _exit (1); + } +} + + +/* STR_UNIQID -- Generate a unit identifier name for an inline string. + */ +char * +str_uniqid() +{ + static char id[] = "ST0000"; + + sprintf (&id[2], "%04d", str_idnum++); + return (id); +} + + +/* 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; + 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 */ + unput ('\n'); + xpp_warn ("Newline while processing string"); + break; + + } else if (*op == '\\') { + if ((*op = input()) == EOF) { + break; + } else if (*op == '\n') { + --op; /* explicit continuation */ + 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 = EOS; + yyleng = (op - yytext); +} + + +/* ERROR -- Output an error message and set exit flag so that no linking occurs. + * Do not abort compiler, however, because it is better to keep going and + * find all the errors in a single compilation. + */ +error (errcode, errmsg) +int errcode; +char *errmsg; +{ + fprintf (stderr, "Error on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], errmsg); + fflush (stderr); + errflag |= errcode; +} + + +/* WARN -- Output a warning message. Do not set exit flag since this is only + * a warning message; linking should occur if there are not any more serious + * errors. + */ +xpp_warn (warnmsg) +char *warnmsg; +{ + fprintf (stderr, "Warning on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], warnmsg); + fflush (stderr); +} + + +/* ACCUM -- Code for conversion of numeric constants to decimal. Convert a + * character string to a binary integer constant, doing the conversion in the + * indicated base. + */ +long +accum (base, strp) +int base; +char **strp; +{ + register char *ip; + long sum; + char digit; + + sum = 0; + ip = *strp; + + switch (base) { + case OCTAL: + case DECIMAL: + for (digit = *ip++; isdigit (digit); digit = *ip++) + sum = sum * base + (digit - '0'); + *strp = ip - 1; + break; + case HEX: + while ((digit = *ip++) != EOF) { + if (isdigit (digit)) + sum = sum * base + (digit - '0'); + else if (digit >= 'a' && digit <= 'f') + sum = sum * base + (digit - 'a' + 10); + else if (digit >= 'A' && digit <= 'F') + sum = sum * base + (digit - 'A' + 10); + else { + *strp = ip; + break; + } + } + break; + default: + error (XPP_COMPERR, "Accum: unknown numeric base"); + return (ERR); + } + + return (sum); +} + + +/* CHARCON -- Convert a character constant to a binary integer value. + * The regular escape sequences are recognized; numeric values are assumed + * to be octal. + */ +charcon (string) +char *string; +{ + register char *ip, ch; + char *cc, *index(); + char *nump; + + ip = string + 1; /* skip leading apostrophe */ + ch = *ip++; + + /* Handle '\c' and '\0dd' notations. + */ + if (ch == '\\') { + if ((cc = index (esc_ch, *ip)) != NULL) { + return (esc_val[cc-esc_ch]); + } else if (isdigit (*ip)) { + nump = ip; + return (accum (OCTAL, &nump)); + } else + return (ch); + } else { + /* Regular characters, i.e., 'c'; just return ASCII value of char. + */ + return (ch); + } +} + + +/* INT_CONSTANT -- Called to decode an integer constant, i.e., a decimal, hex, + * octal, or sexagesimal number, or a character constant. The numeric string + * is converted in the indicated base and replaced by its decimal value. + */ +int_constant (string, base) +char *string; +int base; +{ + char decimal_constant[SZ_NUMBUF], *p; + long accum(), value; + int i; + + p = string; + i = strlen (string); + + switch (base) { + case DECIMAL: + value = accum (10, &p); + break; + case SEXAG: + value = accum (10, &p); + break; + case OCTAL: + value = accum (8, &p); + break; + case HEX: + value = accum (16, &p); + break; + + case CHARCON: + while ((p[i] = input()) != EOF) { + if (p[i] == '\n') { + error (XPP_SYNTAX, "Undelimited character constant"); + return; + } else if (p[i] == '\\') { + p[++i] = input(); + i++; + continue; + } else if (p[i] == '\'') + break; + i += 1; + } + value = charcon (p); + break; + + default: + error (XPP_COMPERR, "Unknown numeric base for integer conversion"); + value = ERR; + } + + /* Output the decimal value of the integer constant. We are simply + * replacing the SPP constant by a decimal constant. + */ + sprintf (decimal_constant, "%ld", value); + outstr (decimal_constant); +} + + +/* HMS -- Convert number in HMS format into a decimal constant, and output + * in that form. Successive : separated fields are scaled to 1/60 th of + * the preceeding field. Thus "12:30" is equivalent to "12.5". Some care + * is taken to preserve the precision of the number. + */ +char * +hms (number) +char *number; +{ + char cvalue[SZ_NUMBUF], *ip; + int bvalue, ndigits; + long scale = 10000000; + long units = 1; + long value = 0; + + for (ndigits=0, ip=number; *ip; ip++) + if (isdigit (*ip)) + ndigits++; + + /* Get the unscaled base value part of the number. */ + ip = number; + bvalue = accum (DECIMAL, &ip); + + /* Convert any sexagesimal encoded fields. */ + while (*ip == ':') { + ip++; + units *= 60; + value += (accum (DECIMAL, &ip) * scale / units); + } + + /* Convert the fractional part of the number, if any. + */ + if (*ip++ == '.') + while (isdigit (*ip)) { + units *= 10; + value += (*ip++ - '0') * scale / units; + } + + /* Format the output number. */ + if (ndigits > MIN_REALPREC) + sprintf (cvalue, "%d.%dD0", bvalue, value); + else + sprintf (cvalue, "%d.%d", bvalue, value); + cvalue[ndigits+1] = '\0'; + + /* Print the translated number. */ + outstr (cvalue); +} + + +/* + * Revision history (when i remembered) -- + * + * 14-Dec-82: Changed hms conversion, to produce degrees or hours, + * rather than seconds (lex pattern, add hms, delete ':' + * action from accum). + * + * 10-Mar-83 Broke C code and Lex code into separate files. + * Added support for error handling. + * Added additional type coercion functions. + * + * 20-Mar-83 Modified processing of TASK stmt to use file inclusion + * to read the RUNTASK file, making it possible to maintain + * the IRAF main as a .x file, rather than as a .r file. + * + * Dec-83 Fixed bug in processing of TASK stmt which prevented + * compilation of processes with many tasks. Added many + * comments and cleaned up the code a bit. + */ diff --git a/unix/boot/spp/xpp/xppmain.c b/unix/boot/spp/xpp/xppmain.c new file mode 100644 index 00000000..766aa41d --- /dev/null +++ b/unix/boot/spp/xpp/xppmain.c @@ -0,0 +1,225 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include "xpp.h" +#include "../../bootProto.h" + +#define import_spp +#define import_knames +#include + +/* + * Main routine for the XPP preprocessor (first pass of the SPP compiler). + */ + +#define IRAFDEFS "host$hlib/iraf.h" + +int errflag; +int foreigndefs; +int hbindefs = 0; +char irafdefs[SZ_PATHNAME]; +char *pkgenv = NULL; +char v_pkgenv[SZ_FNAME]; + +extern FILE *yyin; +extern FILE *yyout; +extern char fname[][SZ_PATHNAME]; +extern int linenum[]; +extern char *vfn2osfn(); +extern char *os_getenv(); +char *dottor(); + +extern void ZZSTRT (void); +extern void ZZSTOP (void); +extern int yylex (void); + +static int isxfile (char *fname); + + +int main (int argc, char *argv[]) +{ + int i, rfflag, nfiles; + FILE *fp_defs, *source; + char *p; + + ZZSTRT(); + + errflag = XPP_OK; + linenum[0] = 1; + rfflag = NO; + nfiles = 0; + + /* Process flags and count the number of files. + */ + for (i=1; argv[i] != NULL; i++) { + if (argv[i][0] == '-') { + switch (argv[i][1]) { + case 'R': + /* Write .r file. */ + rfflag = YES; + break; + case 'r': + /* Not used anymore */ + if ((p = argv[++i]) == NULL) + --i; + break; + case 'h': + /* Use custom irafdefs file. */ + if ((p = argv[++i]) == NULL) + --i; + else { + foreigndefs++; + strcpy (irafdefs, p); + } + break; + case 'A': + /* Use architecture-specific include file. */ + hbindefs++; + break; + case 'p': + /* Load the environment for the named package. */ + if ((pkgenv = argv[++i]) == NULL) + --i; + else + loadpkgenv (pkgenv); + break; + default: + fprintf (stderr, "unknown option '%s'\n", argv[i]); + fflush (stderr); + } + } else if (isxfile (argv[i])) + nfiles++; + } + + /* If no package environment was specified on the command line, + * check if the user has a default package set in their environment. + */ + if (!pkgenv) { + if ((pkgenv = os_getenv("PKGENV"))) { + strcpy (v_pkgenv, pkgenv); + loadpkgenv (pkgenv = v_pkgenv); + } + } + + /* Generate pathname of . + */ + if (!foreigndefs) + strcpy (irafdefs, vfn2osfn (IRAFDEFS,0)); + + /* Process either the standard input or a list of files. + */ + if (nfiles == 0) { + yyin = stdin; + yyout = stdout; + strcpy (fname[0], "STDIN"); + yylex(); + + } else { + /* Preprocess each file. + */ + for (i=1; argv[i] != NULL; i++) + if (isxfile (argv[i])) { + if (nfiles > 1) { + fprintf (stderr, "%s:\n", argv[i]); + fflush (stderr); + } + + /* Open source file. + */ + if ((source = fopen (vfn2osfn(argv[i],0), "r")) == NULL) { + fprintf (stderr, "cannot read file %s\n", argv[i]); + fflush (stderr); + errflag |= XPP_BADXFILE; + } else { + /* Open output file. + */ + if (rfflag) { + char *osfn; + osfn = vfn2osfn (dottor (argv[i]), 0); + if ((yyout = fopen (osfn, "w")) == NULL) { + fprintf (stderr, + "cannot write output file %s\n", osfn); + fflush (stderr); + errflag |= XPP_BADXFILE; + fclose (yyin); + continue; + } + } else + yyout = stdout; + + /* Open and process hlib$iraf.h. + */ + if ((fp_defs = fopen (irafdefs, "r")) == NULL) { + fprintf (stderr, "cannot open %s\n", irafdefs); + ZZSTOP(); + exit (XPP_COMPERR); + } + yyin = fp_defs; + yylex(); + linenum[0] = 1; + fclose (fp_defs); + + /* Process the source file. + */ + strcpy (fname[0], argv[i]); + yyin = source; + yylex(); + fclose (source); + + if (rfflag) + fclose (yyout); + } + } + } + + ZZSTOP(); + exit (errflag); + + return (0); +} + + +/* ISXFILE -- Does the named file have a ".x" extension. + */ +static int +isxfile (char *fname) +{ + char *p; + + if (fname[0] != '-') { + for (p=fname; *p++ != EOS; ) + ; + while (*--p != '.' && p >= fname) + ; + if (*p == '.' && *(p+1) == 'x') + return (YES); + } + return (NO); +} + + +/* DOTTOR -- Change the extension of the named file to ".r". + */ +char * +dottor (fname) +char *fname; +{ + static char rfname[SZ_PATHNAME+1]; + char *ip, *op, *lastdot; + + lastdot = NULL; + for (ip=fname, op=rfname; (*op = *ip++); op++) + if (*op == '.') + lastdot = op; + + if (lastdot) { + *(lastdot+1) = 'r'; + *(lastdot+2) = EOS; + } + + return (rfname); +} diff --git a/unix/boot/spp/xpp/zztest.x b/unix/boot/spp/xpp/zztest.x new file mode 100644 index 00000000..9cf695b0 --- /dev/null +++ b/unix/boot/spp/xpp/zztest.x @@ -0,0 +1,19 @@ +include + +define FOO Memr[Memi[$1+12]] # test comment + +define BAR Memr[$1] +define BAR1 Memr[$1+1] +define BAR2 Memr[TEST($1)] + +define FOOBAR Memr[$1] + +procedure hello() + +pointer xs, xe +define XS Memr[xs+($1)-1] +define XE Memr[xe+($1)-1] + +begin + call printf ("hello, world: %d\n", FOO(1)) +end diff --git a/unix/boot/vmcached/README b/unix/boot/vmcached/README new file mode 100644 index 00000000..6844153c --- /dev/null +++ b/unix/boot/vmcached/README @@ -0,0 +1,17 @@ +VMCACHED -- VMcache daemon. + +The VMcache daemon is a Unix server which manages a file cache in virtual +memory. This is used to optimize virtual memory usage, allowing files to +be cached in memory so that they can be shared or accessed without going +to disk. It is also possible to conditionally access files via "direct +i/o", bypassing system virtual memory and transferring the data directly +from disk to or from process memory. + +NOTE: as of Dec 2001, the Vmcache library and vmcached have been updated +to provide the capabilites described above. The daemon runs, and was used +to develop the VM client interface, which is currently functional, tested, +and installed in os$zfiobf.c. The new version of the VMcache library +however, has not yet been fully tested and should not be used. + +Since this code is still under development it is not part of the normal +IRAF build (hence no mkpkg or mkpkg.sh). diff --git a/unix/boot/vmcached/notes b/unix/boot/vmcached/notes new file mode 100644 index 00000000..f5da300b --- /dev/null +++ b/unix/boot/vmcached/notes @@ -0,0 +1,364 @@ +Virtual Memory Caching Scheme +Mon Oct 25 1999 - Thu Jan 20 2000 + + +OVERVIEW [now somewhat dated] + +Most modern Unix systems implement ordinary file i/o by mapping files into +host memory, faulting the file pages into memory, and copying data to and +from process memory and the cached file pages. This has the effect of +caching recently read file data in memory. This scheme replaces the old +Unix buffer cache, with the advantage that there is no builtin limit on +the size of the cache. The global file cache is shared by both data files +and the file pages of executing programs, and will grow until all physical +memory is in use. + +The advantage of the virtual memory file system (VMFS) is that it makes +maximal use of system memory for caching file data. If a relatively static +set of data is repeatedly accessed it will remain in the system file cache, +speeding access and minimizing i/o and page faulting. The disadvantage +is the same thing: VMFS makes maximal use of system memory for caching +file data. Programs which do heavy file i/o, reading a large amount of +data, fault in a great deal of file data pages which may only be accessed +once. Once the free list is exhausted the system page daemon runs to +reclaim old file pages for reuse. The system pages heavily and becomes +inefficient. + +The goal of the file caching scheme presented here is to continue to cache +file data in the global system file cache, but control how data is cached to +minimize use of the pageout daemon which runs when memory is exhausted. This +scheme makes use of the ** existing operating system kernel facilities ** +to cache the file data and use the cached data for general file access. +The trick is to try to control how data is loaded into the cache, and when +it is removed from the cache, so that cache space is reused efficiently +without invoking the system pageout daemon. Since data is cached by the +system the cache benefits all programs which access the cached file data, +without requiring that the programs explicitly use any cache facilities +such as a custom library. + + +HOW IT WORKS + + +INTERFACE + + + vm = vm_initcache (initstr) + vm_closecache (vm) + + vm_cachefile (vm, fname, flags) + vm_cachefd (vm, fd, flags) + vm_uncachefile (vm, fname) + vm_uncachefd (vm, fd) + + vm_cacheregion (vm, fd, offset, nbytes, flags) + vm_uncacheregion (vm, fd, offset, nbytes) + vm_reservespace (vm, nbytes) + vm_sync (vm, fd) + + +vm_cacheregion (vm, fd, offset, nbytes, flags) + + check whether the indicated region is mapped (vm descriptor) + if not, free space from the tail of the cache; map new region + request that mapped region be faulted into memory (madvise) + move referenced file to head of cache + + redundant requests are harmless, but will reload any missing pages, + and cause the file to again be moved to the head of the cache list + + may need to scan the cache periodically to make adjustments for + files that have changed in size, or been deleted, while still in + the cache + + cached regions may optionally be locked into memory until freed + + the cache controller may function either as a library within a process, + or as a cache controller server process shared by multiple processes + + +vm_uncacheregion (vm, fd, offset, nbytes) + + check whether the indicated region is mapped + if so, unmap the pages + if no more pages remain mapped, remove file from cache list + + +vm_reservespace (vm, nbytes) + + unmap file segments from tail of list until the requested space + (plus some extra space) is available for reuse + + +data structures + + caching mechanism is file-oriented + linked list of mapped regions (each from a file) + for each region keep track of file descriptor, offset, size + linked list of file descriptors + for each file keep track of file size, mtime, + type of mapping (full,region) and so on + + some dynamic things such as the size of a file or wether pages are memory + resident can only be determined by querying the system at runtime + + + +Solaris VM Interface + + madvise (addr, len, advice) + mmap (addr, len, prot, flags, fildes, off) + munmap (addr, len) + mlock (addr, len) + munlock (addr, len) + memcntl (addr, len, cmd, arg, attr, mask) + mctl (addr, len, function, arg) + mincore (addr, len, *vec) + msync (addr, len, flags) + + Notes + Madvise can be used to request that a range of pages be faulted + into memory (WILL_NEED), or freed from memory (DONT_NEED) + + Mctl can be used to invalidate page mappings in a region + + Mincore can be used to determine if pages in a given address range + are resident in memory + + + +VMCACHED -- December 2001 +------------------------------ + +Added VMcache daemon and IRAF interface to same +Design notes follow + + +Various Cache Control Algorithms + + 1. No Cache + + No VMcache daemon. Clients use their builtin default i/o mechanism, + e.g., either normal or direct i/o depending upon the file size. + + 2. Manually or externally controlled cache + + Files are cached only when directed. Clients connect to the cache + daemon to see if files are in the cache and if so use normal VM i/o + to access data in the cache. If the file is not cached the client + uses its default i/o mechanism, e.g., direct i/o. + + 3. LRU Cache + + A client file access causes the accessed file to be cached. Normal + VM i/o is used for file i/o. As new files are cached the space + used by the least recently used files is reclaimed. Accessing a + file moves it to the head of the cache, if it is still in the cache. + Otherwise it is reloaded. + + 4. Adaptive Priority Cache + + This is like the LRU cache, but the cache keeps statistics on files + whether or not they have aged out of the cache, and raises the + cache priority or lifetime of files that are more frequently + accessed. Files that are only accessed once tend to pass quickly + through the cache, or may not even be cached until the second + access. Files that are repeatedly accessed have a higher priority + and will tend to stay in the cache. + +The caching mechanism and algorithm used are independent of the client +programs, hence can be easily tuned or replaced with a different algorithm. + +Factors determining if a file is cached: + + user-assigned priority (0=nocache; 1-N=cache priority) + number of references + time since last access (degrades nref) + amount of available memory (cutoff point) + +Cache priority + + priority = userpri * max(0, + (nref-refbase - ((time - last_access) / tock)) ) + +Tunable parameters + + userpri User defined file priority. Files with a higher + priority stay in the cache longer. A zero priority + prevents a file from being cached. + + refbase The number of file references has to exceed refbase + before the file will be cached. For example, if + refbase=0 the file will be cacheable on the first + reference. If refbase=1 a file will only become + cacheable if accessed two or more times. Refbase + can be used to exclude files from the cache that + are only referenced once and hence are not worth + caching. + + tock While the number of accesses increases the cache + priority of a file, the time interval since the + last access likewise decreases the cache priority + of the file. A time interval of "tock" seconds + will cancel out one file reference. In effect, + tock=N means that a file reference increases the + cache priority of a file for N seconds. A + frequently referenced file will be relatively + unaffected by tock, but tock will cause + infrequently referenced files to age out of the + cache within a few tocks. + +Cache Management + + Manual cache control + + Explicitly caching or refreshing a file always maps the file into + memory and moves it to the head of the cache. + + File access + + Accessing a file (vm_accessfile) allows cache optimization to + occur. The file nref and access time are updated and the priority + of the current file and all files (to a certain depth in the cache + list) are recomputed. If a whole-file level access is being + performed the file size is examined to see if it has changed and + if the file has gotten larger a new segment is created. The + segment descriptor is then unlinked and relinked in the cache in + cache priority order. If the segment is above the VM cutoff it + is loaded into the cache: lower priority segments are freed as + necessary, and if the file is an existing file it is marked + WILL_NEED to queue the file data to be read into memory. + + If the file is a new file it must already have been created + externally to be managed under VMcache. The file size at access + time will determine the size of the file entry in the cache. Some + systems (BSD, Sun) allow a mmap to extend beyond the end of a + file, but others (Linux) do not. To reserve space for a large + file where the ultimate size of the file is known in advance, one + can write a byte where the last byte of the file will be (as with + zfaloc in IRAF) before caching the file, and the entire memory + space will be reserved in advance. If a file is cached and later + extended, re-accessing the file will automatically cache the new + segment of the file (see above). + + Data structures + + Segment descriptors + List of segments linked in memory allocation order + first N segments are cached (whatever will fit) + remainder are maintained in list, but are not cached + manually cached/refreshed segments go to head of list + accessed files are inserted in list based on priority + List of segments belonging to the same file + a file can be stored in the cache in multiple segments + + File hash table + provides fast lookup of an individual file + hash dev+ino to segment + segment points to next segment if collision occurs + only initial/root file segment is indexed + + Cache management + + Relinking of the main list occurs only in certain circumstances + when a segment is manually cached/uncached/refreshed + referenced segment moves to head of list + new segment is always cached + when a file or segment is accessed + priority of each element is computed and segment is + placed in priority order (only referenced segment is moved) + caching/uncaching may occur due to new VM cutoff + when a new segment is added + when an old segment is deleted + Residency in memory is determined by link order + priority normally determines memory residency + but manual caching will override (for a time) + + +File Driver Issues + + Image kernels + + Currently only OIF uses the SF driver. FXF, STF, and QPF (FMIO) + all use the BF driver. Some or all could be changed to use SF + if it is made compatible with BF, otherwrise the VM hooks need + to go into the BF driver. Since potentially any large file can + be cached, putting the VM support into BF is a reasonable option. + + The FITS kernel is a problem currently as it violates device + block size restrictions, using a block size of 2880. + + It is always a good idea to use falloc to pre-allocate storage for + a large imagefile when the size is known in advance. This permits + the VM system to reserve VM space for a new image before data is + written to the file. + + Direct I/O + + Direct i/o is possible only if transfers are aligned on device + blocks and are an integral number of blocks in length. + + Direct i/o flushes any VM buffered data for the file. If a file + is mapped into memory this is not possible, hence direct i/o is + disabled for a file while it is mapped into memory. + + This decision is made at read/write time, hence cannot be + determined reliably when a file is opened. + + FITS Kernel + + Until the block size issues can be addressed, direct i/o cannot + be used for FITS images. Some VM cache control is still possible + however. Options include: + + o Always cache a .fits image: either set vmcached to cache a file + on the first access, or adjust the cache parameters based on + the file type. Use a higher priority for explicitly cached + files (e.g. Mosaic readouts), so that running a sequence of + normal i/o images through the cache does not flush the high + priority images. + + o Writing to new files which have not been pre-allocated is + problematic as a large amount of data can be written, causing + paging. One way to deal with this is to use large transfers + (IMIO will already do this), and to issue a reservespace + directive on each file write at EOF, to free up VM space as + needed. The next access directive would cause the new + portion of the image to be mapped into the cache. + + A possible problem with this is that the new file may initially + be too small to reach the cache threshold. Space could be + reserved in any case, waiting for the next access to cache + the file; the cache daemon could always cache new files of a + certain type; or the file could be cached when it reaches the + cache threshold. + + Kernel File Driver + + A environment variable will be used in the OS driver to define a + cache threshold or to disable use of VMcache entirely. We need + to be able to specify these two things separately. If a cache + threshold is set, files smaller than this size will not result in + a query to the cache daemon. If there is no cache threshold but + VMcache is enabled, the cache daemon will decide whether the file + is too small to be cached. It should also be possible to force + the use of direct i/o if the file is larger than a certain size. + + Kernel file driver parameters: + + enable boolean + + vmcache Use vmcache only if the file size equals or exceeds + the specified threshold. + + directio If the file size equals or exceeds the specified + threshold use direct i/o to access the file. If + direct i/o is enabled in this fashion then vmcache + is not used (otherwise vmcache decides whether to + use direct i/o for a file). + + port Socket number to be used. + + VMPORT=8797 + VMCLIENT=enable,threshold=10m,directio=10m + diff --git a/unix/boot/vmcached/vmcache.c b/unix/boot/vmcached/vmcache.c new file mode 100644 index 00000000..a072951f --- /dev/null +++ b/unix/boot/vmcached/vmcache.c @@ -0,0 +1,1566 @@ +#include +#include +#include +#include +#include +#include +#include +#include "vmcache.h" + +#ifdef sun +#ifndef MS_SYNC +#define MS_SYNC 0 /* SunOS */ +#else +#include +#endif +#endif + +/* + * Virtual Memory Cache Controller + * + * The VM cache controller manages a region of physical memory in the host + * computer. Entire files or file segments are loaded into the cache (into + * memory). Space to store such files is made available by the cache + * controller by freeing the least recently used file segments. This explicit + * freeing of space immediately before it is reused for new data prevents + * (in most cases) the kernel reclaim page daemon from running, causing cached + * data to remain in memory until freed, and preventing the flow of data + * through the cache from causing the system to page heavily and steal pages + * away from the region of memory outside the cache. + * + * vm = vm_initcache (vm|NULL, initstr) + * vm_status (vm, outbuf, maxch, flags) + * vm_closecache (vm) + * + * vm_access (vm, fname, mode, flags) + * vm_statfile (vm, fname, flags) + * vm_setpriority (vm, fname, priority) + * vm_cachefile (vm, fname, flags) + * vm_uncachefile (vm, fname, flags) + * vm_refreshfile (vm, fname, flags) + * vm_cachefd (vm, fd, acmode, flags) + * vm_uncachefd (vm, fd, flags) + * vm_refreshfd (vm, fd, flags) + * + * vm_reservespace (vm, nbytes) + * addr = vm_cacheregion (vm, fname, fd, offset, nbytes, acmode, flags) + * vm_uncacheregion (vm, fd, offset, nbytes, flags) + * vm_refreshregion (vm, fd, offset, nbytes) + * + * vm_sync (vm, fd, offset, nbytes, flags) + * vm_msync (vm, addr, nbytes, flags) + * + * Before the VM cache is used it should be initialized with vm_initcache. + * The string "initstr" may be used to set the size of the cache, enable + * or disable it (e.g. for performance tests), and set other options. + * A summary of the VMcache configuration and contents can be generated + * with vm_status. + * + * Files or file segments are loaded into the cache with routines such as + * vm_cachefile and vm_cacheregion. Normally, cached files or file segments + * are reused on a least-recently-used basis. A file can be locked in the + * cache by setting the VM_LOCKFILE flag when the file is cached. This is + * automatic for vm_cacheregion since the address at which the file is + * mapped is returned to the caller and hence the file is assumed to be in + * use. When a file or region which is locked in the cache is no longer + * needed one of the "uncache" routines should be called to make the space + * used by the cached file data available for reuse. Note that "uncaching" + * a file or file segment does not immediately remove the data from the + * cache. Any "uncached" data normally remains in the cache until the + * space it uses is needed to load other data. + * + * VMcache is a library which is compiled into a process. This can be + * incorportated into a server process to manage the VM cache for a + * group of cooperating processes running on the same computer. The + * vmcached program (VMcache daemon) is one such program. + */ + + +#define DEF_CACHESIZE "50%" +#define DEF_PHYSPAGES 32768 +#define READAHEAD 32768 +#define DEF_PRIORITY 1 +#define DEF_REFBASE 1 +#define DEF_TOCK 600 +#define SZ_HASHTBL 16384 +#define SZ_NAME 64 +#define SZ_VALSTR 64 +#define SZ_PATHNAME 1024 +#define SZ_LINE 4096 + +/* Solaris and FreeBSD have a madvise() system call. */ +#define HAVE_MADVISE 1 + +/* Linux provides a madvise call, but it is not implemented and produces + * a linker warning message. The madvise call will always fail, but this + * is harmless (it just means that the cache fails to control paging and + * everything operates "normally". + */ +#ifdef linux +#undef HAVE_MADVISE +#define MADV_WILLNEED 3 /* will need these pages */ +#define MADV_DONTNEED 4 /* don't need these page */ +#endif + +#define isfile(sp,st) (sp->device == st.st_dev && sp->inode == st.st_ino) + + +/* Segment descriptor. */ +struct segment { + struct segment *next; + struct segment *prev; + struct segment *nexthash; + int priority; + int userpri; + int refcnt; + int nrefs; + time_t atime; + time_t ptime; + void *addr; + int fd; + int acmode; + unsigned long inode; + unsigned long device; + unsigned long offset; + unsigned long nbytes; + char *fname; +}; typedef struct segment Segment; + +/* Main VMcache descriptor. */ +struct vmcache { + Segment *segment_head, *last_mapped, *segment_tail; + int cache_initialized; + int cache_enabled; + int cachelen; + unsigned long cacheused; + unsigned long cachesize; + unsigned long physmem; + int lockpages; + int pagesize; + int defuserpri; + int refbase; + int tock; +}; typedef struct vmcache VMcache; + +static debug = 0; +static VMcache vmcache; +static Segment *hashtbl[SZ_HASHTBL]; + +static int primes[] = { + 101,103,107,109,113,127,131,137,139, + 149,151,157,163,167,173,179,181,191, +}; + +static vm_readahead(); +static vm_uncache(); +static Segment *vm_locate(); +static int vm_cachepriority(); +static int hashint(); + + +/* VM_INITCACHE -- Initialize the VM cache. A pointer to the cache + * descriptor is returned as the function value, or NULL if the cache cannot + * be initialized. The argument VM may point to an existing cache which + * is to be reinitialized, or may be NULL if the cache is being initialized + * for the first time. + * + * The INITSTR argument is used to control all init-time cache options. + * INITSTR is a sequence of keyword=value substrings. The recognized options + * are as follows: + * + * cachesize total cache size + * lockpages lock pages in memory + * enable enable the cache + * debug turn on debug messages + * defpri default file priority + * refbase number of file references before file is cached + * tock interval (seconds) at which file references degrade + * + * Other options may be added in the future. + * + * Keywords which take a size type value (e.g. cachesize) permit values + * such as "x" (size in bytes), "x%" (X percent of physical memory), "xK" + * (X kilobytes), or "xM" (X megabytes). The "x%" notation may not work + * correctly on all systems as it is not always easy to determine the total + * physical memory. + * + * If the cache is initialized with "enable=no" then all the cache routines + * will still be called, the cache controller will be disabled. + */ +void * +vm_initcache (vm, initstr) +register VMcache *vm; +char *initstr; +{ + register char *ip, *op; + char keyword[SZ_NAME], valstr[SZ_NAME]; + char cachesize[SZ_VALSTR], *modchar; + int percent, enable = 1, lockpages = 0; + int defuserpri, refbase, tock; + unsigned long physpages; + + if (debug) + fprintf (stderr, "vm_initcache (0x%x, \"%s\")\n", vm, initstr); + + strcpy (cachesize, DEF_CACHESIZE); + defuserpri = DEF_PRIORITY; + refbase = DEF_REFBASE; + tock = DEF_TOCK; + + /* Scan the initialization string. Initstr may be NULL or the empty + * string, if only the defaults are desired. + */ + for (ip=initstr; ip && *ip; ) { + /* Advance to the next keyword=value pair. */ + while (*ip && (isspace(*ip) || *ip == ',')) + ip++; + + /* Extract the keyword. */ + for (op=keyword; *ip && isalnum(*ip); ) + *op++ = *ip++; + *op = '\0'; + + while (*ip && (isspace(*ip) || *ip == '=')) + ip++; + + /* Extract the value string. */ + for (op=valstr; *ip && (isalnum(*ip) || *ip == '%'); ) + *op++ = *ip++; + *op = '\0'; + + if (strcmp (keyword, "cachesize") == 0) { + strcpy (cachesize, valstr); + } else if (strcmp (keyword, "defpri") == 0) { + defuserpri = atoi (valstr); + } else if (strcmp (keyword, "refbase") == 0) { + refbase = atoi (valstr); + } else if (strcmp (keyword, "tock") == 0) { + tock = atoi (valstr); + } else if (strcmp (keyword, "lockpages") == 0) { + int ch = valstr[0]; + lockpages = (ch == 'y' || ch == 'Y'); + } else if (strcmp (keyword, "enable") == 0) { + int ch = valstr[0]; + enable = (ch == 'y' || ch == 'Y'); + } else if (strcmp (keyword, "debug") == 0) { + int ch = valstr[0]; + debug = (ch == 'y' || ch == 'Y'); + } + } + + /* The VM cache needs to be global for a given host, so we just + * use a statically allocated cache descriptor here. In the most + * general case the whole VMcache interface needs to be split into + * a client-server configuration, with the cache server managing + * virtual memory for a collection of processes. + */ + if (!vm) + vm = &vmcache; + + /* Shut down the old cache if already enabled. */ + vm_closecache (vm); + + /* There is no good way to guess the total physical memory if this + * is not available from the system. But in such a case the user + * can just set the value of the cachesize explicitly in the initstr. + */ +#ifdef _SC_PHYS_PAGES + physpages = sysconf (_SC_PHYS_PAGES); + if (debug) { + fprintf (stderr, "total physical memory %d (%dm)\n", + physpages * getpagesize(), + physpages * getpagesize() / (1024 * 1024)); + } +#else + physpages = DEF_PHYSPAGES; +#endif + + vm->cachelen = 0; + vm->cacheused = 0; + vm->cache_enabled = enable; + vm->cache_initialized = 1; + vm->segment_head = NULL; + vm->segment_tail = NULL; + vm->pagesize = getpagesize(); + vm->physmem = physpages * vm->pagesize; + vm->lockpages = lockpages; + vm->defuserpri = defuserpri; + vm->refbase = refbase; + vm->tock = tock; + + vm->cachesize = percent = strtol (cachesize, &modchar, 10); + if (modchar == cachesize) + vm->cachesize = physpages / 2 * vm->pagesize; + else if (*modchar == '%') + vm->cachesize = physpages * percent / 100 * vm->pagesize; + else if (*modchar == 'k' || *modchar == 'K') + vm->cachesize *= 1024; + else if (*modchar == 'm' || *modchar == 'M') + vm->cachesize *= (1024 * 1024); + else if (*modchar == 'g' || *modchar == 'G') + vm->cachesize *= (1024 * 1024 * 1024); + + return ((void *)vm); +} + + +/* VM_CLOSECACHE -- Forcibly shutdown a cache if it is already open. + * All segments are freed and returned to the system. An attempt is made + * to close any open files (this is the only case where the VM cache code + * closes files opened by the caller). + */ +vm_closecache (vm) +register VMcache *vm; +{ + register Segment *sp; + struct stat st; + + if (debug) + fprintf (stderr, "vm_closecache (0x%x)\n", vm); + if (!vm->cache_initialized) + return; + + /* Free successive segments at the head of the cache list until the + * list is empty. + */ + while (sp = vm->segment_head) { + vm_uncache (vm, sp, VM_DESTROYREGION | VM_CANCELREFCNT); + + /* Since we are closing the cache attempt to forcibly close the + * associated file descriptor if it refers to an open file. + * Make sure that FD refers to the correct file. + */ + if (fstat (sp->fd, &st) == 0) + if (isfile(sp,st)) + close (sp->fd); + } + + vm->cache_initialized = 0; +} + + +/* VM_ACCESS -- Access the named file and determine if it is in the cache. + * Accessing a file via vm_access may cause the file to be loaded into the + * cache, depending upon the cache tuning parameters and per-file statistics + * such as the number of past references to the file and how recently they + * occurred. A return value of -1 indicates that the named file does not + * exist or could not be physically accessed. A value of zero indicates + * that the file is not cached (is not being managed by the cache). A value + * of 1 indicates that the file is being managed by the cache. Accessing + * a file updates the reference count and time of last access of the file. + * and increases the probability that it will be cached in memory. + * + * Applications which use VMcache should call vm_access whenever a file is + * opened or otherwise accessed so that VMcache can keep statistics on file + * accesses and optimize use of the cache. If vm_access returns 1 the client + * should use normal i/o to access the file (normal VM-based file i/o or + * mmap). If vm_access returns 0 VMcache has determined that the file is + * not worth caching in memory, and some form of direct i/o (bypassing + * system virtual memory) should be used to access the file. + * + * The file must exist at the time that vm_access is called. If the file + * already exists and has changed size (e.g., data was appended to the file + * since the last access) then vm_access will add or remove VM segments to + * adjust to the new size of the file. If a new file is being created and + * it is desired to reserve VM space for the file, two approaches are + * possible: 1) use seek,write to write a byte where the EOF of the new + * file will be when all data has been written, so that vm_access will + * reserve space for the new file pages; 2) access the short or zero-length + * file, explicitly reserve unallocated VM space with vm_reservespace, + * and rely upon vm_access to adjust to the new file size the next time + * the file is accessed. Option 1) is the best technique for reserving VM + * space for large new files which may subsequently be shared by other + * applications. + */ +vm_access (vm, fname, mode, flags) +register VMcache *vm; +char *fname, *mode; +int flags; +{ + register Segment *sp, *xp; + Segment *first=NULL, *last=NULL; + unsigned long offset, x0, x1, vm_offset, vm_nbytes; + int spaceused, map, n, status=0, fd; + struct stat st; + + if (debug) + fprintf (stderr, "vm_access (0x%x, \"%s\", 0%o)\n", + vm, fname, flags); + if (!vm->cache_enabled) + return (0); + + if ((fd = open (fname, O_RDONLY)) < 0) + return (-1); + if (fstat (fd, &st) < 0) { +abort: close (fd); + return (-1); + } + + /* Align offset,nbytes to map the full file. */ + x0 = offset = 0; + x0 = (x0 - (x0 % vm->pagesize)); + x1 = offset + st.st_size - 1; + x1 = (x1 - (x1 % vm->pagesize)) + vm->pagesize - 1; + vm_offset = x0; + vm_nbytes = x1 - x0 + 1; + +again: + /* See if the file is already in the cache list. */ + first = last = vm_locate (vm, st.st_ino, st.st_dev); + for (sp = first; sp; sp = sp->nexthash) + if (isfile(sp,st)) + last = sp; + + /* If the file is already in the cache check whether it has changed + * size and adjust the segment descriptors until they agree with the + * current file size before we proceed further. + */ + if (last) { + if (vm_nbytes < (last->offset + last->nbytes)) { + /* If the file has gotten smaller uncache the last segment + * and start over. Repeat until the last segment includes EOF. + */ + vm_uncache (vm, last, VM_DESTROYREGION|VM_CANCELREFCNT); + goto again; + + } else if (vm_nbytes > (last->offset + last->nbytes)) { + /* If the file has gotten larger cache the new data as a new + * file segment. + */ + unsigned long offset, nbytes; + void *addr; + + offset = last->offset + last->nbytes; + nbytes = vm_nbytes - offset; + addr = vm_cacheregion (vm, fname, fd, + offset, nbytes, last->acmode, VM_DONTMAP); + if (!addr) + goto abort; + goto again; + } + /* else fall through */ + } else { + /* File is not currently in the cache. Create a new segment + * encompassing the entire file, but don't map it in yet. + */ + void *addr; + addr = vm_cacheregion (vm, fname, fd, + vm_offset, vm_nbytes, VM_READONLY, VM_DONTMAP); + if (!addr) + goto abort; + goto again; + } + + /* + * If we get here we have one or more file segments in the cache. + * The segments may or may not be mapped and they can be anywhere + * in the cache list. We need to compute the new priority for the + * file, relocate the segments in the cache, determine whether or + * not the file will be mapped, and adjust the contents of the + * cache accordingly. + */ + + /* Update the priority of the current file and give all cached file + * segments the same reference attributes, since we treating the + * entire file as a whole here. + */ + first = vm_locate (vm, st.st_ino, st.st_dev); + first->nrefs++; + first->atime = time(0); + first->priority = vm_cachepriority (vm, first); + + for (sp = first; sp; sp = sp->nexthash) + if (isfile(sp,st)) { + sp->nrefs = first->nrefs; + sp->atime = first->atime; + sp->priority = first->priority; + } + + /* Recompute the priorities of all other segments in the head or + * "active" area of the cache list. + */ + for (sp = vm->segment_head, n=0; sp; sp = sp->next, n++) { + if (!isfile(sp,st)) + sp->priority = vm_cachepriority (vm, sp); + if (sp == vm->last_mapped) + break; + } + for (sp = vm->last_mapped->next; --n >= 0 && sp; sp = sp->next) + if (!isfile(sp,st)) + sp->priority = vm_cachepriority (vm, sp); + + /* Scan the cache list and determine where in priority order to place + * the accessed segment. Since manually cached segments are always + * placed at the head of the list there is no guarantee that the cache + * list will be in strict priority order, but this doesn't matter. + */ + for (xp = vm->segment_head; xp; xp = xp->next) + if (first->priority >= xp->priority) + break; + + /* Relink each segment of the accessed file in just before the lower + * priority segment pointed to by XP. This collects all the file + * segments in allocation order within the list. + */ + for (sp=first; sp; sp = sp->nexthash) + if (isfile(sp,st)) { + /* Unlink segment SP. */ + if (sp->next) + sp->next->prev = sp->prev; + else + vm->segment_tail = sp->prev; + + if (sp->prev) + sp->prev->next = sp->next; + else + vm->segment_head = sp->next; + + /* Link segment SP in just before XP. */ + sp->next = xp; + if (xp) { + sp->prev = xp->prev; + sp->prev->next = sp; + } else { + /* XP is NULL; SP will be the new segment_tail. */ + sp->prev = vm->segment_tail; + vm->segment_tail = sp; + } + + /* If XP is at the list head SP replaces it at the head. */ + if (vm->segment_head == xp) + vm->segment_head = sp; + } + + /* Scan the new cache list to see if the accessed file is in the + * allocated portion of the list. + */ + for (sp = vm->segment_head, spaceused=map=0; sp; sp = sp->next) { + if (sp == first) { + map = (spaceused + vm_nbytes <= vm->cachesize); + break; + } else if (sp->addr && !isfile(sp,st)) { + spaceused += sp->nbytes; + if (spaceused >= vm->cachesize) + break; + } + } + + /* Map the file if it lies above the cutoff point. */ + if (map) { + /* Free sufficient memory pages for the new region. If space + * is already allocated to this file don't free it unnecessarily. + */ + for (sp = first, n=vm_nbytes; sp; sp = sp->nexthash) + if (isfile(sp,st) && sp->addr) + n -= sp->nbytes; + + if (n > 0) + vm_reservespace (vm, n); + + /* Map the accessed file segments. */ + for (sp = first, n=vm_nbytes; sp; sp = sp->nexthash) { + if (!isfile(sp,st)) + continue; + + if (!sp->addr) { + void *addr; + + addr = mmap (NULL, (size_t)sp->nbytes, + sp->acmode, MAP_SHARED, fd, (off_t)sp->offset); + if (!addr) { + map = 0; + break; + } + + /* Lock segment in memory if indicated. */ + if (vm->lockpages && vm->cache_enabled) + mlock (addr, (size_t) sp->nbytes); + + vm->cacheused += sp->nbytes; + sp->addr = addr; + } + + /* Preload the accessed file segment. */ + vm_readahead (vm, sp->addr, sp->nbytes); + } + + status = 1; + } + + close (fd); + return (status); +} + + +/* VM_STATFILE -- Determine if the named file is in the cache. A return + * value of -1 indicates that the named file does not exist or could not + * be accessed. A value of zero indicates that the file is not cached. + * A value of 1 or more indicates the number of file segments in the cache. + */ +vm_statfile (vm, fname) +register VMcache *vm; +char *fname; +{ + register Segment *sp; + struct stat st; + int status=0; + + if (debug) + fprintf (stderr, "vm_statfile (0x%x, \"%s\")\n", vm, fname); + if (!vm->cache_enabled) + return (0); + + if (stat (fname, &st) < 0) + return (-1); + + for (sp = vm_locate(vm,st.st_ino,st.st_dev); sp; sp = sp->nexthash) + if (isfile(sp,st)) + status++; + + return (status); +} + + +/* VM_SETPRIORITY -- Set the user-defined priority of a file already in the + * cache list from a prior access or cache call. If the file priority is + * zero it will never be cached in memory. A priority of 1 is neutral; + * higher values increase the cache priority of the file. + */ +vm_setpriority (vm, fname, priority) +register VMcache *vm; +char *fname; +int priority; +{ + register Segment *sp; + struct stat st; + int status=0; + + if (priority < 0) + priority = 0; + + if (debug) + fprintf (stderr, "vm_setpriority (0x%x, \"%s\", %d)\n", + vm, fname, priority); + if (!vm->cache_enabled) + return (0); + + if (stat (fname, &st) < 0) + return (-1); + + for (sp = vm_locate(vm,st.st_ino,st.st_dev); sp; sp = sp->nexthash) + if (isfile(sp,st)) + sp->userpri = priority; + + return (status); +} + + +/* VM_CACHEFILE -- Cache an entire named file in the VM cache. + */ +vm_cachefile (vm, fname, flags) +register VMcache *vm; +char *fname; +int flags; +{ + struct stat st; + int fd; + + if (debug) + fprintf (stderr, "vm_cachefile (0x%x, \"%s\", 0%o)\n", + vm, fname, flags); + if (!vm->cache_enabled) + return (0); + + if ((fd = open (fname, O_RDONLY)) < 0) + return (-1); + if (fstat (fd, &st) < 0) + return (-1); + + if (!vm_cacheregion (vm, fname, fd, 0L, st.st_size, VM_READONLY, 0)) { + close (fd); + return (-1); + } + + close (fd); + if (!(flags & VM_LOCKFILE)) + vm_uncachefile (vm, fname, 0); + + return (0); +} + + +/* VM_CACHEFD -- Cache an already open file in the VM cache. + */ +vm_cachefd (vm, fd, acmode, flags) +register VMcache *vm; +int acmode; +int flags; +{ + struct stat st; + + if (debug) + fprintf (stderr, "vm_cachefd (0x%x, %d, 0%o, 0%o)\n", + vm, fd, acmode, flags); + if (!vm->cache_enabled) + return (0); + + if (fstat (fd, &st) < 0) + return (-1); + + if (!vm_cacheregion (vm, NULL, fd, 0L, st.st_size, acmode, flags)) + return (-1); + + if (!(flags & VM_LOCKFILE)) + vm_uncachefd (vm, fd, 0); + + return (0); +} + + +/* VM_UNCACHEFILE -- Identify a cached file as ready for reuse. The file + * remains in the cache, but its space is available for reuse on a least + * recently used basis. If it is desired to immediately free the space used + * by cached file immediately the VM_DESTROYREGION flag may be set in FLAGS. + */ +vm_uncachefile (vm, fname, flags) +register VMcache *vm; +char *fname; +int flags; +{ + register Segment *sp; + struct stat st; + int status = 0; + + if (debug) + fprintf (stderr, "vm_uncachefile (0x%x, \"%s\", 0%o)\n", + vm, fname, flags); + if (!vm->cache_enabled) + return (0); + + if (stat (fname, &st) < 0) + return (-1); + + for (sp = vm_locate(vm,st.st_ino,st.st_dev); sp; sp = sp->nexthash) { + if (!isfile(sp,st)) + continue; + if (vm_uncache (vm, sp, flags) < 0) + status = -1; + } + + return (status); +} + + +/* VM_UNCACHEFD -- Uncache an entire file identified by its file descriptor. + * The file remains in the cache, but its space is available for reuse on a + * least recently used basis. If it is desired to immediately free the space + * used by cached file immediately the VM_DESTROYREGION flag may be set in + * FLAGS. + */ +vm_uncachefd (vm, fd, flags) +register VMcache *vm; +int fd; +int flags; +{ + register Segment *sp; + struct stat st; + int status = 0; + + if (debug) + fprintf (stderr, "vm_uncachefd (0x%x, %d, 0%o)\n", + vm, fd, flags); + if (!vm->cache_enabled) + return (0); + + if (fstat (fd, &st) < 0) + return (-1); + + for (sp = vm_locate(vm,st.st_ino,st.st_dev); sp; sp = sp->nexthash) { + if (!isfile(sp,st)) + continue; + if (vm_uncache (vm, sp, flags) < 0) + status = -1; + } + + return (status); +} + + +/* VM_REFRESHFILE -- Refresh an entire named file in the VM cache. + * If the file is not in the cache nothing is done and -1 is returned. + * If the file is cached it is refreshed, i.e., moved to the head of + * the cache, reloading any pages not already present in memory. + */ +vm_refreshfile (vm, fname, flags) +register VMcache *vm; +char *fname; +int flags; +{ + struct stat st; + int fd; + + if (debug) + fprintf (stderr, "vm_refreshfile (0x%x, \"%s\", 0%o)\n", + vm, fname, flags); + if (!vm->cache_enabled) + return (0); + + if ((fd = open (fname, O_RDONLY)) < 0) + return (-1); + if (fstat (fd, &st) < 0) + return (-1); + + if (!vm_refreshregion (vm, fd, 0L, st.st_size)) { + close (fd); + return (-1); + } + + close (fd); + return (0); +} + + +/* VM_REFRESHFD -- Refresh an already open file in the VM cache. + */ +vm_refreshfd (vm, fd, flags) +register VMcache *vm; +int fd; +int flags; +{ + struct stat st; + + if (debug) + fprintf (stderr, "vm_refreshfd (0x%x, %d, 0%o)\n", + vm, fd, flags); + if (!vm->cache_enabled) + return (0); + + if (fstat (fd, &st) < 0) + return (-1); + + if (!vm_refreshregion (vm, fd, 0L, st.st_size)) + return (-1); + + return (0); +} + + +/* VM_CACHEREGION -- Cache a region or segment of a file. File segments are + * removed from the tail of the LRU cache list until sufficient space is + * available for the new segment. The new file segment is then mapped and a + * request is issued to asynchronously read in the file data. The virtual + * memory address of the cached and mapped region is returned. + * + * File segments may be redundantly cached in which case the existing + * mapping is refreshed and the segment is moved to the head of the cache. + * Each cache operation increments the reference count of the region and + * a matching uncache is required to eventually return the reference count + * to zero allowing the space to be reused. vm_refreshregion can be called + * instead of cacheregion if all that is desired is to refresh the mapping + * and move the cached region to the head of the cache. A single file may + * be cached as multiple segments but the segments must be page aligned + * and must not overlap. The virtual memory addresses of independent segments + * may not be contiguous in virtual memory even though the corresponding + * file regions are. If a new segment overlaps an existing segment it must + * fall within the existing segment as the size of a segment cannot be changed + * once it is created. If a file is expected to grow in size after it is + * cached, the size of the cached region must be at least as large as the + * expected size of the file. + * + * vm_cacheregion can (should) be used instead of MMAP to map files into + * memory, if the files will be managed by the VM cache controller. Otherwise + * the same file may be mapped twice by the same process, which may use + * extra virtual memory. Only files can be mapped using vm_cacheregion, and + * all mappings are for shared data. + * + * If the cache is disabled vm_cacheregion will still map file segments into + * memory, and vm_uncacheregion will unmap them when the reference count goes + * to zero (regardless of whether the VM_DESTROYREGION flag is set if the + * cache is disabled). + * + * If write access to a segment is desired the file referenced by FD must + * have already been opened with write permission. + */ +void * +vm_cacheregion (vm, fname, fd, offset, nbytes, acmode, flags) +register VMcache *vm; +char *fname; +int fd; +unsigned long offset; +unsigned long nbytes; +int acmode, flags; +{ + register Segment *sp, *xp; + unsigned long x0, x1, vm_offset, vm_nbytes; + struct stat st; + int mode; + void *addr; + + if (debug) + fprintf (stderr, + "vm_cacheregion (0x%x, \"%s\", %d, %d, %d, 0%o, 0%o)\n", + vm, fname, fd, offset, nbytes, acmode, flags); + if (fstat (fd, &st) < 0) + return (NULL); + + /* Align offset,nbytes to fill the referenced memory pages. + */ + x0 = offset; + x0 = (x0 - (x0 % vm->pagesize)); + + x1 = offset + nbytes - 1; + x1 = (x1 - (x1 % vm->pagesize)) + vm->pagesize - 1; + + vm_offset = x0; + vm_nbytes = x1 - x0 + 1; + + /* Is this a reference to an already cached segment? + */ + for (sp = vm_locate(vm,st.st_ino,st.st_dev); sp; sp = sp->nexthash) { + if (!isfile(sp,st)) + continue; + + if (x0 >= sp->offset && x0 < (sp->offset + sp->nbytes)) + if (x1 >= sp->offset && x1 < (sp->offset + sp->nbytes)) { + /* New segment lies entirely within an existing one. */ + vm_offset = sp->offset; + vm_nbytes = sp->nbytes; + goto refresh; + } else { + /* New segment extends an existing one. */ + return (NULL); + } + } + + mode = PROT_READ; + if (acmode == VM_READWRITE) + mode |= PROT_WRITE; + + if (flags & VM_DONTMAP) + addr = NULL; + else { + /* Free sufficient memory pages for the new region. */ + vm_reservespace (vm, vm_nbytes); + + /* Map the new segment, reusing the VM pages freed above. */ + addr = mmap (NULL, + (size_t)vm_nbytes, mode, MAP_SHARED, fd, (off_t)vm_offset); + if (!addr) + return (NULL); + + /* Lock segment in memory if indicated. */ + if (vm->lockpages && vm->cache_enabled) + mlock (addr, (size_t) vm_nbytes); + + vm->cacheused += vm_nbytes; + } + + /* Get a segment descriptor for the new segment. */ + if (!(sp = (Segment *) calloc (1, sizeof(Segment)))) { + if (addr) + munmap (addr, vm_nbytes); + return (NULL); + } + + vm->cachelen++; + sp->fd = fd; + sp->acmode = acmode; + sp->inode = st.st_ino; + sp->device = st.st_dev; + sp->offset = vm_offset; + sp->nbytes = vm_nbytes; + sp->addr = addr; + sp->ptime = time(0); + sp->userpri = vm->defuserpri; + if (fname) { + sp->fname = (char *) malloc (strlen(fname)+1); + strcpy (sp->fname, fname); + } + + /* Set up the new segment at the head of the cache. */ + sp->next = vm->segment_head; + sp->prev = NULL; + if (vm->segment_head) + vm->segment_head->prev = sp; + vm->segment_head = sp; + + /* If there is nothing at the tail of the cache yet this element + * becomes the tail of the cache list. + */ + if (!vm->segment_tail) + vm->segment_tail = sp; + if (!vm->last_mapped) + vm->last_mapped = sp; + + /* Add the segment to the global file hash table. + */ + if (xp = vm_locate(vm,st.st_dev,st.st_ino)) { + /* The file is already in the hash table. Add the new segment + * to the tail of the file segment list. + */ + while (xp->nexthash) + xp = xp->nexthash; + xp->nexthash = sp; + + } else { + /* Add initial file segment to hash table. */ + int hashval; + + hashval = hashint (SZ_HASHTBL, (int)st.st_dev, (int)st.st_ino); + if (xp = hashtbl[hashval]) { + while (xp->nexthash) + xp = xp->nexthash; + xp->nexthash = sp; + } else + hashtbl[hashval] = sp; + } + +refresh: + /* Move a new or existing segment to the head of the cache and + * increment the reference count. Refresh the segment pages if + * indicated. + */ + if (vm->segment_head != sp) { + /* Unlink the list element. */ + if (sp->next) + sp->next->prev = sp->prev; + if (sp->prev) + sp->prev->next = sp->next; + + /* Link current segment at head of cache. */ + sp->next = vm->segment_head; + sp->prev = NULL; + if (vm->segment_head) + vm->segment_head->prev = sp; + vm->segment_head = sp; + + if (!vm->segment_tail) + vm->segment_tail = sp; + } + + /* Preload the referenced segment if indicated. */ + if (vm->cache_enabled && !(flags & VM_DONTMAP)) + vm_readahead (vm, addr, vm_nbytes); + + sp->refcnt++; + sp->nrefs++; + sp->atime = time(0); + sp->priority = vm_cachepriority (vm, sp); + + return ((void *)((char *)addr + (offset - vm_offset))); +} + + +/* VM_UNCACHEREGION -- Called after a vm_cacheregion to indicate that the + * cached region is available for reuse. For every call to vm_cacheregion + * there must be a corresponding call to vm_uncacheregion before the space + * used by the region can be reused. Uncaching a region does not immediately + * free the space used by the region, it merely decrements a reference + * count so that the region can later be freed and reused if its space is + * needed. The region remains in the cache and can be immediately reclaimed + * by a subequent vm_cacheregion. If it is known that the space will not + * be reused, it can be freed immediately by setting the VM_DESTROYREGION + * flag in FLAGS. + */ +vm_uncacheregion (vm, fd, offset, nbytes, flags) +register VMcache *vm; +int fd; +unsigned long offset; +unsigned long nbytes; +int flags; +{ + register Segment *sp; + unsigned long x0, x1, vm_offset, vm_nbytes; + struct stat st; + int mode; + + if (debug) + fprintf (stderr, "vm_uncacheregion (0x%x, %d, %d, %d, 0%o)\n", + vm, fd, offset, nbytes, flags); + + /* Map offset,nbytes to a range of memory pages. + */ + x0 = offset; + x0 = (x0 - (x0 % vm->pagesize)); + + x1 = offset + nbytes - 1; + x1 = (x1 - (x1 % vm->pagesize)) + vm->pagesize - 1; + + vm_offset = x0; + vm_nbytes = x1 - x0 + 1; + + if (fstat (fd, &st) < 0) + return (-1); + + /* Locate the referenced segment. */ + for (sp = vm_locate(vm,st.st_ino,st.st_dev); sp; sp = sp->nexthash) + if (isfile(sp,st) && (sp->offset == vm_offset)) + break; + if (!sp) + return (-1); /* not found */ + + return (vm_uncache (vm, sp, flags)); +} + + +/* VM_REFRESHREGION -- Refresh an already cached file region. The region is + * moved to the head of the cache and preloading of any non-memory resident + * pages is initiated. + */ +vm_refreshregion (vm, fd, offset, nbytes) +register VMcache *vm; +int fd; +unsigned long offset; +unsigned long nbytes; +{ + register Segment *sp; + unsigned long x0, x1, vm_offset, vm_nbytes; + struct stat st; + int mode; + void *addr; + + if (debug) + fprintf (stderr, "vm_refreshregion (0x%x, %d, %d, %d)\n", + vm, fd, offset, nbytes); + + if (!vm->cache_enabled) + return (0); + + /* Map offset,nbytes to a range of memory pages. + */ + x0 = offset; + x0 = (x0 - (x0 % vm->pagesize)); + + x1 = offset + nbytes - 1; + x1 = (x1 - (x1 % vm->pagesize)) + vm->pagesize - 1; + + vm_offset = x0; + vm_nbytes = x1 - x0 + 1; + + if (fstat (fd, &st) < 0) + return (-1); + + /* Locate the referenced segment. */ + for (sp = vm_locate(vm,st.st_ino,st.st_dev); sp; sp = sp->nexthash) + if (isfile(sp,st) && (sp->offset == vm_offset)) + break; + if (!sp) + return (-1); /* not found */ + + /* Relink the segment at the head of the cache. + */ + if (vm->last_mapped == sp && sp->prev) + vm->last_mapped = sp->prev; + + if (vm->segment_head != sp) { + /* Unlink the list element. */ + if (sp->next) + sp->next->prev = sp->prev; + if (sp->prev) + sp->prev->next = sp->next; + + /* Link current segment at head of cache. */ + sp->next = vm->segment_head; + sp->prev = NULL; + if (vm->segment_head) + vm->segment_head->prev = sp; + vm->segment_head = sp; + } + + sp->nrefs++; + sp->atime = time(0); + sp->priority = vm_cachepriority (vm, sp); + + /* Preload any missing pages from the referenced segment. */ + madvise (addr, vm_nbytes, MADV_WILLNEED); + + return (0); +} + + +/* VM_UNCACHE -- Internal routine to free a cache segment. + */ +static +vm_uncache (vm, sp, flags) +register VMcache *vm; +register Segment *sp; +int flags; +{ + register Segment *xp; + Segment *first, *last; + int hashval, status=0, mode; + + if (debug) + fprintf (stderr, "vm_uncache (0x%x, 0x%x, 0%o)\n", vm, sp, flags); + + /* Decrement the reference count. Setting VM_CANCELREFCNT (as in + * closecache) causes any references to be ignored. + */ + if (--sp->refcnt < 0 || (flags & VM_CANCELREFCNT)) + sp->refcnt = 0; + + /* If the reference count is zero and the VM_DESTROYREGION flag is + * set, try to free up the pages immediately, otherwise merely + * decrement the reference count so that it can be reused if it is + * referenced before the space it uses is reclaimed by another cache + * load. + */ + if (!sp->refcnt && ((flags & VM_DESTROYREGION) || !vm->cache_enabled)) { + if (vm->cache_enabled) + madvise (sp->addr, sp->nbytes, MADV_DONTNEED); + if (munmap (sp->addr, sp->nbytes) < 0) + status = -1; + vm->cacheused -= sp->nbytes; + + /* Remove the segment from the file hash table. */ + first = vm_locate (vm, sp->device, sp->inode); + hashval = hashint (SZ_HASHTBL, sp->device, sp->inode); + + for (xp=first, last=NULL; xp; last=xp, xp=xp->nexthash) + if (xp == sp) { + if (last) + last->nexthash = sp->nexthash; + if (hashtbl[hashval] == sp) + hashtbl[hashval] = sp->nexthash; + break; + } + + /* Update last_mapped if it points to this segment. */ + if (vm->last_mapped == sp && sp->prev) + vm->last_mapped = sp->prev; + + /* Unlink and free the segment descriptor. */ + if (sp->next) + sp->next->prev = sp->prev; + if (sp->prev) + sp->prev->next = sp->next; + if (vm->segment_head == sp) + vm->segment_head = sp->next; + if (vm->segment_tail == sp) + vm->segment_tail = sp->prev; + + if (sp->fname) + free (sp->fname); + free ((void *)sp); + vm->cachelen--; + } + + return (status); +} + + +/* VM_RESERVESPACE -- Free space in the cache, e.g. to create space to cache + * a new file or file segment. File segments are freed at the tail of the + * cache list until the requested space is available. Only segments which + * have a reference count of zero are freed. We do not actually remove + * segments from the cache here, we just free any mapped pages. + */ +vm_reservespace (vm, nbytes) +register VMcache *vm; +unsigned long nbytes; +{ + register Segment *sp; + unsigned long freespace = vm->cachesize - vm->cacheused; + int locked_segment_seen = 0; + + if (debug) + fprintf (stderr, "vm_reservespace (0x%x, %d)\n", vm, nbytes); + + if (!vm->cache_enabled) + return (0); + + for (sp = vm->last_mapped; sp; sp = sp->prev) { + freespace = vm->cachesize - vm->cacheused; + if (freespace > nbytes) + break; + + if (sp->refcnt) { + locked_segment_seen++; + continue; + } else if (!sp->addr) + continue; + + if (debug) + fprintf (stderr, "vm_reservespace: free %d bytes at 0x%x\n", + sp->nbytes, sp->addr); + + madvise (sp->addr, sp->nbytes, MADV_DONTNEED); + munmap (sp->addr, sp->nbytes); + vm->cacheused -= sp->nbytes; + sp->addr = NULL; + + if (sp == vm->last_mapped && !locked_segment_seen) + vm->last_mapped = sp->prev; + } + + return ((freespace >= nbytes) ? 0 : -1); +} + + +/* VM_STATUS -- Return a description of the status and contents of the VM + * cache. The output is written to the supplied text buffer. + */ +vm_status (vm, outbuf, maxch, flags) +register VMcache *vm; +char *outbuf; +int maxch, flags; +{ + register Segment *sp; + register char *op = outbuf; + char buf[SZ_LINE]; + int seg, nseg; + + sprintf (buf, "initialized %d\n", vm->cache_initialized); + strcpy (op, buf); op += strlen (buf); + + sprintf (buf, "enabled %d\n", vm->cache_enabled); + strcpy (op, buf); op += strlen (buf); + + sprintf (buf, "lockpages %d\n", vm->lockpages); + strcpy (op, buf); op += strlen (buf); + + sprintf (buf, "physmem %d\n", vm->physmem); + strcpy (op, buf); op += strlen (buf); + + sprintf (buf, "cachesize %d\n", vm->cachesize); + strcpy (op, buf); op += strlen (buf); + + sprintf (buf, "cacheused %d\n", vm->cacheused); + strcpy (op, buf); op += strlen (buf); + + sprintf (buf, "pagesize %d\n", vm->pagesize); + strcpy (op, buf); op += strlen (buf); + + for (nseg=0, sp = vm->segment_head; sp; sp = sp->next) + nseg++; + sprintf (buf, "nsegments %d\n", nseg); + strcpy (op, buf); op += strlen (buf); + + for (seg=0, sp = vm->segment_head; sp; sp = sp->next, seg++) { + sprintf (buf, "segment %d inode %d device %d ", + seg, sp->inode, sp->device); + sprintf (buf+strlen(buf), "offset %d nbytes %d refcnt %d %s\n", + sp->offset, sp->nbytes, sp->refcnt, + sp->fname ? sp->fname : "[done]"); + if (op-outbuf+strlen(buf) >= maxch) + break; + strcpy (op, buf); op += strlen (buf); + } + + return (op - outbuf); +} + + +/* VM_LOCATE -- Internal routine to locate the initial segment of a cached + * file given its device and inode. NULL is returned if the referenced file + * has no segments in the cache. + */ +static Segment * +vm_locate (vm, device, inode) +VMcache *vm; +register dev_t device; +register ino_t inode; +{ + register Segment *sp; + int hashval; + + hashval = hashint (SZ_HASHTBL, device, inode); + for (sp = hashtbl[hashval]; sp; sp = sp->nexthash) + if (sp->device == device && sp->inode == inode) + return (sp); + + return (NULL); +} + + +/* HASHINT -- Hash a pair of integer values. An integer hash value in the + * range 0-nthreads is returned. + */ +static int +hashint (nthreads, w1, w2) +int nthreads; +register int w1, w2; +{ + unsigned int h1, h2; + register int i=0; + + h1 = (((w1 >> 16) * primes[i++]) ^ (w1 * primes[i++])); + h2 = (((w2 >> 16) * primes[i++]) ^ (w2 * primes[i++])); + + return ((h1 ^ h2) % nthreads); +} + + +/* VM_CACHEPRIORITY -- Compute the cache priority of a file segment. Various + * heuristics are possible for computing the cache priority of a segment. + * The one used here assigns a priority which scales with a user defined + * per-file priority, and which is a function of the number of recent + * references to the file. The USERPRI, REFBASE, and TOCK parameters can + * be used (possibly in combination with manual cache control commands) to + * tune the algorithm for the expected file activity. + */ +static int +vm_cachepriority (vm, sp) +register VMcache *vm; +register Segment *sp; +{ + register int priority = 0; + time_t curtime = time(NULL); + + /* A user-specified priority of zero overrides. */ + if (sp->userpri <= 0) + return (0); + + /* Compute the cache priority for the segment. */ + priority = (sp->nrefs - vm->refbase) - + ((curtime - sp->atime) / vm->tock); + if (priority < 0) + priority = 0; + priority *= sp->userpri; + + /* Degrade nrefs every tock seconds if the file is not being + * accessed. + */ + if (sp->atime > sp->ptime) + sp->ptime = sp->atime; + else if ((curtime - sp->ptime) > vm->tock) { + sp->nrefs -= ((curtime - sp->ptime) / vm->tock); + if (sp->nrefs < 0) + sp->nrefs = 0; + sp->ptime = curtime; + } + + return (priority); +} + + +/* VM_SYNC -- Sync (update on disk) any pages of virtual memory mapped to + * the given region of the given file. If nbytes=0, any mapped regions of + * the given file are synced. If the VM_ASYNC flag is set the sync operation + * will be performed asynchronously and vm_sync will return immediately, + * otherwise vm_sync waits for the synchronization operation to complete. + */ +vm_sync (vm, fd, offset, nbytes, flags) +register VMcache *vm; +int fd; +unsigned long offset; +unsigned long nbytes; +int flags; +{ + register Segment *sp; + unsigned long x0, x1, vm_offset, vm_nbytes; + int syncflag, status = 0; + struct stat st; + + if (debug) + fprintf (stderr, "vm_sync (0x%x, %d, %d, %d, 0%o)\n", + vm, fd, offset, nbytes, flags); + if (!vm->cache_enabled) + return (0); + + /* Map offset,nbytes to a range of memory pages. + */ + x0 = offset; + x0 = (x0 - (x0 % vm->pagesize)); + + x1 = offset + nbytes - 1; + x1 = (x1 - (x1 % vm->pagesize)) + vm->pagesize - 1; + + vm_offset = x0; + vm_nbytes = x1 - x0 + 1; + +#ifdef sun +#ifdef _SYS_SYSTEMINFO_H + /* This is a mess. The values of MS_SYNC,MS_ASYNC changed between + * Solaris 2.6 and 2.7. This code assumes that the system is + * being built on a Solaris 2.7 or greater system, but the wired-in + * values below allow the executable to be run on earlier versions. + */ + { + char buf[SZ_NAME]; /* e.g. "5.7" */ + + sysinfo (SI_RELEASE, buf, SZ_NAME); + if (buf[0] >= '5' && buf[2] >= '7') + syncflag = (flags & VM_ASYNC) ? MS_ASYNC : MS_SYNC; + else + syncflag = (flags & VM_ASYNC) ? 0x1 : 0x0; + } +#else + syncflag = (flags & VM_ASYNC) ? MS_ASYNC : MS_SYNC; +#endif +#else + syncflag = (flags & VM_ASYNC) ? MS_ASYNC : MS_SYNC; +#endif + + if (fstat (fd, &st) < 0) + return (-1); + + /* Locate the referenced segment. */ + for (sp = vm->segment_head; sp; sp = sp->next) { + if (!isfile(sp,st)) + continue; + + if (!nbytes || sp->offset == vm_offset) + if (msync (sp->addr, sp->nbytes, syncflag)) + status = -1; + } + + return (status); +} + + +/* VM_MSYNC -- Sync the given region of virtual memory. This routine does + * not require that the caller know the file to which the memory is mapped. + * If the VM_ASYNC flag is set the sync operation will be performed + * asynchronously and vm_sync will return immediately, therwise vm_sync waits + * for the synchronization operation to complete. + */ +vm_msync (vm, addr, nbytes, flags) +register VMcache *vm; +void *addr; +unsigned long nbytes; +int flags; +{ + register Segment *sp; + unsigned long addr1, addr2; + int syncflag; + + if (debug) + fprintf (stderr, "vm_msync (0x%x, 0x%x, %d, 0%o)\n", + vm, addr, nbytes, flags); + + /* Align the given address region to the page boundaries. + */ + addr1 = ((long)addr - ((long)addr % vm->pagesize)); + addr2 = (long)addr + nbytes - 1; + addr2 = (addr2 - (addr2 % vm->pagesize)) + vm->pagesize - 1; + syncflag = (flags & VM_ASYNC) ? MS_ASYNC : MS_SYNC; + + return (msync ((void *)addr1, addr2 - addr1 + 1, syncflag)); +} + + +/* VM_READAHEAD -- Internal routine used to request that a segment of file + * data be preloaded. + */ +static +vm_readahead (vm, addr, nbytes) +register VMcache *vm; +void *addr; +unsigned long nbytes; +{ + register int n, nb; + int chunk = READAHEAD * vm->pagesize; + unsigned long buf = (unsigned long) addr; + + /* Break large reads into chunks of READAHEAD memory pages. This + * increases the chance that file access and computation can overlap + * the readahead i/o. + */ + for (n=0; n < nbytes; n += chunk) { + nb = nbytes - n; + if (nb > chunk) + nb = chunk; + madvise ((void *)(buf + n), nb, MADV_WILLNEED); + } +} diff --git a/unix/boot/vmcached/vmcache.h b/unix/boot/vmcached/vmcache.h new file mode 100644 index 00000000..3304b8dd --- /dev/null +++ b/unix/boot/vmcached/vmcache.h @@ -0,0 +1,19 @@ +/* + * VMCACHE.H -- Public definitions for the VMcache interface. + */ + +#define DEF_VMSOCK 8677 +#define ENV_VMSOCK "VMPORT" + +#define VM_READONLY 0001 +#define VM_READWRITE 0002 +#define VM_WRITEONLY 0004 +#define VM_ASYNC 0010 +#define VM_SYNC 0020 +#define VM_LOCKFILE 0040 +#define VM_DESTROYREGION 0100 +#define VM_CANCELREFCNT 0200 +#define VM_DONTMAP 0400 + +void *vm_initcache(); +void *vm_cacheregion(); diff --git a/unix/boot/vmcached/vmcached.c b/unix/boot/vmcached/vmcached.c new file mode 100644 index 00000000..5acccdea --- /dev/null +++ b/unix/boot/vmcached/vmcached.c @@ -0,0 +1,568 @@ +#include +#include +#include +#include +#include +#include "vmcache.h" + +#define NOKNET +#define import_spp +#define import_knames +#include + +/* + * VMCACHED -- VMcache daemon. + * + * The VMcache daemon controls a virtual memory cache for optimizing file + * storage in virtual memory on a single host computer. Clients can connect + * to the daemon to request that files be cached or uncached, query whether + * a file is cached, modify cache parameters, or query the status of the + * cache. + */ + +#define MAX_CLIENTS 256 +#define MAX_ARGS 32 +#define SZ_STATBUF 8192 +#define SZ_CMDBUF 8192 +#define SZ_NAME 32 +#define DEF_CACHESIZE "50%" +#define DEF_PHYSPAGES 32768 +#define DEF_PRIORITY 1 +#define DEF_REFBASE 1 +#define DEF_TOCK 600 + + +/* Client connection. */ +struct client { + int fd; + FILE *out; + char name[SZ_NAME+1]; +}; typedef struct client Client; + +Client client[MAX_CLIENTS]; +int nclients; +int maxclients; +int debug; +int running; +extern char *getenv(); +void *vm; + + +/* MAIN -- VMCACHED main program. + */ +main (argc, argv) +int argc; +char **argv; +{ + char *argp, *op, *cachesize; + int socket, lockpages, defpri, refbase, tock; + int c_argc, fd, status, acmode, server, i; + char *c_argv[MAX_ARGS]; + char initstr[SZ_FNAME]; + char osfn[SZ_FNAME]; + fd_set readfds; + + cachesize = DEF_CACHESIZE; + socket = DEF_VMSOCK; + defpri = DEF_PRIORITY; + refbase = DEF_REFBASE; + tock = DEF_TOCK; + lockpages = 0; + + /* The socket to be used can be set in the environment. */ + if (argp = getenv (ENV_VMSOCK)) + socket = atoi (argp); + + /* Parse argument list. */ + for (i=1; i < argc, argp = argv[i]; i++) { + if (argname (argp, "-k", "-port")) { + argp = (argv[++i]); + socket = atoi (argp); + } else if (argname (argp, "-s", "-cachesize")) { + argp = (argv[++i]); + cachesize = argp; + } else if (argname (argp, "-p", "-defpri")) { + argp = (argv[++i]); + defpri = atoi (argp); + } else if (argname (argp, "-b", "-refbase")) { + argp = (argv[++i]); + refbase = atoi (argp); + } else if (argname (argp, "-t", "-tock")) { + argp = (argv[++i]); + tock = atoi (argp); + } else if (argname (argp, "-l", "-lockpages")) { + lockpages++; + } else if (argname (argp, "-d", "-debug")) { + debug++; + } else + fprintf (stderr, "vmcached: unknown argument `%s'\n", argp); + } + + /* Construct the initstr for VMcache. */ + op = initstr; + sprintf (op, "cachesize=%s,defpri=%d,refbase=%d,tock=%d", + cachesize, defpri, refbase, tock); + if (lockpages) { + op = initstr + strlen(initstr); + strcat (op, ",lockpages"); + } + if (debug) { + op = initstr + strlen(initstr); + strcat (op, ",debug"); + } + + if (debug) + fprintf (stderr, "vmcached: init vmcache `%s'\n", initstr); + + /* Initialize the VM cache. */ + if (!(vm = vm_initcache (NULL, initstr))) { + fprintf (stderr, "vmcached: failed to open socket `%s'\n", osfn); + exit (1); + } + + /* Open the server port for incoming connections. + */ + sprintf (osfn, "inet:%d::nonblock", socket); + acmode = NEW_FILE; + if (debug) + fprintf (stderr, "vmcached: open server socket `%s'\n", osfn); + + ZOPNND (osfn, &acmode, &server); + if (server == XERR) { + fprintf (stderr, "vmcached: failed to open socket `%s'\n", osfn); + vm_closecache (vm); + exit (2); + } + + if (debug) + fprintf (stderr, "vmcached: enter main server loop:\n"); + + /* Loop indefinitely waiting for new connections or client + * requests. + */ + for (running=1; running; ) { + FD_ZERO (&readfds); + FD_SET (server, &readfds); + for (i=0; i < maxclients; i++) + if (client[i].fd) + FD_SET (client[i].fd, &readfds); + if (select (MAX_CLIENTS, &readfds, NULL, NULL, NULL) <= 0) + break; + + /* Check for a new client connection. */ + if (FD_ISSET (server, &readfds)) { + char buf[SZ_CMDBUF]; + FILE *fdopen(); + int fd, n; + + if (debug) + fprintf (stderr, "vmcached: open new client connection: "); + + /* Accept the connection. */ + sprintf (osfn, "sock:%d", server); + acmode = NEW_FILE; + ZOPNND (osfn, &acmode, &fd); + if (fd == XERR) + exit (1); + + for (i=0; i < MAX_CLIENTS; i++) + if (!client[i].fd) + break; + if (i >= MAX_CLIENTS) { + fprintf (stderr, "vmcached: too many clients\n"); + ZCLSND (&fd, &status); + continue; + } + + /* The client name is passed as data in an open. */ + if ((n = read (fd, buf, SZ_CMDBUF)) > 0) { + strncpy (client[i].name, buf, SZ_NAME); + client[i].name[n < SZ_NAME ? n : SZ_NAME] = '\0'; + } + + if (debug) + fprintf (stderr, "fd=%d (%s)\n", fd, client[i].name); + + client[i].fd = fd; + client[i].out = fdopen (fd, "w"); + nclients++; + if (i >= maxclients) + maxclients = i + 1; + + /* Send an acknowledge back to the client. */ + c_argc = 1; c_argv[0] = client[i].name; + putstati (client[i].out, c_argc, c_argv, 0); + } + + /* Check for command input from clients. Any command data + * must be sent as a complete command block. The block must + * be syntatically complete, by may contain multiple + * concatenated commands. If a command references any data + * not passed as part of the command, the data can be read + * from the client input stream during execution of the command. + */ + for (i=0; i < MAX_CLIENTS; i++) { + Client *cx = &client[i]; + if (!cx->fd) + continue; + + if (FD_ISSET (cx->fd, &readfds)) { + int status, buflen; + char buf[SZ_CMDBUF]; + char *ip, *itop; + + if (debug) fprintf (stderr, + "vmcached: client input on fd=%d: ", cx->fd); + + if ((buflen = read (cx->fd, buf, SZ_CMDBUF)) <= 0) { + if (debug) + fputs ("[EOF (disconnected)]\n", stderr); + goto disconnect; + } + if (debug) { + buf[buflen] = '\0'; + fputs (buf, stderr); + } + + ip = buf; + itop = buf + buflen; + + while (getcmd (&ip, itop, &c_argc, c_argv) > 0) + if (execute (cx, c_argc, c_argv) > 0) { +disconnect: fclose (cx->out); + ZCLSND (&cx->fd, &status); + cx->fd = 0; + cx->out = NULL; + nclients--; + if (maxclients == i+1) + maxclients--; + break; + } + + if (cx->out) + fflush (cx->out); + } + } + } + + if (debug) + fprintf (stderr, "vmcached: shutdown\n"); + + /* Close all client connections. */ + for (i=0; i < maxclients; i++) { + Client *cx = &client[i]; + if (cx->fd) { + fclose (cx->out); + close (cx->fd); + cx->fd = 0; + } + } + + ZCLSND (&server, &status); + vm_closecache (vm); + exit (0); +} + + +/* EXECUTE -- Execute a vmcached directive. + * + * Directives are simple newline or semicolon delimited commands, with the + * arguments delimited by whitespace or quotes, e.g., : + * + * access /d1/iraf/h1904b.fits rw + * + * Multiple commands can be concatenated (with command delimiters) and sent + * as a batch if desired. They will be executed in sequence. Most commands + * result in a response to the client. These have the form + * + * '=' + * + * for example, + * + * 1 = access /d1/iraf/h1904b.fits rw + * + * This form makes the status value easy to parse for simple commands. + * The command is echoed so that the status value can be matched to the + * command it is for, e.g., if multiple commands were issued. + */ +execute (cx, argc, argv) +Client *cx; +int argc; +char *argv[]; +{ + char *cmd = argv[0]; + int execstat = 0; + int i, status = 0; + + if (!cmd) + return (-1); + + if (debug) { + fprintf (stderr, "vmcached: execute \"%s (", cmd); + for (i=1; i < argc; i++) { + if (i > 1) + fprintf (stderr, ", "); + fprintf (stderr, "%s", argv[i]); + } + fprintf (stderr, ")\"\n"); + } + + if (strcmp (cmd, "bye") == 0) { + /* Usage: bye + * Close a client connection. + */ + execstat = 1; + + } else if (strcmp (cmd, "quit") == 0) { + /* Usage: quit + * Shutdown vmcached and exit. + */ + running = 0; + + } else if (strcmp (cmd, "access") == 0) { + /* Usage: access [] + * + * Determine whether the named file should be accessed via the + * VMcache (via virtual memory / normal i/o) or via direct i/o, + * bypassing VM. In the simplest scenario we just check whether + * the named file is already in the cache, perhaps loaded via + * the cache directive by a control process. More complex + * strategies are possible, e.g., every access could be set up + * to automatically cache the referenced file; caching could be + * decided on a per-process basic depending upon access history, + * etc. A client about to access a file should issue an access + * directive to the cache to determine whether or not to use VM + * (e.g., normal file i/o) to access the file. + */ + char *fname = argv[1]; + char *mode = (argc > 2) ? argv[2] : "r"; + + if (!fname) + status = -1; + else + status = vm_access (vm, fname, mode, 0); + putstati (cx->out, argc, argv, status); + + } else if (strcmp (cmd, "cache") == 0) { + /* Usage: cache + * + * Cache the named file. The file is asynchronously loaded + * into the VM cache. + */ + char *fname = argv[1]; + + if (!fname) + status = -1; + else + status = vm_cachefile (vm, fname, 0); + putstati (cx->out, argc, argv, status); + + } else if (strcmp (cmd, "uncache") == 0) { + /* Usage: uncache + * + * If the named file is present in the cache the space it is + * marked as ready for reuse. Any VM space used by the file is + * not immediately reused. The actual disk file is not affected. + */ + char *fname = argv[1]; + + if (!fname) + status = -1; + else + status = vm_uncachefile (vm, fname, 0); + putstati (cx->out, argc, argv, status); + + } else if (strcmp (cmd, "delete") == 0) { + /* Usage: delete + * + * If the named file is present in the cache it is removed from + * the cache, freeing the space to be used for other files. The + * actual disk file is not affected. + */ + char *fname = argv[1]; + + if (!fname) + status = -1; + else { + status = vm_uncachefile (vm, fname, + VM_DESTROYREGION|VM_CANCELREFCNT); + } + putstati (cx->out, argc, argv, status); + + } else if (strcmp (cmd, "refresh") == 0) { + /* Usage: refresh + * + * If the named file is present in the cache it is moved to the + * head of the cache (most recently referenced), and any missing + * file pages are asynchronously loaded from disk. + */ + char *fname = argv[1]; + + if (!fname) + status = -1; + else + status = vm_refreshfile (vm, fname, 0); + putstati (cx->out, argc, argv, status); + + } else if (strcmp (cmd, "reserve") == 0) { + /* Usage: reserve + * + * The indicated amount of space is made available in the cache. + * The space goes on the VM free list, for use to buffer data + * without paging out other data. + */ + long nbytes = (argv[1]) ? atol(argv[1]) : 0; + + if (!nbytes) + status = -1; + else + status = vm_reservespace (vm, nbytes); + putstati (cx->out, argc, argv, status); + + } else if (strcmp (cmd, "status") == 0) { + /* Usage: status + * + * The status directive is used to query the status and contents + * of the VM cache. A description of all parameters and cached + * files is returned in text form. + */ + char statbuf[SZ_STATBUF]; + + status = vm_status (vm, statbuf, SZ_STATBUF, 0); + putstats (cx->out, argc, argv, status); + fputs (statbuf, cx->out); + + } else if (strcmp (cmd, "subscribe") == 0) { + /* Usage: subscribe */ + fprintf (cx->out, "%s %d\n", cmd, status); + + } else if (strcmp (cmd, "unsubscribe") == 0) { + /* Usage: unsubscribe */ + fprintf (cx->out, "%s %d\n", cmd, status); + + } else { + execstat = status = -1; + putstati (cx->out, argc, argv, status); + } + + return (execstat); +} + + +/* PUTSTATI -- Return an integer valued command status to the client. + */ +putstati (fp, argc, argv, status) +FILE *fp; +int argc; +char **argv; +int status; +{ + register int i; + + fprintf (fp, "%d = %s", status, argv[0]); + for (i=1; i < argc && argv[i]; i++) + fprintf (fp, " %s", argv[i]); + fprintf (fp, "\n"); + fflush (fp); + + if (debug) + fprintf (stderr, "vmcached: %s -> %d\n", argv[0], status); +} + + +/* PUTSTATS -- Return a string valued command status to the client. + */ +putstats (fp, argc, argv, status) +FILE *fp; +int argc; +char **argv; +char *status; +{ + register int i; + + fprintf (fp, "%s = %s", status, argv[0]); + for (i=0; i < argc && argv[i]; i++) + fprintf (fp, " %s", argv[i]); + fprintf (fp, "\n"); + fflush (fp); +} + + +/* ARGNAME -- Test whether a string is one of the named arguments. + */ +argname (arg, name1, name2) +char *arg; +char *name1, *name2; +{ + int status = 0; + + if (name1) + status |= (strcmp (arg, name1) == 0); + if (name2) + status |= (strcmp (arg, name2) == 0); + + return (status); +} + + +/* GETCMD -- Read a command from the input command block and parse it into + * the command name and arguments. The input pointer is left positioned + * to the text following the command. The command name is returned as + * argv[0]; + */ +getcmd (ipp, itop, argc, argv) +char **ipp; +char *itop; +int *argc; +char *argv[]; +{ + register char *ip = *ipp; + register char *argp; + int i, nargs = 0; + + for (i=0; i < MAX_ARGS; i++) + argv[i] = NULL; + + while (ip < itop && (*ip == ' ' || *ip == '\t')) + ip++; + + /* Get command name and any arguments. */ + while (ip < itop && *ip != '\n' && *ip != ';') { + /* Get next argument. */ + argp = ip; + + /* Quoted strings may include whitespace. The quote characters + * are omitted from the argument. + */ + if (*ip == '\'') { + for (argp = ++ip; ip < itop && *ip != '\''; ) + ip++; + } else if (*ip == '"') { + for (argp = ++ip; ip < itop && *ip != '"'; ) + ip++; + } else { + while (ip < itop && !isspace(*ip)) { + if (*ip == '\\' && ip+1 < itop) + ip++; + ip++; + } + } + + *ip++ = '\0'; + if (argp[0]) + argv[nargs++] = argp; + + /* Skip forward to next argument. */ + while (ip < itop && (*ip == ' ' || *ip == '\t')) + ip++; + } + + /* Skip forward to next command line. */ + while (ip < itop && (isspace(*ip) || *ip == ';')) + ip++; + + *argc = nargs; + *ipp = ip; + + return (nargs); +} diff --git a/unix/boot/wtar/README b/unix/boot/wtar/README new file mode 100644 index 00000000..2baafbd4 --- /dev/null +++ b/unix/boot/wtar/README @@ -0,0 +1,21 @@ +WTAR -- Write a tar format file or tape. This is a portable, non-UNIX, non- + proprietary program for writing tar format files on a variety of + systems. The TAR format is an excellent choice for transporting + files between different machines because of its simplicity, efficiency, + and machine independence. + + +wtar [-tvdo] [-f tarfile] [files] + + -t print names of files as they are written + -v verbose output + -d debug mode + -o omit binary files + -f fn write to file FN (stdout, mt[ab..], binary file) + [files] files or directories to be written to tar file + + +Output may be to a disk file, a magtape device, or to the standard output +(on some systems). Text files may be padded with extra blanks at the end on +some systems, due to lack of knowledge of the precise file length when the +file header is written. diff --git a/unix/boot/wtar/mkpkg.sh b/unix/boot/wtar/mkpkg.sh new file mode 100644 index 00000000..1bf0e0f6 --- /dev/null +++ b/unix/boot/wtar/mkpkg.sh @@ -0,0 +1,6 @@ +# Bootstrap WTAR. + +$CC -c $HSI_CF wtar.c +$CC $HSI_LF wtar.o $HSI_LIBS -o wtar.e +mv wtar.e ../../hlib +rm -f wtar.o diff --git a/unix/boot/wtar/wtar.c b/unix/boot/wtar/wtar.c new file mode 100644 index 00000000..2b9c03a1 --- /dev/null +++ b/unix/boot/wtar/wtar.c @@ -0,0 +1,717 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define NOKNET +#define import_spp +#define import_finfo +#define import_knames +#include + +#include "../bootProto.h" + + +/* + * WTAR -- Write a UNIX tar format file (on disk, tape, or to stdout) + * + * Switches: + * f write to named file, otherwise write to stdout + * t print name of each file written + * v verbose; print full description of each file + * d print debug messages + * o omit binary files (e.g. when foreign host has + * incompatible binary file format) + */ + +#define TBLOCK 512 +#define NBLOCK 20 +#define NAMSIZ 100 +#define MAXERR 20 +#define MAXTRYS 100 +#define SZ_TAPEBUFFER (TBLOCK * NBLOCK) +#define RWXR_XR_X 0755 + +#define LF_LINK 1 +#define LF_SYMLINK 2 +#define LF_DIR 5 + +/* File header structure. One of these precedes each file on the tape. + * Each file occupies an integral number of TBLOCK size logical blocks + * on the tape. The number of logical blocks per physical block is variable, + * with at most NBLOCK logical blocks per physical tape block. Two zero + * blocks mark the end of the tar file. + */ +union hblock { + char dummy[TBLOCK]; + struct header { + char name[NAMSIZ]; /* NULL delimited */ + char mode[8]; /* octal, ascii */ + char uid[8]; + char gid[8]; + char size[12]; + char mtime[12]; + char chksum[8]; + char linkflag; + char linkname[NAMSIZ]; + } dbuf; +}; + +/* Decoded file header. + */ +struct fheader { + char name[NAMSIZ]; + int mode; + int uid; + int gid; + int isdir; + long size; + long mtime; + long chksum; + int linkflag; + char linkname[NAMSIZ]; +}; + +/* Map TAR file mode bits into characters for printed output. + */ +struct _modebits { + int code; + char ch; +} modebits[] = { + { 040000, 'd' }, + { 0400, 'r' }, + { 0200, 'w' }, + { 0100, 'x' }, + { 040, 'r' }, + { 020, 'w' }, + { 010, 'x' }, + { 04, 'r' }, + { 02, 'w' }, + { 01, 'x' }, + { 0, 0 } +}; + +int debug=NO; /* Print debugging messages */ +int omitbinary; /* omit binary files */ +int printfnames; /* Print file names */ +int verbose; /* Print everything */ + +struct fheader *curfil; +int nerrs; +char *first_file; +char tapeblock[SZ_TAPEBUFFER]; +char *nextblock = NULL; +int nblocks; +int in; +int out = EOF; + + +extern int ZZSTRT (void); +extern int ZZSTOP (void); +extern int ZFINFO (PKCHAR *fname, XLONG *finfo_struct, XINT *status); + +extern int tape_open (char *fname, int mode); +extern int tape_close (int fd); +extern int tape_write (int fd, char *buf, int nbytes); + + +static void putfiles (char *dir, int out, char *path); +static void tarfileout (char *fname, int out, int ftype, char *path); +static int putheader (register struct fheader *fh, int out); +static int cchksum (register char *p, register int nbytes); +static void printheader (FILE *fp, register struct fheader *fh, int verbose); +static void copyfile (char *fname, struct fheader *fh, int ftype, int out); +static int putblock (int out, char *buf); +static void endtar (int out); +static int u_fmode (int iraf_fmode, int ftype); +static char *dname (char *dir); + + + + +/* MAIN -- "wtar [-tvdo] [-f tarfile] [files]". If no files are listed the + * current directory tree is used as input. If no output file is specified + * output is to the standard output. + */ +int main (int argc, char *argv[]) +{ + static char *def_flist[2] = { ".", NULL }; + char *argp, **flist; + int argno, ftype, i; + + ZZSTRT(); + + flist = def_flist; + omitbinary = NO; + printfnames = debug; + verbose = debug; + + if (debug) { + printf ("wtar called with %d arguments:", argc); + for (argno=1; (argp = argv[argno]) != NULL; argno++) + printf (" %s", argp); + printf ("\n"); + } + + /* Process the argument list. + */ + for (argno=1; (argp = argv[argno]) != NULL; argno++) { + if (*argp != '-') { + flist = &argv[argno]; + break; + + } else { + for (argp++; *argp; argp++) { + switch (*argp) { + case 'd': + debug++; + printfnames++; + verbose++; + break; + case 't': + printfnames++; + break; + case 'v': + printfnames++; + verbose++; + break; + case 'o': + omitbinary++; + break; + + case 'f': + if (argv[argno+1]) { + argno++; + if (debug) + printf ("open output file `%s'\n", argv[argno]); + out = tape_open (argv[argno], 1); + if (out == ERR) { + fflush (stdout); + fprintf (stderr, + "cannot open `%s'\n", argv[argno]); + ZZSTOP(); + exit (OSOK+1); + } + } + break; + + default: + fflush (stdout); + fprintf (stderr, + "Warning: unknown switch -%c\n", *argp); + fflush (stderr); + } + } + } + } + + /* Write to the standard output if no output file specified. + * The filename "stdin" is reserved. + */ + if (out == ERR) { + if (debug) + printf ("output defaults to stdout\n"); + out = tape_open ("stdout", 1); + } + + nextblock = tapeblock; + nblocks = 0; + + /* Put each directory and file listed on the command line to + * the tarfile. + */ + for (i=0; (argp = flist[i]) != NULL; i++) + if ((ftype = os_filetype (argp)) == DIRECTORY_FILE) + putfiles (argp, out, ""); + else + tarfileout (argp, out, ftype, ""); + + /* Close the tarfile. + */ + endtar (out); + tape_close (out); + + ZZSTOP(); + exit (OSOK); + + return (0); +} + + +/* PUTFILES -- Put the named directory tree to the output tarfile. We chdir + * to each subdirectory to minimize path searches and speed up execution. + */ +static void +putfiles ( + char *dir, /* directory name */ + int out, /* output file */ + char *path /* pathname of curr. directory */ +) +{ + char newpath[SZ_PATHNAME+1]; + char oldpath[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + int ftype, dp; + + if (debug) + printf ("putfiles (%s, %d, %s)\n", dir, out, path); + + /* Put the directory file itself to the output as a file. + */ + tarfileout (dir, out, DIRECTORY_FILE, path); + + if ((dp = os_diropen (dir)) == ERR) { + fflush (stdout); + fprintf (stderr, "cannot open subdirectory `%s%s'\n", path, dir); + fflush (stderr); + return; + } + + os_fpathname (".", oldpath, SZ_PATHNAME); + sprintf (newpath, "%s%s", dname(path), dir); + strcpy (newpath, dname(newpath)); + + if (debug) + printf ("change directory to %s\n", newpath); + if (os_chdir (dir) == ERR) { + os_dirclose (dp); + fflush (stdout); + fprintf (stderr, "cannot change directory to `%s'\n", newpath); + fflush (stderr); + return; + } + + /* Put each file in the directory to the output file. Recursively + * read any directories encountered. + */ + while (os_gfdir (dp, fname, SZ_PATHNAME) > 0) + if (os_symlink (fname, 0, 0)) + tarfileout (fname, out, LF_SYMLINK, newpath); + else if ((ftype = os_filetype (fname)) == DIRECTORY_FILE) + putfiles (fname, out, newpath); + else + tarfileout (fname, out, ftype, newpath); + + if (debug) + printf ("return from subdirectory %s\n", newpath); + if (os_chdir (oldpath) == ERR) { + fflush (stdout); + fprintf (stderr, "cannot return from subdirectory `%s'\n", newpath); + fflush (stderr); + } + + os_dirclose (dp); +} + + +/* TARFILEOUT -- Write the named file to the output in tar format. + */ +static void +tarfileout ( + char *fname, /* file to be output */ + int out, /* output stream */ + int ftype, /* file type */ + char *path /* current path */ +) +{ + struct _finfo fi; + struct fheader fh; + int status; + + if (debug) + printf ("put file `%s', type %d\n", fname, ftype); + + if (ftype == BINARY_FILE && omitbinary) { + if (printfnames) { + fflush (stdout); + fprintf (stderr, "omit binary file `%s'\n", fname); + fflush (stderr); + } + return; + } + + /* Get info on file to make file header. + */ + ZFINFO ((PKCHAR *)vfn2osfn(fname,0), (XLONG *) &fi, (XINT *) &status); + if (status == XERR) { + fflush (stdout); + fprintf (stderr, "Warning: can't get info on file `%s'\n", fname); + fflush (stderr); + return; + } + + /* Format and output the file header. + */ + memset (&fh, 0, sizeof(fh)); + strcpy (fh.name, path); + strcat (fh.name, fname); + strcpy (fh.linkname, ""); + fh.linkflag = 0; + + if (ftype == DIRECTORY_FILE) { + strcpy (fh.name, dname(fh.name)); + fh.size = 0; + fh.isdir = 1; + fh.linkflag = LF_DIR; + } else { + fh.size = fi.fi_size; + fh.isdir = 0; + } + + os_getowner (fname, &fh.uid, &fh.gid); + fh.mode = u_fmode (fi.fi_perm, fi.fi_type); + fh.mtime = os_utime (fi.fi_mtime); + + if (ftype == LF_SYMLINK) { + struct stat fi; + lstat (fname, &fi); + + /* Set attributes of symbolic link, not file pointed to. */ + fh.uid = fi.st_uid; + fh.gid = fi.st_gid; + fh.mode = fi.st_mode; + fh.mtime = fi.st_mtime; + fh.size = 0; + + fh.linkflag = LF_SYMLINK; + os_symlink (fname, fh.linkname, NAMSIZ); + } + + if (putheader (&fh, out) == EOF) { + fflush (stdout); + fprintf (stderr, + "Warning: could not write file header for `%s'\n", fname); + fflush (stderr); + return; + } + + /* Copy the file data. + */ + if (fh.size > 0 && !fh.isdir && !fh.linkflag) + copyfile (fname, &fh, ftype, out); + + if (printfnames) { + printheader (stdout, &fh, verbose); + fflush (stdout); + } +} + + +/* PUTHEADER -- Encode and write the file header to the output tarfile. + */ +static int +putheader ( + register struct fheader *fh, /* (input) file header */ + int out /* output file descriptor */ +) +{ + register char *ip; + register int n; + union hblock hb; + char chksum[10]; + + + /* Clear the header block. */ + for (n=0; n < TBLOCK; n++) + hb.dummy[n] = '\0'; + + /* Encode the file header. + */ + strcpy (hb.dbuf.name, fh->name); + sprintf (hb.dbuf.mode, "%6o ", fh->mode); + sprintf (hb.dbuf.uid, "%6o ", fh->uid); + sprintf (hb.dbuf.gid, "%6o ", fh->gid); + sprintf (hb.dbuf.size, "%11lo ", fh->size); + sprintf (hb.dbuf.mtime, "%11lo ", fh->mtime); + + switch (fh->linkflag) { + case LF_SYMLINK: + hb.dbuf.linkflag = '2'; + break; + case LF_DIR: + hb.dbuf.linkflag = '5'; + break; + default: + hb.dbuf.linkflag = '0'; + break; + } + strcpy (hb.dbuf.linkname, fh->linkname); + + /* Encode the checksum value for the file header and then + * write the field. Calculate the checksum with the checksum + * field blanked out. Compute the actual checksum as the sum of + * all bytes in the header block. A sum of zero indicates the + * end of the tar file. + */ + for (n=0; n < 8; n++) + hb.dbuf.chksum[n] = ' '; + + sprintf (chksum, "%6o", cchksum (hb.dummy, TBLOCK)); + for (n=0, ip=chksum; n < 8; n++) + hb.dbuf.chksum[n] = *ip++; + + if (debug) { + printf ("File header:\n"); + printf (" name = %s\n", hb.dbuf.name); + printf (" mode = %s\n", hb.dbuf.mode); + printf (" uid = %s\n", hb.dbuf.uid); + printf (" gid = %s\n", hb.dbuf.gid); + printf (" size = %-12.12s\n", hb.dbuf.size); + printf (" mtime = %-12.12s\n", hb.dbuf.mtime); + printf (" chksum = %s\n", hb.dbuf.chksum); + printf (" linkflag = %c\n", hb.dbuf.linkflag); + printf (" linkname = %s\n", hb.dbuf.linkname); + fflush (stdout); + } + + /* Write the header to the tarfile. + */ + return (putblock (out, hb.dummy)); +} + + +/* CCHKSUM -- Compute the checksum of a byte array. + */ +static int +cchksum ( + register char *p, + register int nbytes +) +{ + register int sum; + + for (sum=0; --nbytes >= 0; ) + sum += *p++; + + return (sum); +} + + +/* PRINTHEADER -- Print the file header in either short or long (verbose) + * format, e.g.: + * drwxr-xr-x 9 tody 1024 Nov 3 17:53 . + */ +static void +printheader ( + FILE *fp, /* output file */ + register struct fheader *fh, /* file header struct */ + int verbose /* long format output */ +) +{ + register struct _modebits *mp; + char *tp, *ctime(); + + if (!verbose) { + fprintf (fp, "%s\n", fh->name); + return; + } + + for (mp=modebits; mp->code; mp++) + fprintf (fp, "%c", mp->code & fh->mode ? mp->ch : '-'); + + tp = ctime (&fh->mtime); + fprintf (fp, "%3d %4d %2d %8ld %-12.12s %-4.4s %s", + fh->linkflag, + fh->uid, + fh->gid, + fh->size, + tp + 4, tp + 20, + fh->name); + + if (fh->linkflag && *fh->linkname) + fprintf (fp, " -> %s\n", fh->linkname); + else + fprintf (fp, "\n"); +} + + +/* COPYFILE -- Copy bytes from the input file to the output file. Each file + * consists of a integral number of TBLOCK size blocks on the output file. + */ +static void +copyfile ( + char *fname, /* file being read from */ + struct fheader *fh, /* file header structure */ + int ftype, /* file type, text or binary */ + int out /* output file */ +) +{ + register char *bp; + register int i; + int nbytes, nleft, blocks, fd, count, total, ch; + char buf[TBLOCK*2]; + + bp = buf; + total = nbytes = 0; + blocks = (fh->size + TBLOCK - 1 ) / TBLOCK; + + if ((fd = os_open (fname, 0, ftype)) == ERR) { + fflush (stdout); + fprintf (stderr, "Warning: cannot open file `%s'\n", fname); + fflush (stderr); + goto pad_; + } + + while (blocks > 0) { + if ((count = os_read (fd, bp, TBLOCK)) == ERR || count > TBLOCK) { + fflush (stdout); + fprintf (stderr, "Warning: file read error on `%s'\n", fname); + fflush (stderr); + if (nerrs++ > MAXERR) { + fprintf (stderr, "Too many errors\n"); + exit (OSOK+1); + } + } else { + /* Buffer input to TBLOCK blocks. + */ + if (count == 0) /* EOF */ + break; + else if ((nbytes += count) < TBLOCK) + bp += count; + else { + putblock (out, buf); + blocks--; + + /* Copy overflow back to beginning... */ + if (nbytes > TBLOCK) { + nleft = nbytes - TBLOCK; + os_amovb (&buf[TBLOCK], buf, nbytes - TBLOCK); + } else + nleft = 0; + + bp = (char *) ((long)buf + nleft); + total += nbytes; + nbytes = nleft; + } + } + } + + os_close (fd); + + /* Fill current block and subsequent full blocks until the number of + * bytes specified in the file header have been output. All files + * occupy an integral number of 512 byte blocks on tape. For text + * files, pad with spaces, otherwise pad with nulls. Also, for text + * files, add newlines to avoid excessively long lines. + */ +pad_: + ch = (ftype == TEXT_FILE) ? ' ' : '\0'; + while (blocks > 0) { + for (i=nbytes; i < TBLOCK; i++) + if (ftype == TEXT_FILE && i % 64 == 0) + buf[i] = '\n'; + else + buf[i] = ch; + + if (ftype == TEXT_FILE) + buf[TBLOCK-1] = '\n'; + + putblock (out, buf); + blocks--; + nbytes = 0; + } +} + + +/* PUTBLOCK -- Write a block to tape (buffered). + */ +static int +putblock (int out, char *buf) +{ + int nbytes = 0; + + if (buf) { + os_amovb (buf, nextblock, TBLOCK); + nextblock += TBLOCK; + if (++nblocks == NBLOCK) + nbytes = SZ_TAPEBUFFER; + } else if (nblocks > 0) + nbytes = SZ_TAPEBUFFER; + + if (nbytes > 0) { + if (tape_write (out, tapeblock, nbytes) < nbytes) { + fflush (stdout); + fprintf (stderr, "Warning: write error on tarfile\n"); + fflush (stderr); + } + + nextblock = tapeblock; + nblocks = 0; + } + + return (TBLOCK); +} + + +/* ENDTAR -- Write the end of the tar file, i.e., two zero blocks. + */ +static void +endtar (int out) +{ + register int i; + union hblock hb; + + if (debug) + printf ("write end of tar file\n"); + + for (i=0; i < TBLOCK; i++) + hb.dummy[i] = '\0'; + + putblock (out, hb.dummy); /* write 2 null blocks */ + putblock (out, hb.dummy); + putblock (out, 0); /* flush tape buffer */ +} + + +/* U_FMODE -- Convert the IRAF file mode bits to the corresponding UNIX bits + * for the tar file header. + */ +static int +u_fmode (int iraf_fmode, int ftype) +{ + register int in = iraf_fmode; + register int m = 0; + int exec; + + exec = (ftype == FI_DIRECTORY || ftype == FI_EXECUTABLE); + + if (in & 001) m |= 0400; /* Owner READ */ + if (in & 002) m |= 0200; /* WRITE */ + if (exec) m |= 0100; /* EXECUTE */ + + if (in & 004) m |= 040; /* Group READ */ + if (in & 010) m |= 020; /* WRITE */ + if (exec) m |= 010; /* EXECUTE */ + + if (in & 020) m |= 004; /* World READ */ + if (in & 040) m |= 002; /* WRITE */ + if (exec) m |= 001; /* EXECUTE */ + + return (m); +} + + +/* DNAME -- Normalize a directory pathname. For unix, this means convert + * an // sequences into a single /, and make sure the directory pathname ends + * in a single /. + */ +static char * +dname (char *dir) +{ + register char *ip, *op; + static char path[SZ_PATHNAME+1]; + + for (ip=dir, op=path; *ip; *op++ = *ip++) + while (*ip == '/' && *(ip+1) == '/') + ip++; + + if (op > path && *(op-1) != '/') + *op++ = '/'; + *op = EOS; + + return (path); +} diff --git a/unix/boot/wtar/wtar.hlp b/unix/boot/wtar/wtar.hlp new file mode 100644 index 00000000..fdbc3aea --- /dev/null +++ b/unix/boot/wtar/wtar.hlp @@ -0,0 +1,89 @@ +.help wtar Oct92 softools +.ih +NAME +wtar -- write TAR format archive file +.ih +USAGE +wtar [-flags] [-f archive] [files] +.ih +ARGUMENTS +.ls 12 -d +Print debug messages. +.le +.ls 12 -o +Omit binary files. +.le +.ls 12 -t +Print the name of each file as it is written or omitted. +.le +.ls 12 -v +Verbose mode; print more information about each file. +.le +.ls 12 -f archive +The tar format file to be written, i.e., "stdout", a host magtape device +name (e.g., "/dev/nrmt8" or "MSA0"), or the IRAF virtual filename of a disk +file. The default is the standard output. +.le +.ls 12 files +The names of the files or root directories of directory trees to be written +to the archive file. If no files are specified "." (the directory tree +rooted at the current directory) is assumed. +.le +.ih +DESCRIPTION +The named files and directories are written to the indicated +UNIX "tar" format output file. Any directories in the file list are +recursively descended. The named directories should be subdirectories of +the current directory when \fIwtar\fR is called. Binary files may be +omitted if desired, e.g., when transporting software to a different host, or +when making a backup of a large system which would otherwise exceed the +capacity of a single reel of tape. All file, directory, and magtape names +conform to the IRAF standard. + +The output file is normally either a disk file (e.g., if the transport +medium is an electronic network), or a magtape file. If the output file is +a magtape multiple files, i.e., wtar archives, may be written on the tape. +The blocking factor is fixed at 10240 bytes per record. + +The TAR format file written by \fIwtar\fR conforms to the UNIX standard except +that [1] no link information is preserved, [2] the user and group numbers +may not be preserved (they are preserved in the UNIX version of \fIwtar\fR), +and [3] some versions of \fIwtar\fR (e.g., VMS) pad text files at the end +with extra blank lines. + +All \fIwtar\fR filename arguments are IRAF virtual filenames (or host +filenames). Magtape devices should be specified by their host (not IRAF) +device name, e.g., "/dev/nrmt8" or "MSA0". +.ih +EXAMPLES +1. Make a source-only archive of the IRAF system on the UNIX device +/dev/nrmt8. + +.nf + cl> cd iraf + cl> wtar -of /dev/nrmt8 +.fi + +2. Archive the "uparm" directory to the VMS logical device MSA0:. + + cl> wtar -f msa0 uparm + +3. Make a disk archive of the LIB and PKG directory trees in your home +directory. + + cl> wtar -f home$archive.tar lib pkg + +4. Examine the resultant file to make sure everything worked correctly. + + cl> rtar -tvf home$archive.tar + + +5. Make a disk archive, using a host filename for the output file. + + cl> wtar -f /tmp2/arc lib pkg sys + +IRAF magtape commands such as \fIrewind\fR may be used with \fIwtar\fR, +but switching between IRAF and host device names can be confusing. +.ih +SEE ALSO +rtar, rmbin diff --git a/unix/boot/xyacc/Makefile b/unix/boot/xyacc/Makefile new file mode 100644 index 00000000..1afcdfdd --- /dev/null +++ b/unix/boot/xyacc/Makefile @@ -0,0 +1,21 @@ +HLIB = ../../hlib/ +IRAFLIB = ../../../lib/ +VGRIND = csh /usr/ucb/vgrind -W + +head: xyacc +xyacc: y1.o y2.o y3.o y4.o + cc -o xyacc.e y?.o + +y1.o y2.o y3.o y4.o: dextern files + +install: + mv -f xyacc.e $(HLIB) + cp yaccpar.x $(IRAFLIB) + +clean : + rm -f *.o + +vgrind: + cp /dev/null index + $(VGRIND) -h 'Yacc' dextern files y1.c y2.c y3.c y4.c + $(VGRIND) -h 'Yacc' -x index diff --git a/unix/boot/xyacc/README b/unix/boot/xyacc/README new file mode 100644 index 00000000..2da6b992 --- /dev/null +++ b/unix/boot/xyacc/README @@ -0,0 +1,117 @@ +.help xyacc +.nf +This directory contains the source for the Yacc compiler compiler as modified +to produce SPP language parsers. This version of XYACC is based on code +obtained from the OpenSolaris project and distributed under the Common +Development and Distribution License (CDDL), considered to be a 'free' +license. All parsers in the system will be regenerated using this new +version of XYACC, all vestiges of the original XYACC code have been +removed. + +Notes regarding the changes required for SPP from the original README +file are included below. + +Mike Fitzpatrick +1/25/2011 + + +------------------------------------------------------------------------------ + + For the most part, the operation of SPP/Yacc is as described in the +Yacc reference manual, with the important differences noted below. A +complete working example of a desk calculator program may be found in +the subdirectory debug, file dc.y. + +Notes on SPP Yacc + + (1) The Yacc input syntax is unmodified, except that the comment convention + is now as in SPP, rather than C (i.e., use #, rather than /*..*/). + All defines, actions, etc. are of course given in the SPP language. + + (2) The Yacc output file is "ytab.x", rather than "y.tab.c". The token + defs file "y.tab.h" now contains SPP defines, rather than C #defines. + The states file "y.output" is completely unmodified. + + (3) The global declarations section %{ .. %} had to be changed somewhat + because SPP does not have global variables. The section is now + divided into two subsections. The first is for global defines, + includes, etc. which go into the header area of the ytab.x file. + Then follows a %L, telling Yacc that the local declarations for + the parser procedure follow. This second section should contain + variable and function declarations required for the user supplied + actions (code fragments to be executed when a rule of the grammar + is recognized) in the yyparse procedure. + + (4) The global declarations section MUST contain the following two + defines: + + YYMAXDEPTH Depth of the parser stacks; determines + the maximum complexity of a language + construct which can be parsed. A typical + value is 150. + + YYOPLEN The length, in struct units, of a token + operand value structure. You define the + operand structure to be whatever you wish; + all the parser needs to know is how big an + element is. The lexical analyzer and the + actions, both of which are supplied by the + user, use the operand structure for + communications. Operand structures are + always referred to by a Mem pointer. + + (5) The calling sequence for the parser is as follows + + status = yyparse (fd, debug, yylex) + + where + status is OK, EOF, or ERR (syntax error) + fd is the text stream to be parsed + debug is a boolean, true to print debugging info + yylex is the user supplied lexical analysis procedure. + + The calling sequence for the lexical analysis procedure is as + follows (the name "yylex" may be anything): + + token = yylex (fd, yylval) + + where + Token is the integer code for the token. The tokens are + named in the Yacc grammar, and are defined either by + the user or by Yacc in the header area of ytab.x. + If Yacc is permitted to assign codes to tokens, the + token defininitions file ytab.h is written out. + fd is the file to be read + yylval is a POINTER to the token value structure to be + returned by yylex. + + (6) The SPP version of Yacc, unlike the C version, does not use any + external or global variables for communication between routines, + and hence it is possible for several distinct parsers to coexist + in the same image. If this is done, the user supplied yylex + procedures should be named something else, and the name of the + parser procedure (yyparse) should be changed. This can be done + by putting a "define yyparse" in the global definitions area. + + (7) Token values (i.e., $$, $1, $2, yyval, yylval, etc.) are always + pointers to structures in the SPP version, as opposed to structures + in the C version. Thus actions like + + { $$ = $1; } + + which are common in the C version, are programmed like this in SPP: + + { YYMOVE ($1, $$) } + + where YYMOVE is a Yacc supplied macro which copies an operand + structure. + + (8) The source for the language independent part of the parser is given + in "lib$yaccpar.x". + +Doug Tody, 21 Feb 84. +20Jan85: + y.tab.x -> ytab.x (etc), added EOF token +20Apr85: + lib$yaccpar.x, deleted entry points for examining parser stack and + other context state variables. diff --git a/unix/boot/xyacc/debug/dc.y b/unix/boot/xyacc/debug/dc.y new file mode 100644 index 00000000..0d6fe655 --- /dev/null +++ b/unix/boot/xyacc/debug/dc.y @@ -0,0 +1,306 @@ +# SPP/Yacc specification for a simple desk calculator. Input consists +# of simple arithmetic expressions; output is the value of the expression. +# Operands are restricted to integer and real numeric constants. + +%{ +include +include + +define YYMAXDEPTH 150 # length of parser stack + +task dc = t_dc + +# Operand Structure (parser stack) +define YYOPLEN 2 # size of operand structure +define OPTYPE Memi[$1] # operand datatype +define OPVALI Memi[$1+1] # integer value of operand +define OPVALR Memr[$1+1] # real value of operand + +%} + +%token CONST LETTER YYEOF + +%left '+' '-' +%left '*' '/' +%left UMINUS + +%% + +prog : # Empty + | prog stmt eost { + return (OK) + } + | YYEOF { + return (EOF) + } + | prog error '\n' { + yyerrok + } + ; + +stmt : expr { + # Print the value of an expression. + if (OPTYPE($1) == TY_INT) { + call printf ("%d\n") + call pargi (OPVALI($1)) + } else { + call printf ("%g\n") + call pargr (OPVALR($1)) + } + } + | LETTER '=' expr { + # Set the value of a register (from a-z). + call putreg (OPVALI($1), $3) + } + ; + +expr : '(' expr ')' { + YYMOVE ($2, $$) + } + | expr '+' opnl expr { + call binop ($1, $4, $$, '+') + } + | expr '-' opnl expr { + call binop ($1, $4, $$, '-') + } + | expr '*' opnl expr { + call binop ($1, $4, $$, '*') + } + | expr '/' opnl expr { + call binop ($1, $4, $$, '/') + } + | '-' expr %prec UMINUS { + call unop ($2, $$, '-') + } + | LETTER { + call getreg (OPVALI($1), $$) + } + | CONST + ; + +eost : ';' + | '\n' + ; + +opnl : # Empty + | opnl '\n' + ; + +%% + + +# DC -- Main routine for the desk calculator. + +procedure t_dc() + +bool debug +int status +bool clgetb() +int yyparse() +extern yylex() + +begin + debug = clgetb ("debug") + + repeat { + status = yyparse (STDIN, debug, yylex) + if (status == ERR) + call eprintf ("syntax error") + } until (status == EOF) +end + + +# BINOP -- Perform an arithmetic binary operation on two operands (passed +# by pointer), returning the result in a third. + +procedure binop (a, b, c, operation) + +pointer a, b, c # c = a op b +int operation # i.e., '+', '-', etc. +int i, j, k +real x, y, z + +begin + if (OPTYPE(a) == TY_INT && OPTYPE(b) == TY_INT) { + # Both operands are of type int, so return an integer result. + + i = OPVALI(a) + j = OPVALI(b) + + switch (operation) { + case '+': + k = i + j + case '-': + k = i - j + case '*': + k = i * j + case '/': + k = i / j + default: + call error (1, "unknown binary operator") + } + OPVALI(c) = k + OPTYPE(c) = TY_INT + + } else { + # At least one of the two operands is a real. Perform the + # calculation in type real, producing a real result. + + if (OPTYPE(a) == TY_INT) + x = OPVALI(a) + else + x = OPVALR(a) + if (OPTYPE(b) == TY_INT) + y = OPVALI(b) + else + y = OPVALR(b) + + switch (operation) { + case '+': + z = x + y + case '-': + z = x - y + case '*': + z = x * y + case '/': + z = x / y + default: + call error (1, "unknown binary operator") + } + + OPVALR(c) = z + OPTYPE(c) = TY_REAL + } +end + + +# UNOP -- Perform a unary operation. Since there is only one operand, the +# datatype does not change. + +procedure unop (a, b, operation) + +pointer a, b +int operation + +begin + OPTYPE(b) = OPTYPE(a) + + switch (operation) { + case '-': + switch (OPTYPE(a)) { + case TY_INT: + OPVALI(b) = -OPVALI(a) + case TY_REAL: + OPVALR(b) = -OPVALR(a) + } + default: + call error (2, "unknown unary operator") + } +end + + +# GETREG, PUTREG -- Fetch or store the contents of a register variable. +# Registers are referred to by letter, A-Z or a-z. + +define MAXREG ('z'-'a'+1) + + +procedure getreg (regchar, op) + +int regchar +pointer op + +bool store +int regbuf[MAXREG*YYOPLEN] +int reg, offset + +begin + store = false + goto 10 + +entry putreg (regchar, op) + store = true + + # Compute offset into storage. Structures are stored in buffer + # by a binary copy, knowing only the length of the structure. +10 if (IS_UPPER(regchar)) + reg = regchar - 'A' + 1 + else + reg = regchar - 'a' + 1 + reg = max(1, min(MAXREG, reg)) + offset = (reg-1) * YYOPLEN + 1 + + # Copy the operand structure either in or out. + if (store) + call amovi (Memi[op], regbuf[offset], YYOPLEN) + else + call amovi (regbuf[offset], Memi[op], YYOPLEN) +end + + +# YYLEX -- Lexical input routine. Return next token from the input +# stream. Recognized tokens are CONST (numeric constants), LETTER, +# and the operator characters. + +int procedure yylex (fd, yylval) + +int fd +pointer yylval +char ch, lbuf[SZ_LINE] +int ip, nchars, token, junk +double dval +int lexnum(), getline(), gctod() +data ip /0/ + +begin + # Fetch a nonempty input line, or advance to start of next token + # if within a line. Newline is a token. + repeat { + if (ip <= 0 || lbuf[ip] == EOS) { + if (getline (fd, lbuf) == EOF) { + ip = 0 + return (YYEOF) + } else + ip = 1 + } + while (IS_WHITE (lbuf[ip])) + ip = ip + 1 + } until (lbuf[ip] != EOS) + + # Determine type of token. If numeric constant, convert to binary + # and return value in op structure (yylval). If letter (register + # variable) return value and advance input one char. If any other + # character, return char itself as the token, and advance input one + # character. + + if (IS_DIGIT (lbuf[ip])) + token = lexnum (lbuf, ip, nchars) + else + token = LEX_NONNUM + + switch (token) { + case LEX_OCTAL, LEX_DECIMAL, LEX_HEX: + junk = gctod (lbuf, ip, dval) + OPTYPE(yylval) = TY_INT + OPVALI(yylval) = int (dval) + return (CONST) + + case LEX_REAL: + junk = gctod (lbuf, ip, dval) + OPTYPE(yylval) = TY_REAL + OPVALR(yylval) = dval + return (CONST) + + default: + ch = lbuf[ip] + ip = ip + 1 + if (IS_ALPHA (ch)) { + OPTYPE(yylval) = LETTER + OPVALI(yylval) = ch + return (LETTER) + } else { + OPTYPE(yylval) = ch + return (OPTYPE(yylval)) + } + } +end diff --git a/unix/boot/xyacc/debug/y.output b/unix/boot/xyacc/debug/y.output new file mode 100644 index 00000000..5640244f --- /dev/null +++ b/unix/boot/xyacc/debug/y.output @@ -0,0 +1,331 @@ + +state 0 + $accept : _prog $end + prog : _ (1) + + YYEOF shift 2 + . reduce 1 + + prog goto 1 + +state 1 + $accept : prog_$end + prog : prog_stmt eost + prog : prog_error \n + + $end accept + error shift 4 + CONST shift 9 + LETTER shift 6 + - shift 8 + ( shift 7 + . error + + stmt goto 3 + expr goto 5 + +state 2 + prog : YYEOF_ (3) + + . reduce 3 + + +state 3 + prog : prog stmt_eost + + \n shift 12 + ; shift 11 + . error + + eost goto 10 + +state 4 + prog : prog error_\n + + \n shift 13 + . error + + +state 5 + stmt : expr_ (5) + expr : expr_+ opnl expr + expr : expr_- opnl expr + expr : expr_* opnl expr + expr : expr_/ opnl expr + + + shift 14 + - shift 15 + * shift 16 + / shift 17 + . reduce 5 + + +state 6 + stmt : LETTER_= expr + expr : LETTER_ (13) + + = shift 18 + . reduce 13 + + +state 7 + expr : (_expr ) + + CONST shift 9 + LETTER shift 20 + - shift 8 + ( shift 7 + . error + + expr goto 19 + +state 8 + expr : -_expr + + CONST shift 9 + LETTER shift 20 + - shift 8 + ( shift 7 + . error + + expr goto 21 + +state 9 + expr : CONST_ (14) + + . reduce 14 + + +state 10 + prog : prog stmt eost_ (2) + + . reduce 2 + + +state 11 + eost : ;_ (15) + + . reduce 15 + + +state 12 + eost : \n_ (16) + + . reduce 16 + + +state 13 + prog : prog error \n_ (4) + + . reduce 4 + + +state 14 + expr : expr +_opnl expr + opnl : _ (17) + + . reduce 17 + + opnl goto 22 + +state 15 + expr : expr -_opnl expr + opnl : _ (17) + + . reduce 17 + + opnl goto 23 + +state 16 + expr : expr *_opnl expr + opnl : _ (17) + + . reduce 17 + + opnl goto 24 + +state 17 + expr : expr /_opnl expr + opnl : _ (17) + + . reduce 17 + + opnl goto 25 + +state 18 + stmt : LETTER =_expr + + CONST shift 9 + LETTER shift 20 + - shift 8 + ( shift 7 + . error + + expr goto 26 + +state 19 + expr : ( expr_) + expr : expr_+ opnl expr + expr : expr_- opnl expr + expr : expr_* opnl expr + expr : expr_/ opnl expr + + + shift 14 + - shift 15 + * shift 16 + / shift 17 + ) shift 27 + . error + + +state 20 + expr : LETTER_ (13) + + . reduce 13 + + +state 21 + expr : expr_+ opnl expr + expr : expr_- opnl expr + expr : expr_* opnl expr + expr : expr_/ opnl expr + expr : - expr_ (12) + + . reduce 12 + + +state 22 + expr : expr + opnl_expr + opnl : opnl_\n + + CONST shift 9 + LETTER shift 20 + - shift 8 + \n shift 29 + ( shift 7 + . error + + expr goto 28 + +state 23 + expr : expr - opnl_expr + opnl : opnl_\n + + CONST shift 9 + LETTER shift 20 + - shift 8 + \n shift 29 + ( shift 7 + . error + + expr goto 30 + +state 24 + expr : expr * opnl_expr + opnl : opnl_\n + + CONST shift 9 + LETTER shift 20 + - shift 8 + \n shift 29 + ( shift 7 + . error + + expr goto 31 + +state 25 + expr : expr / opnl_expr + opnl : opnl_\n + + CONST shift 9 + LETTER shift 20 + - shift 8 + \n shift 29 + ( shift 7 + . error + + expr goto 32 + +state 26 + stmt : LETTER = expr_ (6) + expr : expr_+ opnl expr + expr : expr_- opnl expr + expr : expr_* opnl expr + expr : expr_/ opnl expr + + + shift 14 + - shift 15 + * shift 16 + / shift 17 + . reduce 6 + + +state 27 + expr : ( expr )_ (7) + + . reduce 7 + + +state 28 + expr : expr_+ opnl expr + expr : expr + opnl expr_ (8) + expr : expr_- opnl expr + expr : expr_* opnl expr + expr : expr_/ opnl expr + + * shift 16 + / shift 17 + . reduce 8 + + +state 29 + opnl : opnl \n_ (18) + + . reduce 18 + + +state 30 + expr : expr_+ opnl expr + expr : expr_- opnl expr + expr : expr - opnl expr_ (9) + expr : expr_* opnl expr + expr : expr_/ opnl expr + + * shift 16 + / shift 17 + . reduce 9 + + +state 31 + expr : expr_+ opnl expr + expr : expr_- opnl expr + expr : expr_* opnl expr + expr : expr * opnl expr_ (10) + expr : expr_/ opnl expr + + . reduce 10 + + +state 32 + expr : expr_+ opnl expr + expr : expr_- opnl expr + expr : expr_* opnl expr + expr : expr_/ opnl expr + expr : expr / opnl expr_ (11) + + . reduce 11 + + +15/127 terminals, 5/300 nonterminals +19/600 grammar rules, 33/750 states +0 shift/reduce, 0 reduce/reduce conflicts reported +13/350 working sets used +memory: states,etc. 226/12000, parser 14/12000 +11/600 distinct lookahead sets +5 extra closures +59 shift entries, 1 exceptions +15 goto entries +0 entries saved by goto default +Optimizer space used: input 145/12000, output 249/12000 +249 table entries, 204 zero +maximum spread: 259, maximum offset: 259 diff --git a/unix/boot/xyacc/debug/ytab.x b/unix/boot/xyacc/debug/ytab.x new file mode 100644 index 00000000..5a453b52 --- /dev/null +++ b/unix/boot/xyacc/debug/ytab.x @@ -0,0 +1,645 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define YYMAXDEPTH 150 # length of parser stack + +task dc = t_dc + +# Operand Structure (parser stack) +define YYOPLEN 2 # size of operand structure +define OPTYPE Memi[$1] # operand datatype +define OPVALI Memi[$1+1] # integer value of operand +define OPVALR Memr[$1+1] # real value of operand + +define CONST 257 +define LETTER 258 +define YYEOF 259 +define UMINUS 260 +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + +# line 89 "dc.y" + + + +# DC -- Main routine for the desk calculator. + +procedure t_dc() + +bool debug +int status +bool clgetb() +int yyparse() +extern yylex() + +begin + debug = clgetb ("debug") + + repeat { + status = yyparse (STDIN, debug, yylex) + if (status == ERR) + call eprintf ("syntax error") + } until (status == EOF) +end + + +# BINOP -- Perform an arithmetic binary operation on two operands (passed +# by pointer), returning the result in a third. + +procedure binop (a, b, c, opchar) + +pointer a, b, c # c = a op b +char opchar # i.e., '+', '-', etc. +int i, j, k +real x, y, z + +begin + if (OPTYPE(a) == TY_INT && OPTYPE(b) == TY_INT) { + # Both operands are of type int, so return an integer result. + + i = OPVALI(a) + j = OPVALI(b) + + switch (opchar) { + case '+': + k = i + j + case '-': + k = i - j + case '*': + k = i * j + case '/': + k = i / j + default: + call error (1, "unknown binary operator") + } + OPVALI(c) = k + OPTYPE(c) = TY_INT + + } else { + # At least one of the two operands is a real. Perform the + # calculation in type real, producing a real result. + + if (OPTYPE(a) == TY_INT) + x = OPVALI(a) + else + x = OPVALR(a) + if (OPTYPE(b) == TY_INT) + y = OPVALI(b) + else + y = OPVALR(b) + + switch (opchar) { + case '+': + z = x + y + case '-': + z = x - y + case '*': + z = x * y + case '/': + z = x / y + default: + call error (1, "unknown binary operator") + } + + OPVALR(c) = z + OPTYPE(c) = TY_REAL + } +end + + +# UNOP -- Perform a unary operation. Since there is only one operand, the +# datatype does not change. + +procedure unop (a, b, opchar) + +pointer a, b +char opchar + +begin + OPTYPE(b) = OPTYPE(a) + + switch (opchar) { + case '-': + switch (OPTYPE(a)) { + case TY_INT: + OPVALI(b) = -OPVALI(a) + case TY_REAL: + OPVALR(b) = -OPVALR(a) + } + default: + call error (2, "unknown unary operator") + } +end + + +# GETREG, PUTREG -- Fetch or store the contents of a register variable. +# Registers are referred to by letter, A-Z or a-z. + +define MAXREG ('z'-'a'+1) + + +procedure getreg (regchar, op) + +char regchar +pointer op + +bool store +int regbuf[MAXREG*YYOPLEN] +int reg, offset + +begin + store = false + goto 10 + +entry putreg (regchar, op) + store = true + + # Compute offset into storage. Structures are stored in buffer + # by a binary copy, knowing only the length of the structure. +10 if (IS_UPPER(regchar)) + reg = regchar - 'A' + 1 + else + reg = regchar - 'a' + 1 + reg = max(1, min(MAXREG, reg)) + offset = (reg-1) * YYOPLEN + 1 + + # Copy the operand structure either in or out. + if (store) + call amovi (Memi[op], regbuf[offset], YYOPLEN) + else + call amovi (regbuf[offset], Memi[op], YYOPLEN) +end + + +# YYLEX -- Lexical input routine. Return next token from the input +# stream. Recognized tokens are CONST (numeric constants), LETTER, +# and the operator characters. + +int procedure yylex (fd, yylval) + +int fd +pointer yylval +char ch, lbuf[SZ_LINE] +int ip, nchars, token, junk +double dval +int lexnum(), getline(), gctod() +data ip /0/ + +begin + # Fetch a nonempty input line, or advance to start of next token + # if within a line. Newline is a token. + repeat { + if (ip <= 0 || lbuf[ip] == EOS) { + if (getline (fd, lbuf) == EOF) { + ip = 0 + return (YYEOF) + } else + ip = 1 + } + while (IS_WHITE (lbuf[ip])) + ip = ip + 1 + } until (lbuf[ip] != EOS) + + # Determine type of token. If numeric constant, convert to binary + # and return value in op structure (yylval). If letter (register + # variable) return value and advance input one char. If any other + # character, return char itself as the token, and advance input one + # character. + + if (IS_DIGIT (lbuf[ip])) + token = lexnum (lbuf, ip, nchars) + else + token = LEX_NONNUM + + switch (token) { + case LEX_OCTAL, LEX_DECIMAL, LEX_HEX: + junk = gctod (lbuf, ip, dval) + OPTYPE(yylval) = TY_INT + OPVALI(yylval) = int (dval) + return (CONST) + + case LEX_REAL: + junk = gctod (lbuf, ip, dval) + OPTYPE(yylval) = TY_REAL + OPVALR(yylval) = dval + return (CONST) + + default: + ch = lbuf[ip] + ip = ip + 1 + if (IS_ALPHA (ch)) { + OPTYPE(yylval) = LETTER + OPVALI(yylval) = ch + return (LETTER) + } else { + OPTYPE(yylval) = ch + return (OPTYPE(yylval)) + } + } +end +define YYNPROD 19 +define YYLAST 249 + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer sp, yypvt +short yystate, yyn +int yyxi + +int toksp # declarations for status entry points +int uups, uuchar +pointer valsp, uuop, uupv, uuval, uulval +int yygtok(), yygval(), yystat() +errchk salloc, yylex + +short yyexca[6] +data (yyexca(i),i= 1, 6) / -1, 1, 0, -1, -2, 0/ +short yyact[249] +data (yyact(i),i= 1, 8) / 29, 7, 2, 7, 18, 12, 8, 16/ +data (yyact(i),i= 9, 16) / 8, 27, 16, 14, 17, 15, 5, 17/ +data (yyact(i),i= 17, 24) / 16, 14, 13, 15, 10, 17, 19, 21/ +data (yyact(i),i= 25, 32) / 3, 22, 1, 0, 0, 0, 7, 0/ +data (yyact(i),i= 33, 40) / 0, 26, 0, 8, 0, 28, 30, 31/ +data (yyact(i),i= 41, 48) / 32, 23, 24, 25, 0, 0, 0, 0/ +data (yyact(i),i= 49, 56) / 0, 0, 0, 0, 0, 0, 11, 0/ +data (yyact(i),i= 57, 64) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i= 65, 72) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i= 73, 80) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i= 81, 88) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i= 89, 96) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i= 97,104) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=105,112) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=113,120) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=121,128) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=129,136) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=137,144) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=145,152) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=153,160) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=161,168) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=169,176) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=177,184) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=185,192) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=193,200) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=201,208) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=209,216) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=217,224) / 0, 4, 9, 6, 9, 20, 0, 0/ +data (yyact(i),i=225,232) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=233,240) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=241,248) / 0, 0, 0, 0, 0, 0, 0, 9/ +data (yyact(i),i=249,249) / 20/ +short yypact[33] +data (yypact(i),i= 1, 8) /-257, -39,-1000, -5, 8, -26, -57, -37/ +data (yypact(i),i= 9, 16) / -37,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i= 17, 24) /-1000,-1000, -37, -32,-1000,-1000, -10, -10/ +data (yypact(i),i= 25, 32) / -10, -10, -26,-1000, -35,-1000, -35,-1000/ +data (yypact(i),i= 33, 33) /-1000/ +short yypgo[6] +data (yypgo(i),i= 1, 6) / 0, 26, 24, 20, 14, 25/ +short yyr1[19] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 1, 1, 2, 2, 4/ +data (yyr1(i),i= 9, 16) / 4, 4, 4, 4, 4, 4, 4, 3/ +data (yyr1(i),i= 17, 19) / 3, 5, 5/ +short yyr2[19] +data (yyr2(i),i= 1, 8) / 0, 0, 3, 1, 3, 1, 3, 3/ +data (yyr2(i),i= 9, 16) / 4, 4, 4, 4, 2, 1, 1, 1/ +data (yyr2(i),i= 17, 19) / 1, 0, 2/ +short yychk[33] +data (yychk(i),i= 1, 8) /-1000, -1, 259, -2, 256, -4, 258, 40/ +data (yychk(i),i= 9, 16) / 45, 257, -3, 59, 10, 10, 43, 45/ +data (yychk(i),i= 17, 24) / 42, 47, 61, -4, 258, -4, -5, -5/ +data (yychk(i),i= 25, 32) / -5, -5, -4, 41, -4, 10, -4, -4/ +data (yychk(i),i= 33, 33) / -4/ +short yydef[33] +data (yydef(i),i= 1, 8) / 1, -2, 3, 0, 0, 5, 13, 0/ +data (yydef(i),i= 9, 16) / 0, 14, 2, 15, 16, 4, 17, 17/ +data (yydef(i),i= 17, 24) / 17, 17, 0, 0, 13, 12, 0, 0/ +data (yydef(i),i= 25, 32) / 0, 0, 6, 7, 8, 18, 9, 10/ +data (yydef(i),i= 33, 33) / 11/ + +begin + call smark (sp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (sp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (sp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (sp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + +case 2: +# line 30 "dc.y" +{ + return (OK) + } +case 3: +# line 33 "dc.y" +{ + return (EOF) + } +case 4: +# line 36 "dc.y" +{ + yyerrok + } +case 5: +# line 41 "dc.y" +{ + # Print the value of an expression. + if (OPTYPE(yypvt) == TY_INT) { + call printf ("%d\n") + call pargi (OPVALI(yypvt)) + } else { + call printf ("%g\n") + call pargr (OPVALR(yypvt)) + } + } +case 6: +# line 51 "dc.y" +{ + # Set the value of a register (from a-z). + call putreg (char(OPVALI(yypvt-2*YYOPLEN)), yypvt) + } +case 7: +# line 57 "dc.y" +{ + YYMOVE (yypvt-YYOPLEN, yyval) + } +case 8: +# line 60 "dc.y" +{ + call binop (yypvt-3*YYOPLEN, yypvt, yyval, '+') + } +case 9: +# line 63 "dc.y" +{ + call binop (yypvt-3*YYOPLEN, yypvt, yyval, '-') + } +case 10: +# line 66 "dc.y" +{ + call binop (yypvt-3*YYOPLEN, yypvt, yyval, '*') + } +case 11: +# line 69 "dc.y" +{ + call binop (yypvt-3*YYOPLEN, yypvt, yyval, '/') + } +case 12: +# line 72 "dc.y" +{ + call unop (yypvt, yyval, '-') + } +case 13: +# line 75 "dc.y" +{ + call getreg (char(OPVALI(yypvt)), yyval) + } } + + goto yystack_ # stack new state and value + + +# The following entry points are provided so that lexical routines +# and actions may get information of the parser status, i.e., how +# deep is the stack, what tokens are currently stacked, and so on. +# Conceivably there could be reentrancy problems here... + + # YYGTOK -- Read an element from the token stack. +entry yygtok (toksp) + return (yys[toksp]) + + # YYGVAL -- Read an element from the value stack. +entry yygval (valsp, uuop) + YYMOVE (valsp, uuop) + return (OPTYPE(uuop)) + + # YYSTAT -- Return parser state variables. The code for the token + # currently on top of the stack is returned as the function value. + +entry yystat (uups, uupv, uuchar, uuval, uulval) + uups = yyps + uupv = yypv + uuchar = yychar + YYMOVE (yyval, uuval) + YYMOVE (yylval, uulval) + + if (yyps <= 0) + return (0) + else + return (yys[yyps]) +end diff --git a/unix/boot/xyacc/dextern.h b/unix/boot/xyacc/dextern.h new file mode 100644 index 00000000..e735003d --- /dev/null +++ b/unix/boot/xyacc/dextern.h @@ -0,0 +1,382 @@ +/* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License (the "License"). + * You may not use this file except in compliance with the License. + * + * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE + * or http://www.opensolaris.org/os/licensing. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at usr/src/OPENSOLARIS.LICENSE. + * If applicable, add the following below this CDDL HEADER, with the + * fields enclosed by brackets "[]" replaced with your own identifying + * information: Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + */ +/* + * Copyright 2008 Sun Microsystems, Inc. All rights reserved. + * Use is subject to license terms. + */ + +/* Copyright (c) 1988 AT&T */ +/* All Rights Reserved */ + +#ifndef _DEXTERN_H +#define _DEXTERN_H + +//#pragma ident "%Z%%M% %I% %E% SMI" + +#include +#include +#include +#include +#include +#ifdef LINUX +#include +#include +#else +#include +#endif +#include +#include + + +#ifdef __cplusplus +extern "C" { +#endif + + /* MANIFEST CONSTANT DEFINITIONS */ +#if u3b || u3b15 || u3b2 || vax || uts || sparc +#define WORD32 +#endif +#ifdef LINUX +#include +#endif + + /* base of nonterminal internal numbers */ + +#define NTBASE 010000 + + /* internal codes for error and accept actions */ + +#define ERRCODE 8190 +#define ACCEPTCODE 8191 + + /* sizes and limits */ + +#define ACTSIZE 12000 +#define MEMSIZE 12000 +#define NSTATES 750 +#define PSTSIZE 1024 +#define NTERMS 127 +#define NPROD 600 +#define NNONTERM 300 +#define TEMPSIZE 1200 +#define CNAMSZ 5000 +#define LSETSIZE 600 +#define WSETSIZE 350 + +#define NAMESIZE 50 +#define NTYPES 63 + +#define NMBCHARSZ 100 +#define LKFACTOR 16 + +#define WORD32 +#ifdef WORD32 + + /* bit packing macros (may be machine dependent) */ +#define BIT(a, i) ((a)[(i)>>5] & (1<<((i)&037))) +#define SETBIT(a, i) ((a)[(i)>>5] |= (1<<((i)&037))) + + /* number of words needed to hold n+1 bits */ +#define NWORDS(n) (((n)+32)/32) + +#else + + /* bit packing macros (may be machine dependent) */ +#define BIT(a, i) ((a)[(i)>>4] & (1<<((i)&017))) +#define SETBIT(a, i) ((a)[(i)>>4] |= (1<<((i)&017))) + + /* number of words needed to hold n+1 bits */ +#define NWORDS(n) (((n)+16)/16) +#endif + + /* + * relationships which must hold: + * TBITSET ints must hold NTERMS+1 bits... + * WSETSIZE >= NNONTERM + * LSETSIZE >= NNONTERM + * TEMPSIZE >= NTERMS + NNONTERMs + 1 + * TEMPSIZE >= NSTATES + */ + + /* associativities */ + +#define NOASC 0 /* no assoc. */ +#define LASC 1 /* left assoc. */ +#define RASC 2 /* right assoc. */ +#define BASC 3 /* binary assoc. */ + + /* flags for state generation */ + +#define DONE 0 +#define MUSTDO 1 +#define MUSTLOOKAHEAD 2 + + /* flags for a rule having an action, and being reduced */ + +#define ACTFLAG 04 +#define REDFLAG 010 + + /* output parser flags */ +#define YYFLAG1 (-1000) + + /* macros for getting associativity and precedence levels */ + +#define ASSOC(i) ((i)&07) +#define PLEVEL(i) (((i)>>4)&077) +#define TYPE(i) ((i>>10)&077) + + /* macros for setting associativity and precedence levels */ + +#define SETASC(i, j) i |= j +#define SETPLEV(i, j) i |= (j<<4) +#define SETTYPE(i, j) i |= (j<<10) + + /* looping macros */ + +#define TLOOP(i) for (i = 1; i <= ntokens; ++i) +#define NTLOOP(i) for (i = 0; i <= nnonter; ++i) +#define PLOOP(s, i) for (i = s; i < nprod; ++i) +#define SLOOP(i) for (i = 0; i < nstate; ++i) +#define WSBUMP(x) ++x +#define WSLOOP(s, j) for (j = s; j < &wsets[cwp]; ++j) +#define ITMLOOP(i, p, q) q = pstate[i+1]; for (p = pstate[i]; p < q; ++p) +#define SETLOOP(i) for (i = 0; i < tbitset; ++i) + + /* I/O descriptors */ + +extern FILE *finput; /* input file */ +extern FILE *faction; /* file for saving actions */ +extern FILE *fdefine; /* file for #defines */ +extern FILE *ftable; /* y.tab.c file */ +extern FILE *ftemp; /* tempfile to pass 2 */ +extern FILE *fdebug; /* tempfile for two debugging info arrays */ +extern FILE *foutput; /* y.output file */ +extern FILE *fsppout; /* ytab.x file */ + + /* structure declarations */ + +typedef struct looksets { + int *lset; +} LOOKSETS; + +typedef struct item { + int *pitem; + LOOKSETS *look; +} ITEM; + +typedef struct toksymb { + char *name; + int value; +} TOKSYMB; + +typedef struct mbclit { + char character; + int tvalue; /* token issued for the character */ +} MBCLIT; + +typedef struct ntsymb { + char *name; + int tvalue; +} NTSYMB; + +typedef struct wset { + int *pitem; + int flag; + LOOKSETS ws; +} WSET; + + /* token information */ + +extern int ntokens; /* number of tokens */ +extern TOKSYMB *tokset; +extern int ntoksz; + + /* + * multibyte (c > 255) character literals are + * handled as though they were tokens except + * that it generates a separate mapping table. + */ +extern int nmbchars; /* number of mb literals */ +extern MBCLIT *mbchars; +extern int nmbcharsz; + + /* nonterminal information */ + +extern int nnonter; /* the number of nonterminals */ +extern NTSYMB *nontrst; +extern int nnontersz; + + /* grammar rule information */ + +extern int nprod; /* number of productions */ +extern int **prdptr; /* pointers to descriptions of productions */ +extern int *levprd; /* contains production levels to break conflicts */ +extern char *had_act; /* set if reduction has associated action code */ + + /* state information */ + +extern int nstate; /* number of states */ +extern ITEM **pstate; /* pointers to the descriptions of the states */ +extern int *tystate; /* contains type information about the states */ +extern int *defact; /* the default action of the state */ + +extern int size; + + /* lookahead set information */ + +extern int TBITSET; +extern LOOKSETS *lkst; +extern int nolook; /* flag to turn off lookahead computations */ + + /* working set information */ + +extern WSET *wsets; + + /* storage for productions */ + +extern int *mem0; +extern int *mem; +extern int *tracemem; +extern int new_memsize; + + /* storage for action table */ + +extern int *amem; +extern int *memp; /* next free action table position */ +extern int *indgo; /* index to the stored goto table */ +extern int new_actsize; + + /* temporary vector, indexable by states, terms, or ntokens */ + +extern int *temp1; +extern int lineno; /* current line number */ + + /* statistics collection variables */ + +extern int zzgoent; +extern int zzgobest; +extern int zzacent; +extern int zzexcp; +extern int zzrrconf; +extern int zzsrconf; + + /* define external functions */ + +extern void setup(int, char *[]); +extern void closure(int); +extern void output(void); +extern void aryfil(int *, int, int); +extern void error(char *, ...); +extern void warning(int, char *, ...); +extern void putitem(int *, LOOKSETS *); +extern void go2out(void); +extern void hideprod(void); +extern void callopt(void); +extern void warray(char *, int *, int); +extern char *symnam(int); +extern char *writem(int *); +extern void exp_mem(int); +extern void exp_act(int **); +extern int apack(int *, int); +extern int state(int); +extern void fprintf3(FILE *, const char *, const char *, const char *, ...); +extern void error3(const char *, const char *, const char *, ...); + +extern char *wscpy(char *, const char *); +extern size_t wslen(const char *); +extern int wscmp(const char *, const char *); + + + /* yaccpar location */ + +extern char *parser; + + /* default settings for a number of macros */ + + /* name of yacc tempfiles */ + +#ifndef TEMPNAME +#define TEMPNAME "yacc.tmp" +#endif + +#ifndef ACTNAME +#define ACTNAME "yacc.acts" +#endif + +#ifndef DEBUGNAME +#define DEBUGNAME "yacc.debug" +#endif + +#ifndef OFILE /* output file name */ +#define OFILE "ytab.x" +#endif + +#ifndef TABFILE /* parser tables file name */ +#define TABFILE "yacc.tab" +#endif + +#ifndef UDFILE /* user global declarations file name */ +#define UDFILE "yacc.udecl" +#endif + +#ifndef FILEU /* user output file name */ +#define FILEU "y.output" +#endif + +#ifndef FILED /* output file for # defines */ +#define FILED "ytab.h" +#endif + + /* command to clobber tempfiles after use */ + +#ifndef ZAPFILE +#define ZAPFILE(x) (void)unlink(x) +#endif + +#ifndef PARSER +#define PARSER "/iraf/iraf/lib/yaccpar.x" +#endif + + + +/* + * Lint is unable to properly handle formats with wide strings + * (e.g. %ws) and misdiagnoses them as being malformed. + * This macro is used to work around that, by substituting + * a pointer to a null string when compiled by lint. This + * trick works because lint is not able to evaluate the + * variable. + * + * When lint is able to handle %ws, it would be appropriate + * to come back through and remove the use of this macro. + */ +#if defined(__lint) +static const char *lint_ws_fmt = ""; +#define WSFMT(_fmt) lint_ws_fmt +#else +#define WSFMT(_fmt) _fmt +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* _DEXTERN_H */ diff --git a/unix/boot/xyacc/mkpkg.sh b/unix/boot/xyacc/mkpkg.sh new file mode 100644 index 00000000..205d8f5d --- /dev/null +++ b/unix/boot/xyacc/mkpkg.sh @@ -0,0 +1,7 @@ +# XYACC -- Yacc parser generator for SPP. + +$CC -c $HSI_CF y[1-4].c +$CC $HSI_LF y[1-4].o -o xyacc.e +mv -f xyacc.e ../../hlib +cp yaccpar.x ../../../lib +rm -f *.o diff --git a/unix/boot/xyacc/y1.c b/unix/boot/xyacc/y1.c new file mode 100644 index 00000000..58f2f945 --- /dev/null +++ b/unix/boot/xyacc/y1.c @@ -0,0 +1,1307 @@ +/* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License (the "License"). + * You may not use this file except in compliance with the License. + * + * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE + * or http://www.opensolaris.org/os/licensing. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at usr/src/OPENSOLARIS.LICENSE. + * If applicable, add the following below this CDDL HEADER, with the + * fields enclosed by brackets "[]" replaced with your own identifying + * information: Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + */ +/* + * Copyright 2008 Sun Microsystems, Inc. All rights reserved. + * Use is subject to license terms. + */ + +/* Copyright (c) 1988 AT&T */ +/* All Rights Reserved */ + +//#pragma ident "%Z%%M% %I% %E% SMI" + +#include "dextern.h" +#include +#include +#include +#include +#include /* For error() */ + +static void mktbls (void); +static void others (void); +static void summary (void); +static char *chcopy (char *, char *); +static int setunion (int *, int *); +static void prlook (LOOKSETS *); +static void cpres (void); +static void cpfir (void); +static void cempty (void); +static void stagen (void); +static LOOKSETS *flset (LOOKSETS *); +static void exp_lkst (void); +static void exp_wsets (void); +static void exp_states (void); +static void exp_psmem (void); + + /* lookahead computations */ + +int TBITSET; +static int tbitset; /* size of lookahead sets */ +LOOKSETS *lkst; +static int lsetsize; + +static int nlset = 0; /* next lookahead set index */ +int nolook = 0; /* flag to suppress lookahead computations */ +static LOOKSETS clset; /* temporary storage for lookahead computations */ + +static ITEM *psmem, *zzmemsz; +static int new_pstsize = PSTSIZE; + + /* I/O descriptors */ + +extern FILE *finput; /* input file */ +extern FILE *faction; /* file for saving actions */ +extern FILE *fdefine; /* file for #defines */ +extern FILE *fudecl; /* file for user declarations */ +extern FILE *ftable; /* parser tables file */ +extern FILE *fsppout; /* SPP output file */ +extern FILE *ftemp; /* tempfile to pass 2 */ +extern FILE *foutput; /* y.output file */ + + /* working set computations */ + +WSET *wsets; +int cwp; +static int wsetsz = 0; /* number of WSET items in wsets block */ + + /* state information */ + +int nstate = 0; /* number of states */ +static int nstatesz = NSTATES; /* number of state space allocated */ +ITEM **pstate; /* ptr to descriptions of the states */ +int *tystate; /* contains type info about the states */ +int *indgo; /* index to the stored goto table */ +static int *tmp_lset; +static int *tstates; /* states generated by terminal gotos */ +static int *ntstates; /* states generated by non-term gotos */ +static int *mstates; /* chain of overflows of term/nonterm */ + /* generation lists */ + + /* storage for the actions in the parser */ + +int *amem, *memp; /* next free action table position */ +int new_actsize = ACTSIZE; + + /* other storage areas */ + +int *temp1; /* temp storate, indexed by terms+ntokens or states */ +int lineno = 0; /* current input line number */ +int size; +static int fatfl = 1; /* if on, error is fatal */ +static int nerrors = 0; /* number of errors */ + + /* storage for information about the nonterminals */ + +static int ***pres; /* vector of pointers to productions */ + /* yielding each nonterminal */ +static LOOKSETS **pfirst; /* vector of pointers to first sets for */ + /* each nonterminal */ +static int *pempty; /* vector of nonterminals nontrivially */ + /* deriving e */ +extern int nprodsz; + +int +main (int argc, char *argv[]) +{ + (void) setlocale (LC_ALL, ""); +#if !defined(TEXT_DOMAIN) /* Should be defined by cc -D */ +#define TEXT_DOMAIN "SYS_TEST" /* Use this only if it weren't */ +#endif + /* + (void) textdomain (TEXT_DOMAIN); + */ + + setup (argc, argv); /* initialize and read productions */ + TBITSET = NWORDS (ntoksz * LKFACTOR); + tbitset = NWORDS (ntokens * LKFACTOR); + mktbls (); + cpres (); /* make table of which productions yield a */ + /* given nonterminal */ + cempty (); /* make a table of which nonterminals can match */ + /* the empty string */ + cpfir (); /* make a table of firsts of nonterminals */ + stagen (); /* generate the states */ + output (); /* write the states and the tables */ + go2out (); + hideprod (); + summary (); + callopt (); + others (); + return (0); +} + + +static void +mktbls () +{ + int i; + + size = ntoksz + nnontersz + 1; + if (size < nstatesz) + size = nstatesz; + if (size < new_memsize) + size = new_memsize; + + amem = (int *) malloc (sizeof (int) * new_actsize); + psmem = (ITEM *) malloc (sizeof (ITEM) * new_pstsize); + if ((psmem == NULL) || (amem == NULL)) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This error happens when yacc could not allocate + * initial memory to be used for internal tables. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("couldn't allocate initial table"); + zzmemsz = psmem; + memp = amem; + + /* + * For lkst + */ +#define INIT_LSIZE nnontersz*LKFACTOR + tmp_lset = (int *) + calloc ((size_t) (TBITSET * (INIT_LSIZE + 1)), sizeof (int)); + if (tmp_lset == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Yacc could not allocate memory for table named lookset. + * Do not translate 'lookset'. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("could not allocate lookset array"); + lkst = (LOOKSETS *) malloc (sizeof (LOOKSETS) * (INIT_LSIZE + 1)); + for (i = 0; i <= INIT_LSIZE; ++i) + lkst[i].lset = tmp_lset + TBITSET * i; + tmp_lset = NULL; + + /* + * For wsets + */ + tmp_lset = (int *) + calloc ((size_t) (TBITSET * (nnontersz + 1)), sizeof (int)); + if (tmp_lset == NULL) + error ("could not allocate lookset array"); + wsets = (WSET *) malloc (sizeof (WSET) * (nnontersz + 1)); + for (i = 0; i <= nnontersz; ++i) + wsets[i].ws.lset = tmp_lset + TBITSET * i; + tmp_lset = NULL; + + clset.lset = (int *) malloc (sizeof (int) * TBITSET); + tstates = (int *) malloc (sizeof (int) * (ntoksz + 1)); + ntstates = (int *) malloc (sizeof (int) * (nnontersz + 1)); + temp1 = (int *) malloc (sizeof (int) * size); + pres = (int ***) malloc (sizeof (int **) * (nnontersz + 2)); + pfirst = (LOOKSETS **) malloc (sizeof (LOOKSETS *) * (nnontersz + 2)); + pempty = (int *) malloc (sizeof (int) * (nnontersz + 1)); + + pstate = (ITEM **) malloc (sizeof (ITEM *) * (nstatesz + 2)); + tystate = (int *) malloc (sizeof (int) * nstatesz); + indgo = (int *) malloc (sizeof (int) * nstatesz); + mstates = (int *) malloc (sizeof (int) * nstatesz); + defact = (int *) malloc (sizeof (int) * nstatesz); + + if ((lkst == NULL) || (wsets == NULL) || (tstates == NULL) || + (ntstates == NULL) || (temp1 == NULL) || (pres == NULL) || + (pfirst == NULL) || (pempty == NULL) || (pstate == NULL) || + (tystate == NULL) || (indgo == NULL) || (mstates == NULL) || + (defact == NULL) || (clset.lset == NULL)) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate mktbls(). It is a function name. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("cannot allocate tables in mktbls()"); + + aryfil (ntstates, nnontersz + 1, 0); + aryfil (tstates, ntoksz + 1, 0); + wsetsz = nnontersz + 1; + lsetsize = INIT_LSIZE + 1; +} + +/* put out other arrays, copy the parsers */ +static void +others () +{ + extern int gen_lines; + int c, i, j; + int tmpline; + + finput = fopen (parser, "r"); + if (finput == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This error message is issued when yacc can not find + * the parser to be copied. + */ + error ("cannot find parser %s", parser); + + warray ("yyr1", levprd, nprod); + + aryfil (temp1, nprod, 0); + /* had_act[i] is either 1 or 0 */ +/* original + PLOOP(1, i) + temp1[i] = ((prdptr[i+1] - prdptr[i]-2) << 1) | had_act[i]; +*/ + PLOOP (1, i) temp1[i] = prdptr[i + 1] - prdptr[i] - 2; + + warray ("yyr2", temp1, nprod); + + aryfil (temp1, nstate, -1000); + TLOOP (i) for (j = tstates[i]; j != 0; j = mstates[j]) + temp1[j] = tokset[i].value; + NTLOOP (i) for (j = ntstates[i]; j != 0; j = mstates[j]) + temp1[j] = -i; + warray ("yychk", temp1, nstate); + warray ("yydef", defact, nstate); + + fclose (ftable); + fclose (fudecl); + + if ((fdebug = fopen (DEBUGNAME, "r")) == NULL) + error ("cannot open yacc.debug"); + while ((c = getc (fdebug)) != EOF) + (void) putc (c, fsppout); + (void) fclose (fdebug); + ZAPFILE (DEBUGNAME); + + if (gen_lines) + (void) fprintf (fsppout, "# line\t1 \"%s\"\n", parser); + tmpline = 1; + /* copy parser text */ + while ((c = getc (finput)) != EOF) { + if (c == '\n') + tmpline++; + if (c == '$') { + if ((c = getc (finput)) == 'A') { + /* Replace $A macro by the user declarations. + */ + fudecl = fopen (UDFILE, "r"); + if (fudecl == NULL) + error ("cannot reopen user declarations tempfile"); + while ((c = getc (fudecl)) != EOF) + putc (c, fsppout); + fclose (fudecl); + ZAPFILE (UDFILE); + /* Skip remainder of line following macro. + */ + while ((c = getc (finput)) != '\n' && c != EOF); + + } else if (c == 'B') { + /* Replace $B macro by the parser tables. + */ + ftable = fopen (TABFILE, "r"); + if (ftable == NULL) + error ("cannot reopen parser tables tempfile"); + while ((c = getc (ftable)) != EOF) + putc (c, fsppout); + fclose (ftable); + ZAPFILE (TABFILE); + /* Skip remainder of line following macro. + */ + while ((c = getc (finput)) != '\n' && c != EOF); + + } else if (c == 'C') { + /* Replace $C macro by user-supplied actions. + */ + faction = fopen (ACTNAME, "r"); + if (faction == NULL) + error ("cannot reopen action tempfile"); + while ((c = getc (faction)) != EOF) + putc (c, fsppout); + fclose (faction); + ZAPFILE (ACTNAME); + /* Skip remainder of line following macro. + */ + while ((c = getc (finput)) != '\n' && c != EOF); + + } else { + putc ('$', fsppout); + putc (c, fsppout); + } + + } else + putc (c, fsppout); + } + + fclose (fsppout); +} + + +/* copies string q into p, returning next free char ptr */ +static char * +chcopy (p, q) + char *p, *q; +{ + while ((*p = *q++)) + ++p; + return (p); +} + +#define ISIZE 400 +/* creates output string for item pointed to by pp */ +char * +writem (pp) + int *pp; +{ + int i, *p; + static int isize = ISIZE; + static char *sarr = NULL; + char *q; + + if (sarr == NULL) { + sarr = (char *) malloc (sizeof (char) * isize); + if (sarr == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This error is issued when yacc could not allocate + * memory for internally used array. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("could not allocate output string array"); + for (i = 0; i < isize; ++i) + sarr[i] = ' '; + } + for (p = pp; *p > 0; ++p) /* NULL */ + ; + p = prdptr[-*p]; + q = chcopy (sarr, nontrst[*p - NTBASE].name); + q = chcopy (q, " : "); + + for (;;) { + *q++ = ++p == pp ? '_' : ' '; + *q = 0; + if ((i = *p) <= 0) + break; + q = chcopy (q, symnam (i)); + while (q > &sarr[isize - 30]) { + static char *sarrbase; + + sarrbase = sarr; + isize += ISIZE; + sarr = (char *) + realloc ((char *) sarr, sizeof (*sarr) * isize); + if (sarr == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This error is issued when yacc could not allocate + * memory for internally used array. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("cannot expand sarr arrays"); + q = q - sarrbase + sarr; + } + } + + /* an item calling for a reduction */ + if ((i = *pp) < 0) { + q = chcopy (q, " ("); + (void) sprintf (q, "%d)", -i); + } + return (sarr); +} + +/* return a pointer to the name of symbol i */ +char * +symnam (int i) +{ + char *cp; + + cp = (i >= NTBASE) ? nontrst[i - NTBASE].name : tokset[i].name; + if (*cp == ' ') + ++cp; + return (cp); +} + +static int zzcwp = 0; +static int zzclose = 0; +int zzgoent = 0; +int zzgobest = 0; +int zzacent = 0; +int zzexcp = 0; +int zzsrconf = 0; +int zzrrconf = 0; + +/* output the summary on the tty */ +static void +summary () +{ + if (foutput != NULL) { + (void) fprintf (foutput, + "\n%d/%d terminals, %d/%d nonterminals\n", + ntokens, ntoksz, nnonter, nnontersz); + (void) fprintf (foutput, + "%d/%d grammar rules, %d/%d states\n", + nprod, nprodsz, nstate, nstatesz); + (void) fprintf (foutput, + "%d shift/reduce, %d reduce/reduce conflicts reported\n", + zzsrconf, zzrrconf); + (void) fprintf (foutput, "%d/%d working sets used\n", zzcwp, wsetsz); + (void) fprintf (foutput, + "memory: states,etc. %" PRIdPTR + "/%d, parser %" PRIdPTR "/%d\n", + mem - tracemem, new_memsize, + memp - amem, new_actsize); + (void) fprintf (foutput, + "%d/%d distinct lookahead sets\n", nlset, lsetsize); + (void) fprintf (foutput, "%d extra closures\n", zzclose - 2 * nstate); + (void) fprintf (foutput, + "%d shift entries, %d exceptions\n", zzacent, zzexcp); + (void) fprintf (foutput, "%d goto entries\n", zzgoent); + (void) fprintf (foutput, + "%d entries saved by goto default\n", zzgobest); + } + if (zzsrconf != 0 || zzrrconf != 0) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * You may just leave this message un-translated. + * This message only makes sense to those who knows + * how yacc works, and the person should know what + * this message means in English. + */ + (void) fprintf (stderr, "\nconflicts: "); + if (zzsrconf) + (void) fprintf (stderr, "%d shift/reduce", zzsrconf); + if (zzsrconf && zzrrconf) + (void) fprintf (stderr, ", "); + if (zzrrconf) + (void) fprintf (stderr, "%d reduce/reduce", zzrrconf); + (void) fprintf (stderr, "\n"); + } + + if (ftemp != NULL) + (void) fclose (ftemp); + if (fdefine != NULL) + (void) fclose (fdefine); +} + +/* write out error comment */ +/*PRINTFLIKE1*/ +void +error (char *s, ...) +{ + extern char *infile; + va_list ap; + + va_start (ap, s); + + ++nerrors; + if (!lineno) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is a prefix to the error messages + * passed to error() function. + */ + (void) fprintf (stderr, "command line: fatal: "); + else { + (void) fprintf (stderr, "\"%s\", ", infile); +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is a prefix to the error messages + * passed to error() function. + */ + (void) fprintf (stderr, "line %d: fatal: ", lineno); + } + (void) vfprintf (stderr, s, ap); + (void) fprintf (stderr, "\n"); + va_end (ap); + if (!fatfl) + return; + summary (); + exit (1); +} + +/* + * Print out a warning message. + */ +/*PRINTFLIKE2*/ +void +warning (int flag, char *s, ...) +{ + extern char *infile; + va_list ap; + va_start (ap, s); + + (void) fprintf (stderr, "\"%s\", ", infile); + /* + * If flag, print lineno as well. + */ + if (flag == 0) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is a prefix to the warning messages + * passed to warning() function. + */ + (void) fprintf (stderr, "warning: "); + else +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is a prefix to the warning messages + * passed to warning() function. + */ + (void) fprintf (stderr, "line %d: warning: ", lineno); + (void) vfprintf (stderr, s, ap); + (void) fprintf (stderr, "\n"); + va_end (ap); +} + +/* set elements 0 through n-1 to c */ +void +aryfil (v, n, c) + int *v, n, c; +{ + int i; + for (i = 0; i < n; ++i) + v[i] = c; +} + +/* set a to the union of a and b */ +/* return 1 if b is not a subset of a, 0 otherwise */ +static int +setunion (a, b) + int *a, *b; +{ + int i, x, sub; + + sub = 0; + SETLOOP (i) { + *a = (x = *a) | *b++; + if (*a++ != x) + sub = 1; + } + return (sub); +} + +static void +prlook (p) + LOOKSETS *p; +{ + int j, *pp; + pp = p->lset; + if (pp == 0) + (void) fprintf (foutput, "\tNULL"); + else { + (void) fprintf (foutput, " { "); + TLOOP (j) { + if (BIT (pp, j)) + (void) fprintf (foutput, WSFMT ("%s "), symnam (j)); + } + (void) fprintf (foutput, "}"); + } +} + +/* + * compute an array with the beginnings of productions yielding + * given nonterminals + * The array pres points to these lists + * the array pyield has the lists: the total size is only NPROD+1 + */ +static void +cpres () +{ + int **ptrpy; + int **pyield; + int c, j, i; + + /* + * 2/29/88 - + * nprodsz is the size of the tables describing the productions. + * Normally this will be NPROD unless the production tables have + * been expanded, in which case the tables will be NPROD * N(where + * N is the number of times the tables had to be expanded.) + */ + if ((pyield = (int **) malloc (sizeof (int *) * nprodsz)) == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This error is issued when yacc could not allocate + * memory for internally used array. + * + * pyield is name of an array. You should not try to translate + * this word. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("cannot allocate space for pyield array"); + + ptrpy = pyield; + + NTLOOP (i) { + c = i + NTBASE; + pres[i] = ptrpy; + fatfl = 0; /* make undefined symbols nonfatal */ + PLOOP (0, j) { + if (*prdptr[j] == c) /* linear search for all c's */ + *ptrpy++ = prdptr[j] + 1; + } + if (pres[i] == ptrpy) { /* c not found */ +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Ask somebody who knows yacc how to translate nonterminal or + * look at translated yacc document. + */ + error ("undefined nonterminal: %s", nontrst[i].name); + } + } + pres[i] = ptrpy; + fatfl = 1; + if (nerrors) { + summary (); + exit (1); + } + if (ptrpy != &pyield[nprod]) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This is an internal error message. + * Very little use to user. You may leave it + * un-translated. + * + * pyied is name of an array. Do not translate it. + */ + error ("internal Yacc error: pyield %d", ptrpy - &pyield[nprod]); +} + +static int indebug = 0; +/* compute an array with the first of nonterminals */ +static void +cpfir () +{ + int *p, **s, i, **t, ch, changes; + + zzcwp = nnonter; + NTLOOP (i) { + aryfil (wsets[i].ws.lset, tbitset, 0); + t = pres[i + 1]; + /* initially fill the sets */ + for (s = pres[i]; s < t; ++s) { + /* check if ch is non-terminal */ + for (p = *s; (ch = *p) > 0; ++p) { + if (ch < NTBASE) { /* should be token */ + SETBIT (wsets[i].ws.lset, ch); + break; + } else if (!pempty[ch - NTBASE]) + break; + } + } + } + + /* now, reflect transitivity */ + + changes = 1; + while (changes) { + changes = 0; + NTLOOP (i) { + t = pres[i + 1]; + for (s = pres[i]; s < t; ++s) { + for (p = *s; (ch = (*p - NTBASE)) >= 0; ++p) { + changes |= setunion (wsets[i].ws.lset, wsets[ch].ws.lset); + if (!pempty[ch]) + break; + } + } + } + } + + NTLOOP (i) pfirst[i] = flset (&wsets[i].ws); + if (!indebug) + return; + if ((foutput != NULL)) { + NTLOOP (i) { + (void) fprintf (foutput, WSFMT ("\n%s: "), nontrst[i].name); + prlook (pfirst[i]); + (void) fprintf (foutput, " %d\n", pempty[i]); + } + } +} + +/* sorts last state,and sees if it equals earlier ones. returns state number */ +int +state (int c) +{ + int size1, size2; + int i; + ITEM *p1, *p2, *k, *l, *q1, *q2; + p1 = pstate[nstate]; + p2 = pstate[nstate + 1]; + if (p1 == p2) + return (0); /* null state */ + /* sort the items */ + for (k = p2 - 1; k > p1; k--) { /* make k the biggest */ + for (l = k - 1; l >= p1; --l) + if (l->pitem > k->pitem) { + int *s; + LOOKSETS *ss; + s = k->pitem; + k->pitem = l->pitem; + l->pitem = s; + ss = k->look; + k->look = l->look; + l->look = ss; + } + } + size1 = p2 - p1; /* size of state */ + + for (i = (c >= NTBASE) ? ntstates[c - NTBASE] : tstates[c]; + i != 0; i = mstates[i]) { + /* get ith state */ + q1 = pstate[i]; + q2 = pstate[i + 1]; + size2 = q2 - q1; + if (size1 != size2) + continue; + k = p1; + for (l = q1; l < q2; l++) { + if (l->pitem != k->pitem) + break; + ++k; + } + if (l != q2) + continue; + /* found it */ + pstate[nstate + 1] = pstate[nstate]; /* delete last state */ + /* fix up lookaheads */ + if (nolook) + return (i); + for (l = q1, k = p1; l < q2; ++l, ++k) { + int s; + SETLOOP (s) clset.lset[s] = l->look->lset[s]; + if (setunion (clset.lset, k->look->lset)) { + tystate[i] = MUSTDO; + /* register the new set */ + l->look = flset (&clset); + } + } + return (i); + } + /* state is new */ + if (nolook) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * You may leave this untranslated. Leave + * state/nolook un-translated. + */ + error ("yacc state/nolook error"); + pstate[nstate + 2] = p2; + if (nstate + 1 >= nstatesz) + exp_states (); + if (c >= NTBASE) { + mstates[nstate] = ntstates[c - NTBASE]; + ntstates[c - NTBASE] = nstate; + } else { + mstates[nstate] = tstates[c]; + tstates[c] = nstate; + } + tystate[nstate] = MUSTDO; + return (nstate++); +} + +static int pidebug = 0; + +void +putitem (ptr, lptr) + int *ptr; + LOOKSETS *lptr; +{ + register ITEM *j; + + if (pidebug && (foutput != NULL)) + (void) fprintf (foutput, + WSFMT ("putitem(%s), state %d\n"), writem (ptr), + nstate); + j = pstate[nstate + 1]; + j->pitem = ptr; + if (!nolook) + j->look = flset (lptr); + pstate[nstate + 1] = ++j; + if (j > zzmemsz) { + zzmemsz = j; + if (zzmemsz >= &psmem[new_pstsize]) + exp_psmem (); + /* error("out of state space"); */ + } +} + +/* + * mark nonterminals which derive the empty string + * also, look for nonterminals which don't derive any token strings + */ +static void +cempty () +{ +#define EMPTY 1 +#define WHOKNOWS 0 +#define OK 1 + int i, *p; + + /* + * first, use the array pempty to detect productions + * that can never be reduced + */ + + /* set pempty to WHONOWS */ + aryfil (pempty, nnonter + 1, WHOKNOWS); + + /* + * now, look at productions, marking nonterminals which + * derive something + */ + more: + PLOOP (0, i) { + if (pempty[*prdptr[i] - NTBASE]) + continue; + for (p = prdptr[i] + 1; *p >= 0; ++p) + if (*p >= NTBASE && pempty[*p - NTBASE] == WHOKNOWS) + break; + if (*p < 0) { /* production can be derived */ + pempty[*prdptr[i] - NTBASE] = OK; + goto more; + } + } + + /* now, look at the nonterminals, to see if they are all OK */ + + NTLOOP (i) { + /* + * the added production rises or falls as the + * start symbol ... + */ + if (i == 0) + continue; + if (pempty[i] != OK) { + fatfl = 0; +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Ask somebody who knows yacc how to translate nonterminal or + * look at translated yacc document. Check how 'derive' is + * translated in these documents also. + */ + error ("nonterminal %s never derives any token string", + nontrst[i].name); + } + } + + if (nerrors) { + summary (); + exit (1); + } + + /* + * now, compute the pempty array, to see which nonterminals + * derive the empty string + */ + + /* set pempty to WHOKNOWS */ + + aryfil (pempty, nnonter + 1, WHOKNOWS); + + /* loop as long as we keep finding empty nonterminals */ + + again: + PLOOP (1, i) { + /* not known to be empty */ + if (pempty[*prdptr[i] - NTBASE] == WHOKNOWS) { + for (p = prdptr[i] + 1; + *p >= NTBASE && pempty[*p - NTBASE] == EMPTY; ++p); + /* we have a nontrivially empty nonterminal */ + if (*p < 0) { + pempty[*prdptr[i] - NTBASE] = EMPTY; + goto again; /* got one ... try for another */ + } + } + } +} + +/* generate the states */ +static int gsdebug = 0; +static void +stagen () +{ + int i, j; + int c; + register WSET *p, *q; + + /* initialize */ + + nstate = 0; + + pstate[0] = pstate[1] = psmem; + aryfil (clset.lset, tbitset, 0); + putitem (prdptr[0] + 1, &clset); + tystate[0] = MUSTDO; + nstate = 1; + pstate[2] = pstate[1]; + + aryfil (amem, new_actsize, 0); + + /* now, the main state generation loop */ + + more: + SLOOP (i) { + if (tystate[i] != MUSTDO) + continue; + tystate[i] = DONE; + aryfil (temp1, nnonter + 1, 0); + /* take state i, close it, and do gotos */ + closure (i); + WSLOOP (wsets, p) { /* generate goto's */ + if (p->flag) + continue; + p->flag = 1; + c = *(p->pitem); + if (c <= 1) { + if (pstate[i + 1] - pstate[i] <= p - wsets) + tystate[i] = MUSTLOOKAHEAD; + continue; + } + /* do a goto on c */ + WSLOOP (p, q) { + /* this item contributes to the goto */ + if (c == *(q->pitem)) { + putitem (q->pitem + 1, &q->ws); + q->flag = 1; + } + } + if (c < NTBASE) + (void) state (c); /* register new state */ + else + temp1[c - NTBASE] = state (c); + } + if (gsdebug && (foutput != NULL)) { + (void) fprintf (foutput, "%d: ", i); + NTLOOP (j) { + if (temp1[j]) + (void) fprintf (foutput, + WSFMT ("%s %d, "), nontrst[j].name, + temp1[j]); + } + (void) fprintf (foutput, "\n"); + } + indgo[i] = apack (&temp1[1], nnonter - 1) - 1; + goto more; /* we have done one goto; do some more */ + } + /* no more to do... stop */ +} + +/* generate the closure of state i */ +static int cldebug = 0; /* debugging flag for closure */ + +void +closure (int i) +{ + int c, ch, work, k; + register WSET *u, *v; + int *pi; + int **s, **t; + ITEM *q; + register ITEM *p; + int idx1 = 0; + + ++zzclose; + + /* first, copy kernel of state i to wsets */ + cwp = 0; + ITMLOOP (i, p, q) { + wsets[cwp].pitem = p->pitem; + wsets[cwp].flag = 1; /* this item must get closed */ + SETLOOP (k) wsets[cwp].ws.lset[k] = p->look->lset[k]; + WSBUMP (cwp); + } + + /* now, go through the loop, closing each item */ + + work = 1; + while (work) { + work = 0; + /* + * WSLOOP(wsets, u) { + */ + for (idx1 = 0; idx1 < cwp; idx1++) { + u = &wsets[idx1]; + if (u->flag == 0) + continue; + c = *(u->pitem); /* dot is before c */ + if (c < NTBASE) { + u->flag = 0; + /* + * only interesting case is where . is + * before nonterminal + */ + continue; + } + + /* compute the lookahead */ + aryfil (clset.lset, tbitset, 0); + + /* find items involving c */ + + WSLOOP (u, v) { + if (v->flag == 1 && *(pi = v->pitem) == c) { + v->flag = 0; + if (nolook) + continue; + while ((ch = *++pi) > 0) { + /* terminal symbol */ + if (ch < NTBASE) { + SETBIT (clset.lset, ch); + break; + } + /* nonterminal symbol */ + (void) setunion (clset.lset, + pfirst[ch - NTBASE]->lset); + if (!pempty[ch - NTBASE]) + break; + } + if (ch <= 0) + (void) setunion (clset.lset, v->ws.lset); + } + } + + /* now loop over productions derived from c */ + + c -= NTBASE; /* c is now nonterminal number */ + + t = pres[c + 1]; + for (s = pres[c]; s < t; ++s) { + /* put these items into the closure */ + WSLOOP (wsets, v) { /* is the item there */ + /* yes, it is there */ + if (v->pitem == *s) { + if (nolook) + goto nexts; + if (setunion (v->ws.lset, clset.lset)) + v->flag = work = 1; + goto nexts; + } + } + + /* not there; make a new entry */ + if (cwp + 1 >= wsetsz) + exp_wsets (); + + wsets[cwp].pitem = *s; + wsets[cwp].flag = 1; + if (!nolook) { + work = 1; + SETLOOP (k) wsets[cwp].ws.lset[k] = clset.lset[k]; + } + WSBUMP (cwp); + nexts:; + } + } + } + + /* have computed closure; flags are reset; return */ + + if (&wsets[cwp] > &wsets[zzcwp]) + zzcwp = cwp; + if (cldebug && (foutput != NULL)) { + (void) fprintf (foutput, "\nState %d, nolook = %d\n", i, nolook); + WSLOOP (wsets, u) { + if (u->flag) + (void) fprintf (foutput, "flag set!\n"); + u->flag = 0; + (void) fprintf (foutput, WSFMT ("\t%s"), writem (u->pitem)); + prlook (&u->ws); + (void) fprintf (foutput, "\n"); + } + } +} + +static LOOKSETS * +flset (p) + LOOKSETS *p; +{ + /* decide if the lookahead set pointed to by p is known */ + /* return pointer to a perminent location for the set */ + + int j, *w; + int *u, *v; + register LOOKSETS *q; + + for (q = &lkst[nlset]; q-- > lkst;) { + u = p->lset; + v = q->lset; + w = &v[tbitset]; + while (v < w) + if (*u++ != *v++) + goto more; + /* we have matched */ + return (q); + more:; + } + /* add a new one */ + q = &lkst[nlset++]; + if (nlset >= lsetsize) { + exp_lkst (); + q = &lkst[nlset++]; + } + SETLOOP (j) q->lset[j] = p->lset[j]; + return (q); +} + +static void +exp_lkst () +{ + int i, j; + static LOOKSETS *lookbase; + + lookbase = lkst; + lsetsize += LSETSIZE; + tmp_lset = (int *) + calloc ((size_t) (TBITSET * (lsetsize - LSETSIZE)), sizeof (int)); + if (tmp_lset == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Memory allocation error. Do not translate lookset. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("could not expand lookset array"); + lkst = (LOOKSETS *) realloc ((char *) lkst, sizeof (LOOKSETS) * lsetsize); + for (i = lsetsize - LSETSIZE, j = 0; i < lsetsize; ++i, ++j) + lkst[i].lset = tmp_lset + TBITSET * j; + tmp_lset = NULL; + if (lkst == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Memory allocation error. Do not translate lookset. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("could not expand lookahead sets"); + for (i = 0; i <= nnonter; ++i) + pfirst[i] = pfirst[i] - lookbase + lkst; + for (i = 0; i <= nstate + 1; ++i) { + if (psmem[i].look) + psmem[i].look = psmem[i].look - lookbase + lkst; + if (pstate[i]->look) + pstate[i]->look = pstate[i]->look - lookbase + lkst; + } +} + +static void +exp_wsets () +{ + int i, j; + + wsetsz += WSETSIZE; + tmp_lset = (int *) + calloc ((size_t) (TBITSET * (wsetsz - WSETSIZE)), sizeof (int)); + if (tmp_lset == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Memory allocation error. Do not translate lookset. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("could not expand lookset array"); + wsets = (WSET *) realloc ((char *) wsets, sizeof (WSET) * wsetsz); + for (i = wsetsz - WSETSIZE, j = 0; i < wsetsz; ++i, ++j) + wsets[i].ws.lset = tmp_lset + TBITSET * j; + tmp_lset = NULL; + if (wsets == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Memory allocation error. You may just transltate + * this as 'Could not allocate internally used memory.' + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("could not expand working sets"); +} + +static void +exp_states () +{ + nstatesz += NSTATES; + + pstate = (ITEM **) + realloc ((char *) pstate, sizeof (ITEM *) * (nstatesz + 2)); + mstates = (int *) realloc ((char *) mstates, sizeof (int) * nstatesz); + defact = (int *) realloc ((char *) defact, sizeof (int) * nstatesz); + tystate = (int *) realloc ((char *) tystate, sizeof (int) * nstatesz); + indgo = (int *) realloc ((char *) indgo, sizeof (int) * nstatesz); + + if ((*pstate == NULL) || (tystate == NULL) || (defact == NULL) || + (indgo == NULL) || (mstates == NULL)) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Memory allocation error. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("cannot expand table of states"); +} + +static void +exp_psmem () +{ + int i; + + new_pstsize += PSTSIZE; + psmem = (ITEM *) realloc ((char *) psmem, sizeof (ITEM) * new_pstsize); + if (psmem == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Memory allocation error. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("cannot expand pstate memory"); + + zzmemsz = zzmemsz - pstate[0] + psmem; + for (i = 1; i <= nstate + 1; ++i) + pstate[i] = pstate[i] - pstate[0] + psmem; + pstate[0] = psmem; +} diff --git a/unix/boot/xyacc/y2.c b/unix/boot/xyacc/y2.c new file mode 100644 index 00000000..072b6c8c --- /dev/null +++ b/unix/boot/xyacc/y2.c @@ -0,0 +1,1952 @@ +/* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License (the "License"). + * You may not use this file except in compliance with the License. + * + * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE + * or http://www.opensolaris.org/os/licensing. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at usr/src/OPENSOLARIS.LICENSE. + * If applicable, add the following below this CDDL HEADER, with the + * fields enclosed by brackets "[]" replaced with your own identifying + * information: Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + */ +/* + * Copyright 2008 Sun Microsystems, Inc. All rights reserved. + * Use is subject to license terms. + */ + +/* Copyright (c) 1988 AT&T */ +/* All Rights Reserved */ + +//#pragma ident "%Z%%M% %I% %E% SMI" + +#include "dextern.h" +#include + + +#define IDENTIFIER 257 + +#define MARK 258 +#define TERM 259 +#define LEFT 260 +#define RIGHT 261 +#define BINARY 262 +#define PREC 263 +#define LCURLY 264 +#define C_IDENTIFIER 265 /* name followed by colon */ +#define NUMBER 266 +#define START 267 +#define TYPEDEF 268 +#define TYPENAME 269 +#define UNION 270 +#define ENDFILE 0 +#define LHS_TEXT_LEN 80 /* length of lhstext */ +#define RHS_TEXT_LEN 640 /* length of rhstext */ + /* communication variables between various I/O routines */ + +#define v_FLAG 0x01 +#define d_FLAG 0x02 +#define DEFAULT_PREFIX "y" + +char *infile; /* input file name */ +static int numbval; /* value of an input number */ +static int toksize = NAMESIZE; +static char *tokname; /* input token name */ +char *parser = PARSER; /* location of common parser */ + +static void finact (void); +static char *cstash (char *); +static void defout (void); +static void cpyunion (void); +static void cpycode (void); +static void cpyact (int); +static void lhsfill (char *); +static void rhsfill (char *); +static void lrprnt (void); +#ifdef XYACC_DEBUG +static void beg_debug (void); +static void end_toks (void); +static void end_debug (void); +#endif +static void exp_tokname (void); +static void exp_prod (void); +static void exp_ntok (void); +static void exp_nonterm (void); +static int defin (int, char *); +static int gettok (void); +static int chfind (int, char *); +static int skipcom (void); +static int findchtok (int); +#ifdef PREFIX_DEFINE +static void put_prefix_define (char *); +#endif + + +/* storage of names */ + +/* + * initial block to place token and + * nonterminal names are stored + * points to initial block - more space + * is allocated as needed. + */ +static char cnamesblk0[CNAMSZ]; +static char *cnames = cnamesblk0; + +/* place where next name is to be put in */ +static char *cnamp = cnamesblk0; + +/* number of defined symbols output */ +static int ndefout = 3; + + /* storage of types */ +static int defunion = 0; /* union of types defined? */ +static int ntypes = 0; /* number of types defined */ +static char *typeset[NTYPES]; /* pointers to type tags */ + + /* symbol tables for tokens and nonterminals */ + +int ntokens = 0; +int ntoksz = NTERMS; +TOKSYMB *tokset; +int *toklev; + +int nnonter = -1; +NTSYMB *nontrst; +int nnontersz = NNONTERM; + +static int start; /* start symbol */ + + /* assigned token type values */ +static int extval = 0; + + /* input and output file descriptors */ + +FILE *finput; /* yacc input file */ +FILE *faction; /* file for saving actions */ +FILE *fdefine; /* file for # defines */ +FILE *ftable; /* y.tab.x file */ +FILE *ftemp; /* tempfile to pass 2 */ +FILE *fudecl; /* file for user declarations */ +FILE *fsppout; /* SPP y.tab.x output file */ +FILE *fdebug; /* where the strings for debugging are stored */ +FILE *foutput; /* y.output file */ + + /* output string */ + +static char *lhstext; +static char *rhstext; + + /* storage for grammar rules */ + +int *mem0; /* production storage */ +int *mem; +int *tracemem; +extern int *optimmem; +int new_memsize = MEMSIZE; +int nprod = 1; /* number of productions */ +int nprodsz = NPROD; + +int **prdptr; +int *levprd; +char *had_act; + +/* flag for generating the # line's default is yes */ +int gen_lines = 1; +int act_lines = 0; + +/* flag for whether to include runtime debugging */ +static int gen_testing = 0; + +/* flag for version stamping--default turned off */ +static char *v_stmp = "n"; + +int nmbchars = 0; /* number of mb literals in mbchars */ +MBCLIT *mbchars = (MBCLIT *) 0; /* array of mb literals */ +int nmbcharsz = 0; /* allocated space for mbchars */ + +void +setup (argc, argv) + int argc; + char *argv[]; +{ + int ii, i, j, lev, t, ty; + /* ty is the sequencial number of token name in tokset */ + int c; + int *p; + char *cp; + char actname[8]; + unsigned int options = 0; + char *file_prefix = DEFAULT_PREFIX; + char *sym_prefix = ""; +#define F_NAME_LENGTH 128 + char fname[F_NAME_LENGTH + 1]; + + foutput = NULL; + fdefine = NULL; + i = 1; + + tokname = (char *) malloc (sizeof (char) * toksize); + tokset = (TOKSYMB *) malloc (sizeof (TOKSYMB) * ntoksz); + toklev = (int *) malloc (sizeof (int) * ntoksz); + nontrst = (NTSYMB *) malloc (sizeof (NTSYMB) * nnontersz); + mem0 = (int *) malloc (sizeof (int) * new_memsize); + prdptr = (int **) malloc (sizeof (int *) * (nprodsz + 2)); + levprd = (int *) malloc (sizeof (int) * (nprodsz + 2)); + had_act = (char *) calloc ((nprodsz + 2), sizeof (char)); + lhstext = (char *) calloc (1, sizeof (char) * LHS_TEXT_LEN); + rhstext = (char *) calloc (1, sizeof (char) * RHS_TEXT_LEN); + aryfil (toklev, ntoksz, 0); + aryfil (levprd, nprodsz, 0); + for (ii = 0; ii < ntoksz; ++ii) + tokset[ii].value = 0; + for (ii = 0; ii < nnontersz; ++ii) + nontrst[ii].tvalue = 0; + aryfil (mem0, new_memsize, 0); + mem = mem0; + tracemem = mem0; + + while ((c = getopt (argc, argv, "vVdltp:Q:Y:P:b:")) != EOF) + switch (c) { + case 'v': + options |= v_FLAG; + break; + case 'V': + (void) fprintf (stderr, "yacc: NOAO/IRAF v1.0\n"); + break; + case 'Q': + v_stmp = optarg; + if (*v_stmp != 'y' && *v_stmp != 'n') +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate -Q and [y/n]. + */ + error ("yacc: -Q should be followed by [y/n]"); + break; + case 'd': + options |= d_FLAG; + break; + case 'l': + gen_lines = 0; /* don't gen #lines */ + break; + case 't': + gen_testing = 1; /* set YYDEBUG on */ + break; + case 'Y': + cp = (char *) malloc (strlen (optarg) + sizeof ("/yaccpar") + 1); + cp = strcpy (cp, optarg); + parser = strcat (cp, "/yaccpar"); + break; + case 'P': + parser = optarg; + break; + case 'p': + if (strcmp (optarg, "yy") != 0) + sym_prefix = optarg; + else + sym_prefix = ""; + break; + case 'b': + file_prefix = optarg; + break; + case '?': + default: +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This is a usage message. The translate should be + * consistent with man page translation. + */ + (void) fprintf (stderr, + "Usage: yacc [-vVdltY] [-Q(y/n)] [-b file_prefix] [-p sym_prefix]" + " [-P parser] file\n"); + exit (1); + } + /* + * Open y.output if -v is specified + */ + if (options & v_FLAG) { + (void) strncpy (fname, + file_prefix, F_NAME_LENGTH - strlen (".output")); + (void) strcat (fname, ".output"); + foutput = fopen (fname, "w"); + if (foutput == NULL) + error ("cannot open y.output"); + } + + /* + * Open y.tab.h if -d is specified + */ + if (options & d_FLAG) { + (void) strncpy (fname, + file_prefix, F_NAME_LENGTH - strlen (".tab.h")); + (void) strcat (fname, ".tab.h"); + fdefine = fopen (fname, "w"); + if (fdefine == NULL) + error ("cannot open y.tab.h"); + } + + fdebug = fopen (DEBUGNAME, "w"); + if (fdebug == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate yacc.debug. + */ + error ("cannot open yacc.debug"); + /* + * Open ytab.x + (void) strncpy(fname, file_prefix, F_NAME_LENGTH-strlen(".tab.x")); + (void) strcat(fname, ".tab.x"); + ftable = fopen(fname, "w"); + if (ftable == NULL) + error("cannot open %s", fname); + */ + + + fsppout = fopen (OFILE, "w"); + if (fsppout == NULL) + error ("cannot create output file"); + ftable = fopen (TABFILE, "w"); + if (ftable == NULL) + error ("cannot create table file"); + fudecl = fopen (UDFILE, "w"); + if (fudecl == NULL) + error ("cannot create user declarations file"); + + + ftemp = fopen (TEMPNAME, "w"); + faction = fopen (ACTNAME, "w"); + if (ftemp == NULL || faction == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * The message means: "Could not open a temporary file." + */ + error ("cannot open temp file"); + + if ((finput = fopen (infile = argv[optind], "r")) == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error ("cannot open input file"); + + lineno = 1; + cnamp = cnames; + (void) defin (0, "$end"); + extval = 0400; + (void) defin (0, "error"); + (void) defin (1, "$accept"); + mem = mem0; + lev = 0; + ty = 0; + i = 0; +#ifdef XYACC_DEBUG + beg_debug(); /* initialize fdebug file */ +#endif + + /* + * sorry -- no yacc parser here..... + * we must bootstrap somehow... + */ + + t = gettok (); + if (*v_stmp == 'y') + (void) fprintf (ftable, "#ident\t\"yacc: NOAO/IRAF v1.0\"\n"); + for (; t != MARK && t != ENDFILE;) { + int tok_in_line; + switch (t) { + + case ';': + t = gettok (); + break; + + case START: + if ((t = gettok ()) != IDENTIFIER) { + error ("bad %%start construction"); + } + start = chfind (1, tokname); + t = gettok (); + continue; + + case TYPEDEF: + tok_in_line = 0; + if ((t = gettok ()) != TYPENAME) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate %%type. + */ + error ("bad syntax in %%type"); + ty = numbval; + for (;;) { + t = gettok (); + switch (t) { + + case IDENTIFIER: + /* + * The following lines are idented to left. + */ + tok_in_line = 1; + if ((t = chfind (1, tokname)) < NTBASE) { + j = TYPE (toklev[t]); + if (j != 0 && j != ty) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error + ("type redeclaration of token %s", + tokset[t].name); + } else + SETTYPE (toklev[t], ty); + } else { + j = nontrst[t - NTBASE].tvalue; + if (j != 0 && j != ty) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Check how nonterminal is translated in translated + * yacc man page or yacc user's document. + */ + error + ("type redeclaration of nonterminal %s", + nontrst[t - NTBASE].name); + } else + nontrst[t - NTBASE].tvalue = ty; + } + /* FALLTHRU */ + /* + * End Indentation + */ + case ',': + continue; + + case ';': + t = gettok (); + break; + default: + break; + } + if (!tok_in_line) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error ("missing tokens or illegal tokens"); + break; + } + continue; + + case UNION: + /* copy the union declaration to the output */ + cpyunion (); + defunion = 1; + t = gettok (); + continue; + + case LEFT: + case BINARY: + case RIGHT: + i++; + /* FALLTHRU */ + case TERM: + tok_in_line = 0; + + /* nonzero means new prec. and assoc. */ + lev = (t - TERM) | 04; + ty = 0; + + /* get identifiers so defined */ + + t = gettok (); + if (t == TYPENAME) { /* there is a type defined */ + ty = numbval; + t = gettok (); + } + + for (;;) { + switch (t) { + + case ',': + t = gettok (); + continue; + + case ';': + break; + + case IDENTIFIER: + tok_in_line = 1; + j = chfind (0, tokname); + if (j > NTBASE) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error ("%s is not a token.", tokname); + } + if (lev & ~04) { + if (ASSOC (toklev[j]) & ~04) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error + ("redeclaration of precedence of %s", + tokname); + SETASC (toklev[j], lev); + SETPLEV (toklev[j], i); + } else { + if (ASSOC (toklev[j])) + (void) warning (1, + "redeclaration of precedence of %s.", + tokname); + SETASC (toklev[j], lev); + } + if (ty) { + if (TYPE (toklev[j])) + error ( +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + "redeclaration of type of %s", tokname); + SETTYPE (toklev[j], ty); + } + if ((t = gettok ()) == NUMBER) { + tokset[j].value = numbval; + if (j < ndefout && j > 2) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error + ("type number of %s should be defined earlier", + tokset[j].name); + } + if (numbval >= -YYFLAG1) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error + ("token numbers must be less than %d", + -YYFLAG1); + } + t = gettok (); + } + continue; + + } + if (!tok_in_line) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error ("missing tokens or illegal tokens"); + break; + } + continue; + + case LCURLY: + defout (); + cpycode (); + t = gettok (); + continue; + + default: + error ("syntax error"); + + } + + } + + if (t == ENDFILE) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate %%%%. + */ + error ("unexpected EOF before %%%%"); + } + + /* t is MARK */ + + defout (); +#ifdef XYACC_DEBUG + end_toks(); /* all tokens dumped - get ready for reductions */ +#endif + + fprintf (fsppout, "define\tyyclearin\tyychar = -1\n"); + fprintf (fsppout, "define\tyyerrok\t\tyyerrflag = 0\n"); + fprintf (fsppout, + "define\tYYMOVE\t\tcall amovi (Memi[$1], Memi[$2], YYOPLEN)\n"); + + prdptr[0] = mem; + /* added production */ + *mem++ = NTBASE; + + /* if start is 0, we will overwrite with the lhs of the first rule */ + *mem++ = start; + *mem++ = 1; + *mem++ = 0; + prdptr[1] = mem; + + while ((t = gettok ()) == LCURLY) + cpycode (); + + if (t != C_IDENTIFIER) + error ("bad syntax on first rule"); + + if (!start) + prdptr[0][1] = chfind (1, tokname); + + /* read rules */ + + while (t != MARK && t != ENDFILE) { + + /* process a rule */ + + if (t == '|') { + rhsfill ((char *) 0); /* restart fill of rhs */ + *mem = *prdptr[nprod - 1]; + if (++mem >= &tracemem[new_memsize]) + exp_mem (1); + } else if (t == C_IDENTIFIER) { + *mem = chfind (1, tokname); + if (*mem < NTBASE) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Check how nonterminal is translated. + */ + error ("illegal nonterminal in grammar rule"); + if (++mem >= &tracemem[new_memsize]) + exp_mem (1); + lhsfill (tokname); /* new rule: restart strings */ + } else +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error ("illegal rule: missing semicolon or | ?"); + + /* read rule body */ + + + t = gettok (); + more_rule: + while (t == IDENTIFIER) { + *mem = chfind (1, tokname); + if (*mem < NTBASE) + levprd[nprod] = toklev[*mem] & ~04; + if (++mem >= &tracemem[new_memsize]) + exp_mem (1); + rhsfill (tokname); /* add to rhs string */ + t = gettok (); + } + + if (t == PREC) { + if (gettok () != IDENTIFIER) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate %%prec. + */ + error ("illegal %%prec syntax"); + j = chfind (2, tokname); + if (j >= NTBASE) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate %%prec. + */ + error ("nonterminal %s illegal after %%prec", + nontrst[j - NTBASE].name); + levprd[nprod] = toklev[j] & ~04; + t = gettok (); + } + + if (t == '=') { + had_act[nprod] = 1; + levprd[nprod] |= ACTFLAG; + (void) fprintf (faction, "\ncase %d:", nprod); + cpyact (mem - prdptr[nprod] - 1); + /* !SPP (void) fprintf(faction, " break;"); */ + + if ((t = gettok ()) == IDENTIFIER) { + /* action within rule... */ + +#ifdef XYACC_DEBUG + lrprnt(); /* dump lhs, rhs */ +#endif + (void) sprintf (actname, "$$%d", nprod); + /* + * make it nonterminal + */ + j = chfind (1, actname); + + /* + * the current rule will become rule + * number nprod+1 move the contents down, + * and make room for the null + */ + + if (mem + 2 >= &tracemem[new_memsize]) + exp_mem (1); + for (p = mem; p >= prdptr[nprod]; --p) + p[2] = *p; + mem += 2; + + /* enter null production for action */ + + p = prdptr[nprod]; + + *p++ = j; + *p++ = -nprod; + + /* update the production information */ + + levprd[nprod + 1] = levprd[nprod] & ~ACTFLAG; + levprd[nprod] = ACTFLAG; + + if (++nprod >= nprodsz) + exp_prod (); + prdptr[nprod] = p; + + /* + * make the action appear in + * the original rule + */ + *mem++ = j; + if (mem >= &tracemem[new_memsize]) + exp_mem (1); + /* get some more of the rule */ + goto more_rule; + } + } + while (t == ';') + t = gettok (); + *mem++ = -nprod; + if (mem >= &tracemem[new_memsize]) + exp_mem (1); + + /* check that default action is reasonable */ + + if (ntypes && !(levprd[nprod] & ACTFLAG) && + nontrst[*prdptr[nprod] - NTBASE].tvalue) { + /* no explicit action, LHS has value */ + int tempty; + tempty = prdptr[nprod][1]; + if (tempty < 0) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * LHS means Left Hand Side. It does not need to be translated. + */ + error ("must return a value, since LHS has a type"); + else if (tempty >= NTBASE) + tempty = nontrst[tempty - NTBASE].tvalue; + else + tempty = TYPE (toklev[tempty]); + if (tempty != nontrst[*prdptr[nprod] - NTBASE].tvalue) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Check how action is transltated in yacc man page or documents. + */ + error ("default action causes potential type clash"); + } + } + + if (++nprod >= nprodsz) + exp_prod (); + prdptr[nprod] = mem; + levprd[nprod] = 0; + } + /* end of all rules */ + +#ifdef XYACC_DEBUG + end_debug(); /* finish fdebug file's input */ +#endif + finact (); + if (t == MARK) { + /* + if (gen_lines) + (void) fprintf(fsppout, "\n# a line %d \"%s\"\n", + lineno, infile); + */ + while ((c = getc (finput)) != EOF) + (void) putc (c, fsppout); + } + (void) fclose (finput); +} + +static void +finact () +{ + /* finish action routine */ + (void) fclose (faction); + (void) fprintf (fsppout, "define\tYYERRCODE\t%d\n", tokset[2].value); +} + +static char * +cstash (s) + register char *s; +{ + char *temp; + static int used = 0; + static int used_save = 0; + static int exp_cname = CNAMSZ; + int len = strlen (s); + + /* + * 2/29/88 - + * Don't need to expand the table, just allocate new space. + */ + used_save = used; + while (len >= (exp_cname - used_save)) { + exp_cname += CNAMSZ; + if (!used) + free ((char *) cnames); + if ((cnames = (char *) malloc (sizeof (char) * exp_cname)) == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("cannot expand string dump"); + cnamp = cnames; + used = 0; + } + + temp = cnamp; + do { + *cnamp++ = *s; + } + while (*s++); + used += cnamp - temp; + return (temp); +} + +static int +defin (int t, char *s) +{ + /* define s to be a terminal if t=0 or a nonterminal if t=1 */ + + int val; + + val = 0; + if (t) { + if (++nnonter >= nnontersz) + exp_nonterm (); + nontrst[nnonter].name = cstash (s); + return (NTBASE + nnonter); + } + /* must be a token */ + if (++ntokens >= ntoksz) + exp_ntok (); + tokset[ntokens].name = cstash (s); + + /* establish value for token */ + + if (s[0] == ' ' && s[2] == 0) { /* single character literal */ + val = findchtok (s[1]); + } else if (s[0] == ' ' && s[1] == '\\') { /* escape sequence */ + if (s[3] == 0) { /* single character escape sequence */ + switch (s[2]) { + /* character which is escaped */ + case 'a': + (void) warning (1, +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to warning() function. + * Do not trasnlate ANSI C, \\a. + */ + "\\a is ANSI C \"alert\" character"); +#if __STDC__ - 1 == 0 + val = '\a'; + break; +#else + val = '\007'; + break; +#endif + case 'v': + val = '\v'; + break; + case 'n': + val = '\n'; + break; + case 'r': + val = '\r'; + break; + case 'b': + val = '\b'; + break; + case 't': + val = '\t'; + break; + case 'f': + val = '\f'; + break; + case '\'': + val = '\''; + break; + case '"': + val = '"'; + break; + case '?': + val = '?'; + break; + case '\\': + val = '\\'; + break; +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + default: + error ("invalid escape"); + } + } else if (s[2] <= '7' && s[2] >= '0') { /* \nnn sequence */ + int i = 3; + val = s[2] - '0'; + while (isdigit (s[i]) && i <= 4) { + if (s[i] >= '0' && s[i] <= '7') + val = val * 8 + s[i] - '0'; + else +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + */ + error ("illegal octal number"); + i++; + } + if (s[i] != 0) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate \\nnn. + */ + error ("illegal \\nnn construction"); + if (val > 255) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate + * \\nnn, \\xnnnnnnnn. + */ + error + ("\\nnn exceed \\377; use \\xnnnnnnnn for char value of multibyte char"); + if (val == 0 && i >= 4) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate \\000. + */ + error ("'\\000' is illegal"); + } else if (s[2] == 'x') { /* hexadecimal \xnnn sequence */ + int i = 3; + val = 0; +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to warning() function. + * Do not translate \\x, ANSI C. + */ + (void) warning (1, "\\x is ANSI C hex escape"); + if (isxdigit (s[i])) + while (isxdigit (s[i])) { + int tmpval; + if (isdigit (s[i])) + tmpval = s[i] - '0'; + else if (s[i] >= 'a') + tmpval = s[i] - 'a' + 10; + else + tmpval = s[i] - 'A' + 10; + val = 16 * val + tmpval; + i++; + } else + error ("illegal hexadecimal number"); + if (s[i] != 0) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate \\xnn. + */ + error ("illegal \\xnn construction"); +#define LWCHAR_MAX 0x7fffffff + if ((unsigned) val > LWCHAR_MAX) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate \\xnnnnnnnn and %#x. + */ + error (" \\xnnnnnnnn exceed %#x", LWCHAR_MAX); + if (val == 0) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate \\x00. + */ + error ("'\\x00' is illegal"); + val = findchtok (val); + } else + error ("invalid escape"); + } else { + val = extval++; + } + tokset[ntokens].value = val; + toklev[ntokens] = 0; + return (ntokens); +} + +static void +defout () +{ + /* write out the defines (at the end of the declaration section) */ + + register int i, c; + register char *cp; + + for (i = ndefout; i <= ntokens; ++i) { + + cp = tokset[i].name; + if (*cp == ' ') { /* literals */ + (void) fprintf (fdebug, WSFMT ("\t\"%s\",\t%d,\n"), + tokset[i].name + 1, tokset[i].value); + continue; /* was cp++ */ + } + + for (; (c = *cp) != 0; ++cp) { + if (islower (c) || isupper (c) || isdigit (c) || c == '_') + /* EMPTY */ ; + else + goto nodef; + } + + (void) fprintf (fdebug, + WSFMT ("\t\"%s\",\t%d,\n"), tokset[i].name, + tokset[i].value); + (void) fprintf (fsppout, WSFMT ("define\t%s\t\t%d\n"), + tokset[i].name, tokset[i].value); + if (fdefine != NULL) + (void) fprintf (fdefine, + WSFMT ("define\t%s\t\t%d\n"), tokset[i].name, + tokset[i].value); + + nodef:; + } + ndefout = ntokens + 1; +} + +static int +gettok () +{ + int i, base; + static int peekline; /* number of '\n' seen in lookahead */ + int c, match, reserve; + begin: + reserve = 0; + lineno += peekline; + peekline = 0; + c = getc (finput); + /* + * while (c == ' ' || c == '\n' || c == '\t' || c == '\f') { + */ + while (isspace (c)) { + if (c == '\n') + ++lineno; + c = getc (finput); + } + if (c == '#') { /* skip comment */ + lineno += skipcom (); + goto begin; + } + + switch (c) { + + case EOF: + return (ENDFILE); + case '{': + (void) ungetc (c, finput); + return ('='); /* action ... */ + case '<': /* get, and look up, a type name (union member name) */ + i = 0; + while ((c = getc (finput)) != '>' && c != EOF && c != '\n') { + tokname[i] = c; + if (++i >= toksize) + exp_tokname (); + } + if (c != '>') + error ("unterminated < ... > clause"); + tokname[i] = 0; + if (i == 0) + error ("missing type name in < ... > clause"); + for (i = 1; i <= ntypes; ++i) { + if (!strcmp (typeset[i], tokname)) { + numbval = i; + return (TYPENAME); + } + } + typeset[numbval = ++ntypes] = cstash (tokname); + return (TYPENAME); + + case '"': + case '\'': + match = c; + tokname[0] = ' '; + i = 1; + for (;;) { + c = getc (finput); + if (c == '\n' || c == EOF) + error ("illegal or missing ' or \""); + if (c == '\\') { + c = getc (finput); + tokname[i] = '\\'; + if (++i >= toksize) + exp_tokname (); + } else if (c == match) + break; + tokname[i] = c; + if (++i >= toksize) + exp_tokname (); + } + break; + + case '%': + case '\\': + + switch (c = getc (finput)) { + + case '0': + return (TERM); + case '<': + return (LEFT); + case '2': + return (BINARY); + case '>': + return (RIGHT); + case '%': + case '\\': + return (MARK); + case '=': + return (PREC); + case '{': + return (LCURLY); + default: + reserve = 1; + } + + default: + + if (isdigit (c)) { /* number */ + numbval = c - '0'; + base = (c == '0') ? 8 : 10; + for (c = getc (finput); isdigit (c); c = getc (finput)) { + numbval = numbval * base + c - '0'; + } + (void) ungetc (c, finput); + return (NUMBER); + } else if (islower (c) || isupper (c) || + c == '_' || c == '.' || c == '$') { + i = 0; + while (islower (c) || isupper (c) || + isdigit (c) || c == '_' || c == '.' || c == '$') { + tokname[i] = c; + if (reserve && isupper (c)) + tokname[i] = tolower (c); + if (++i >= toksize) + exp_tokname (); + c = getc (finput); + } + } else + return (c); + + (void) ungetc (c, finput); + } + + tokname[i] = 0; + + if (reserve) { /* find a reserved word */ + if (!strcmp (tokname, "term")) + return (TERM); + if (!strcmp (tokname, "token")) + return (TERM); + if (!strcmp (tokname, "left")) + return (LEFT); + if (!strcmp (tokname, "nonassoc")) + return (BINARY); + if (!strcmp (tokname, "binary")) + return (BINARY); + if (!strcmp (tokname, "right")) + return (RIGHT); + if (!strcmp (tokname, "prec")) + return (PREC); + if (!strcmp (tokname, "start")) + return (START); + if (!strcmp (tokname, "type")) + return (TYPEDEF); + if (!strcmp (tokname, "union")) + return (UNION); + error ("invalid escape, or illegal reserved word: %s", tokname); + } + + /* look ahead to distinguish IDENTIFIER from C_IDENTIFIER */ + + c = getc (finput); + /* + * while (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '/') + * { + */ + while (isspace (c) || c == '/') { + if (c == '\n') { + ++peekline; + } else if (c == '#') { /* look for comments */ + peekline += skipcom (); + } + c = getc (finput); + } + if (c == ':') + return (C_IDENTIFIER); + (void) ungetc (c, finput); + return (IDENTIFIER); +} + +static int +fdtype (int t) +{ + /* determine the type of a symbol */ + int v; + if (t >= NTBASE) + v = nontrst[t - NTBASE].tvalue; + else + v = TYPE (toklev[t]); + if (v <= 0) + error ("must specify type for %s", + (t >= NTBASE) ? nontrst[t - NTBASE].name : tokset[t].name); + return (v); +} + +static int +chfind (int t, char *s) +{ + int i; + + if (s[0] == ' ') + t = 0; + TLOOP (i) { + if (!strcmp (s, tokset[i].name)) { + return (i); + } + } + NTLOOP (i) { + if (!strcmp (s, nontrst[i].name)) { + return (i + NTBASE); + } + } + /* cannot find name */ + if (t > 1) + error ("%s should have been defined earlier", s); + return (defin (t, s)); +} + +static void +cpyunion () +{ + /* + * copy the union declaration to the output, + * and the define file if present + */ + int level, c; + if (gen_lines) + (void) fprintf (fsppout, "\n# line %d \"%s\"\n", lineno, infile); + (void) fprintf (fsppout, "typedef union\n"); + if (fdefine) + (void) fprintf (fdefine, "\ntypedef union\n"); + (void) fprintf (fsppout, "#ifdef __cplusplus\n\tYYSTYPE\n#endif\n"); + if (fdefine) + (void) fprintf (fdefine, "#ifdef __cplusplus\n\tYYSTYPE\n#endif\n"); + + level = 0; + for (;;) { + if ((c = getc (finput)) == EOF) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * EOF - End Of File. + * Do not translate %%union. + */ + error ("EOF encountered while processing %%union"); + (void) putc (c, fsppout); + if (fdefine) + (void) putc (c, fdefine); + + switch (c) { + + case '\n': + ++lineno; + break; + + case '{': + ++level; + break; + + case '}': + --level; + if (level == 0) { /* we are finished copying */ + (void) fprintf (fsppout, " YYSTYPE;\n"); + if (fdefine) + (void) fprintf (fdefine, + " YYSTYPE;\nextern YYSTYPE yylval;\n"); + return; + } + } + } +} + +static void +cpycode () +{ + /* copies code between \{ and \} */ + int c; + FILE *out; + + + c = getc (finput); + if (c == '\n') { + c = getc (finput); + lineno++; + } + + /* The %{ .. %} section is divided up into a global and a local region. + * The global region is first, so set the out file to fsppout (write + * directly into SPP output file). The start of the local declarations + * for the parser is marked by %L. When this is seen, direct output + * into the temp file fudecl, which is later inserted into the + * declarations section of yyparse. + */ + out = fsppout; + + if (gen_lines) + (void) fprintf (out, "\n# line %d \"%s\"\n", lineno, infile); + for (; c >= 0; c = getc (finput)) { + if (c == '\\') { + if ((c = getc (finput)) == '}') + return; + else + putc ('\\', out); + } + if (c == '%') { + if ((c = getc (finput)) == '}') { + return; + } else if (c == 'L') { + out = fudecl; + continue; + } else + putc ('%', out); + } + putc (c, out); + if (c == '\n') + ++lineno; + } + + error ("eof before %%}"); +} + +static int +skipcom () +{ + register int ch; + + /* skip over SPP comments */ + while ((ch = getc (finput)) != '\n') + if (ch == EOF) + error ("EOF inside comment"); + + return (1); +} + + +static void +cpyact (int offset) +{ + /* copy C action to the next ; or closing } */ + int brac, c, match, j, s, tok, argument; + char id_name[NAMESIZE + 1]; + int id_idx = 0; + + if (gen_lines) { + (void) fprintf (faction, "\n# line %d \"%s\"\n", lineno, infile); + act_lines++; + } + brac = 0; + id_name[0] = 0; + loop: + c = getc (finput); + swt: + switch (c) { + case ';': + if (brac == 0) { + (void) putc (c, faction); + return; + } + goto lcopy; + case '{': + brac++; + goto lcopy; + case '$': + s = 1; + tok = -1; + argument = 1; + while ((c = getc (finput)) == ' ' || c == '\t') + /* NULL */ ; + if (c == '<') { /* type description */ + (void) ungetc (c, finput); + if (gettok () != TYPENAME) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate $ + */ + error ("bad syntax on $ clause"); + tok = numbval; + c = getc (finput); + } + if (c == '$') { + (void) fprintf (faction, "yyval"); + if (ntypes) { /* put out the proper tag... */ + if (tok < 0) + tok = fdtype (*prdptr[nprod]); + (void) fprintf (faction, WSFMT (".%s"), typeset[tok]); + } + goto loop; + } + if (c == '-') { + s = -s; + c = getc (finput); + } + if (isdigit (c)) { + j = 0; + while (isdigit (c)) { + j = j * 10 + c - '0'; + c = getc (finput); + } + j = j * s - offset; + if (j > 0) { +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate $%d. + */ + error ("Illegal use of $%d", j + offset); + } + + switch (-j) { + case 0: + fprintf (faction, "yypvt"); + break; + case 1: + fprintf (faction, "yypvt-YYOPLEN"); + break; + default: + fprintf (faction, "yypvt-%d*YYOPLEN", -j); + } + + + if (ntypes) { /* put out the proper tag */ + if (j + offset <= 0 && tok < 0) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate $%d. + */ + error ("must specify type of $%d", j + offset); + if (tok < 0) + tok = fdtype (prdptr[nprod][j + offset]); + (void) fprintf (faction, WSFMT (".%s"), typeset[tok]); + } + goto swt; + } + (void) putc ('$', faction); + if (s < 0) + (void) putc ('-', faction); + goto swt; + case '}': + if (--brac) + goto lcopy; + (void) putc (c, faction); + return; + case '/': /* look for comments */ + (void) putc (c, faction); + c = getc (finput); + if (c != '*') + goto swt; + /* it really is a comment */ + (void) putc (c, faction); + c = getc (finput); + while (c != EOF) { + while (c == '*') { + (void) putc (c, faction); + if ((c = getc (finput)) == '/') + goto lcopy; + } + (void) putc (c, faction); + if (c == '\n') + ++lineno; + c = getc (finput); + } + error ("EOF inside comment"); + /* FALLTHRU */ + case '\'': /* character constant */ + case '"': /* character string */ + match = c; + (void) putc (c, faction); + while ((c = getc (finput)) != EOF) { + if (c == '\\') { + (void) putc (c, faction); + c = getc (finput); + if (c == '\n') + ++lineno; + } else if (c == match) + goto lcopy; + else if (c == '\n') +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * This error message is issued when + * quoted string has multiple lines. + */ + error ("newline in string or char. const."); + (void) putc (c, faction); + } + error ("EOF in string or character constant"); + /* FALLTHRU */ + case EOF: +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Check how 'action' is translated in yacc mapage/document. + */ + error ("action does not terminate"); + /* FALLTHRU */ + case '\n': + ++lineno; + goto lcopy; + } + lcopy: + (void) putc (c, faction); + /* + * Save the possible identifier name. + * Used to print out a warning message. + */ + if (id_idx >= NAMESIZE) { + /* + * Error. Silently ignore. + */ + /* EMPTY */ ; + } + /* + * If c has a possibility to be a + * part of identifier, save it. + */ + else if (isalnum (c) || c == '_') { + id_name[id_idx++] = c; + id_name[id_idx] = 0; + } else { + id_idx = 0; + id_name[id_idx] = 0; + } + goto loop; +} + +static void +lhsfill (s) /* new rule, dump old (if exists), restart strings */ + char *s; +{ + static int lhs_len = LHS_TEXT_LEN; + int s_lhs = strlen (s); + if (s_lhs >= lhs_len) { + lhs_len = s_lhs + 2; + lhstext = (char *) + realloc ((char *) lhstext, sizeof (char) * lhs_len); + if (lhstext == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * LHS -- Left Hand Side. + */ + error ("couldn't expanded LHS length"); + } + rhsfill ((char *) 0); + (void) strcpy (lhstext, s); /* don't worry about too long of a name */ +} + +static void +rhsfill (s) + char *s; /* either name or 0 */ +{ + static char *loc; /* next free location in rhstext */ + static int rhs_len = RHS_TEXT_LEN; + static int used = 0; + int s_rhs = (s == NULL ? 0 : strlen (s)); + register char *p; + + if (!s) { /* print out and erase old text */ + if (*lhstext) /* there was an old rule - dump it */ + lrprnt (); + (loc = rhstext)[0] = 0; + return; + } + /* add to stuff in rhstext */ + p = s; + + used = loc - rhstext; + if ((s_rhs + 3) >= (rhs_len - used)) { + static char *textbase; + textbase = rhstext; + rhs_len += s_rhs + RHS_TEXT_LEN; + rhstext = (char *) + realloc ((char *) rhstext, sizeof (char) * rhs_len); + if (rhstext == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * RHS -- Right Hand Side. + */ + error ("couldn't expanded RHS length"); + loc = loc - textbase + rhstext; + } + + *loc++ = ' '; + if (*s == ' ') { /* special quoted symbol */ + *loc++ = '\''; /* add first quote */ + p++; + } + while ((*loc = *p++)) { + if (loc++ > &rhstext[RHS_TEXT_LEN] - 3) + break; + } + + if (*s == ' ') + *loc++ = '\''; + *loc = 0; /* terminate the string */ +} + +static void +lrprnt () +{ /* print out the left and right hand sides */ + char *rhs; + char *m_rhs = NULL; + + if (!*rhstext) /* empty rhs - print usual comment */ + rhs = " /* empty */"; + else { + int idx1; /* tmp idx used to find if there are d_quotes */ + int idx2; /* tmp idx used to generate escaped string */ + char *p; + /* + * Check if there are any double quote in RHS. + */ + for (idx1 = 0; rhstext[idx1] != 0; idx1++) { + if (rhstext[idx1] == '"') { + /* + * A double quote is found. + */ + idx2 = strlen (rhstext) * 2; + p = m_rhs = (char *) + malloc ((idx2 + 1) * sizeof (char)); + if (m_rhs == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * RHS - Right Hand Side. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("Couldn't allocate memory for RHS."); + /* + * Copy string + */ + for (idx2 = 0; rhstext[idx2] != 0; idx2++) { + /* + * Check if this quote is escaped or not + */ + if (rhstext[idx2] == '"') { + int tmp_l = idx2 - 1; + int cnt = 0; + while (tmp_l >= 0 && rhstext[tmp_l] == '\\') { + cnt++; + tmp_l--; + } + /* + * If quote is not escaped, + * then escape it. + */ + if (cnt % 2 == 0) + *p++ = '\\'; + } + *p++ = rhstext[idx2]; + } + *p = 0; + /* + * Break from the loop + */ + break; + } + } + if (m_rhs == NULL) + rhs = rhstext; + else + rhs = m_rhs; + } + (void) fprintf (fdebug, WSFMT ("\t\"%s :%s\",\n"), lhstext, rhs); + if (m_rhs) + free (m_rhs); +} + + +#ifdef XYACC_DEBUG + +static void +beg_debug () +{ /* dump initial sequence for fdebug file */ + (void) fprintf (fdebug, "typedef struct\n"); + (void) fprintf (fdebug, "#ifdef __cplusplus\n\tyytoktype\n"); + (void) fprintf (fdebug, "#endif\n{\n"); + (void) fprintf (fdebug, "#ifdef __cplusplus\nconst\n#endif\n"); + (void) fprintf (fdebug, "char *t_name; int t_val; } yytoktype;\n"); + (void) fprintf (fdebug, + "#ifndef YYDEBUG\n#\tdefine YYDEBUG\t%d", gen_testing); + (void) fprintf (fdebug, "\t/*%sallow debugging */\n#endif\n\n", + gen_testing ? " " : " don't "); + (void) fprintf (fdebug, "#if YYDEBUG\n\nyytoktype yytoks[] =\n{\n"); +} + + +static void +end_toks () +{ /* finish yytoks array, get ready for yyred's strings */ + (void) fprintf (fdebug, "\t\"-unknown-\",\t-1\t/* ends search */\n"); + (void) fprintf (fdebug, "};\n\n"); + (void) fprintf (fdebug, "#ifdef __cplusplus\nconst\n#endif\n"); + (void) fprintf (fdebug, "char * yyreds[] =\n{\n"); + (void) fprintf (fdebug, "\t\"-no such reduction-\",\n"); +} + + +static void +end_debug () +{ /* finish yyred array, close file */ + lrprnt (); /* dump last lhs, rhs */ + (void) fprintf (fdebug, "};\n#endif /* YYDEBUG */\n"); + (void) fclose (fdebug); +} + +#endif + + +/* + * 2/29/88 - + * The normal length for token sizes is NAMESIZE - If a token is + * seen that has a longer length, expand "tokname" by NAMESIZE. + */ +static void +exp_tokname () +{ + toksize += NAMESIZE; + tokname = (char *) realloc ((char *) tokname, sizeof (char) * toksize); +} + + +/* + * 2/29/88 - + * + */ +static void +exp_prod () +{ + int i; + nprodsz += NPROD; + + prdptr = + (int **) realloc ((char *) prdptr, sizeof (int *) * (nprodsz + 2)); + levprd = (int *) realloc ((char *) levprd, sizeof (int) * (nprodsz + 2)); + had_act = (char *) + realloc ((char *) had_act, sizeof (char) * (nprodsz + 2)); + for (i = nprodsz - NPROD; i < nprodsz + 2; ++i) + had_act[i] = 0; + + if ((*prdptr == NULL) || (levprd == NULL) || (had_act == NULL)) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("couldn't expand productions"); +} + +/* + * 2/29/88 - + * Expand the number of terminals. Initially there are NTERMS; + * each time space runs out, the size is increased by NTERMS. + * The total size, however, cannot exceed MAXTERMS because of + * the way LOOKSETS(struct looksets) is set up. + * Tables affected: + * tokset, toklev : increased to ntoksz + * + * tables with initial dimensions of TEMPSIZE must be changed if + * (ntoksz + NNONTERM) >= TEMPSIZE : temp1[] + */ +static void +exp_ntok () +{ + ntoksz += NTERMS; + + tokset = (TOKSYMB *) realloc ((char *) tokset, sizeof (TOKSYMB) * ntoksz); + toklev = (int *) realloc ((char *) toklev, sizeof (int) * ntoksz); + + if ((tokset == NULL) || (toklev == NULL)) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate NTERMS. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("couldn't expand NTERMS"); +} + + +static void +exp_nonterm () +{ + nnontersz += NNONTERM; + + nontrst = (NTSYMB *) + realloc ((char *) nontrst, sizeof (TOKSYMB) * nnontersz); + if (nontrst == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Do not translate NTERMS. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("couldn't expand NNONTERM"); +} + +void +exp_mem (flag) + int flag; +{ + int i; + static int *membase; + new_memsize += MEMSIZE; + + membase = tracemem; + tracemem = (int *) + realloc ((char *) tracemem, sizeof (int) * new_memsize); + if (tracemem == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("couldn't expand mem table"); + if (flag) { + for (i = 0; i <= nprod; ++i) + prdptr[i] = prdptr[i] - membase + tracemem; + mem = mem - membase + tracemem; + } else { + size += MEMSIZE; + temp1 = (int *) realloc ((char *) temp1, sizeof (int) * size); + optimmem = optimmem - membase + tracemem; + } +} + +static int +findchtok (chlit) + int chlit; +/* + * findchtok(chlit) returns the token number for a character literal + * chlit that is "bigger" than 255 -- the max char value that the + * original yacc was build for. This yacc treate them as though + * an ordinary token. + */ +{ + int i; + + if (chlit < 0xff) + return (chlit); /* single-byte char */ + for (i = 0; i < nmbchars; ++i) { + if (mbchars->character == chlit) + return (mbchars->tvalue); + } + + /* Not found. Register it! */ + if (++nmbchars > nmbcharsz) { /* Make sure there's enough space */ + nmbcharsz += NMBCHARSZ; + mbchars = (MBCLIT *) + realloc ((char *) mbchars, sizeof (MBCLIT) * nmbcharsz); + if (mbchars == NULL) + error ("too many character literals"); + } + mbchars[nmbchars - 1].character = chlit; + return (mbchars[nmbchars - 1].tvalue = extval++); + /* Return the newly assigned token. */ +} + +/* + * When -p is specified, symbol prefix for + * yy{parse, lex, error}(), + * yy{lval, val, char, debug, errflag, nerrs} + * are defined to the specified name. + */ +#ifdef PREFIX_DEFINE + +static void +put_prefix_define (char *pre) +{ + char *syms[] = { + /* Functions */ + "parse", + "lex", + "error", + /* Variables */ + "lval", + "val", + "char", + "debug", + "errflag", + "nerrs", + NULL + }; + int i; + + for (i = 0; syms[i]; i++) + (void) fprintf (fsppout, "define\tyy%s\t%s%s\n", + syms[i], pre, syms[i]); +} + +#endif + + diff --git a/unix/boot/xyacc/y3.c b/unix/boot/xyacc/y3.c new file mode 100644 index 00000000..1b6ac149 --- /dev/null +++ b/unix/boot/xyacc/y3.c @@ -0,0 +1,606 @@ +/* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License (the "License"). + * You may not use this file except in compliance with the License. + * + * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE + * or http://www.opensolaris.org/os/licensing. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at usr/src/OPENSOLARIS.LICENSE. + * If applicable, add the following below this CDDL HEADER, with the + * fields enclosed by brackets "[]" replaced with your own identifying + * information: Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + */ +/* + * Copyright 2008 Sun Microsystems, Inc. All rights reserved. + * Use is subject to license terms. + */ + +/* Copyright (c) 1988 AT&T */ +/* All Rights Reserved */ + +//#pragma ident "%Z%%M% %I% %E% SMI" + +#include "dextern.h" + +static void go2gen (int); +static void precftn (int, int, int); +static void wract (int); +static void wrstate (int); +static void wdef (char *, int); +static void wrmbchars (void); + /* important local variables */ +static int lastred; /* number of the last reduction of a state */ +int *defact; +extern int *toklev; +extern int cwp; + +int exca[NSTATES * 2]; /* buffer states for printing with warray */ +int nexca; + + + /* I/O descriptors */ + +extern FILE *finput; /* input file */ +extern FILE *faction; /* file for saving actions */ +extern FILE *fdefine; /* file for #defines */ +extern FILE *fudecl; /* file for user declarations */ +extern FILE *ftable; /* parser tables file */ +extern FILE *fsppout; /* SPP output file */ +extern FILE *ftemp; /* tempfile to pass 2 */ +extern FILE *foutput; /* y.output file */ + + + + +/* print the output for the states */ +void +output () +{ + int i, k, c; + register WSET *u, *v; + + /* + (void) fprintf(fsppout, "static YYCONST yytabelem yyexca[] ={\n"); + */ + + SLOOP (i) { /* output the stuff for state i */ + nolook = !(tystate[i] == MUSTLOOKAHEAD); + closure (i); + /* output actions */ + nolook = 1; + aryfil (temp1, ntoksz + nnontersz + 1, 0); + WSLOOP (wsets, u) { + c = *(u->pitem); + if (c > 1 && c < NTBASE && temp1[c] == 0) { + WSLOOP (u, v) { + if (c == *(v->pitem)) + putitem (v->pitem + 1, (LOOKSETS *) 0); + } + temp1[c] = state (c); + } else if (c > NTBASE && temp1[(c -= NTBASE) + ntokens] == 0) { + temp1[c + ntokens] = amem[indgo[i] + c]; + } + } + if (i == 1) + temp1[1] = ACCEPTCODE; + /* now, we have the shifts; look at the reductions */ + lastred = 0; + WSLOOP (wsets, u) { + c = *(u->pitem); + if (c <= 0) { /* reduction */ + lastred = -c; + TLOOP (k) { + if (BIT (u->ws.lset, k)) { + if (temp1[k] == 0) + temp1[k] = c; + else if (temp1[k] < 0) { + /* + * reduce/reduce + * conflict + */ + /* BEGIN CSTYLED */ + if (foutput != NULL) + (void) fprintf (foutput, + WSFMT + ("\n%d: reduce/reduce conflict" + " (red'ns %d and %d ) on %s"), + i, -temp1[k], lastred, + symnam (k)); + if (-temp1[k] > lastred) + temp1[k] = -lastred; + ++zzrrconf; + /* END CSTYLED */ + } else + /* + * potentia + * shift/reduce + * conflict. + */ + precftn (lastred, k, i); + } + } + } + } + wract (i); + } + + /* + (void) fprintf(fsppout, "\t};\n"); + */ + warray ("yyexca", exca, nexca); + wdef ("YYNPROD", nprod); + if (nmbchars > 0) { + wrmbchars (); + } +} + +static int pkdebug = 0; +int +apack (p, n) + int *p; + int n; +{ + /* pack state i from temp1 into amem */ + int off; + int *pp, *qq; + int *q, *rr; + int diff; + + /* + * we don't need to worry about checking because we + * we will only look up entries known to be there... + */ + + /* eliminate leading and trailing 0's */ + + q = p + n; + for (pp = p, off = 0; *pp == 0 && pp <= q; ++pp, --off) + /* NULL */ ; + if (pp > q) + return (0); /* no actions */ + p = pp; + + /* now, find a place for the elements from p to q, inclusive */ + /* for( rr=amem; rr<=r; ++rr,++off ){ *//* try rr */ + rr = amem; + for (;; ++rr, ++off) { + while (rr >= &amem[new_actsize - 1]) + exp_act (&rr); + qq = rr; + for (pp = p; pp <= q; ++pp, ++qq) { + if (*pp) { + diff = qq - rr; + while (qq >= &amem[new_actsize - 1]) { + exp_act (&rr); + qq = diff + rr; + } + if (*pp != *qq && *qq != 0) + goto nextk; + } + } + + /* we have found an acceptable k */ + + if (pkdebug && foutput != NULL) + (void) fprintf (foutput, + "off = %d, k = %" PRIdPTR "\n", off, rr - amem); + + qq = rr; + for (pp = p; pp <= q; ++pp, ++qq) { + if (*pp) { + diff = qq - rr; + while (qq >= &amem[new_actsize - 1]) { + exp_act (&rr); + qq = diff + rr; + } + if (qq > memp) + memp = qq; + *qq = *pp; + } + } + if (pkdebug && foutput != NULL) { + for (pp = amem; pp <= memp; pp += 10) { + (void) fprintf (foutput, "\t"); + for (qq = pp; qq <= pp + 9; ++qq) + (void) fprintf (foutput, "%d ", *qq); + (void) fprintf (foutput, "\n"); + } + } + return (off); + nextk:; + } + /* error("no space in action table" ); */ + /* NOTREACHED */ +} + +void +go2out () +{ + /* output the gotos for the nontermninals */ + int i, j, k, best, count, cbest, times; + + (void) fprintf (ftemp, "$\n"); /* mark begining of gotos */ + + for (i = 1; i <= nnonter; ++i) { + go2gen (i); + /* find the best one to make default */ + best = -1; + times = 0; + for (j = 0; j < nstate; ++j) { /* is j the most frequent */ + if (tystate[j] == 0) + continue; + if (tystate[j] == best) + continue; + /* is tystate[j] the most frequent */ + count = 0; + cbest = tystate[j]; + for (k = j; k < nstate; ++k) + if (tystate[k] == cbest) + ++count; + if (count > times) { + best = cbest; + times = count; + } + } + + /* best is now the default entry */ + zzgobest += (times - 1); + for (j = 0; j < nstate; ++j) { + if (tystate[j] != 0 && tystate[j] != best) { + (void) fprintf (ftemp, "%d,%d,", j, tystate[j]); + zzgoent += 1; + } + } + + /* now, the default */ + + zzgoent += 1; + (void) fprintf (ftemp, "%d\n", best); + + } +} + +static int g2debug = 0; +static void +go2gen (int c) +{ + /* output the gotos for nonterminal c */ + int i, work, cc; + ITEM *p, *q; + + /* first, find nonterminals with gotos on c */ + aryfil (temp1, nnonter + 1, 0); + temp1[c] = 1; + + work = 1; + while (work) { + work = 0; + PLOOP (0, i) { + if ((cc = prdptr[i][1] - NTBASE) >= 0) { + /* cc is a nonterminal */ + if (temp1[cc] != 0) { + /* + * cc has a goto on c + * thus, the left side of + * production i does too. + */ + cc = *prdptr[i] - NTBASE; + if (temp1[cc] == 0) { + work = 1; + temp1[cc] = 1; + } + } + } + } + } + + /* now, we have temp1[c] = 1 if a goto on c in closure of cc */ + + if (g2debug && foutput != NULL) { + (void) fprintf (foutput, WSFMT ("%s: gotos on "), nontrst[c].name); + NTLOOP (i) if (temp1[i]) + (void) fprintf (foutput, WSFMT ("%s "), nontrst[i].name); + (void) fprintf (foutput, "\n"); + } + + /* now, go through and put gotos into tystate */ + aryfil (tystate, nstate, 0); + SLOOP (i) { + ITMLOOP (i, p, q) { + if ((cc = *p->pitem) >= NTBASE) { + if (temp1[cc -= NTBASE]) { + /* goto on c is possible */ + tystate[i] = amem[indgo[i] + c]; + break; + } + } + } + } +} + +/* decide a shift/reduce conflict by precedence. */ +static void +precftn (int r, int t, int s) +{ + + /* + * r is a rule number, t a token number + * the conflict is in state s + * temp1[t] is changed to reflect the action + */ + + int lp, lt, action; + + lp = levprd[r]; + lt = toklev[t]; + if (PLEVEL (lt) == 0 || PLEVEL (lp) == 0) { + /* conflict */ + if (foutput != NULL) + (void) fprintf (foutput, + WSFMT ("\n%d: shift/reduce conflict" + " (shift %d, red'n %d) on %s"), + s, temp1[t], r, symnam (t)); + ++zzsrconf; + return; + } + if (PLEVEL (lt) == PLEVEL (lp)) + action = ASSOC (lt) & ~04; + else if (PLEVEL (lt) > PLEVEL (lp)) + action = RASC; /* shift */ + else + action = LASC; /* reduce */ + + switch (action) { + case BASC: /* error action */ + temp1[t] = ERRCODE; + return; + case LASC: /* reduce */ + temp1[t] = -r; + return; + } +} + + +/* WRACT -- Output the state I. Modified to save state array in exca + * for later printing by warray. + */ +static void +wract (int i) +{ + /* output state i */ + /* temp1 has the actions, lastred the default */ + int p, p0, p1; + int ntimes, tred, count, j; + int flag; + + /* find the best choice for lastred */ + + lastred = 0; + ntimes = 0; + TLOOP (j) { + if (temp1[j] >= 0) + continue; + if (temp1[j] + lastred == 0) + continue; + /* count the number of appearances of temp1[j] */ + count = 0; + tred = -temp1[j]; + levprd[tred] |= REDFLAG; + TLOOP (p) { + if (temp1[p] + tred == 0) + ++count; + } + if (count > ntimes) { + lastred = tred; + ntimes = count; + } + } + + /* + * for error recovery, arrange that, if there is a shift on the + * error recovery token, `error', that the default be the error action + if (temp1[2] > 0) + */ + if (temp1[1] > 0) + lastred = 0; + + /* clear out entries in temp1 which equal lastred */ + TLOOP (p) { + if (temp1[p] + lastred == 0) + temp1[p] = 0; + } + + wrstate (i); + defact[i] = lastred; + + flag = 0; + TLOOP (p0) { + if ((p1 = temp1[p0]) != 0) { + if (p1 < 0) { + p1 = -p1; + goto exc; + } else if (p1 == ACCEPTCODE) { + p1 = -1; + goto exc; + } else if (p1 == ERRCODE) { + p1 = 0; + goto exc; + exc: + if (flag++ == 0) { + exca[nexca++] = -1; + exca[nexca++] = i; + } + exca[nexca++] = tokset[p0].value; + exca[nexca++] = p1; + ++zzexcp; + if (nexca >= NSTATES * 2) { + error ("state table overflow"); + } + } else { + (void) fprintf (ftemp, "%d,%d,", tokset[p0].value, p1); + ++zzacent; + } + } + } + if (flag) { + defact[i] = -2; + exca[nexca++] = -2; + exca[nexca++] = lastred; + } + (void) fprintf (ftemp, "\n"); +} + +static void +wrstate (int i) +{ + /* writes state i */ + int j0, j1; + register ITEM *pp, *qq; + register WSET *u; + + if (foutput == NULL) + return; + (void) fprintf (foutput, "\nstate %d\n", i); + ITMLOOP (i, pp, qq) { + (void) fprintf (foutput, WSFMT ("\t%s\n"), writem (pp->pitem)); + } + if (tystate[i] == MUSTLOOKAHEAD) { + /* print out empty productions in closure */ + WSLOOP (wsets + (pstate[i + 1] - pstate[i]), u) { + if (*(u->pitem) < 0) + (void) fprintf (foutput, WSFMT ("\t%s\n"), writem (u->pitem)); + } + } + + /* check for state equal to another */ + TLOOP (j0) if ((j1 = temp1[j0]) != 0) { + (void) fprintf (foutput, WSFMT ("\n\t%s "), symnam (j0)); + if (j1 > 0) { /* shift, error, or accept */ + if (j1 == ACCEPTCODE) + (void) fprintf (foutput, "accept"); + else if (j1 == ERRCODE) + (void) fprintf (foutput, "error"); + else + (void) fprintf (foutput, "shift %d", j1); + } else + (void) fprintf (foutput, "reduce %d", -j1); + } + + /* output the final production */ + if (lastred) + (void) fprintf (foutput, "\n\t. reduce %d\n\n", lastred); + else + (void) fprintf (foutput, "\n\t. error\n\n"); + + /* now, output nonterminal actions */ + j1 = ntokens; + for (j0 = 1; j0 <= nnonter; ++j0) { + if (temp1[++j1]) + (void) fprintf (foutput, + WSFMT ("\t%s goto %d\n"), + symnam (j0 + NTBASE), temp1[j1]); + } +} + +static void +wdef (char *s, int n) +{ + /* output a definition of s to the value n */ + (void) fprintf (fsppout, WSFMT ("define\t%s\t\t%d\n"), s, n); +} + +# define NDP_PERLINE 8 + +void +warray (s, v, n) + char *s; + int *v, n; +{ + register int i, j; + + fprintf (ftable, "short\t%s[%d]\n", s, n); + + for (j = 0; j < n; j += NDP_PERLINE) { + fprintf (ftable, "data\t(%s(i),i=%3d,%3d)\t/", + s, j + 1, (j + NDP_PERLINE < n) ? j + NDP_PERLINE : n); + + for (i = j; i < j + NDP_PERLINE && i < n; i++) { + if ((i == j + NDP_PERLINE - 1) || i >= n - 1) + fprintf (ftable, "%4d/\n", v[i]); + else + fprintf (ftable, "%4d,", v[i]); + } + } +} + +void +hideprod () +{ + /* + * in order to free up the mem and amem arrays for the optimizer, + * and still be able to output yyr1, etc., after the sizes of + * the action array is known, we hide the nonterminals + * derived by productions in levprd. + */ + + int i, j; + + j = 0; + levprd[0] = 0; + PLOOP (1, i) { + if (!(levprd[i] & REDFLAG)) { + ++j; + if (foutput != NULL) { + (void) fprintf (foutput, + WSFMT ("Rule not reduced: %s\n"), + writem (prdptr[i])); + } + } + levprd[i] = *prdptr[i] - NTBASE; + } + if (j) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * Check how 'reduced' is translated in yacc man page/document. + */ + (void) fprintf (stderr, "%d rules never reduced\n", j); +} + + +static int +cmpmbchars (p, q) + MBCLIT *p, *q; +{ + /* Compare two MBLITs. */ + return ((p->character) - (q->character)); +} + +static void +wrmbchars () +{ + int i; + + return wdef ("YYNMBCHARS", nmbchars); + qsort (mbchars, nmbchars, sizeof (*mbchars), + (int (*)(const void *, const void *)) cmpmbchars); + (void) fprintf (ftable, + "static struct{\n\tchar character;" + "\n\tint tvalue;\n}yymbchars[YYNMBCHARS]={\n"); + for (i = 0; i < nmbchars; ++i) { + (void) fprintf (ftable, "\t{%#x,%d}", + (int) mbchars[i].character, mbchars[i].tvalue); + if (i < nmbchars - 1) { + /* Not the last. */ + (void) fprintf (ftable, ",\n"); + } + } + (void) fprintf (ftable, "\n};\n"); +} diff --git a/unix/boot/xyacc/y4.c b/unix/boot/xyacc/y4.c new file mode 100644 index 00000000..2badc0e5 --- /dev/null +++ b/unix/boot/xyacc/y4.c @@ -0,0 +1,528 @@ +/* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License (the "License"). + * You may not use this file except in compliance with the License. + * + * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE + * or http://www.opensolaris.org/os/licensing. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at usr/src/OPENSOLARIS.LICENSE. + * If applicable, add the following below this CDDL HEADER, with the + * fields enclosed by brackets "[]" replaced with your own identifying + * information: Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + */ +/* + * Copyright 2008 Sun Microsystems, Inc. All rights reserved. + * Use is subject to license terms. + */ + +/* Copyright (c) 1988 AT&T */ +/* All Rights Reserved */ + +//#pragma ident "%Z%%M% %I% %E% SMI" + +#include "dextern.h" +#include +#define NOMORE -1000 + +static void gin (int); +static void stin (int); +static void osummary (void); +static void aoutput (void); +static void arout (char *, int *, int); +static int nxti (void); +static int gtnm (void); + +static int *ggreed; +static int *pgo; +static int *yypgo; + +static int maxspr = 0; /* maximum spread of any entry */ +static int maxoff = 0; /* maximum offset into an array */ +int *optimmem; +static int *maxa; + +static int nxdb = 0; +static int adb = 0; + + /* I/O descriptors */ + +extern FILE *finput; /* input file */ +extern FILE *faction; /* file for saving actions */ +extern FILE *fdefine; /* file for #defines */ +extern FILE *fudecl; /* file for user declarations */ +extern FILE *ftable; /* parser tables file */ +extern FILE *fsppout; /* SPP output file */ +extern FILE *ftemp; /* tempfile to pass 2 */ +extern FILE *foutput; /* y.output file */ + + +void +callopt () +{ + int i, *p, j, k, *q; + + ggreed = (int *) malloc (sizeof (int) * size); + pgo = (int *) malloc (sizeof (int) * size); + yypgo = &nontrst[0].tvalue; + + /* read the arrays from tempfile and set parameters */ + + if ((finput = fopen (TEMPNAME, "r")) == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * tempfile can be translated as temporary file. + */ + error ("optimizer cannot open tempfile"); + + optimmem = tracemem; + pgo[0] = 0; + temp1[0] = 0; + nstate = 0; + nnonter = 0; + for (;;) { + switch (gtnm ()) { + + case '\n': + temp1[++nstate] = (--optimmem) - tracemem; + /* FALLTHRU */ + + case ',': + continue; + + case '$': + break; + + default: + error ("bad tempfile"); + } + break; + } + + temp1[nstate] = yypgo[0] = (--optimmem) - tracemem; + + for (;;) { + switch (gtnm ()) { + + case '\n': + yypgo[++nnonter] = optimmem - tracemem; + /* FALLTHRU */ + case ',': + continue; + + case EOF: + break; + + default: +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * tempfile can be translated as 'temporary file'. + */ + error ("bad tempfile"); + } + break; + } + + yypgo[nnonter--] = (--optimmem) - tracemem; + + for (i = 0; i < nstate; ++i) { + k = 32000; + j = 0; + q = tracemem + temp1[i + 1]; + for (p = tracemem + temp1[i]; p < q; p += 2) { + if (*p > j) + j = *p; + if (*p < k) + k = *p; + } + if (k <= j) { + /* + * nontrivial situation + * temporarily, kill this for compatibility + */ + /* j -= k; j is now the range */ + if (k > maxoff) + maxoff = k; + } + tystate[i] = (temp1[i + 1] - temp1[i]) + 2 * j; + if (j > maxspr) + maxspr = j; + } + + /* initialize ggreed table */ + for (i = 1; i <= nnonter; ++i) { + ggreed[i] = 1; + j = 0; + /* minimum entry index is always 0 */ + q = tracemem + yypgo[i + 1] - 1; + for (p = tracemem + yypgo[i]; p < q; p += 2) { + ggreed[i] += 2; + if (*p > j) + j = *p; + } + ggreed[i] = ggreed[i] + 2 * j; + if (j > maxoff) + maxoff = j; + } + + /* now, prepare to put the shift actions into the amem array */ + for (i = 0; i < new_actsize; ++i) + amem[i] = 0; + maxa = amem; + + for (i = 0; i < nstate; ++i) { + if (tystate[i] == 0 && adb > 1) + (void) fprintf (ftable, "State %d: null\n", i); + indgo[i] = YYFLAG1; + } + + while ((i = nxti ()) != NOMORE) { + if (i >= 0) + stin (i); + else + gin (-i); + } + + if (adb > 2) { /* print a array */ + for (p = amem; p <= maxa; p += 10) { + (void) fprintf (ftable, "%4" PRIdPTR " ", p - amem); + for (i = 0; i < 10; ++i) + (void) fprintf (ftable, "%4d ", p[i]); + (void) fprintf (ftable, "\n"); + } + } + + + /* write out the output appropriate to the language */ + aoutput (); + osummary (); + ZAPFILE (TEMPNAME); +} + +static void +gin (int i) +{ + int *r, *s, *q1, *q2; + int *p; + + /* enter gotos on nonterminal i into array amem */ + ggreed[i] = 0; + + q2 = tracemem + yypgo[i + 1] - 1; + q1 = tracemem + yypgo[i]; + + /* now, find a place for it */ + + /* for( p=amem; p < &amem[new_actsize]; ++p ){ */ + p = amem; + for (;;) { + while (p >= &amem[new_actsize]) + exp_act (&p); + if (*p) + goto nextgp; + for (r = q1; r < q2; r += 2) { + s = p + *r + 1; + /* + * Check if action table needs to + * be expanded or not. If so, + * expand it. + */ + while (s >= &amem[new_actsize]) { + exp_act (&p); + s = p + *r + 1; + } + if (*s) + goto nextgp; + if (s > maxa) { + while ((maxa = s) >= &amem[new_actsize]) + /* error( "amem array overflow" ); */ + exp_act (&p); + } + } + /* we have found a spot */ + *p = *q2; + if (p > maxa) { + while ((maxa = p) >= &amem[new_actsize]) + /* error("amem array overflow"); */ + exp_act (&p); + } + for (r = q1; r < q2; r += 2) { + s = p + *r + 1; + /* + * Check if action table needs to + * be expanded or not. If so, + * expand it. + */ + while (s >= &amem[new_actsize]) { + exp_act (&p); + s = p + *r + 1; + } + *s = r[1]; + } + + pgo[i] = p - amem; + if (adb > 1) + (void) fprintf (ftable, + "Nonterminal %d, entry at %d\n", i, pgo[i]); + goto nextgi; + + nextgp: + ++p; + } + /* error( "cannot place goto %d\n", i ); */ + nextgi:; +} + +static void +stin (int i) +{ + int *r, n, nn, flag, j, *q1, *q2; + int *s; + + tystate[i] = 0; + + /* Enter state i into the amem array */ + + q2 = tracemem + temp1[i + 1]; + q1 = tracemem + temp1[i]; + /* Find an acceptable place */ + + nn = -maxoff; + more: + for (n = nn; n < new_actsize; ++n) { + flag = 0; + for (r = q1; r < q2; r += 2) { + s = *r + n + amem; + if (s < amem) + goto nextn; + /* + * Check if action table needs to + * be expanded or not. If so, + * expand it. + */ + while (s >= &amem[new_actsize]) { + exp_act ((int **) NULL); + s = *r + n + amem; + } + if (*s == 0) + ++flag; + else if (*s != r[1]) + goto nextn; + } + + /* + * check that the position equals another + * only if the states are identical + */ + for (j = 0; j < nstate; ++j) { + if (indgo[j] == n) { + if (flag) + /* + * we have some disagreement. + */ + goto nextn; + if (temp1[j + 1] + temp1[i] == temp1[j] + temp1[i + 1]) { + /* states are equal */ + indgo[i] = n; + if (adb > 1) + (void) fprintf (ftable, + "State %d: entry at" + " %d equals state %d\n", i, n, j); + return; + } + goto nextn; /* we have some disagreement */ + } + } + + for (r = q1; r < q2; r += 2) { + while ((s = *r + n + amem) >= &amem[new_actsize]) { + /* + * error( "out of space"); + */ + exp_act ((int **) NULL); + } + if (s > maxa) + maxa = s; + if (*s != 0 && *s != r[1]) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * Leave this untrasnlated. Yacc internal error. + */ + error ("clobber of amem array, pos'n %d, by %d", + s - amem, r[1]); + *s = r[1]; + } + indgo[i] = n; + if (adb > 1) + (void) fprintf (ftable, "State %d: entry at %d\n", i, indgo[i]); + return; + nextn:; + } + + /* error( "Error; failure to place state %d\n", i ); */ + exp_act ((int **) NULL); + nn = new_actsize - ACTSIZE; + goto more; + /* NOTREACHED */ +} + +static int +nxti () +{ + /* finds the next i */ + int i, max, maxi; + max = 0; + maxi = 0; + + for (i = 1; i <= nnonter; ++i) + if (ggreed[i] >= max) { + max = ggreed[i]; + maxi = -i; + } + + for (i = 0; i < nstate; ++i) + if (tystate[i] >= max) { + max = tystate[i]; + maxi = i; + } + if (nxdb) + (void) fprintf (ftable, "nxti = %d, max = %d\n", maxi, max); + if (max == 0) + return (NOMORE); + else + return (maxi); +} + +static void +osummary () +{ + /* write summary */ + int i, *p; + + if (foutput == NULL) + return; + i = 0; + for (p = maxa; p >= amem; --p) { + if (*p == 0) + ++i; + } + + (void) fprintf (foutput, + "Optimizer space used: input %" PRIdPTR + "/%d, output %" PRIdPTR "/%d\n", + optimmem - tracemem + 1, new_memsize, maxa - amem + 1, + new_actsize); + (void) fprintf (foutput, "%" PRIdPTR " table entries, %d zero\n", + (maxa - amem) + 1, i); + (void) fprintf (foutput, "maximum spread: %d, maximum offset: %d\n", + maxspr, maxoff); + +} + + +/* AOUTPUT -- This version is for SPP. + */ +static void +aoutput () +{ + /* write out the optimized parser */ + + fprintf (fsppout, "define\tYYLAST\t\t%d\n", (int) (maxa - amem + 1)); + + arout ("yyact", amem, (maxa - amem) + 1); + arout ("yypact", indgo, nstate); + arout ("yypgo", pgo, nnonter + 1); +} + + +/* AROUT -- Output SPP declarations and initializations for a Yacc table. + */ +# define NDP_PERLINE 8 + +static void +arout (s, v, n) + char *s; + int *v, n; +{ + register int i, j; + + fprintf (ftable, "short\t%s[%d]\n", s, n); + + for (j = 0; j < n; j += NDP_PERLINE) { + fprintf (ftable, "data\t(%s(i),i=%3d,%3d)\t/", + s, j + 1, (j + NDP_PERLINE < n) ? j + NDP_PERLINE : n); + + for (i = j; i < j + NDP_PERLINE && i < n; i++) { + if ((i == j + NDP_PERLINE - 1) || i >= n - 1) + fprintf (ftable, "%4d/\n", v[i]); + else + fprintf (ftable, "%4d,", v[i]); + } + } +} + +static int +gtnm () +{ + int s, val, c; + + /* read and convert an integer from the standard input */ + /* return the terminating character */ + /* blanks, tabs, and newlines are ignored */ + + s = 1; + val = 0; + + while ((c = getc (finput)) != EOF) { + if (iswdigit (c)) + val = val * 10 + c - '0'; + else if (c == '-') + s = -1; + else + break; + } + *optimmem++ = s * val; + if (optimmem >= &tracemem[new_memsize]) + exp_mem (0); + return (c); +} + +void +exp_act (ptr) + int **ptr; +{ + static int *actbase; + int i; + new_actsize += ACTSIZE; + + actbase = amem; + amem = (int *) realloc ((char *) amem, sizeof (int) * new_actsize); + if (amem == NULL) +/* + * TRANSLATION_NOTE -- This is a message from yacc. + * This message is passed to error() function. + * + * You may just translate this as: + * 'Could not allocate internally used memory.' + */ + error ("couldn't expand action table"); + + for (i = new_actsize - ACTSIZE; i < new_actsize; ++i) + amem[i] = 0; + if (ptr != NULL) + *ptr = *ptr - actbase + amem; + if (memp >= amem) + memp = memp - actbase + amem; + if (maxa >= amem) + maxa = maxa - actbase + amem; +} diff --git a/unix/boot/xyacc/yaccpar.x b/unix/boot/xyacc/yaccpar.x new file mode 100644 index 00000000..71a323b4 --- /dev/null +++ b/unix/boot/xyacc/yaccpar.x @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer yysp, yypvt +short yystate, yyn +int yyxi, i +errchk salloc, yylex + +$A # User declarations go here. +$B # YACC parser tables defining the finite automaton go here. + +begin + call smark (yysp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (yysp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (yysp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (yysp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + $C # YACC replaces this line by the user supplied actions. + } + + goto yystack_ # stack new state and value +end diff --git a/unix/f2c/README b/unix/f2c/README new file mode 100644 index 00000000..1416f521 --- /dev/null +++ b/unix/f2c/README @@ -0,0 +1,186 @@ +To compile f2c on Linux or Unix systems, copy makefile.u to makefile, +edit makefile if necessary (see the comments in it and below) and +type "make" (or maybe "nmake", depending on your system). + +To compile f2c.exe on MS Windows systems with Microsoft Visual C++, + + copy makefile.vc makefile + nmake + +With other PC compilers, you may need to compile xsum.c with -DMSDOS +(i.e., with MSDOS #defined). + +If your compiler does not understand ANSI/ISO C syntax (i.e., if +you have a K&R C compiler), compile with -DKR_headers . + +On non-Unix systems where files have separate binary and text modes, +you may need to "make xsumr.out" rather than "make xsum.out". + +If (in accordance with what follows) you need to any of the source +files (excluding the makefile), first issue a "make xsum.out" (or, if +appropriate, "make xsumr.out") to check the validity of the f2c source, +then make your changes, then type "make f2c". + +The file usignal.h is for the benefit of strictly ANSI include files +on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. +You may need to modify usignal.h if you are not running f2c on a UNIX +system. + +Should you get the message "xsum0.out xsum1.out differ", see what lines +are different (`diff xsum0.out xsum1.out`) and ask netlib +(e.g., netlib@netlib.org) to send you the files in question, +plus the current xsum0.out (which may have changed) "from f2c/src". +For example, if exec.c and expr.c have incorrect check sums, you would +send netlib the message + send exec.c expr.c xsum0.out from f2c/src +You can also ftp these files from netlib.bell-labs.com; for more +details, ask netlib@netlib.org to "send readme from f2c". + +On some systems, the malloc and free in malloc.c let f2c run faster +than do the standard malloc and free. Other systems may not tolerate +redefinition of malloc and free (though changes of 8 Nov. 1994 may +render this less of a problem than hitherto). If your system permits +use of a user-supplied malloc, you may wish to change the MALLOC = +line in the makefile to "MALLOC = malloc.o", or to type + make MALLOC=malloc.o +instead of + make +Still other systems have a -lmalloc that provides performance +competitive with that from malloc.c; you may wish to compare the two +on your system. If your system does not permit user-supplied malloc +routines, then f2c may fault with "MALLOC=malloc.o", or may display +other untoward behavior. + +On some BSD systems, you may need to create a file named "string.h" +whose single line is +#include +you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment +in the makefile, and you may need to add " memset.o" to the "OBJECTS =" +assignment in the makefile -- see the comments in memset.c . + +For non-UNIX systems, you may need to change some things in sysdep.c, +such as the choice of intermediate file names. + +On some systems, you may need to modify parts of sysdep.h (which is +included by defs.h). In particular, for Sun 4.1 systems and perhaps +some others, you need to comment out the typedef of size_t. For some +systems (e.g., IRIX 4.0.1 and AIX) it is better to add +#define ANSI_Libraries +to the beginning of sysdep.h (or to supply -DANSI_Libraries in the +makefile). + +Alas, some systems #define __STDC__ but do not provide a true standard +(ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours +is such a system, then (a) you should complain loudly to your vendor +about __STDC__ being erroneously defined, and (b) you should insert +#undef __STDC__ +at the beginning of sysdep.h . You may need to make other adjustments. + +For some non-ANSI versions of stdio, you must change the values given +to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". +You may need to make this change if you run f2c and get an error +message of the form + Compiler error ... cannot open intermediate file ... + +In the days of yore, two libraries, libF77 and libI77, were used with +f77 (the Fortran compiler on which f2c is based). Separate source for +these libraries is still available from netlib, but it is more +convenient to combine them into a single library, libf2c. Source for +this combined library is also available from netlib in f2c/libf2c.zip, +e.g., + http://netlib.bell-labs.com/netlib/f2c/libf2c.zip +or + http://www.netlib.org/f2c/libf2c.zip + +(and similarly for other netlib mirrors). After unzipping libf2c.zip, +copy the relevant makefile.* to makefile, edit makefile if necessary +(see the comments in it and in libf2c/README) and invoke "make" or +"nmake". The resulting library is called *f2c.lib on MS Windows +systems and libf2c.a or libf2c.so on Linux and Unix systems; +makefile.u just shows how to make libf2c.a. Details on creating the +shared-library variant, libf2c.so, are system-dependent; some that +have worked under Linux appear below. For some other systems, you can +glean the details from the system-dependent makefile variants in +directory http://www.netlib.org/ampl/solvers/funclink or +http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. + +In general, under Linux it is necessary to compile libf2c (or libI77) +with -DNON_UNIX_STDIO . Under at least one variant of Linux, you can +make and install a shared-library version of libf2c by compiling +libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then +executing + + mkdir t + ln lib?77/*.o t + cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o + cd .. + rm -r t + rm /usr/lib/libf2c* + mv libf2c.a libf2c.so /usr/lib + cd /usr/lib + ln libf2c.so libf2c.so.1 + ln libf2c.so libf2c.so.1.0.0 + +On some other systems, /usr/local/lib is the appropriate installation +directory. + + +Some older C compilers object to + typedef void (*foo)(); +or to + typedef void zap; + zap (*foo)(); +If yours is such a compiler, change the definition of VOID in +f2c.h from void to int. + +For convenience with systems that use control-Z to denote end-of-file, +f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the +beginning of a line as an end-of-file indicator. You can disable this +test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can +change control-Z to some other character by #defining EOF_CHAR to +be the desired value. + + +If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your +printf is inaccurate (e.g., with Symantec C++ version 6.0, +printf("%.17g",12.) prints 12.000000000000001), you can make f2c print +correctly rounded numbers by compiling with -DUSE_DTOA and adding +dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes + + OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o + +Also add the rule + + dtoa.o: dtoa.c + $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c + +(without the initial tab) to the makefile, where IEEE... is one of +IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's +arithmetic. See the comments near the start of dtoa.c. + +The relevant source files, dtoa.c and g_fmt.c, are available +separately from netlib's fp directory. For example, you could +send the E-mail message + + send dtoa.c g_fmt.c from fp + +to netlib@netlib.netlib.org (or use anonymous ftp from +ftp.netlib.org and look in directory /netlib/fp). + +The makefile has a rule for creating tokdefs.h. If you cannot use the +makefile, an alternative is to extract tokdefs.h from the beginning of +gram.c: it's the first 100 lines. + +File mem.c has #ifdef CRAY lines that are appropriate for machines +with the conventional CRAY architecture, but not for "Cray" machines +based on DEC Alpha chips, such as the T3E; on such machines, you may +need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. + + +Please send bug reports to dmg at acm.org (with " at " changed to "@"). +The old index file (now called "readme" due to unfortunate changes in +netlib conventions: "send readme from f2c") will report recent +changes in the recent-change log at its end; all changes will be shown +in the "changes" file ("send changes from f2c"). To keep current +source, you will need to request xsum0.out and version.c, in addition +to the changed source files. diff --git a/unix/f2c/changes b/unix/f2c/changes new file mode 100644 index 00000000..f8d24179 --- /dev/null +++ b/unix/f2c/changes @@ -0,0 +1,3482 @@ +31 Aug. 1989: + 1. A(min(i,j)) now is translated correctly (where A is an array). + 2. 7 and 8 character variable names are allowed (but elicit a + complaint under -ext). + 3. LOGICAL*1 is treated as LOGICAL, with just one error message + per LOGICAL*1 statement (rather than one per variable declared + in that statement). [Note that LOGICAL*1 is not in Fortran 77.] + Like f77, f2c now allows the format in a read or write statement + to be an integer array. + +5 Sept. 1989: + Fixed botch in argument passing of substrings of equivalenced +variables. + +15 Sept. 1989: + Warn about incorrect code generated when a character-valued +function is not declared external and is passed as a parameter +(in violation of the Fortran 77 standard) before it is invoked. +Example: + + subroutine foo(a,b) + character*10 a,b + call goo(a,b) + b = a(3) + end + +18 Sept. 1989: + Complain about overlapping initializations. + +20 Sept. 1989: + Warn about names declared EXTERNAL but never referenced; +include such names as externs in the generated C (even +though most C compilers will discard them). + +24 Sept. 1989: + New option -w8 to suppress complaint when COMMON or EQUIVALENCE +forces word alignment of a double. + Under -A (for ANSI C), ensure that floating constants (terminated +by 'f') contain either a decimal point or an exponent field. + Repair bugs sometimes encountered with CHAR and ICHAR intrinsic +functions. + Restore f77's optimizations for copying and comparing character +strings of length 1. + Always assume floating-point valued routines in libF77 return +doubles, even under -R. + Repair occasional omission of arguments in routines having multiple +entry points. + Repair bugs in computing offsets of character strings involved +in EQUIVALENCE. + Don't omit structure qualification when COMMON variables are used +as FORMATs or internal files. + +2 Oct. 1989: + Warn about variables that appear only in data stmts; don't emit them. + Fix bugs in character DATA for noncharacter variables +involved in EQUIVALENCE. + Treat noncharacter variables initialized (at least partly) with +character data as though they were equivalenced -- put out a struct +and #define the variables. This eliminates the hideous and nonportable +numeric values that were used to initialize such variables. + Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) . + Quit when given invalid options. + +8 Oct. 1989: + Modified naming scheme for generated intermediate variables; +more are recycled, fewer distinct ones used. + New option -W nn specifies nn characters/word for Hollerith +data initializing non-character variables. + Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet". + Integer expressions of the form (i+const1) - (i+const2), where +i is a scalar integer variable, are now simplified to (const1-const2); +this leads to simpler translation of some substring expressions. + Initialize uninitialized portions of character string arrays to 0 +rather than to blanks. + +9 Oct. 1989: + New option -c to insert comments showing original Fortran source. + New option -g to insert line numbers of original Fortran source. + +10 Oct. 1989: + ! recognized as in-line comment delimiter (a la Fortran 88). + +24 Oct. 1989: + New options to ease coping with systems that want the structs +that result from COMMON blocks to be defined just once: + -E causes uninitialized COMMON blocks to be declared Extern; +if Extern is undefined, f2c.h #defines it to be extern. + -ec causes a separate .c file to be emitted for each +uninitialized COMMON block: COMMON /ABC/ yields abc_com.c; +thus one can compile *_com.c into a library to ensure +precisely one definition. + -e1c is similar to -ec, except that everything goes into +one file, along with comments that give a sed script for +splitting the file into the pieces that -ec would give. +This is for use with netlib's "execute f2c" service (for which +-ec is coerced into -e1c, and the sed script will put everything +but the COMMON definitions into f2c_out.c ). + +28 Oct. 1989: + Convert "i = i op ..." into "i op= ...;" even when i is a +dummy argument. + +13 Nov. 1989: + Name integer constants (passed as arguments) c__... rather +than c_... so + common /c/stuff + call foo(1) + ... +is translated correctly. + +19 Nov. 1989: + Floating-point constants are now kept as strings unless they +are involved in constant expressions that get simplified. The +floating-point constants kept as strings can have arbitrarily +many significant figures and a very large exponent field (as +large as long int allows on the machine on which f2c runs). +Thus, for example, the body of + + subroutine zot(x) + double precision x(6), pi + parameter (pi=3.1415926535897932384626433832795028841972) + x(1) = pi + x(2) = pi+1 + x(3) = 9287349823749272.7429874923740978492734D-298374 + x(4) = .89 + x(5) = 4.0005 + x(6) = 10D7 + end + +now gets translated into + + x[1] = 3.1415926535897932384626433832795028841972; + x[2] = 4.1415926535897931; + x[3] = 9.2873498237492727429874923740978492734e-298359; + x[4] = (float).89; + x[5] = (float)4.0005; + x[6] = 1e8; + +rather than the former + + x[1] = 3.1415926535897931; + x[2] = 4.1415926535897931; + x[3] = 0.; + x[4] = (float)0.89000000000000003; + x[5] = (float)4.0004999999999997; + x[6] = 100000000.; + + Recognition of f77 machine-constant intrinsics deleted, i.e., +epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp. + +22 Nov. 1989: + Workarounds for glitches on some Sun systems... + libf77: libF77/makefile modified to point out possible need +to compile libF77/main.c with -Donexit=on_exit . + libi77: libI77/wref.c (and libI77/README) modified so non-ANSI +systems can compile with USE_STRLEN defined, which will cause + sprintf(b = buf, "%#.*f", d, x); + n = strlen(b) + d1; +rather than + n = sprintf(b = buf, "%#.*f", d, x) + d1; +to be compiled. + +26 Nov. 1989: + Longer names are now accepted (up to 50 characters); names may +contain underscores (in which case they will have two underscores +appended, to avoid clashes with library names). + +28 Nov. 1989: + libi77 updated: + 1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d . + 2. Try to get things right on machines where ints have 16 bits. + +29 Nov. 1989: + Supplied missing semicolon in parameterless subroutines that +have multiple entry points (all of them parameterless). + +30 Nov. 1989: + libf77 and libi77 revised to use types from f2c.h. + f2c now types floating-point valued C library routines as "double" +rather than "doublereal" (for use with nonstandard C compilers for +which "double" is IEEE double extended). + +1 Dec. 1989: + f2c.h updated to eliminate #defines rendered unnecessary (and, +indeed, dangerous) by change of 26 Nov. to long names possibly +containing underscores. + libi77 further revised: yesterday's change omitted two tweaks to fmt.h +(tweaks which only matter if float and real or double and doublereal are +different types). + +2 Dec. 1989: + Better error message (than "bad tag") for NAMELIST, which no longer +inhibits C output. + +4 Dec. 1989: + Allow capital letters in hex constants (f77 extension; e.g., +x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer +167848909). + libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked +again to allow float and real or double and doublereal to be different. + +6 Dec. 1989: + Revised f2c.h -- required for the following... + Simpler looking translations for abs, min, max, using #defines in +revised f2c.h . + libi77: more corrections to types; additions for NAMELIST. + Corrected casts in some I/O calls. + Translation of NAMELIST; libi77 must still be revised. Currently +libi77 gives you a run-time error message if you attempt NAMELIST I/O. + +7 Dec. 1989: + Fixed bug that prevented local integer variables that appear in DATA +stmts from being ASSIGNed statement labels. + Fillers (for DATA statements initializing EQUIVALENCEd variables and +variables in COMMON) typed integer rather than doublereal (for slightly +more portability, e.g. to Crays). + libi77: missing return values supplied in a few places; some tests +reordered for better working on the Cray. + libf77: better accuracy for complex divide, complex square root, +real mod function (casts to double; double temporaries). + +9 Dec. 1989: + Fixed bug that caused needless (albeit harmless) empty lines to be +inserted in the C output when a comment line contained trailing blanks. + Further tweak to type of fillers: allow doublereal fillers if the +struct has doublereal data. + +11 Dec. 1989: + Alteration of rule for producing external (C) names from names that +contain underscores. Now the external name is always obtained by +appending a pair of underscores. + +12 Dec. 1989: + C production inhibited after most errors. + +15 Dec. 1989: + Fixed bug in headers for subroutines having two or more character +strings arguments: the length arguments were reversed. + +19 Dec. 1989: + f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil +compilation of libF77 and libI77. + libf77: getenv_ adjusted to work with unsorted environments. + libi77: the iostat= specifier should now work right with internal I/O. + +20 Dec. 1989: + f2c bugs fixed: In the absence of an err= specifier, the iostat= +specifier was generally set wrong. Character strings containing +explicit nulls (\0) were truncated at the first null. + Unlabeled DO loops recognized; must be terminated by ENDDO. +(Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.) + +29 Dec. 1989: + Nested unlabeled DO loops now handled properly; new warning for +extraneous text at end of FORMAT. + +30 Dec. 1989: + Fixed bug in translating dble(real(...)), dble(sngl(...)), and +dble(float(...)), where ... is either of type double complex or +is an expression requiring assignment to intermediate variables (e.g., +dble(real(foo(x+1))), where foo is a function and x is a variable). +Regard nonblank label fields on continuation lines as an error. + +3 Jan. 1990: + New option -C++ yields output that should be understood +by C++ compilers. + +6 Jan. 1989: + -a now excludes variables that appear in a namelist from those +that it makes automatic. (As before, it also excludes variables +that appear in a common, data, equivalence, or save statement.) + The syntactically correct Fortran + read(*,i) x + end +now yields syntactically correct C (even though both the Fortran +and C are buggy -- no FORMAT has not been ASSIGNed to i). + +7 Jan. 1990: + libi77: routines supporting NAMELIST added. Surrounding quotes +made optional when no ambiguity arises in a list or namelist READ +of a character-string value. + +9 Jan. 1990: + f2c.src made available. + +16 Jan. 1990: + New options -P to produce ANSI C or C++ prototypes for procedures +defined. Change to -A and -C++: f2c tries to infer prototypes for +invoked procedures unless the new -!P option is given. New warning +messages for inconsistent calling sequences among procedures within +a single file. Most of f2c/src is affected. + f2c.h: typedefs for procedure arguments added; netlib's f2c service +will insert appropriate typedefs for use with older versions of f2c.h. + +17 Jan. 1990: + f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out +updated. Castargs and protofile made extern in defs.h; exec.c +modified so superfluous else clauses are diagnosed; unused variables +omitted from declarations in format.c proc.c putpcc.c . + +21 Jan. 1990: + No C emitted for procedures declared external but not referenced. + f2c.h: more new types added for use with -P. + New feature: f2c accepts as arguments files ending in .p or .P; +such files are assumed to be prototype files, such as produced by +the -P option. All prototype files are read before any Fortran files +and apply globally to all Fortran files. Suitable prototypes help f2c +warn about calling-sequence errors and can tell f2c how to type +procedures declared external but not explicitly typed; the latter is +mainly of interest for users of the -A and -C++ options. (Prototype +arguments are not available to netlib's "execute f2c" service.) + New option -it tells f2c to try to infer types of untyped external +arguments from their use as parameters to prototyped or previously +defined procedures. + f2c/src: many minor cleanups; most modules changed. Individual +files in f2c/src are now in "bundle" format. The former f2c.1 is +now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the +same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src". People who +do not obtain a new copy of "all from f2c/src" should at least add + fclose(sortfp); +after the call on do_init_data(outfile, sortfp) in format_data.c . + +22 Jan. 1990: + Cleaner man page wording (thanks to Doug McIlroy). + -it now also applies to all untyped EXTERNAL procedures, not just +arguments. + +23 Jan. 01:34:00 EST 1990: + Bug fixes: under -A and -C++, incorrect C was generated for +subroutines having multiple entries but no arguments. + Under -A -P, subroutines of no arguments were given prototype +calling sequence () rather than (void). + Character-valued functions elicited erroneous warning messages +about inconsistent calling sequences when referenced by another +procedure in the same file. + f2c.1t: omit first appearance of libF77.a in FILES section; +load order of libraries is -lF77 -lI77, not vice versa (bug +introduced in yesterday's edits); define .F macro for those whose +-man lacks it. (For a while after yesterday's fixes were posted, +f2c.1t was out of date. Sorry!) + +23 Jan. 9:53:24 EST 1990: + Character substring expressions involving function calls having +character arguments (including the intrinsic len function) yielded +incorrect C. + Procedures defined after invocation (in the same file) with +conflicting argument types also got an erroneous message about +the wrong number of arguments. + +24 Jan. 11:44:00 EST 1990: + Bug fixes: -p omitted #undefs; COMMON block names containing +underscores had their C names incorrectly computed; a COMMON block +having the name of a previously defined procedure wreaked havoc; +if all arguments were .P files, f2c tried reading the second as a +Fortran file. + New feature: -P emits comments showing COMMON block lengths, so one +can get warnings of incompatible COMMON block lengths by having f2c +read .P (or .p) files. Now by running f2c twice, first with -P -!c +(or -P!c), then with *.P among the arguments, you can be warned of +inconsistent COMMON usage, and COMMON blocks having inconsistent +lengths will be given the maximum length. (The latter always did +happen within each input file; now -P lets you extend this behavior +across files.) + +26 Jan. 16:44:00 EST 1990: + Option -it made less aggressive: untyped external procedures that +are invoked are now typed by the rules of Fortran, rather than by +previous use of procedures to which they are passed as arguments +before being invoked. + Option -P now includes information about references, i.e., called +procedures, in the prototype files (in the form of special comments). +This allows iterative invocations of f2c to infer more about untyped +external names, particularly when multiple Fortran files are involved. + As usual, there are some obscure bug fixes: +1. Repair of erroneous warning messages about inconsistent number of +arguments that arose when a character dummy parameter was discovered +to be a function or when multiple entry points involved character +variables appearing in a previous entry point. +2. Repair of memory fault after error msg about "adjustable character +function". +3. Under -U, allow MAIN_ as a subroutine name (in the same file as a +main program). +4. Change for consistency: a known function invoked as a subroutine, +then as a function elicits a warning rather than an error. + +26 Jan. 22:32:00 EST 1990: + Fixed two bugs that resulted in incorrect C for substrings, within +the body of a character-valued function, of the function's name, when +those substrings were arguments to another function (even implicitly, +as in character-string assignment). + +28 Jan. 18:32:00 EST 1990: + libf77, libi77: checksum files added; "make check" looks for +transmission errors. NAMELIST read modified to allow $ rather than & +to precede a namelist name, to allow $ rather than / to terminate +input where the name of another variable would otherwise be expected, +and to regard all nonprinting ASCII characters <= ' ' as spaces. + +29 Jan. 02:11:00 EST 1990: + "fc from f2c" added. + -it option made the default; -!it turns it off. Type information is +now updated in a previously missed case. + -P option tweaked again; message about when rerunning f2c may change +prototypes or declarations made more accurate. + New option -Ps implies -P and returns exit status 4 if rerunning +f2c -P with prototype inputs might change prototypes or declarations. +Now you can execute a crude script like + + cat *.f >zap.F + rm -f zap.P + while :; do + f2c -Ps -!c zap.[FP] + case $? in 4) ;; *) break;; esac + done + +to get a file zap.P of the best prototypes f2c can determine for *.f . + +Jan. 29 07:30:21 EST 1990: + Forgot to check for error status when setting return code 4 under -Ps; +error status (1, 2, 3, or, for caught signal, 126) now takes precedence. + +Jan 29 14:17:00 EST 1990: + Incorrect handling of + open(n,'filename') +repaired -- now treated as + open(n,file='filename') +(and, under -ext, given an error message). + New optional source file memset.c for people whose systems don't +provide memset, memcmp, and memcpy; #include in mem.c +changed to #include "string.h" so BSD people can create a local +string.h that simply says #include . + +Jan 30 10:34:00 EST 1990: + Fix erroneous warning at end of definition of a procedure with +character arguments when the procedure had previously been called with +a numeric argument instead of a character argument. (There were two +warnings, the second one incorrectly complaining of a wrong number of +arguments.) + +Jan 30 16:29:41 EST 1990: + Fix case where -P and -Ps erroneously reported another iteration +necessary. (Only harm is the extra iteration.) + +Feb 3 01:40:00 EST 1990: + Supply semicolon occasionally omitted under -c . + Try to force correct alignment when numeric variables are initialized +with character data (a non-standard and non-portable practice). You +must use the -W option if your code has such data statements and is +meant to run on a machine with other than 4 characters/word; e.g., for +code meant to run on a Cray, you would specify -W8 . + Allow parentheses around expressions in output lists (in write and +print statements). + Rename source files so their names are <= 12 characters long +(so there's room to append .Z and still have <= 14 characters); +renamed files: formatdata.c niceprintf.c niceprintf.h safstrncpy.c . + f2c material made available by anonymous ftp from research.att.com +(look in dist/f2c ). + +Feb 3 03:49:00 EST 1990: + Repair memory fault that arose from use (in an assignment or +call) of a non-argument variable declared CHARACTER*(*). + +Feb 9 01:35:43 EST 1990: + Fix erroneous error msg about bad types in + subroutine foo(a,adim) + dimension a(adim) + integer adim + Fix improper passing of character args (and possible memory fault) +in the expression part of a computed goto. + Fix botched calling sequences in array references involving +functions having character args. + Fix memory fault caused by invocation of character-valued functions +of no arguments. + Fix botched calling sequence of a character*1-valued function +assigned to a character*1 variable. + Fix bug in error msg for inconsistent number of args in prototypes. + Allow generation of C output despite inconsistencies in prototypes, +but give exit code 8. + Simplify include logic (by removing some bogus logic); never +prepend "/usr/include/" to file names. + Minor cleanups (that should produce no visible change in f2c's +behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c . + +Feb 10 00:19:38 EST 1990: + Insert (integer) casts when floating-point expressions are used +as subscripts. + Make SAVE stmt (with no variable list) override -a . + Minor cleanups: change field to Field in struct Addrblock (for the +benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c . + +Feb 13 00:39:00 EST 1990: + Error msg fix in gram.dcl: change "cannot make %s parameter" +to "cannot make into parameter". + +Feb 14 14:02:00 EST 1990: + Various cleanups (invisible on systems with 4-byte ints), thanks +to Dave Regan: vaxx.c eliminated; %d changed to %ld various places; +external names adjusted for the benefit of stupid systems (that ignore +case and recognize only 6 significant characters in external names); +buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish +text and binary files; several unused functions eliminated; missing +arg supplied to an unlikely fatalstr invocation. + +Thu Feb 15 19:15:53 EST 1990: + More cleanups (invisible on systems with 4 byte ints); casts inserted +so most complaints from cyntax(1) and lint(1) go away; a few (int) +versus (long) casts corrected. + +Fri Feb 16 19:55:00 EST 1990: + Recognize and translate unnamed Fortran 8x do while statements. + Fix bug that occasionally caused improper breaking of character +strings. + New error message for attempts to provide DATA in a type-declaration +statement. + +Sat Feb 17 11:43:00 EST 1990: + Fix infinite loop clf -> Fatal -> done -> clf after I/O error. + Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)" +in p1_addr (in p1output.c); this was probably harmless. + Move a misplaced } in lex.c (which slowed initkey()). + Thanks to Gary Word for pointing these things out. + +Sun Feb 18 18:07:00 EST 1990: + Detect overlapping initializations of arrays and scalar variables +in previously missed cases. + Treat logical*2 as logical (after issuing a warning). + Don't pass string literals to p1_comment(). + Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g. +on a Cray. + Attempt to isolate UNIX-specific things in sysdep.c (a new source +file). Unless sysdep.c is compiled with SYSTEM_SORT defined, the +intermediate files created for DATA statements are now sorted in-core +without invoking system(). + +Tue Feb 20 16:10:35 EST 1990: + Move definition of binread and binwrite from init.c to sysdep.c . + Recognize Fortran 8x tokens < <= == >= > <> as synonyms for +.LT. .LE. .EQ. .GE. .GT. .NE. + Minor cleanup in putpcc.c: fully remove simoffset(). + More discussion of system dependencies added to libI77/README. + +Tue Feb 20 21:44:07 EST 1990: + Minor cleanups for the benefit of EBCDIC machines -- try to remove +the assumption that 'a' through 'z' are contiguous. (Thanks again to +Gary Word.) Also, change log2 to log_2 (shouldn't be necessary). + +Wed Feb 21 06:24:56 EST 1990: + Fix botch in init.c introduced in previous change; only matters +to non-ASCII machines. + +Thu Feb 22 17:29:12 EST 1990: + Allow several entry points to mention the same array. Protect +parameter adjustments with if's (for the case that an array is not +an argument to all entrypoints). + Under -u, allow + subroutine foo(x,n) + real x(n) + integer n + Compute intermediate variables used to evaluate dimension expressions +at the right time. Example previously mistranslated: + subroutine foo(x,k,m,n) + real x(min(k,m,n)) + ... + write(*,*) x + Detect duplicate arguments. (The error msg points to the first +executable stmt -- not wonderful, but not worth fixing.) + Minor cleanup of min/max computation (sometimes slightly simpler). + +Sun Feb 25 09:39:01 EST 1990: + Minor tweak to multiple entry points: protect parameter adjustments +with if's only for (array) args that do not appear in all entry points. + Minor tweaks to format.c and io.c (invisible unless your compiler +complained at the duplicate #defines of IOSUNIT and IOSFMT or at +comparisons of p1gets(...) with NULL). + +Sun Feb 25 18:40:10 EST 1990: + Fix bug introduced Feb. 22: if a subprogram contained DATA and the +first executable statement was labeled, then the label got lost. +(Just change INEXEC to INDATA in p1output.c; it occurs just once.) + +Mon Feb 26 17:45:10 EST 1990: + Fix bug in handling of " and ' in comments. + +Wed Mar 28 01:43:06 EST 1990: +libI77: + 1. Repair nasty I/O bug: opening two files and closing the first +(after possibly reading or writing it), then writing the second caused +the last buffer of the second to be lost. + 2. Formatted reads of logical values treated all letters other than +t or T as f (false). + libI77 files changed: err.c rdfmt.c Version.c + (Request "libi77 from f2c" -- you can't get these files individually.) + +f2c itself: + Repair nasty bug in translation of + ELSE IF (condition involving complicated abs, min, or max) +-- auxiliary statements were emitted at the wrong place. + Supply semicolon previously omitted from the translation of a label +(of a CONTINUE) immediately preceding an ELSE IF or an ELSE. This +bug made f2c produce invalid C. + Correct a memory fault that occurred (on some machines) when the +error message "adjustable dimension on non-argument" should be given. + Minor tweaks to remove some harmless warnings by overly chatty C +compilers. + Argument arays having constant dimensions but a variable lower bound +(e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in +the array offset computation. + +Wed Mar 28 18:47:59 EST 1990: +libf77: add exit(0) to end of main [return(0) encounters a Cray bug] + +Sun Apr 1 16:20:58 EDT 1990: + Avoid dereferencing null when processing equivalences after an error. + +Fri Apr 6 08:29:49 EDT 1990: + Calls involving alternate return specifiers omitted processing +needed for things like min, max, abs, and // (concatenation). + INTEGER*2 PARAMETERs were treated as INTEGER*4. + Convert some O(n^2) parsing to O(n). + +Tue Apr 10 20:07:02 EDT 1990: + When inconsistent calling sequences involve differing numbers of +arguments, report the first differing argument rather than the numbers +of arguments. + Fix bug under -a: formatted I/O in which either the unit or the +format was a local character variable sometimes resulted in invalid C +(a static struct initialized with an automatic component). + Improve error message for invalid flag after elided -. + Complain when literal table overflows, rather than infinitely +looping. (The complaint mentions the new and otherwise undocumented +-NL option for specifying a larger literal table.) + New option -h for forcing strings to word (or, with -hd, double-word) +boundaries where possible. + Repair a bug that could cause improper splitting of strings. + Fix bug (cast of c to doublereal) in + subroutine foo(c,r) + double complex c + double precision r + c = cmplx(r,real(c)) + end + New include file "sysdep.h" has some things from defs.h (and +elsewhere) that one may need to modify on some systems. + Some large arrays that were previously statically allocated are now +dynamically allocated when f2c starts running. + f2c/src files changed: + README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c + io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c + output.c parse_args.c pread.c put.c putpcc.c sysdep.h + version.c xsum0.out + +Wed Apr 11 18:27:12 EDT 1990: + Fix bug in argument consistency checking of character, complex, and +double complex valued functions. If the same source file contained a +definition of such a function with arguments not explicitly typed, +then subsequent references to the function might get erroneous +warnings of inconsistent calling sequences. + Tweaks to sysdep.h for partially ANSI systems. + New options -kr and -krd cause f2c to use temporary variables to +enforce Fortran evaluation-order rules with pernicious, old-style C +compilers that apply the associative law to floating-point operations. + +Sat Apr 14 15:50:15 EDT 1990: + libi77: libI77 adjusted to allow list-directed and namelist I/O +of internal files; bug in namelist I/O of logical and character arrays +fixed; list input of complex numbers adjusted to permit d or D to +denote the start of the exponent field of a component. + f2c itself: fix bug in handling complicated lower-bound +expressions for character substrings; e.g., min and max did not work +right, nor did function invocations involving character arguments. + Switch to octal notation, rather than hexadecimal, for nonprinting +characters in character and string constants. + Fix bug (when neither -A nor -C++ was specified) in typing of +external arguments of type complex, double complex, or character: + subroutine foo(c) + external c + complex c +now results in + /* Complex */ int (*c) (); +(as, indeed, it once did) rather than + complex (*c) (); + +Sat Apr 14 22:50:39 EDT 1990: + libI77/makefile: updated "make check" to omit lio.c + lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC). + (Request, e.g., "libi77 from f2c" -- you can't ask for individual +files from lib[FI]77.) + +Wed Apr 18 00:56:37 EDT 1990: + Move declaration of atof() from defs.h to sysdep.h, where it is +now not declared if stdlib.h is included. (NeXT's stdlib.h has a +#define atof that otherwise wreaks havoc.) + Under -u, provide a more intelligible error message (than "bad tag") +for an attempt to define a function without specifying its type. + +Wed Apr 18 17:26:27 EDT 1990: + Recognize \v (vertical tab) in Hollerith as well as quoted strings; +add recognition of \r (carriage return). + New option -!bs turns off recognition of escapes in character strings +(\0, \\, \b, \f, \n, \r, \t, \v). + Move to sysdep.c initialization of some arrays whose initialization +assumed ASCII; #define Table_size in sysdep.h rather than using +hard-coded 256 in allocating arrays of size 1 << (bits/byte). + +Thu Apr 19 08:13:21 EDT 1990: + Warn when escapes would make Hollerith extend beyond statement end. + Omit max() definition from misc.c (should be invisible except on +systems that erroneously #define max in stdlib.h). + +Mon Apr 23 22:24:51 EDT 1990: + When producing default-style C (no -A or -C++), cast switch +expressions to (int). + Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c . + Add #define scrub(x) to sysdep.h, with invocations in format.c and +formatdata.c, so that people who have systems like VMS that would +otherwise create multiple versions of intermediate files can +#define scrub(x) unlink(x) + +Tue Apr 24 18:28:36 EDT 1990: + Pass string lengths once rather than twice to a function of character +arguments involved in comparison of character strings of length 1. + +Fri Apr 27 13:11:52 EDT 1990: + Fix bug that made f2c gag on concatenations involving char(...) on +some systems. + +Sat Apr 28 23:20:16 EDT 1990: + Fix control-stack bug in + if(...) then + else if (complicated condition) + else + endif +(where the complicated condition causes assignment to an auxiliary +variable, e.g., max(a*b,c)). + +Mon Apr 30 13:30:10 EDT 1990: + Change fillers for DATA with holes from substructures to arrays +(in an attempt to make things work right with C compilers that have +funny padding rules for substructures, e.g., Sun C compilers). + Minor cleanup of exec.c (should not affect generated C). + +Mon Apr 30 23:13:51 EDT 1990: + Fix bug in handling return values of functions having multiple +entry points of differing return types. + +Sat May 5 01:45:18 EDT 1990: + Fix type inference bug in + subroutine foo(x) + call goo(x) + end + subroutine goo(i) + i = 3 + end +Instead of warning of inconsistent calling sequences for goo, +f2c was simply making i a real variable; now i is correctly +typed as an integer variable, and f2c issues an error message. + Adjust error messages issued at end of declarations so they +don't blame the first executable statement. + +Sun May 6 01:29:07 EDT 1990: + Fix bug in -P and -Ps: warn when the definition of a subprogram adds +information that would change prototypes or previous declarations. + +Thu May 10 18:09:15 EDT 1990: + Fix further obscure bug with (default) -it: inconsistent calling +sequences and I/O statements could interact to cause a memory fault. +Example: + SUBROUTINE FOO + CALL GOO(' Something') ! Forgot integer first arg + END + SUBROUTINE GOO(IUNIT,MSG) + CHARACTER*(*)MSG + WRITE(IUNIT,'(1X,A)') MSG + END + +Fri May 11 16:49:11 EDT 1990: + Under -!c, do not delete any .c files (when there are errors). + Avoid dereferencing 0 when a fatal error occurs while reading +Fortran on stdin. + +Wed May 16 18:24:42 EDT 1990: + f2c.ps made available. + +Mon Jun 4 12:53:08 EDT 1990: + Diagnose I/O units of invalid type. + Add specific error msg about dummy arguments in common. + +Wed Jun 13 12:43:17 EDT 1990: + Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear +both in a DATA statement and in either COMMON or EQUIVALENCE. + +Mon Jun 18 16:58:31 EDT 1990: + Trivial updates to f2c.ps . ("Fortran 8x" --> "Fortran 90"; omit +"(draft)" from "(draft) ANSI C".) + +Tue Jun 19 07:36:32 EDT 1990: + Fix incorrect code generated for ELSE IF(expression involving +function call passing non-constant substring). + Under -h, preserve the property that strings are null-terminated +where possible. + Remove spaces between # and define in lex.c output.c parse.h . + +Mon Jun 25 07:22:59 EDT 1990: + Minor tweak to makefile to reduce unnecessary recompilations. + +Tue Jun 26 11:49:53 EDT 1990: + Fix unintended truncation of some integer constants on machines +where casting a long to (int) may change the value. E.g., when f2c +ran on machines with 16-bit ints, "i = 99999" was being translated +to "i = -31073;". + +Wed Jun 27 11:05:32 EDT 1990: + Arrange for CHARACTER-valued PARAMETERs to honor their length +specifications. Allow CHAR(nn) in expressions defining such PARAMETERs. + +Fri Jul 20 09:17:30 EDT 1990: + Avoid dereferencing 0 when a FORMAT statement has no label. + +Thu Jul 26 11:09:39 EDT 1990: + Remarks about VOID and binread,binwrite added to README. + Tweaks to parse_args: should be invisible unless your compiler +complained at (short)*store. + +Thu Aug 2 02:07:58 EDT 1990: + f2c.ps: change the first line of page 5 from + include stuff +to + include 'stuff' + +Tue Aug 14 13:21:24 EDT 1990: + libi77: libI77 adjusted to treat tabs as spaces in list input. + +Fri Aug 17 07:24:53 EDT 1990: + libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z) +in an open of a currently open file works right. + +Tue Aug 28 01:56:44 EDT 1990: + Fix bug in warnings of inconsistent calling sequences: if an +argument to a subprogram was never referenced, then a previous +invocation of the subprogram (in the same source file) that +passed something of the wrong type for that argument did not +elicit a warning message. + +Thu Aug 30 09:46:12 EDT 1990: + libi77: prevent embedded blanks in list output of complex values; +omit exponent field in list output of values of magnitude between +10 and 1e8; prevent writing stdin and reading stdout or stderr; +don't close stdin, stdout, or stderr when reopening units 5, 6, 0. + +Tue Sep 4 12:30:57 EDT 1990: + Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION. + Warn of missing final END even if there are previous errors. + +Fri Sep 7 13:55:34 EDT 1990: + Remark about "make xsum.out" and "make f2c" added to README. + +Tue Sep 18 23:50:01 EDT 1990: + Fix null dereference (and, on some systems, writing of bogus *_com.c +files) under -ec or -e1c when a prototype file (*.p or *.P) describes +COMMON blocks that do not appear in the Fortran source. + libi77: + Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid +references to stat and fstat on non-UNIX systems. + On UNIX systems, add component udev to unit; decide that old +and new files are the same iff both the uinode and udev components +of unit agree. + When an open stmt specifies STATUS='OLD', use stat rather than +access (on UNIX systems) to check the existence of the file (in case +directories leading to the file have funny permissions and this is +a setuid or setgid program). + +Thu Sep 27 16:04:09 EDT 1990: + Supply missing entry for Impldoblock in blksize array of cpexpr +(in expr.c). No examples are known where this omission caused trouble. + +Tue Oct 2 22:58:09 EDT 1990: + libf77: test signal(...) == SIG_IGN rather than & 01 in main(). + libi77: adjust rewind.c so two successive rewinds after a write +don't clobber the file. + +Thu Oct 11 18:00:14 EDT 1990: + libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c, +open.c; adjust g_char in util.c for segmented memories; in f_inqu +(inquire.c), define x appropriately when MSDOS is defined. + +Mon Oct 15 20:02:11 EDT 1990: + Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a +synonym for FILE= in OPEN statements. + +Wed Oct 17 16:40:37 EDT 1990: + libf77, libi77: minor cleanups: _cleanup() and abort() invocations +replaced by invocations of sig_die in main.c; some error messages +previously lost in buffers will now appear. + +Mon Oct 22 16:11:27 EDT 1990: + libf77: separate sig_die from main (for folks who don't want to use +the main in libF77). + libi77: minor tweak to comments in README. + +Fri Nov 2 13:49:35 EST 1990: + Use two underscores rather than one in generated temporary variable +names to avoid conflict with COMMON names. f2c.ps updated to reflect +this change and the NAME= extension introduced 15 Oct. + Repair a rare memory fault in io.c . + +Mon Nov 5 16:43:55 EST 1990: + libi77: changes to open.c (and err.c): complain if an open stmt +specifies new= and the file already exists (as specified by Fortrans 77 +and 90); allow file= to be omitted in open stmts and allow +status='replace' (Fortran 90 extensions). + +Fri Nov 30 10:10:14 EST 1990: + Adjust malloc.c for unusual systems whose sbrk() can return values +not properly aligned for doubles. + Arrange for slightly more helpful and less repetitive warnings for +non-character variables initialized with character data; these warnings +are (still) suppressed by -w66. + +Fri Nov 30 15:57:59 EST 1990: + Minor tweak to README (about changing VOID in f2c.h). + +Mon Dec 3 07:36:20 EST 1990: + Fix spelling of "character" in f2c.1t. + +Tue Dec 4 09:48:56 EST 1990: + Remark about link_msg and libf2c added to f2c/README. + +Thu Dec 6 08:33:24 EST 1990: + Under -U, render label nnn as L_nnn rather than Lnnn. + +Fri Dec 7 18:05:00 EST 1990: + Add more names from f2c.h (e.g. integer, real) to the c_keywords +list of names to which an underscore is appended to avoid confusion. + +Mon Dec 10 19:11:15 EST 1990: + Minor tweaks to makefile (./xsum) and README (binread/binwrite). + libi77: a few modifications for POSIX systems; meant to be invisible +elsewhere. + +Sun Dec 16 23:03:16 EST 1990: + Fix null dereference caused by unusual erroneous input, e.g. + call foo('abc') + end + subroutine foo(msg) + data n/3/ + character*(*) msg + end +(Subroutine foo is illegal because the character statement comes after a +data statement.) + Use decimal rather than hex constants in xsum.c (to prevent +erroneous warning messages about constant overflow). + +Mon Dec 17 12:26:40 EST 1990: + Fix rare extra underscore in character length parameters passed +for multiple entry points. + +Wed Dec 19 17:19:26 EST 1990: + Allow generation of C despite error messages about bad alignment +forced by equivalence. + Allow variable-length concatenations in I/O statements, such as + open(3, file=bletch(1:n) // '.xyz') + +Fri Dec 28 17:08:30 EST 1990: + Fix bug under -p with formats and internal I/O "units" in COMMON, +as in + COMMON /FIGLEA/F + CHARACTER*20 F + F = '(A)' + WRITE (*,FMT=F) 'Hello, world!' + END + +Tue Jan 15 12:00:24 EST 1991: + Fix bug when two equivalence groups are merged, the second with +nonzero offset, and the result is then merged into a common block. +Example: + INTEGER W(3), X(3), Y(3), Z(3) + COMMON /ZOT/ Z + EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1)) +***** W WAS GIVEN THE WRONG OFFSET + Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs. +(Currently NML= and FMT= are treated as synonyms -- there's no +error message if, e.g., NML= specifies a format.) + libi77: minor adjustment to allow internal READs from character +string constants in read-only memory. + +Fri Jan 18 22:56:15 EST 1991: + Add comment to README about needing to comment out the typedef of +size_t in sysdep.h on some systems, e.g. Sun 4.1. + Fix misspelling of "statement" in an error message in lex.c + +Wed Jan 23 00:38:48 EST 1991: + Allow hex, octal, and binary constants to have the qualifying letter +(z, x, o, or b) either before or after the quoted string containing the +digits. For now this change will not be reflected in f2c.ps . + +Tue Jan 29 16:23:45 EST 1991: + Arrange for character-valued statement functions to give results of +the right length (that of the statement function's name). + +Wed Jan 30 07:05:32 EST 1991: + More tweaks for character-valued statement functions: an error +check and an adjustment so a right-hand side of nonconstant length +(e.g., a substring) is handled right. + +Wed Jan 30 09:49:36 EST 1991: + Fix p1_head to avoid printing (char *)0 with %s. + +Thu Jan 31 13:53:44 EST 1991: + Add a test after the cleanup call generated for I/O statements with +ERR= or END= clauses to catch the unlikely event that the cleanup +routine encounters an error. + +Mon Feb 4 08:00:58 EST 1991: + Minor cleanup: omit unneeded jumps and labels from code generated for +some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=. + +Tue Feb 5 01:39:36 EST 1991: + Change Mktemp to mktmp (for the benefit of systems so brain-damaged +that they do not distinguish case in external names -- and that for +some reason want to load mktemp). Try to get xsum0.out right this +time (it somehow didn't get updated on 4 Feb. 1991). + Add note to libi77/README about adjusting the interpretation of +RECL= specifiers in OPENs for direct unformatted I/O. + +Thu Feb 7 17:24:42 EST 1991: + New option -r casts values of REAL functions, including intrinsics, +to REAL. This only matters for unportable code like + real r + r = asin(1.) + if (r .eq. asin(1.)) ... +[The behavior of such code varies with the Fortran compiler used -- +and sometimes is affected by compiler options.] For now, the man page +at the end of f2c.ps is the only part of f2c.ps that reflects this new +option. + +Fri Feb 8 18:12:51 EST 1991: + Cast pointer differences passed as arguments to the appropriate type. +This matters, e.g., with MSDOS compilers that yield a long pointer +difference but have int == short. + Disallow nonpositive dimensions. + +Fri Feb 15 12:24:15 EST 1991: + Change %d to %ld in sprintf call in putpower in putpcc.c. + Free more memory (e.g. allowing translation of larger Fortran +files under MS-DOS). + Recognize READ (character expression) and WRITE (character expression) +as formatted I/O with the format given by the character expression. + Update year in Notice. + +Sat Feb 16 00:42:32 EST 1991: + Recant recognizing WRITE(character expression) as formatted output +-- Fortran 77 is not symmetric in its syntax for READ and WRITE. + +Mon Mar 4 15:19:42 EST 1991: + Fix bug in passing the real part of a complex argument to an intrinsic +function. Omit unneeded parentheses in nested calls to intrinsics. +Example: + subroutine foo(x, y) + complex y + x = exp(sin(real(y))) + exp(imag(y)) + end + +Fri Mar 8 15:05:42 EST 1991: + Fix a comment in expr.c; omit safstrncpy.c (which had bugs in +cases not used by f2c). + +Wed Mar 13 02:27:23 EST 1991: + Initialize firstmemblock->next in mem_init in mem.c . [On most +systems it was fortuituously 0, but with System V, -lmalloc could +trip on this missed initialization.] + +Wed Mar 13 11:47:42 EST 1991: + Fix a reference to freed memory. + +Wed Mar 27 00:42:19 EST 1991: + Fix a memory fault caused by such illegal Fortran as + function foo + x = 3 + logical foo ! declaration among executables + foo=.false. ! used to suffer memory fault + end + +Fri Apr 5 08:30:31 EST 1991: + Fix loss of % in some format expressions, e.g. + write(*,'(1h%)') + Fix botch introduced 27 March 1991 that caused subroutines with +multiple entry points to have extraneous declarations of ret_val. + +Fri Apr 5 12:44:02 EST 1991 + Try again to omit extraneous ret_val declarations -- this morning's +fix was sometimes wrong. + +Mon Apr 8 13:47:06 EDT 1991: + Arrange for s_rnge to have the right prototype under -A -C . + +Wed Apr 17 13:36:03 EDT 1991: + New fatal error message for apparent invocation of a recursive +statement function. + +Thu Apr 25 15:13:37 EDT 1991: + F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot +about -i2 when adding NAMELIST.) This required a change to f2c.h +(that only affects NAMELIST I/O under -i2.) Man-page description of +-i2 adjusted to reflect that -i2 stores array lengths in short ints. + +Fri Apr 26 02:54:41 EDT 1991: + Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays +(file rsne.c). + +Thu May 9 02:13:51 EDT 1991: + Omit a trailing space in expr.c (could cause a false xsum value if +a mailer drops the trailing blank). + +Thu May 16 13:14:59 EDT 1991: + Libi77: increase LEFBL in lio.h to overcome a NeXT bug. + Tweak for compilers that recognize "nested" comments: inside comments, +turn /* into /+ (as well as */ into +/). + +Sat May 25 11:44:25 EDT 1991: + libf77: s_rnge: declare line long int rather than int. + +Fri May 31 07:51:50 EDT 1991: + libf77: system_: officially return status. + +Mon Jun 17 16:52:53 EDT 1991: + Minor tweaks: omit unnecessary declaration of strcmp (that caused +trouble on a system where strcmp was a macro) from misc.c; add +SHELL = /bin/sh to makefiles. + Fix a dereference of null when a CHARACTER*(*) declaration appears +(illegally) after DATA. Complain only once per subroutine about +declarations appearing after DATA. + +Mon Jul 1 00:28:13 EDT 1991: + Add test and error message for illegal use of subroutine names, e.g. + SUBROUTINE ZAP(A) + ZAP = A + END + +Mon Jul 8 21:49:20 EDT 1991: + Issue a warning about things like + integer i + i = 'abc' +(which is treated as i = ichar('a')). [It might be nice to treat 'abc' +as an integer initialized (in a DATA statement) with 'abc', but +other matters have higher priority.] + Render + i = ichar('A') +as + i = 'A'; +rather than + i = 65; +(which assumes ASCII). + +Fri Jul 12 07:41:30 EDT 1991: + Note added to README about erroneous definitions of __STDC__ . + +Sat Jul 13 13:38:54 EDT 1991: + Fix bugs in double type convesions of complex values, e.g. +sngl(real(...)) or dble(real(...)) (where ... is complex). + +Mon Jul 15 13:21:42 EDT 1991: + Fix bug introduced 8 July 1991 that caused erroneous warnings +"ichar([first char. of] char. string) assumed for conversion to numeric" +when a subroutine had an array of character strings as an argument. + +Wed Aug 28 01:12:17 EDT 1991: + Omit an unused function in format.c, an unused variable in proc.c . + Under -r8, promote complex to double complex (as the man page claims). + +Fri Aug 30 17:19:17 EDT 1991: + f2c.ps updated: slightly expand description of intrinsics and,or,xor, +not; add mention of intrinsics lshift, rshift; add note about f2c +accepting Fortran 90 inline comments (starting with !); update Cobalt +Blue address. + +Tue Sep 17 07:17:33 EDT 1991: + libI77: err.c and open.c modified to use modes "rb" and "wb" +when (f)opening unformatted files; README updated to point out +that it may be necessary to change these modes to "r" and "w" +on some non-ANSI systems. + +Tue Oct 15 10:25:49 EDT 1991: + Minor tweaks that make some PC compilers happier: insert some +casts, add args to signal functions. + Change -g to emit uncommented #line lines -- and to emit more of them; +update fc, f2c.1, f2c.1t, f2c.ps to reflect this. + Change uchar to Uchar in xsum.c . + Bring gram.c up to date. + +Thu Oct 17 09:22:05 EDT 1991: + libi77: README, fio.h, sue.c, uio.c changed so the length field +in unformatted sequential records has type long rather than int +(unless UIOLEN_int is #defined). This is for systems where sizeof(int) +can vary, depending on the compiler or compiler options. + +Thu Oct 17 13:42:59 EDT 1991: + libi77: inquire.c: when MSDOS is defined, don't strcmp units[i].ufnm +when it is NULL. + +Fri Oct 18 15:16:00 EDT 1991: + Correct xsum0.out in "all from f2c/src" (somehow botched on 15 Oct.). + +Tue Oct 22 18:12:56 EDT 1991: + Fix memory fault when a character*(*) argument is used (illegally) +as a dummy variable in the definition of a statement function. (The +memory fault occurred when the statement function was invoked.) + Complain about implicit character*(*). + +Thu Nov 14 08:50:42 EST 1991: + libi77: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c; this change +should be invisible unless you're running a brain-damaged system. + +Mon Nov 25 19:04:40 EST 1991: + libi77: correct botches introduced 17 Oct. 1991 and 14 Nov. 1991 +(change uint to Uint in lwrite.c; other changes that only matter if +sizeof(int) != sizeof(long)). + Add a more meaningful error message when bailing out due to an attempt +to invoke a COMMON variable as a function. + +Sun Dec 1 19:29:24 EST 1991: + libi77: uio.c: add test for read failure (seq. unformatted reads); +adjust an error return from EOF to off end of record. + +Tue Dec 10 17:42:28 EST 1991: + Add tests to prevent memory faults with bad uses of character*(*). + +Thu Dec 12 11:24:41 EST 1991: + libi77: fix bug with internal list input that caused the last +character of each record to be ignored; adjust error message in +internal formatted input from "end-of-file" to "off end of record" +if the format specifies more characters than the record contains. + +Wed Dec 18 17:48:11 EST 1991: + Fix bug in translating nonsensical ichar invocations involving +concatenations. + Fix bug in passing intrinsics lle, llt, lge, lgt as arguments; +hl_le was being passed rather than l_le, etc. + libf77: adjust length parameters from long to ftnlen, for +compiling with f2c_i2 defined. + +Sat Dec 21 15:30:57 EST 1991: + Allow DO nnn ... to end with an END DO statement labelled nnn. + +Tue Dec 31 13:53:47 EST 1991: + Fix bug in handling dimension a(n**3,2) -- pow_ii was called +incorrectly. + Fix bug in translating + subroutine x(abc,n) + character abc(n) + write(abc,'(i10)') 123 + end +(omitted declaration and initialiation of abc_dim1). + Complain about dimension expressions of such invalid types +as complex and logical. + +Fri Jan 17 11:54:20 EST 1992: + Diagnose some illegal uses of main program name (rather than +memory faulting). + libi77: (1) In list and namelist input, treat "r* ," and "r*," +alike (where r is a positive integer constant), and fix a bug in +handling null values following items with repeat counts (e.g., +2*1,,3). (2) For namelist reading of a numeric array, allow a new +name-value subsequence to terminate the current one (as though the +current one ended with the right number of null values). +(3) [lio.h, lwrite.c]: omit insignificant zeros in list and namelist +output. (Compile with -DOld_list_output to get the old behavior.) + +Sat Jan 18 15:58:01 EST 1992: + libi77: make list output consistent with F format by printing .1 +rather than 0.1 (introduced yesterday). + +Wed Jan 22 08:32:43 EST 1992: + libi77: add comment to README pointing out preconnection of +Fortran units 5, 6, 0 to stdin, stdout, stderr (respectively). + +Mon Feb 3 11:57:53 EST 1992: + libi77: fix namelist read bug that caused the character following +a comma to be ignored. + +Fri Feb 28 01:04:26 EST 1992: + libf77: fix buggy z_sqrt.c (double precision square root), which +misbehaved for arguments in the southwest quadrant. + +Thu Mar 19 15:05:18 EST 1992: + Fix bug (introduced 17 Jan 1992) in handling multiple entry points +of differing types (with implicitly typed entries appearing after +the first executable statement). + Fix memory fault in the following illegal Fortran: + double precision foo(i) +* illegal: above should be "double precision function foo(i)" + foo = i * 3.2 + entry moo(i) + end + Note about ANSI_Libraries (relevant, e.g., to IRIX 4.0.1 and AIX) +added to README. + Abort zero divides during constant simplification. + +Sat Mar 21 01:27:09 EST 1992: + Tweak ckalloc (misc.c) for systems where malloc(0) = 0; this matters +for subroutines with multiple entry points but no arguments. + Add "struct memblock;" to init.c (irrelevant to most compilers). + +Wed Mar 25 13:31:05 EST 1992: + Fix bug with IMPLICIT INTEGER*4(...): under -i2 or -I2, the *4 was +ignored. + +Tue May 5 09:53:55 EDT 1992: + Tweaks to README; e.g., ANSI_LIbraries changed to ANSI_Libraries . + +Wed May 6 23:49:07 EDT 1992 + Under -A and -C++, have subroutines return 0 (even if they have +no * arguments). + Adjust libi77 (rsne.c and lread.c) for systems where ungetc is +a macro. Tweak lib[FI]77/makefile to use unique intermediate file +names (for parallel makes). + +Tue May 19 09:03:05 EDT 1992: + Adjust libI77 to make err= work with internal list and formatted I/O. + +Sat May 23 18:17:42 EDT 1992: + Under -A and -C++, supply "return 0;" after the code generated for +a STOP statement -- the C compiler doesn't know that s_stop won't +return. + New (mutually exclusive) options: + -f treats all input lines as free-format lines, + honoring text that appears after column 72 + and not padding lines shorter than 72 characters + with blanks (which matters if a character string + is continued across 2 or more lines). + -72 treats text appearing after column 72 as an error. + +Sun May 24 09:45:37 EDT 1992: + Tweak description of -f in f2c.1 and f2c.1t; update f2c.ps . + +Fri May 29 01:17:15 EDT 1992: + Complain about externals used as variables. Example + subroutine foo(a,b) + external b + a = a*b ! illegal use of b; perhaps should be b() + end + +Mon Jun 15 11:15:27 EDT 1992: + Fix bug in handling namelists with names that have underscores. + +Sat Jun 27 17:30:59 EDT 1992: + Under -A and -C++, end Main program aliases with "return 0;". + Under -A and -C++, use .P files and usage in previous subprograms +in the current file to give prototypes for functions declared EXTERNAL +but not invoked. + Fix memory fault under -d1 -P . + Under -A and -C++, cast arguments to the right types in calling +a function that has been defined in the current file or in a .P file. + Fix bug in handling multi-dimensional arrays with array references +in their leading dimensions. + Fix bug in the intrinsic cmplx function when the first argument +involves an expression for which f2c generates temporary variables, +e.g. cmplx(abs(real(a)),1.) . + +Sat Jul 18 07:36:58 EDT 1992: + Fix buglet with -e1c (invisible on most systems) temporary file +f2c_functions was unlinked before being closed. + libf77: fix bugs in evaluating m**n for integer n < 0 and m an +integer different from 1 or a real or double precision 0. +Catch SIGTRAP (to print "Trace trap" before aborting). Programs +that previously erroneously computed 1 for 0**-1 may now fault. +Relevant routines: main.c pow_di.c pow_hh.c pow_ii.c pow_ri.c . + +Sat Jul 18 08:40:10 EDT 1992: + libi77: allow namelist input to end with & (e.g. &end). + +Thu Jul 23 00:14:43 EDT 1992 + Append two underscores rather than one to C keywords used as +local variables to avoid conflicts with similarly named COMMON blocks. + +Thu Jul 23 11:20:55 EDT 1992: + libf77, libi77 updated to assume ANSI prototypes unless KR_headers +is #defined. + libi77 now recognizes a Z format item as in Fortran 90; +the implementation assumes 8-bit bytes and botches character strings +on little-endian machines (by printing their bytes from right to +left): expect this bug to persist; fixing it would require a +change to the I/O calling sequences. + +Tue Jul 28 15:18:33 EDT 1992: + libi77: insert missed "#ifdef KR_headers" lines around getnum +header in rsne.c. Version not updated. + +NOTE: "index from f2c" now ends with current timestamps of files in +"all from f2c/src", sorted by time. To bring your source up to date, +obtain source files with a timestamp later than the time shown in your +version.c. + +Fri Aug 14 08:07:09 EDT 1992: + libi77: tweak wrt_E in wref.c to avoid signing NaNs. + +Sun Aug 23 19:05:22 EDT 1992: + fc: supply : after O in getopt invocation (for -O1 -O2 -O3). + +Mon Aug 24 18:37:59 EDT 1992: + Recant above tweak to fc: getopt is dumber than I thought; +it's necessary to say -O 1 (etc.). + libF77/README: add comments about ABORT, ERF, DERF, ERFC, DERFC, +GETARG, GETENV, IARGC, SIGNAL, and SYSTEM. + +Tue Oct 27 01:57:42 EST 1992: + libf77, libi77: + 1. Fix botched indirection in signal_.c. + 2. Supply missing l_eof = 0 assignment to s_rsne() in rsne.c (so +end-of-file on other files won't confuse namelist reads of external +files). + 3. Prepend f__ to external names that are only of internal +interest to lib[FI]77. + +Thu Oct 29 12:37:18 EST 1992: + libf77: Fix botch in signal_.c when KR_headers is #defined; +add CFLAGS to makefile. + libi77: trivial change to makefile for consistency with +libF77/makefile. + +Wed Feb 3 02:05:16 EST 1993: + Recognize types INTEGER*1, LOGICAL*1, LOGICAL*2, INTEGER*8. +INTEGER*8 is not well tested and will only work reasonably on +systems where int = 4 bytes, long = 8 bytes; on such systems, +you'll have to modify f2c.h appropriately, changing integer +from long to int and adding typedef long longint. You'll also +have to compile libI77 with Allow_TYQUAD #defined and adjust +libF77/makefile to compile pow_qq.c. In the f2c source, changes +for INTEGER*8 are delimited by #ifdef TYQUAD ... #endif. You +can omit the INTEGER*8 changes by compiling with NO_TYQUAD +#defined. Otherwise, the new command-line option -!i8 +disables recognition of INTEGER*8. + libf77: add pow_qq.c + libi77: add #ifdef Allow_TYQUAD stuff. Changes for INTEGER*1, +LOGICAL*1, and LOGICAL*2 came last 23 July 1992. Fix bug in +backspace (that only bit when the last character of the second +or subsequent buffer read was the previous newline). Guard +against L_tmpnam being too small in endfile.c. For MSDOS, +close and reopen files when copying to truncate. Lengthen +LINTW (buffer size in lwrite.c). + Add \ to the end of #define lines that get broken. + Fix bug in handling NAMELIST of items in EQUIVALENCE. + Under -h (or -hd), convert Hollerith to integer in general expressions +(e.g., assignments), not just when they're passed as arguments, and +blank-pad rather than 0-pad the Hollerith to a multiple of +sizeof(integer) or sizeof(doublereal). + Add command-line option -s, which instructs f2c preserve multi- +dimensional subscripts (by emitting and using appropriate #defines). + Fix glitch (with default type inferences) in examples like + call foo('abc') + end + subroutine foo(goo) + end +This gave two warning messages: + Warning on line 4 of y.f: inconsistent calling sequences for foo: + here 1, previously 2 args and string lengths. + Warning on line 4 of y.f: inconsistent calling sequences for foo: + here 2, previously 1 args and string lengths. +Now the second Warning is suppressed. + Complain about all inconsistent arguments, not just the first. + Switch to automatic creation of "all from f2c/src". For folks +getting f2c source via ftp, this means f2c/src/all.Z is now an +empty file rather than a bundle. + Separate -P and -A: -P no longer implies -A. + +Thu Feb 4 00:32:20 EST 1993: + Fix some glitches (introduced yesterday) with -h . + +Fri Feb 5 01:40:38 EST 1993: + Fix bug in types conveyed for namelists (introduced 3 Feb. 1993). + +Fri Feb 5 21:26:43 EST 1993: + libi77: tweaks to NAMELIST and open (after comments by Harold +Youngren): + 1. Reading a ? instead of &name (the start of a namelist) causes + the namelist being sought to be written to stdout (unit 6); + to omit this feature, compile rsne.c with -DNo_Namelist_Questions. + 2. Reading the wrong namelist name now leads to an error message + and an attempt to skip input until the right namelist name is found; + to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. + 3. Namelist writes now insert newlines before each variable; to omit + this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. + 4. For OPEN of sequential files, ACCESS='APPEND' (or + access='anything else starting with "A" or "a"') causes the file to + be positioned at end-of-file, so a write will append to the file. + (This is nonstandard, but does not require modifying data + structures.) + +Mon Feb 8 14:40:37 EST 1993: + Increase number of continuation lines allowed from 19 to 99, +and allow changing this limit with -NC (e.g. -NC200 for 200 lines). + Treat control-Z (at the beginning of a line) as end-of-file: see +the new penultimate paragraph of README. + Fix a rarely seen glitch that could make an error messages to say +"line 0". + +Tue Feb 9 02:05:40 EST 1993 + libi77: change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO, +and, in err.c under NON_UNIX_STDIO, avoid close(creat(name,0666)) +when the unit has another file descriptor for name. + +Tue Feb 9 17:12:49 EST 1993 + libi77: more tweaks for NON_UNIX_STDIO: use stdio routines +rather than open, close, creat, seek, fdopen (except for f__isdev). + +Fri Feb 12 15:49:33 EST 1993 + Update src/gram.c (which was forgotten in the recent updates). +Most folks regenerate it anyway (wity yacc or bison). + +Thu Mar 4 17:07:38 EST 1993 + Increase default max labels in computed gotos and alternate returns +to 257, and allow -Nl1234 to specify this number. + Tweak put.c to check p->tag == TADDR in realpart() and imagpart(). + Adjust fc script to allow .r (RATFOR) files and -C (check subscripts). + Avoid declaring strchr in niceprintf.c under -DANSI_Libraries . + gram.c updated again. + libi77: err.c, open.c: take declaration of fdopen from rawio.h. + +Sat Mar 6 07:09:11 EST 1993 + libi77: uio.c: adjust off-end-of-record test for sequential +unformatted reads to respond to err= rather than end= . + +Sat Mar 6 16:12:47 EST 1993 + Treat scalar arguments of the form (v) and v+0, where v is a variable, +as expressions: assign to a temporary variable, and pass the latter. + gram.c updated. + +Mon Mar 8 09:35:38 EST 1993 + "f2c.h from f2c" updated to add types logical1 and integer1 for +LOGICAL*1 and INTEGER*1. ("f2c.h from f2c" is supposed to be the +same as "f2c.h from f2c/src", which was updated 3 Feb. 1993.) + +Mon Mar 8 17:57:55 EST 1993 + Fix rarely seen bug that could cause strange casts in function +invocations (revealed by an example with msdos/f2c.exe). + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Fri Mar 12 12:37:01 EST 1993 + Fix bug with -s in handling subscripts involving min, max, and +complicated expressions requiring temporaries. + Fix bug in handling COMMONs that need padding by a char array. + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Fri Mar 12 17:16:16 EST 1993 + libf77, libi77: updated for compiling under C++. + +Mon Mar 15 16:21:37 EST 1993 + libi77: more minor tweaks (for -DKR_headers); Version.c not changed. + +Thu Mar 18 12:37:30 EST 1993 + Flag -r (for discarding carriage-returns on systems that end lines +with carriage-return/newline pairs, e.g. PCs) added to xsum, and +xsum.c converted to ANSI/ISO syntax (with K&R syntax available with +-DKR_headers). [When time permits, the f2c source will undergo a +similar conversion.] + libi77: tweaks to #includes in endfile.c, err.c, open.c, rawio.h; +Version.c not changed. + f2c.ps updated (to pick up revision of 2 Feb. 1993 to f2c.1). + +Fri Mar 19 09:19:26 EST 1993 + libi77: add (char *) casts to malloc and realloc invocations +in err.c, open.c; Version.c not changed. + +Tue Mar 30 07:17:15 EST 1993 + Fix bug introduced 6 March 1993: possible memory corruption when +loops in data statements involve constant subscripts, as in + DATA (GUNIT(1,I),I=0,14)/15*-1/ + +Tue Mar 30 16:17:42 EST 1993 + Fix bug with -s: (floating-point array item)*(complex item) +generates an _subscr() reference for the floating-point array, +but a #define for the _subscr() was omitted. + +Tue Apr 6 12:11:22 EDT 1993 + libi77: adjust error returns for formatted inputs to flush the current +input line when err= is specified. To restore the old behavior (input +left mid-line), either adjust the #definition of errfl in fio.h or omit +the invocation of f__doend in err__fl (in err.c). + +Tue Apr 6 13:30:04 EDT 1993 + Fix bug revealed in + subroutine foo(i) + call goo(int(i)) + end +which now passes a copy of i, rather than i itself. + +Sat Apr 17 11:41:02 EDT 1993 + Adjust appending of underscores to conform with f2c.ps ("A Fortran +to C Converter"): names that conflict with C keywords or f2c type +names now have just one underscore appended (rather than two); add +"integer1", "logical1", "longint" to the keyword list. + Append underscores to names that appear in EQUIVALENCE and are +component names in a structure declared in f2c.h, thus avoiding a +problem caused by the #defines emitted for equivalences. Example: + complex a + equivalence (i,j) + a = 1 ! a.i went awry because of #define i + j = 2 + write(*,*) a, i + end + Adjust line-breaking logic to avoid splitting very long constants +(and names). Example: + ! The next line starts with tab and thus is a free-format line. + a=.012345689012345689012345689012345689012345689012345689012345689012345689 + end + Omit extraneous "return 0;" from entry stubs emitted for multiple +entry points of type character, complex, or double complex. + +Sat Apr 17 14:35:05 EDT 1993 + Fix bug (introduced 4 Feb.) in separating -P from -A that kept f2c +from re-reading a .P file written without -A or -C++ describing a +routine with an external argument. [See the just-added note about +separating -P from -A in the changes above for 3 Feb. 1993.] + Fix bug (type UNKNOWN for V in the example below) revealed by + subroutine a() + external c + call b(c) + end + subroutine b(v) + end + +Sun Apr 18 19:55:26 EDT 1993 + Fix wrong calling sequence for mem() in yesterday's addition to +equiv.c . + +Wed Apr 21 17:39:46 EDT 1993 + Fix bug revealed in + + ASSIGN 10 TO L1 + GO TO 20 + 10 ASSIGN 30 TO L2 + STOP 10 + + 20 ASSIGN 10 TO L2 ! Bug here because 10 had been assigned + ! to another label, then defined. + GO TO L2 + 30 END + +Fri Apr 23 18:38:50 EDT 1993 + Fix bug with -h revealed in + CHARACTER*9 FOO + WRITE(FOO,'(I6)') 1 + WRITE(FOO,'(I6)') 2 ! struct icilist io___3 botched + END + +Tue Apr 27 16:08:28 EDT 1993 + Tweak to makefile: remove "size f2c". + +Tue May 4 23:48:20 EDT 1993 + libf77: tweak signal_ line of f2ch.add . + +Tue Jun 1 13:47:13 EDT 1993 + Fix bug introduced 3 Feb. 1993 in handling multiple entry +points with differing return types -- the postfix array in proc.c +needed a new entry for integer*8 (which resulted in wrong +Multitype suffixes for non-integral types). + For (default) K&R C, generate VOID rather than int functions for +functions of Fortran type character, complex, and double complex. + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Tue Jun 1 23:11:15 EDT 1993 + f2c.h: add Multitype component g and commented type longint. + proc.c: omit "return 0;" from stubs for complex and double complex +entries (when entries have multiple types); add test to avoid memory +fault with illegal combinations of entry types. + +Mon Jun 7 12:00:47 EDT 1993 + Fix memory fault in + common /c/ m + integer m(1) + data m(1)/1/, m(2)/2/ ! one too many initializers + end + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Fri Jun 18 13:55:51 EDT 1993 + libi77: change type of signal_ in f2ch.add; change type of il in +union Uint from long to integer (for machines like the DEC Alpha, +where integer should be the same as int). Version.c not changed. + Tweak gram.dcl and gram.head: add semicolons after some rules that +lacked them, and remove an extraneous semicolon. These changes are +completely transparent to our local yacc programs, but apparently +matter on some VMS systems. + +Wed Jun 23 01:02:56 EDT 1993 + Update "fc" shell script, and bring f2c.1 and f2c.1t up to date: +they're meant to be linked with (i.e., the same as) src/f2c.1 and +src/f2c.1t . [In the last update of f2c.1* (2 Feb. 1993), only +src/f2c.1 and src/f2c.1t got changed -- a mistake.] + +Wed Jun 23 09:04:31 EDT 1993 + libi77: fix bug in format reversions for internal writes. +Example: + character*60 lines(2) + write(lines,"('n =',i3,2(' more text',i3))") 3, 4, 5, 6 + write(*,*) 'lines(1) = ', lines(1) + write(*,*) 'lines(2) = ', lines(2) + end +gave an error message that began "iio: off end of record", rather +than giving the correct output: + + lines(1) = n = 3 more text 4 more text 5 + lines(2) = more text 6 more text + +Thu Aug 5 11:31:14 EDT 1993 + libi77: lread.c: fix bug in handling repetition counts for logical +data (during list or namelist input). Change struct f__syl to +struct syl (for buggy compilers). + +Sat Aug 7 16:05:30 EDT 1993 + libi77: lread.c (again): fix bug in namelist reading of incomplete +logical arrays. + Fix minor calling-sequence errors in format.c, output.c, putpcc.c: +should be invisible. + +Mon Aug 9 09:12:38 EDT 1993 + Fix erroneous cast under -A in translating + character*(*) function getc() + getc(2:3)=' ' !wrong cast in first arg to s_copy + end + libi77: lread.c: fix bug in namelist reading of an incomplete array +of numeric data followed by another namelist item whose name starts +with 'd', 'D', 'e', or 'E'. + +Fri Aug 20 13:22:10 EDT 1993 + Fix bug in do while revealed by + subroutine skdig (line, i) + character line*(*), ch*1 + integer i + logical isdigit + isdigit(ch) = ch.ge.'0' .and. ch.le.'9' + do while (isdigit(line(i:i))) ! ch__1[0] was set before + ! "while(...) {...}" + i = i + 1 + enddo + end + +Fri Aug 27 08:22:54 EDT 1993 + Add #ifdefs to avoid declaring atol when it is a macro; version.c +not updated. + +Wed Sep 8 12:24:26 EDT 1993 + libi77: open.c: protect #include "sys/..." with +#ifndef NON_UNIX_STDIO; Version date not changed. + +Thu Sep 9 08:51:21 EDT 1993 + Adjust "include" to interpret file names relative to the directory +of the file that contains the "include". + +Fri Sep 24 00:56:12 EDT 1993 + Fix offset error resulting from repeating the same equivalence +statement twice. Example: + real a(2), b(2) + equivalence (a(2), b(2)) + equivalence (a(2), b(2)) + end + Increase MAXTOKENLEN (to roughly the largest allowed by ANSI C). + +Mon Sep 27 08:55:09 EDT 1993 + libi77: endfile.c: protect #include "sys/types.h" with +#ifndef NON_UNIX_STDIO; Version.c not changed. + +Fri Oct 15 15:37:26 EDT 1993 + Fix rarely seen parsing bug illustrated by + subroutine foo(xabcdefghij) + character*(*) xabcdefghij + IF (xabcdefghij.NE.'##') GOTO 40 + 40 end +in which the spacing in the IF line is crucial. + +Thu Oct 21 13:55:11 EDT 1993 + Give more meaningful error message (then "unexpected character in +cds") when constant simplification leads to Infinity or NaN. + +Wed Nov 10 15:01:05 EST 1993 + libi77: backspace.c: adjust, under -DMSDOS, to cope with MSDOS +text files, as handled by some popular PC C compilers. Beware: +the (defective) libraries associated with these compilers assume lines +end with \r\n (conventional MS-DOS text files) -- and ftell (and +hence the current implementation of backspace) screws up if lines with +just \n. + +Thu Nov 18 09:37:47 EST 1993 + Give a better error (than "control stack empty") for an extraneous +ENDDO. Example: + enddo + end + Update comments about ftp in "readme from f2c". + +Sun Nov 28 17:26:50 EST 1993 + Change format of time stamp in version.c to yyyymmdd. + Sort parameter adjustments (or complain of impossible dependencies) +so that dummy arguments are referenced only after being adjusted. +Example: + subroutine foo(a,b) + integer a(2) ! a must be adjusted before b + double precision b(a(1),a(2)) + call goo(b(3,4)) + end + Adjust structs for initialized common blocks and equivalence classes +to omit the trailing struct component added to force alignment when +padding already forces the desired alignment. Example: + PROGRAM TEST + COMMON /Z/ A, CC + CHARACTER*4 CC + DATA cc /'a'/ + END +now gives + struct { + integer fill_1[1]; + char e_2[4]; + } z_ = { {0}, {'a', ' ', ' ', ' '} }; +rather than +struct { + integer fill_1[1]; + char e_2[4]; + real e_3; + } z_ = { {0}, {'a', ' ', ' ', ' '}, (float)0. }; + +Wed Dec 8 16:24:43 EST 1993 + Adjust lex.c to recognize # nnn "filename" lines emitted by cpp; +this affects the file names and line numbers in error messages and +the #line lines emitted under -g. + Under -g, arrange for a file that starts with an executable +statement to have the first #line line indicate line 1, rather +than the line number of the END statement ending the main program. + Adjust fc script to run files ending in .F through /lib/cpp. + Fix bug ("Impossible tag 2") in + if (t .eq. (0,2)) write(*,*) 'Bug!' + end + libi77: iio.c: adjust internal formatted reads to treat short records +as though padded with blanks (rather than causing an "off end of record" +error). + +Wed Dec 15 15:19:15 EST 1993 + fc: adjusted for .F files to pass -D and -I options to cpp. + +Fri Dec 17 20:03:38 EST 1993 + Fix botch introduced 28 Nov. 1993 in vax.c; change "version of" +to "version". + +Tue Jan 4 15:39:52 EST 1994 + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Wed Jan 19 08:55:19 EST 1994 + Arrange to accept + integer Nx, Ny, Nz + parameter (Nx = 10, Ny = 20) + parameter (Nz = max(Nx, Ny)) + integer c(Nz) + call foo(c) + end +rather than complaining "Declaration error for c: adjustable dimension +on non-argument". The necessary changes cause some hitherto unfolded +constant expressions to be folded. + Accept BYTE as a synonym for INTEGER*1. + +Thu Jan 27 08:57:40 EST 1994 + Fix botch in changes of 19 Jan. 1994 that broke entry points with +multi-dimensional array arguments that did not appear in the subprogram +argument list and whose leading dimensions depend on arguments. + +Mon Feb 7 09:24:30 EST 1994 + Remove artifact in "fc" script that caused -O to be ignored: + 87c87 + < # lcc ignores -O... + --- + > CFLAGS="$CFLAGS $O" + +Sun Feb 20 17:04:58 EST 1994 + Fix bugs reading .P files for routines with arguments of type +INTEGER*1, INTEGER*8, LOGICAL*2. + Fix glitch in reporting inconsistent arguments for routines involving +character arguments: "arg n" had n too large by the number of +character arguments. + +Tue Feb 22 20:50:08 EST 1994 + Trivial changes to data.c format.c main.c niceprintf.c output.h and +sysdep.h (consistency improvements). + libI77: lread.c: check for NULL return from realloc. + +Fri Feb 25 23:56:08 EST 1994 + output.c, sysdep.h: arrange for -DUSE_DTOA to use dtoa.c and g_fmt.c +for correctly rounded decimal values on IEEE-arithmetic machines +(plus machines with VAX and IBM-mainframe arithmetic). These +routines are available from netlib's fp directory. + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only); the +former uses -DUSE_DTOA to keep 12 from printing as 12.000000000000001. + vax.c: fix wrong arguments to badtag and frchain introduced +28 Nov. 1993. + Source for f2c converted to ANSI/ISO format, with the K&R format +available by compilation with -DKR_headers . + Arrange for (double precision expression) relop (single precision +constant) to retain the single-precision nature of the constant. +Example: + double precision t + if (t .eq. 0.3) ... + +Mon Feb 28 11:40:24 EST 1994 + README updated to reflect a modification just made to netlib's +"dtoa.c from fp": +96a97,105 +> Also add the rule +> +> dtoa.o: dtoa.c +> $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c +> +> (without the initial tab) to the makefile, where IEEE... is one of +> IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's +> arithmetic. See the comments near the start of dtoa.c. +> + +Sat Mar 5 09:41:52 EST 1994 + Complain about functions with the name of a previously declared +common block (which is illegal). + New option -d specifies the directory for output .c and .P files; +f2c.1 and f2c.1t updated. The former undocumented debug option -dnnn +is now -Dnnn. + +Thu Mar 10 10:21:44 EST 1994 + libf77: add #undef min and #undef max lines to s_paus.c s_stop.c +and system_.c; Version.c not changed. + libi77: add -DPad_UDread lines to uio.c and explanation to README: + Some buggy Fortran programs use unformatted direct I/O to write + an incomplete record and later read more from that record than + they have written. For records other than the last, the unwritten + portion of the record reads as binary zeros. The last record is + a special case: attempting to read more from it than was written + gives end-of-file -- which may help one find a bug. Some other + Fortran I/O libraries treat the last record no differently than + others and thus give no help in finding the bug of reading more + than was written. If you wish to have this behavior, compile + uio.c with -DPad_UDread . +Version.c not changed. + +Tue Mar 29 17:27:54 EST 1994 + Adjust make_param so dimensions involving min, max, and other +complicated constant expressions do not provoke error messages +about adjustable dimensions on non-arguments. + Fix botch introduced 19 Jan 1994: "adjustable dimension on non- +argument" messages could cause some things to be freed twice. + +Tue May 10 07:55:12 EDT 1994 + Trivial changes to exec.c, p1output.c, parse_args.c, proc.c, +and putpcc.c: change arguments from + type foo[] +to + type *foo +for consistency with defs.h. For most compilers, this makes no +difference. + +Thu Jun 2 12:18:18 EDT 1994 + Fix bug in handling FORMAT statements that have adjacent character +(or Hollerith) strings: an extraneous \002 appeared between the +strings. + libf77: under -DNO_ONEXIT, arrange for f_exit to be called just +once; previously, upon abnormal termination (including stop statements), +it was called twice. + +Mon Jun 6 15:52:57 EDT 1994 + libf77: Avoid references to SIGABRT and SIGIOT if neither is defined; +Version.c not changed. + libi77: Add cast to definition of errfl() in fio.h; this only matters +on systems with sizeof(int) < sizeof(long). Under -DNON_UNIX_STDIO, +use binary mode for direct formatted files (to avoid any confusion +connected with \n characters). + +Fri Jun 10 16:47:31 EDT 1994 + Fix bug under -A in handling unreferenced (and undeclared) +external arguments in subroutines with multiple entry points. Example: + subroutine m(fcn,futil) + external fcn,futil + call fcn + entry mintio(i1) ! (D_fp)0 rather than (U_fp)0 for futil + end + +Wed Jun 15 10:38:14 EDT 1994 + Allow char(constant expression) function in parameter declarations. +(This was probably broken in the changes of 29 March 1994.) + +Fri Jul 1 23:54:00 EDT 1994 + Minor adjustments to makefile (rule for f2c.1 commented out) and +sysdep.h (#undef KR_headers if __STDC__ is #defined, and base test +for ANSI_Libraries and ANSI_Prototypes on KR_headers rather than +__STDC__); version.c touched but not changed. + libi77: adjust fp.h so local.h is only needed under -DV10; +Version.c not changed. + +Tue Jul 5 03:05:46 EDT 1994 + Fix segmentation fault in + subroutine foo(a,b,k) + data i/1/ + double precision a(k,1) ! sequence error: must precede data + b = a(i,1) + end + libi77: Fix bug (introduced 6 June 1994?) in reopening files under +NON_UNIX_STDIO. + Fix some error messages caused by illegal Fortran. Examples: +* 1. + x(i) = 0 !Missing declaration for array x + call f(x) !Said Impossible storage class 8 in routine mkaddr + end !Now says invalid use of statement function x +* 2. + f = g !No declaration for g; by default it's a real variable + call g !Said invalid class code 2 for function g + end !Now says g cannot be called +* 3. + intrinsic foo !Invalid intrinsic name + a = foo(b) !Said intrcall: bad intrgroup 0 + end !Now just complains about line 1 + +Tue Jul 5 11:14:26 EDT 1994 + Fix glitch in handling erroneous statement function declarations. +Example: + a(j(i) - i) = a(j(i) - i) + 1 ! bad statement function + call foo(a(3)) ! Said Impossible type 0 in routine mktmpn + end ! Now warns that i and j are not used + +Wed Jul 6 17:31:25 EDT 1994 + Tweak test for statement functions that (illegally) call themselves; +f2c will now proceed to check for other errors, rather than bailing +out at the first recursive statement function reference. + Warn about but retain divisions by 0 (instead of calling them +"compiler errors" and quiting). On IEEE machines, this permits + double precision nan, ninf, pinf + nan = 0.d0/0.d0 + pinf = 1.d0/0.d0 + ninf = -1.d0/0.d0 + write(*,*) 'nan, pinf, ninf = ', nan, pinf, ninf + end +to print + nan, pinf, ninf = NaN Infinity -Infinity + libi77: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an +optimization that requires exponents to have 2 digits when 2 digits +suffice. lwrite.c wsfe.c (list and formatted external output): +omit ' ' carriage-control when compiled with -DOMIT_BLANK_CC . +Off-by-one bug fixed in character count for list output of character +strings. Omit '.' in list-directed printing of Nan, Infinity. + +Mon Jul 11 13:05:33 EDT 1994 + src/gram.c updated. + +Tue Jul 12 10:24:42 EDT 1994 + libi77: wrtfmt.c: under G11.4, write 0. as " .0000 " rather +than " .0000E+00". + +Thu Jul 14 17:55:46 EDT 1994 + Fix glitch in changes of 6 July 1994 that could cause erroneous +"division by zero" warnings (or worse). Example: + subroutine foo(a,b) + y = b + a = a / y ! erroneous warning of division by zero + end + +Mon Aug 1 16:45:17 EDT 1994 + libi77: lread.c rsne.c: for benefit of systems with a buggy stdio.h, +declare ungetc when neither KR_headers nor ungetc is #defined. +Version.c not changed. + +Wed Aug 3 01:53:00 EDT 1994 + libi77: lwrite.c (list output): do not insert a newline when +appending an oversize item to an empty line. + +Mon Aug 8 00:51:01 EDT 1994 + Fix bug (introduced 3 Feb. 1993) that, under -i2, kept LOGICAL*2 +variables from appearing in INQUIRE statements. Under -I2, allow +LOGICAL*4 variables to appear in INQUIRE. Fix intrinsic function +LEN so it returns a short value under -i2, a long value otherwise. + exec.c: fix obscure memory fault possible with bizarre (and highly +erroneous) DO-loop syntax. + +Fri Aug 12 10:45:57 EDT 1994 + libi77: fix glitch that kept ERR= (in list- or format-directed input) +from working after a NAMELIST READ. + +Thu Aug 25 13:58:26 EDT 1994 + Suppress -s when -C is specified. + Give full pathname (netlib@research.att.com) for netlib in readme and +src/README. + +Wed Sep 7 22:13:20 EDT 1994 + libi77: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, +INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 in NAMELISTs. + +Fri Sep 16 17:50:18 EDT 1994 + Change name adjustment for reserved words: instead of just appending +"_" (a single underscore), append "_a_" to local variable names to avoid +trouble when a common block is named a reserved word and the same +reserved word is also a local variable name. Example: + common /const/ a,b,c + real const(3) + equivalence (const(1),a) + a = 1.234 + end + Arrange for ichar() to treat characters as unsigned. + libf77: s_cmp.c: treat characters as unsigned in comparisons. +These changes for unsignedness only matter for strings that contain +non-ASCII characters. Now ichar() should always be >= 0. + +Sat Sep 17 11:19:32 EDT 1994 + fc: set rc=$? before exit (to get exit code right in trap code). + +Mon Sep 19 17:49:43 EDT 1994 + libf77: s_paus.c: flush stderr after PAUSE; add #ifdef MSDOS stuff. + libi77: README: point out general need for -DMSDOS under MS-DOS. + +Tue Sep 20 11:42:30 EDT 1994 + Fix bug in comparing identically named common blocks, in which +all components have the same names and types, but at least one is +dimensioned (1) and the other is not dimensioned. Example: + subroutine foo + common /ab/ a + a=1. !!! translated correctly to ab_1.a = (float)1.; + end + subroutine goo + common /ab/ a(1) + a(1)=2. !!! translated erroneously to ab_1.a[0] = (float)2. + end + +Tue Sep 27 23:47:34 EDT 1994 + Fix bug introduced 16 Sept. 1994: don't add _a_ to C keywords +used as external names. In fact, return to earlier behavior of +appending __ to C keywords unless they are used as external names, +in which case they get just one underscore appended. + Adjust constant handling so integer and logical PARAMETERs retain +type information, particularly under -I2. Example: + SUBROUTINE FOO + INTEGER I + INTEGER*1 I1 + INTEGER*2 I2 + INTEGER*4 I4 + LOGICAL L + LOGICAL*1 L1 + LOGICAL*2 L2 + LOGICAL*4 L4 + PARAMETER (L=.FALSE., L1=.FALSE., L2=.FALSE., L4=.FALSE.) + PARAMETER (I=0,I1=0,I2=0,I4=0) + CALL DUMMY(I, I1, I2, I4, L, L1, L2, L4) + END + f2c.1t: Change f\^2c to f2c (omit half-narrow space) in line following +".SH NAME" for benefit of systems that cannot cope with troff commands +in this context. + +Wed Sep 28 12:45:19 EDT 1994 + libf77: s_cmp.c fix glitch in -DKR_headers version introduced +12 days ago. + +Thu Oct 6 09:46:53 EDT 1994 + libi77: util.c: omit f__mvgbt (which is never used). + f2c.h: change "long" to "long int" to facilitate the adjustments +by means of sed described above. Comment out unused typedef of Long. + +Fri Oct 21 18:02:24 EDT 1994 + libf77: add s_catow.c and adjust README to point out that changing +"s_cat.o" to "s_catow.o" in the makefile will permit the target of a +concatenation to appear on its right-hand side (contrary to the +Fortran 77 Standard and at the cost of some run-time efficiency). + +Wed Nov 2 00:03:58 EST 1994 + Adjust -g output to contain only one #line line per statement, +inserting \ before the \n ending lines broken because of their +length [this insertion was recanted 10 Dec. 1994]. This change +accommodates an idiocy in the ANSI/ISO C standard, which leaves +undefined the behavior of #line lines that occur within the arguments +to a macro call. + +Wed Nov 2 14:44:27 EST 1994 + libi77: under compilation with -DALWAYS_FLUSH, flush buffers at +the end of each write statement, and test (via the return from +fflush) for write failures, which can be caught with an ERR= +specifier in the write statement. This extra flushing slows +execution, but can abort execution or alter the flow of control +when a disk fills up. + f2c/src/io.c: Add ERR= test to e_wsle invocation (end of +list-directed external output) to catch write failures when libI77 +is compiled with -DALWAYS_FLUSH. + +Thu Nov 3 10:59:13 EST 1994 + Fix bug in handling dimensions involving certain intrinsic +functions of constant expressions: the expressions, rather than +pointers to them, were passed. Example: + subroutine subtest(n,x) + real x(2**n,n) ! pow_ii(2,n) was called; now it's pow_ii(&c__2,n) + x(2,2)=3. + end + +Tue Nov 8 23:56:30 EST 1994 + malloc.c: remove assumption that only malloc calls sbrk. This +appears to make malloc.c useful on RS6000 systems. + +Sun Nov 13 13:09:38 EST 1994 + Turn off constant folding of integers used in floating-point +expressions, so the assignment in + subroutine foo(x) + double precision x + x = x*1000000*500000 + end +is rendered as + *x = *x * 1000000 * 500000; +rather than as + *x *= 1783793664; + +Sat Dec 10 16:31:40 EST 1994 + Supply a better error message (than "Impossible type 14") for + subroutine foo + foo = 3 + end + Under -g, convey name of included files to #line lines. + Recant insertion of \ introduced (under -g) 2 Nov. 1994. + +Thu Dec 15 14:33:55 EST 1994 + New command-line option -Idir specifies directories in which to +look for non-absolute include files (after looking in the directory +of the current input file). There can be several -Idir options, each +specifying one directory. All -Idir options are considered, from +left to right, until a suitably named file is found. The -I2 and -I4 +command-line options have precedence, so directories named 2 or 4 +must be spelled by some circumlocation, such as -I./2 . + f2c.ps updated to mention the new -Idir option, correct a typo, +and bring the man page at the end up to date. + lex.c: fix bug in reading line numbers in #line lines. + fc updated to pass -Idir options to f2c. + +Thu Dec 29 09:48:03 EST 1994 + Fix bug (e.g., addressing fault) in diagnosing inconsistency in +the type of function eta in the following example: + function foo(c1,c2) + double complex foo,c1,c2 + double precision eta + foo = eta(c1,c2) + end + function eta(c1,c2) + double complex eta,c1,c2 + eta = c1*c2 + end + +Mon Jan 2 13:27:26 EST 1995 + Retain casts for SNGL (or FLOAT) that were erroneously optimized +away. Example: + subroutine foo(a,b) + double precision a,b + a = float(b) ! now rendered as *a = (real) (*b); + end + Use float (rather than double) temporaries in certain expressions +of type complex. Example: the temporary for sngl(b) in + complex a + double precision b + a = sngl(b) - (3.,4.) +is now of type float. + +Fri Jan 6 00:00:27 EST 1995 + Adjust intrinsic function cmplx to act as dcmplx (returning +double complex rather than complex) if either of its args is of +type double precision. The double temporaries used prior to 2 Jan. +1995 previously gave it this same behavior. + +Thu Jan 12 12:31:35 EST 1995 + Adjust -krd to use double temporaries in some calculations of +type complex. + libf77: pow_[dhiqrz][hiq].c: adjust x**i to work on machines +that sign-extend right shifts when i is the most negative integer. + +Wed Jan 25 00:14:42 EST 1995 + Fix memory fault in handling overlapping initializations in + block data + common /zot/ d + double precision d(3) + character*6 v(4) + real r(2) + equivalence (d(3),r(1)), (d(1),v(1)) + data v/'abcdef', 'ghijkl', 'mnopqr', 'stuvwx'/ + data r/4.,5./ + end + names.c: add "far", "huge", "near" to c_keywords (causing them +to have __ appended when used as local variables). + libf77: add s_copyow.c, an alternative to s_copy.c for handling +(illegal) character assignments where the right- and left-hand +sides overlap, as in a(2:4) = a(1:3). + +Thu Jan 26 14:21:19 EST 1995 + libf77: roll s_catow.c and s_copyow.c into s_cat.c and s_copy.c, +respectively, allowing the left-hand side of a character assignment +to appear on its right-hand side unless s_cat.c and s_copy.c are +compiled with -DNO_OVERWRITE (which is a bit more efficient). +Fortran 77 forbids the left-hand side from participating in the +right-hand side (of a character assignment), but Fortran 90 allows it. + libi77: wref.c: fix glitch in printing the exponent of 0 when +GOOD_SPRINTF_EXPONENT is not #defined. + +Fri Jan 27 12:25:41 EST 1995 + Under -C++ -ec (or -C++ -e1c), surround struct declarations with + #ifdef __cplusplus + extern "C" { + #endif +and + #ifdef __cplusplus + } + #endif +(This isn't needed with cfront, but apparently is necessary with +some other C++ compilers.) + libf77: minor tweak to s_copy.c: copy forward whenever possible +(for better cache behavior). + +Wed Feb 1 10:26:12 EST 1995 + Complain about parameter statements that assign values to dummy +arguments, as in + subroutine foo(x) + parameter(x = 3.4) + end + +Sat Feb 4 20:22:02 EST 1995 + fc: omit "lib=/lib/num/lib.lo". + +Wed Feb 8 08:41:14 EST 1995 + Minor changes to exec.c, putpcc.c to avoid "bad tag" or "error +in frexpr" with certain invalid Fortran. + +Sat Feb 11 08:57:39 EST 1995 + Complain about integer overflows, both in simplifying integer +expressions, and in converting integers from decimal to binary. + Fix a memory fault in putcx1() associated with invalid input. + +Thu Feb 23 11:20:59 EST 1995 + Omit MAXTOKENLEN; realloc token if necessary (to handle very long +strings). + +Fri Feb 24 11:02:00 EST 1995 + libi77: iio.c: z_getc: insert (unsigned char *) to allow internal +reading of characters with high-bit set (on machines that sign-extend +characters). + +Tue Mar 14 18:22:42 EST 1995 + Fix glitch (in io.c) in handling 0-length strings in format +statements, as in + write(*,10) + 10 format(' ab','','cd') + libi77: lread.c and rsfe.c: adjust s_rsle and s_rsfe to check for +end-of-file (to prevent infinite loops with empty read statements). + +Wed Mar 22 10:01:46 EST 1995 + f2c.ps: adjust discussion of -P on p. 7 to reflect a change made +3 Feb. 1993: -P no longer implies -A. + +Fri Apr 21 18:35:00 EDT 1995 + fc script: remove absolute paths (since PATH specifies only standard +places). On most systems, it's still necessary to adjust the PATH +assignment at the start of fc to fit the local conventions. + +Fri May 26 10:03:17 EDT 1995 + fc script: add recognition of -P and .P files. + libi77: iio.c: z_wnew: fix bug in handling T format items in internal +writes whose last item is written to an earlier position than some +previous item. + +Wed May 31 11:39:48 EDT 1995 + libf77: added subroutine exit(rc) (with integer return code rc), +which works like a stop statement but supplies rc as the program's +return code. + +Fri Jun 2 11:56:50 EDT 1995 + Fix memory fault in + parameter (x=2.) + data x /2./ + end +This now elicits two error messages; the second ("too many +initializers"), though not desirable, seems hard to eliminate +without considerable hassle. + +Mon Jul 17 23:24:20 EDT 1995 + Fix botch in simplifying constants in certain complex +expressions. Example: + subroutine foo(s,z) + double complex z + double precision s, M, P + parameter ( M = 100.d0, P = 2.d0 ) + z = M * M / s * dcmplx (1.d0, P/M) +*** The imaginary part of z was miscomputed *** + end + Under -ext, complain about nonintegral dimensions. + +Fri Jul 21 11:18:36 EDT 1995 + Fix glitch on line 159 of init.c: change + "(shortlogical *)0)", +to + "(shortlogical *)0", +This affects multiple entry points when some but not all have +arguments of type logical*2. + libi77: adjust lwrite.c, wref.c, wrtfmt.c so compiling with +-DWANT_LEAD_0 causes formatted writes of floating-point numbers of +magnitude < 1 to have an explicit 0 before the decimal point (if the +field-width permits it). Note that the Fortran 77 Standard leaves it +up to the implementation whether to supply these superfluous zeros. + +Tue Aug 1 09:25:56 EDT 1995 + Permit real (or double precision) parameters in dimension expressions. + +Mon Aug 7 08:04:00 EDT 1995 + Append "_eqv" rather than just "_" to names that that appear in +EQUIVALENCE statements as well as structs in f2c.h (to avoid a +conflict when these names also name common blocks). + +Tue Aug 8 12:49:02 EDT 1995 + Modify yesterday's change: merge st_fields with c_keywords, to +cope with equivalences introduced to permit initializing numeric +variables with character data. DATA statements causing these +equivalences can appear after executable statements, so the only +safe course is to rename all local variable with names in the +former st_fields list. This has the unfortunate side effect that +the common local variable "i" will henceforth be renamed "i__". + +Wed Aug 30 00:19:32 EDT 1995 + libf77: add F77_aloc, now used in s_cat and system_ (to allocate +memory and check for failure in so doing). + libi77: improve MSDOS logic in backspace.c. + +Wed Sep 6 09:06:19 EDT 1995 + libf77: Fix return type of system_ (integer) under -DKR_headers. + libi77: Move some f_init calls around for people who do not use +libF77's main(); now open and namelist read statements that are the +first I/O statements executed should work right in that context. +Adjust namelist input to treat a subscripted name whose subscripts do +not involve colons similarly to the name without a subscript: accept +several values, stored in successive elements starting at the +indicated subscript. Adjust namelist output to quote character +strings (avoiding confusion with arrays of character strings). + +Thu Sep 7 00:36:04 EDT 1995 + Fix glitch in integer*8 exponentiation function: it's pow_qq, not +pow_qi. + libi77: fix some bugs with -DAllow_TYQUAD (for integer*8); when +looking for the &name that starts NAMELIST input, treat lines whose +first nonblank character is something other than &, $, or ? as +comment lines (i.e., ignore them), unless rsne.c is compiled with +-DNo_Namelist_Comments. + +Thu Sep 7 09:05:40 EDT 1995 + libi77: rdfmt.c: one more tweak for -DAllow_TYQUAD. + +Tue Sep 19 00:03:02 EDT 1995 + Adjust handling of floating-point subscript bounds (a questionable +f2c extension) so subscripts in the generated C are of integral type. + Move #define of roundup to proc.c (where its use is commented out); +version.c left at 19950918. + +Wed Sep 20 17:24:19 EDT 1995 + Fix bug in handling ichar() under -h. + +Thu Oct 5 07:52:56 EDT 1995 + libi77: wrtfmt.c: fix bug with t editing (f__cursor was not always +zeroed in mv_cur). + +Tue Oct 10 10:47:54 EDT 1995 + Under -ext, warn about X**-Y and X**+Y. Following the original f77, +f2c treats these as X**(-Y) and X**(+Y), respectively. (They are not +allowed by the official Fortran 77 Standard.) Some Fortran compilers +give a bizarre interpretation to larger contexts, making multiplication +noncommutative: they treat X**-Y*Z as X**(-Y*Z) rather than X**(-Y)*Z, +which, following the rules of Fortran 77, is the same as (X**(-Y))*Z. + +Wed Oct 11 13:27:05 EDT 1995 + libi77: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c +to err.c. This should work around a problem with buggy loaders and +sometimes leads to smaller executable programs. + +Sat Oct 21 23:54:22 EDT 1995 + Under -h, fix bug in the treatment of ichar('0') in arithmetic +expressions. + Demote to -dneg (a new command-line option not mentioned in the +man page) imitation of the original f77's treatment of unary minus +applied to a REAL operand (yielding a DOUBLE PRECISION result). +Previously this imitation (which was present for debugging) occurred +under (the default) -!R. It is still suppressed by -R. + +Tue Nov 7 23:52:57 EST 1995 + Adjust assigned GOTOs to honor SAVE declarations. + Add comments about ranlib to lib[FI]77/README and makefile. + +Tue Dec 19 22:54:06 EST 1995 + libf77: s_cat.c: fix bug when 2nd or later arg overlaps lhs. + +Tue Jan 2 17:54:00 EST 1996 + libi77: rdfmt.c: move #include "ctype.h" up before "stdlib.h"; no +change to Version.c. + +Sun Feb 25 22:20:20 EST 1996 + Adjust expr.c to permit raising the integer constants 1 and -1 to +negative constant integral powers. + Avoid faulting when -T and -d are not followed by a directory name +(immediately, without intervening spaces). + +Wed Feb 28 12:49:01 EST 1996 + Fix a glitch in handling complex parameters assigned a "wrong" type. +Example: + complex d, z + parameter(z = (0d0,0d0)) + data d/z/ ! elicited "non-constant initializer" + call foo(d) + end + +Thu Feb 29 00:53:12 EST 1996 + Fix bug in handling character parameters assigned a char() value. +Example: + character*2 b,c + character*1 esc + parameter(esc = char(27)) + integer i + data (b(i:i),i=1,2)/esc,'a'/ + data (c(i:i),i=1,2)/esc,'b'/ ! memory fault + call foo(b,c) + end + +Fri Mar 1 23:44:51 EST 1996 + Fix glitch in evaluating .EQ. and .NE. when both operands are +logical constants (.TRUE. or .FALSE.). + +Fri Mar 15 17:29:54 EST 1996 + libi77: lread.c, rsfe.c: honor END= in READ stmts with empty iolist. + +Tue Mar 19 23:08:32 EST 1996 + lex.c: arrange for a "statement" consisting of a single short bogus +keyword to elicit an error message showing the whole keyword. The +error message formerly omitted the last letter of the bad keyword. + libf77: s_cat.c: supply missing break after overlap detection. + +Mon May 13 23:35:26 EDT 1996 + Recognize Fortran 90's /= as a synonym for .NE.. (<> remains a +synonym for .NE..) + Emit an empty int function of no arguments to supply an external +name to named block data subprograms (so they can be called somewhere +to force them to be loaded from a library). + Fix bug (memory fault) in handling the following illegal Fortran: + parameter(i=1) + equivalence(i,j) + end + Treat cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for +the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, +respectively, unless -cd is specified. + Recognize the Fortran 90 bit-manipulation intrinsics btest, iand, +ibclr, ibits, ibset, ieor, ior, ishft, and ishftc, unless -i90 is +specified. Note that iand, ieor, and ior are thus now synonyms for +"and", "xor", and "or", respectively. + Add three macros (bit_test, bit_clear, bit_set) to f2c.h for use +with btest, ibclr, and ibset, respectively. Add new functions +[lq]bit_bits, [lq]bit_shift, and [lq]_bit_cshift to libF77 for +use with ibits, ishft, and ishftc, respectively. + Add integer function ftell(unit) (returning -1 on error) and +subroutine fseek(unit, offset, whence, *) to libI77 (with branch to +label * on error). + +Tue May 14 23:21:12 EDT 1996 + Fix glitch (possible memory fault, or worse) in handling multiple +entry points with names over 28 characters long. + +Mon Jun 10 01:20:16 EDT 1996 + Update netlib E-mail and ftp addresses in f2c/readme and +f2c/src/readme (which are different files) -- to reflect the upcoming +breakup of AT&T. + libf77: trivial tweaks to F77_aloc.c and system_.c; Version.c not +changed. + libi77: Adjust rsli.c and lread.c so internal list input with too +few items in the input string will honor end= . + +Mon Jun 10 22:59:57 EDT 1996 + Add Bits_per_Byte to sysdep.h and adjust definition of Table_size +to depend on Bits_per_Byte (forcing Table_size to be a power of 2); in +lex.c, change "comstart[c & 0xfff]" to "comstart[c & (Table_size-1)]" +to avoid an out-of-range subscript on end-of-file. + +Wed Jun 12 00:24:28 EDT 1996 + Fix bug in output.c (dereferencing a freed pointer) revealed in + print * !np in out_call in output.c clobbered by free + end !during out_expr. + +Wed Jun 19 08:12:47 EDT 1996 + f2c.h: add types uinteger, ulongint (for libF77); add qbit_clear +and qbit_set macros (in a commented-out section) for integer*8. + For integer*8, use qbit_clear and qbit_set for ibclr and ibset. + libf77: add casts to unsigned in [lq]bitshft.c. + +Thu Jun 20 13:30:43 EDT 1996 + Complain at character*(*) in common (rather than faulting). + Fix bug in recognizing hex constants that start with "16#" (e.g., +16#1234abcd, which is a synonym for z'1234abcd'). + Fix bugs in constant folding of expressions involving btest, ibclr, +and ibset. + Fix bug in constant folding of rshift(16#80000000, -31) (on a 32-bit +machine; more generally, the bug was in constant folding of +rshift(ibset(0,NBITS-1), 1-NBITS) when f2c runs on a machine with +long ints having NBITS bits. + +Mon Jun 24 07:58:53 EDT 1996 + Adjust struct Literal and newlabel() function to accommodate huge +source files (with more than 32767 newlabel() invocations). + Omit .c file when the .f file has a missing final end statement. + +Wed Jun 26 14:00:02 EDT 1996 + libi77: Add discussion of MXUNIT (highest allowed Fortran unit number) +to libI77/README. + +Fri Jun 28 14:16:11 EDT 1996 + Fix glitch with -onetrip: the temporary variable used for nonconstant +initial loop variable values was recycled too soon. Example: + do i = j+1, k + call foo(i+1) ! temp for j+1 was reused here + enddo + end + +Tue Jul 2 16:11:27 EDT 1996 + formatdata.c: add a 0 to the end of the basetype array (for TYBLANK) +(an omission that was harmless on most machines). + expr.c: fix a dereference of NULL that was only possible with buggy +input, such as + subroutine $sub(s) ! the '$' is erroneous + character s*(*) + s(1:) = ' ' + end + +Sat Jul 6 00:44:56 EDT 1996 + Fix glitch in the intrinsic "real" function when applied to a +complex (or double complex) variable and passed as an argument to +some intrinsic functions. Example: + complex a + b = sqrt(a) + end + Fix glitch (only visible if you do not use f2c's malloc and the +malloc you do use is defective in the sense that malloc(0) returns 0) +in handling include files that end with another include (perhaps +followed by comments). + Fix glitch with character*(*) arguments named "h" and "i" when +the body of the subroutine invokes the intrinsic LEN function. + Arrange that after a previous "f2c -P foo.f" has produced foo.P, +running "f2c foo.P foo.f" will produce valid C when foo.f contains + call sub('1234') + end + subroutine sub(msg) + end +Specifically, the length argument in "call sub" is now suppressed. +With or without foo.P, it is also now suppressed when the order of +subprograms in file foo.f is reversed: + subroutine sub(msg) + end + call sub('1234') + end + Adjust copyright notices to reflect AT&T breakup. + +Wed Jul 10 09:25:49 EDT 1996 + Fix bug (possible memory fault) in handling erroneously placed +and inconsistent declarations. Example that faulted: + character*1 w(8) + call foo(w) + end + subroutine foo(m) + data h /0.5/ + integer m(2) ! should be before data + end + Fix bug (possible fault) in handling illegal "if" constructions. +Example (that faulted): + subroutine foo(i,j) + if (i) then ! bug: i is integer, not logical + else if (j) then ! bug: j is integer, not logical + endif + end + Fix glitch with character*(*) argument named "ret_len" to a +character*(*) function. + +Wed Jul 10 23:04:16 EDT 1996 + Fix more glitches in the intrinsic "real" function when applied to a +complex (or double complex) variable and passed as an argument to +some intrinsic functions. Example: + complex a, b + r = sqrt(real(conjg(a))) + sqrt(real(a*b)) + end + +Thu Jul 11 17:27:16 EDT 1996 + Fix a memory fault associated with complicated, illegal input. +Example: + subroutine goo + character a + call foo(a) ! inconsistent with subsequent def and call + end + subroutine foo(a) + end + call foo(a) + end + +Wed Jul 17 19:18:28 EDT 1996 + Fix yet another case of intrinsic "real" applied to a complex +argument. Example: + complex a(3) + x = sqrt(real(a(2))) ! gave error message about bad tag + end + +Mon Aug 26 11:28:57 EDT 1996 + Tweak sysdep.c for non-Unix systems in which process ID's can be +over 5 digits long. + +Tue Aug 27 08:31:32 EDT 1996 + Adjust the ishft intrinsic to use unsigned right shifts. (Previously, +a negative constant second operand resulted in a possibly signed shift.) + +Thu Sep 12 14:04:07 EDT 1996 + equiv.c: fix glitch with -DKR_headers. + libi77: fmtlib.c: fix bug in printing the most negative integer. + +Fri Sep 13 08:54:40 EDT 1996 + Diagnose some illegal appearances of substring notation. + +Tue Sep 17 17:48:09 EDT 1996 + Fix fault in handling some complex parameters. Example: + subroutine foo(a) + double complex a, b + parameter(b = (0,1)) + a = b ! f2c faulted here + end + +Thu Sep 26 07:47:10 EDT 1996 + libi77: fmt.h: for formatted writes of negative integer*1 values, +make ic signed on ANSI systems. If formatted writes of integer*1 +values trouble you when using a K&R C compiler, switch to an ANSI +compiler or use a compiler flag that makes characters signed. + +Tue Oct 1 14:41:36 EDT 1996 + Give a better error message when dummy arguments appear in data +statements. + +Thu Oct 17 13:37:22 EDT 1996 + Fix bug in typechecking arguments to character and complex (or +double complex) functions; the bug could cause length arguments +for character arguments to be omitted on invocations appearing +textually after the first invocation. For example, in + subroutine foo + character c + complex zot + call goo(zot(c), zot(c)) + end +the length was omitted from the second invocation of zot, and +there was an erroneous error message about inconsistent calling +sequences. + +Wed Dec 4 13:59:14 EST 1996 + Fix bug revealed by + subroutine test(cdum,rdum) + complex cdum + rdum=cos(real(cdum)) ! "Unexpected tag 3 in opconv_fudge" + end + Fix glitch in parsing "DO 10 D0 = 1, 10". + Fix glitch in parsing + real*8 x + real*8 x ! erroneous "incompatible type" message + call foo(x) + end + +Mon Dec 9 23:15:02 EST 1996 + Fix glitch in parameter adjustments for arrays whose lower +bound depends on a scalar argument. Example: + subroutine bug(p,z,m,n) + integer z(*),m,n + double precision p(z(m):z(m) + n) ! p_offset botched + call foo(p(0), p(n)) + end + libi77: complain about non-positive rec= in direct read and write +statements. + libf77: trivial adjustments; Version.c not changed. + +Wed Feb 12 00:18:03 EST 1997 + output.c: fix (seldom problematic) glitch in out_call: put parens +around the ... in a test of the form "if (q->tag == TADDR && ...)". + vax.c: fix bug revealed in the "psi_offset =" assignment in the +following example: + subroutine foo(psi,m) + integer z(100),m + common /a/ z + double precision psi(z(m):z(m) + 10) + call foo(m+1, psi(0),psi(10)) + end + +Mon Feb 24 23:44:54 EST 1997 + For consistency with f2c's current treatment of adjacent character +strings in FORMAT statements, recognize a Hollerith string following +a string (and merge adjacent strings in FORMAT statements). + +Wed Feb 26 13:41:11 EST 1997 + New libf2c.zip, a combination of the libf77 and libi77 bundles (and +available only by ftp). + libf77: adjust functions with a complex output argument to permit +aliasing it with input arguments. (For now, at least, this is just +for possible benefit of g77.) + libi77: tweak to ftell_.c for systems with strange definitions of +SEEK_SET, etc. + +Tue Apr 8 20:57:08 EDT 1997 + libf77: [cz]_div.c: tweaks invisible on most systems (that may +improve things slightly with optimized compilation on systems that use +gratuitous extra precision). + libi77: fmt.c: adjust to complain at missing numbers in formats +(but still treat missing ".nnn" as ".0"). + +Fri Apr 11 14:05:57 EDT 1997 + libi77: err.c: attempt to make stderr line buffered rather than +fully buffered. (Buffering is needed for format items T and TR.) + +Thu Apr 17 22:42:43 EDT 1997 + libf77: add F77_aloc.o to makefile (and makefile.u in libf2c.zip). + +Fri Apr 25 19:32:09 EDT 1997 + libf77: add [de]time_.c (which may give trouble on some systems). + +Tue May 27 09:18:52 EDT 1997 + libi77: ftell_.c: fix typo that caused the third argument to be +treated as 2 on some systems. + +Mon Jun 9 00:04:37 EDT 1997 + libi77 (and libf2c.zip): adjust include order in err.c lread.c wref.c +rdfmt.c to include fmt.h (etc.) after system includes. Version.c not +changed. + +Mon Jul 21 16:04:54 EDT 1997 + proc.c: fix glitch in logic for "nonpositive dimension" message. + libi77: inquire.c: always include string.h (for possible use with +-DNON_UNIX_STDIO); Version.c not changed. + +Thu Jul 24 17:11:23 EDT 1997 + Tweak "Notice" to reflect the AT&T breakup -- we missed it when +updating the copyright notices in the source files last summer. + Adjust src/makefile so malloc.o is not used by default, but can +be specified with "make MALLOC=malloc.o". + Add comments to src/README about the "CRAY" T3E. + +Tue Aug 5 14:53:25 EDT 1997 + Add definition of calloc to malloc.c; this makes f2c's malloc +work on some systems where trouble hitherto arose because references +to calloc brought in the system's malloc. (On sensible systems, +calloc is defined separately from malloc. To avoid confusion on +other systems, f2c/malloc.c now defines calloc.) + libi77: lread.c: adjust to accord with a change to the Fortran 8X +draft (in 1990 or 1991) that rescinded permission to elide quote marks +in namelist input of character data; to get the old behavior, compile +with F8X_NML_ELIDE_QUOTES #defined. wrtfmt.o: wrt_G: tweak to print +the right number of 0's for zero under G format. + +Sat Aug 16 05:45:32 EDT 1997 + libi77: iio.c: fix bug in internal writes to an array of character +strings that sometimes caused one more array element than required by +the format to be blank-filled. Example: format(1x). + +Wed Sep 17 00:39:29 EDT 1997 + libi77: fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines +with 64-bit pointers and 32-bit ints that did not 64-bit align +struct syl (e.g., Linux on the DEC Alpha). This change should be +invisible on other machines. + +Sun Sep 21 22:05:19 EDT 1997 + libf77: [de]time_.c (Unix systems only): change return type to double. + +Thu Dec 4 22:10:09 EST 1997 + Fix bug with handling large blocks of comments (over 4k); parts of the +second and subsequent blocks were likely to be lost (not copied into +comments in the resulting C). Allow comment lines to be longer before +breaking them. + +Mon Jan 19 17:19:27 EST 1998 + makefile: change the rule for making gram.c to one for making gram1.c; +henceforth, asking netlib to "send all from f2c/src" will bring you a +working gram.c. Nowadays there are simply too many broken versions of +yacc floating around. + libi77: backspace.c: for b->ufmt==0, change sizeof(int) to +sizeof(uiolen). On machines where this would make a difference, it is +best for portability to compile libI77 with -DUIOLEN_int, which will +render the change invisible. + +Tue Feb 24 08:35:33 EST 1998 + makefile: remove gram.c from the "make clean" rule. + +Wed Feb 25 08:29:39 EST 1998 + makefile: change CFLAGS assignment to -O; add "veryclean" rule. + +Wed Mar 4 13:13:21 EST 1998 + libi77: open.c: fix glitch in comparing file names under +-DNON_UNIX_STDIO. + +Mon Mar 9 23:56:56 EST 1998 + putpcc.c: omit an unnecessary temporary variable in computing +(expr)**3. + libf77, libi77: minor tweaks to make some C++ compilers happy; +Version.c not changed. + +Wed Mar 18 18:08:47 EST 1998 + libf77: minor tweaks to [ed]time_.c; Version.c not changed. + libi77: endfile.c, open.c: acquire temporary files from tmpfile(), +unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). +New buffering scheme independent of NON_UNIX_STDIO for handling T +format items. Now -DNON_UNIX_STDIO is no longer be necessary for +Linux, and libf2c no longer causes stderr to be buffered -- the former +setbuf or setvbuf call for stderr was to make T format items work. +open.c: use the Posix access() function to check existence or +nonexistence of files, except under -DNON_POSIX_STDIO, where trial +fopen calls are used. In open.c, fix botch in changes of 19980304. + libf2c.zip: the PC makefiles are now set for NT/W95, with comments +about changes for DOS. + +Fri Apr 3 17:22:12 EST 1998 + Adjust fix of 19960913 to again permit substring notation on +character variables in data statements. + +Sun Apr 5 19:26:50 EDT 1998 + libi77: wsfe.c: make $ format item work: this was lost in the changes +of 17 March 1998. + +Sat May 16 19:08:51 EDT 1998 + Adjust output of ftnlen constants: rather than appending L, +prepend (ftnlen). This should make the resulting C more portable, +e.g., to systems (such as DEC Alpha Unix systems) on which long +may be longer than ftnlen. + Adjust -r so it also casts REAL expressions passed to intrinsic +functions to REAL. + +Wed May 27 16:02:35 EDT 1998 + libf2c.zip: tweak description of compiling libf2c for INTEGER*8 +to accord with makefile.u rather than libF77/makefile. + +Thu May 28 22:45:59 EDT 1998 + libi77: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: +set f__curunit sooner so various error messages will correctly +identify the I/O unit involved. + libf2c.zip: above, plus tweaks to PC makefiles: for some purposes, +it's still best to compile with -DMSDOS (even for use with NT). + +Thu Jun 18 01:22:52 EDT 1998 + libi77: lread.c: modified so floating-point numbers (containing +either a decimal point or an exponent field) are treated as errors +when they appear as list input for integer data. Compile lread.c with +-DALLOW_FLOAT_IN_INTEGER_LIST_INPUT to restore the old behavior. + +Mon Aug 31 10:38:54 EDT 1998 + formatdata.c: if possible, and assuming doubles must be aligned on +double boundaries, use existing holes in DATA for common blocks to +force alignment of the block. For example, + block data + common /abc/ a, b + double precision a + integer b(2) + data b(2)/1/ + end +used to generate + struct { + integer fill_1[3]; + integer e_2; + doublereal e_3; + } abc_ = { {0}, 1, 0. }; +and now generates + struct { + doublereal fill_1[1]; + integer fill_2[1]; + integer e_3; + } abc_ = { {0}, {0}, 1 }; +In the old generated C, e_3 was added to force alignment; in the new C, +fill_1 does this job. + +Mon Sep 7 19:48:51 EDT 1998 + libi77: move e_wdfe from sfe.c to dfe.c, where it was originally. +Why did it ever move to sfe.c? + +Tue Sep 8 10:22:50 EDT 1998 + Treat dreal as a synonym for dble unless -cd is specified on the +command line. + +Sun Sep 13 22:23:41 EDT 1998 + format.c: fix bug in writing prototypes under f2c -A ... *.P: +under some circumstances involving external functions with no known +type, a null pointer was passed to printf. + +Tue Oct 20 23:25:54 EDT 1998 + Comments added to libf2c/README and libF77/README, pointing out +the need to modify signal1.h on some systems. + +Wed Feb 10 22:59:52 EST 1999 + defs.h lex.c: permit long names (up to at least roughly +MAX_SHARPLINE_LEN = 1000 characters long) in #line lines (which only +matters under -g). + fc: add -U option; recognize .so files. + +Sat Feb 13 10:18:27 EST 1999 + libf2c: endfile.c, lread.c, signal1.h0: minor tweaks to make some +(C++) compilers happier; f77_aloc.c: make exit_() visible to C++ +compilers. Version strings not changed. + +Thu Mar 11 23:14:02 EST 1999 + Modify f2c (exec.c, expr.c) to diagnose incorrect mixing of types +when (f2c extended) intrinsic functions are involved, as in +(not(17) .and. 4). Catching this in the first executable statement +is a bit tricky, as some checking must be postponed until all statement +function declarations have been parsed. Thus there is a chance of +today's changes introducing bugs under (let us hope) unusual conditions. + +Sun Mar 28 13:17:44 EST 1999 + lex.c: tweak to get the file name right in error messages caused +by statements just after a # nnn "filename" line emitted by the C +preprocessor. (The trouble is that the line following the # nnn line +must be read to see if it is a continuation of the stuff that preceded +the # nnn line.) When # nnn "filename" lines appear among the lines +for a Fortran statement, the filename reported in an error message for +the statement should now be the file that was current when the first +line of the statement was read. + +Sun May 2 22:38:25 EDT 1999 + libf77, libi77, libf2c.zip: make getenv_() more portable (call +getenv() rather than knowing about char **environ); adjust some +complex intrinsics to work with overlapping arguments (caused by +inappropriate use of equivalence); open.c: get "external" versus +"internal" right in the error message if a file cannot be opened; +err.c: cast a pointer difference to (int) for %d; rdfmt.c: omit +fixed-length buffer that could be overwritten by formats Inn or Lnn +with nn > 83. + +Mon May 3 13:14:07 EDT 1999 + "Invisible" changes to omit a few compiler warnings in f2c and +libf2c; two new casts in libf2c/open.c that matter with 64-bit longs, +and one more tweak (libf2c/c_log.c) for pathological equivalences. + Minor update to "fc" script: new -L flag and comment correction. + +Fri Jun 18 02:33:08 EDT 1999 + libf2c.zip: rename backspace.c backspac.c, and fix a glitch in it +-- b->ufd may change in t_runc(). (For now, it's still backspace.c +in the libi77 bundle.) + +Sun Jun 27 22:05:47 EDT 1999 + libf2c.zip, libi77: rsne.c: fix bug in namelist input: a misplaced +increment could cause wrong array elements to be assigned; e.g., +"&input k(5)=10*1 &end" assigned k(5) and k(15 .. 23). + +Tue Sep 7 14:10:24 EDT 1999 + f2c.h, libf2c/f2c.h0, libf2c/README: minor tweaks so a simple +sed command converts f2c.h == libf2c/f2c.h0 to a form suitable for +machines with 8-byte longs and doubles, 4-byte int's and floats, +while working with a forthcoming (ill-advised) update to the C +standard that outlaws plain "unsigned". + f2c.h, libf2c/f2c.h0: change "if 0" to "#ifdef INTEGER_STAR_8". + libf77, libf2c.zip: [cz]_div.c and README: arrange for compilation +under -DIEEE_COMPLEX_DIVIDE to make these routines avoid calling sig_die +when the denominator of a complex or double complex division vanishes; +instead, they return pairs of NaNs or Infinities, depending whether the +numerator also vanishes or not. + +Tue Oct 5 23:50:14 EDT 1999 + formatdata.c, io.c, output.c, sysdep.c: adjust to make format +strings legal when they contain 8-bit characters with the high bit on. +(For many C compilers, this is not necessary, but it the ANSI/ISO C +standard does not require this to work.) + libf2c.zip: tweak README and correct xsum0.out. + +Mon Oct 25 17:30:54 EDT 1999 + io.c: fix glitch introduced in the previous change (19991005) that +caused format(' %') to print "%%" rather than "%". + +Mon Nov 15 12:10:35 EST 1999 + libf2c.zip: fix bug with the sequence backspace(n); endfile(n); +rewind(n); read(n). Supply missing (long) casts in a couple of places +where they matter when size(ftnint) == sizeof(int) < sizeof(long). + +Tue Jan 18 19:22:24 EST 2000 + Arrange for parameter statements involving min(...) and max(...) +functions of three or more arguments to work. + Warn about text after "end" (rather than reporting a syntax error +with a surprising line number). + Accept preprocessor line numbers of the form "# 1234" (possibly +with trailing blanks). + Accept a comma after write(...) and before a list of things to write. + +Fri Jan 21 17:26:27 EST 2000 + Minor updates to make compiling Win32 console binaries easier. A +side effect is that the MSDOS restriction of only one Fortran file +per invocation is lifted (and "f2c *.f") works. + +Tue Feb 1 18:38:32 EST 2000 + f2c/src/tokdefs.h added (to help people on non-Unix systems -- the +makefile has always had a rule for generating tokdefs.h). + +Fri Mar 10 18:48:17 EST 2000 + libf77, libf2c.zip: z_log.c: the real part of the double complex log +of numbers near, e.g., (+-1,eps) with |eps| small is now more accurate. +For example if z = (1,1d-7), then "write(*,*) z" now writes +"(5.E-15,1.E-07" rather than the previous "(4.88498131E-15,1.E-07)". + +Thu Apr 20 13:02:54 EDT 2000 + libf77, libi77, libf2c.zip: s_cat.c, rsne.c, xwsne.c: fix type +errors that only matter if sizeof(ftnint) != sizeof(ftnlen). + +Tue May 30 23:36:18 EDT 2000 + expr.c: adjust subcheck() to use a temporary variable of type TYLONG +rather than TYSHORT under -C -I2. + +Wed May 31 08:48:03 EDT 2000 + Simplify yesterday's adjustment; today's change should be invisible. + +Tue Jul 4 22:52:21 EDT 2000 + misc.c, function "addressable": fix fault with "f2c -I2 foo.f" when +foo.f consists of the 4 lines + subroutine foo(c) + character*(*) c + i = min(len(c),23) + end + Sundry files: tweaks for portability, e.g., for compilation by overly +fastidious C++ compilers; "false" and "true" now treated as C keywords +(so they get two underscores appended). + libf77, libi77, libf2c.zip: "invisible" adjustments to permit +compilation by C++ compilers; version numbers not changed. + +Thu Jul 6 23:46:07 EDT 2000 + Various files: tweaks to banish more compiler warnings. + lib?77, libf2c.zip/makefile.u: add "|| true" to ranlib invocations. + Thanks to Nelson H. F. Beebe for messages leading to these changes +(and to many of the ones two days ago). + xsum.c: tweak include order. + +Fri Jul 7 18:01:25 EDT 2000 + fc: accept -m xxx or -mxxx, pass them to the compiler as -mxxx +(suggestion of Nelson Beebe). Note that fc simply appends to CFLAGS, +so system-specific stuff can be supplied in the environment variable +CFLAGS. With some shells, invocations of the form + CFLAGS='system-specific stuff' fc ... +are one way to do this. + +Thu Aug 17 21:38:36 EDT 2000 + Fix obscure glitch: in "Error on line nnn of ...: Bad # line:...", +get nnn right. + +Sat Sep 30 00:28:30 EDT 2000 + libf77, libf2c.zip: dtime_.c, etime_.c: use floating-point divide; +dtime_.d, erf_.c, erfc_.c, etime.c: for use with "f2c -R", compile with +-DREAL=float. + +Tue Dec 5 22:55:56 EST 2000 + lread.c: under namelist input, when reading a logical array, treat +Tstuff= and Fstuff= as new assignments rather than as logical constants. + +Fri Feb 23 00:43:56 EST 2001 + libf2c: endfile.c: adjust to use truncate() unless compiled with +-DNO_TRUNCATE (or with -DMSDOS). Add libf2c/mkfile.plan9. + +Sat Feb 24 21:14:24 EST 2001 + Prevent malloc(0) when a subroutine of no arguments has an entry +with no arguments, as in + subroutine foo + entry goo + end + Fix a fault that was possible when MAIN (illegally) had entry points. + Fix a buffer overflow connected with the error message for names more +than MAXNAMELEN (i.e., 50) bytes long. + Fix a bug in command-line argument passing that caused the invocation +"f2c -!czork foo.f" to complain about two invalid flags ('-ork' and +'-oo.f') instead of just one ('-ork'). + fc: add -s option (strip executable); portability tweaks. + Adjustments to handing of integer*8 to permit processing 8-byte hex, +binary, octal, and decimal constants. The adjustments are only +available when type long long (for >= 64 bit integers) is available to +f2c; they are assumed available unless f2c is compiled with either +-DNO_TYQUAD or -DNO_LONGLONG. As has long been the case, compilation +of f2c itself with -DNO_TYQUAD eliminates recognition of integer*8 +altogether. Compilation with just -DNO_LONGLONG permits the previous +handling of integer*8, which could only handle 32-bit constants +associated with integer*8 variables. + New command-line argument -i8const (available only when f2c itself +is compiled with neither -DNO_TYQUAD nor -DNO_LONGLONG) suppresses +the new automatic promotion of integer constants too long to express +as 32-bit values to type integer*8. There are corresponding updates +to f2c.1 and f2c.1t. + +Wed Feb 28 00:50:04 EST 2001 + Adjust misc.c for (older) systems that recognize long long but do not +have LLONG_MAX or LONGLONG_MAX in limits.h. + main.c: filter out bad files before dofork loop to avoid trouble +in Win32 "f2c.exe" binaries. + +Thu Mar 1 16:25:19 EST 2001 + Cosmetic change for consistency with some other netlib directories: +change NO_LONGLONG to NO_LONG_LONG. (This includes adjusting the above +entry for Feb 23 2001.) No change (other than timestamp) to version.c. + libf2c: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), +thus permitting truncation of scratch files on true Unix systems, +where scratch files have no name. Add an fflush() (surprisingly) +needed on some Linux systems. + +Tue Mar 20 22:03:23 EST 2001 + expr.c: complain ("impossible conversion") about attempts to assign +character expressions ... to integer variables, rather than implicitly +assigning ichar(...). + +Sat Jun 23 23:08:22 EDT 2001 + New command-line option -trapuv adds calls on _uninit_f2c() to prologs +to dynamically initialize local variables, except those appearing in +SAVE or DATA statements, with values that may help find references to +uninitialized variables. For example, with IEEE arithmetic, floating- +point variables are initialized to signaling NaNs. + expr.c: new warning for out-of-bounds constant substring expressions. +Under -C, such expressions now inhibit C output. + libf2c/mkfile.plan9: fix glitch with rule for "check" (or xsum.out). + libf2c.zip: add uninit.c (for _uninit_f2c()) in support of -trapuv. + fc, f2c.1, f2c.1t: adjust for -trapuv. + +Thu Jul 5 22:00:51 EDT 2001 + libf2c.zip: modify uninit.c for __mc68k__ under Linux. + +Wed Aug 22 08:01:37 EDT 2001 + cds.c, expr.c: in constants, preserve the sign of 0. + expr.c: fix some glitches in folding constants to integer*8 +(when NO_LONG_LONG is not #defined). + intr.c: fold constant min(...) and max(...) expressions. + +Fri Nov 16 02:00:03 EST 2001 + libf2c.zip: tweak to permit handling files over 2GB long where +possible, with suitable -D options, provided for some systems in +new header file sysdep1.h (copied from sysdep1.h0 by default). +Add an fseek to endfile.c to fix a glitch on some systems. + +Wed Nov 28 17:58:12 EST 2001 + libf2c.zip: on IEEE systems, print -0 as -0 when the relevant +libf2c/makefile.* is suitably adjusted: see comments about +-DSIGNED_ZEROS in libf2c/makefile.*. + +Fri Jan 18 16:17:44 EST 2002 + libf2c.zip: fix bugs (reported by Holger Helmke) in qbit_bits(): +wrong return type, missing ~ on y in return value. This affects +the intrinsic ibits function for first argument of type integer*8. + +Thu Feb 7 17:14:43 EST 2002 + Fix bug handling leading array dimensions in common: invalid C +resulted. Example (after one provided by Dmitry G. Baksheyev): + + subroutine foo(a) + common/c/m + integer m, n + equivalence(m,n) + integer a(n,2) + a(1,2) = 3 + end + + Fix a bug, apparently introduced sometime after 19980913, in +handling certain substring expressions that involve temporary +assignments and the first invocation of an implicitly typed function. +When the expressions appeared in "else if (...)" and "do while(...)", +the temporary assignments appeared too soon. Examples are hard to +find, but here is one (after an example provided by Nat Bachman): + + subroutine foo(n) + character*8 s + do while (moo(s(n+1:n+2)) .ge. 2) + n = n + 1 + enddo + end + +It is hard for f2c to get this sort of example correct when the +"untyped" function is a generic intrinsic. When incorrect code would +otherwise result, f2c now issues an error message and declines to +produce C. For example, + + subroutine foo(n) + character*8 s + double precision goo + do while (sin(goo(s(n+1:n+2))) .ge. 2) + n = n + 1 + enddo + end + +gives the new error message, but both + + subroutine foo(n) + character*8 s + double precision goo + do while (dsin(goo(s(n+1:n+2))) .ge. 2) + n = n + 1 + enddo + end +and + subroutine foo(n) + character*8 s + double precision goo + do while (sin(goo(min(n, (n-3)**2))) .ge. 2) + n = n + 1 + enddo + end + +give correct C. + +Fri Feb 8 08:43:40 EST 2002 + Make a cleaner fix of the bug fixed yesterday in handling certain +"do while(...)" and "else if (...)" constructs involving auxiliary +assignments. (Yesterday's changes to expr.c are recanted; expr.c +is now restored to that of 20010820.) Now + + subroutine foo(n) + character*8 s + double precision goo + do while (sin(goo(s(n+1:n+2))) .ge. 0.2) + n = n + 1 + enddo + end + +is correctly translated. + +Thu Mar 14 12:53:08 EST 2002 + lex.c: adjust to avoid an error message under -72 when source files +are in CRLF form ("text mode" on Microsoft systems), a source line is +exactly 72 characters long, and f2c is run on a system (such as a Unix +or Linux system) that does not distinguish text and binary modes. +Example (in CRLF form): + write(*,*)"Hello world, with a source line that is 72 chars long." + end + libf2c/z_log.c: add code to cope with buggy compilers (e.g., some +versions of gcc under -O2 or -O3) that do floating-point comparisons +against values computed into extended-precision registers on some +systems (such as Intel IA32 systems). Compile with +-DNO_DOUBLE_EXTENDED to omit the kludge that circumvents this bug. + +Thu May 2 19:09:01 EDT 2002 + src/misc.c, src/sysdep.h, src/gram.c: tweaks for KR_headers (a rare +concern today); version.c touched but left unchanged. + libf2c: fix glitch in makefile.vc; KR_header tweaks in s_stop.c +and uninit.c (which also had a misplaced #endif). + +Wed Jun 5 16:13:34 EDT 2002 + libf2c: uninit.c: for Linux on an ARM processor, add some +#ifndef _FPU... tests; f77vers.c not changed. + +Tue Jun 25 15:13:32 EDT 2002 + New command-line option -K requests old-style ("K&R") C. The +default is changed to -A (ANSI/ISO style). + Under -K, cast string-length arguments to (ftnlen). This should +matter only in the unusual case that "readme" instructs obtaining +f2c.h by + sed 's/long int /long long /' f2c.h0 >f2c.h + Increase defaults for some table sizes: make -Nn802 -Nq300 -Nx400 +the default. + +Fri Sep 6 18:39:24 EDT 2002 + libf2c.zip: rsne.c: fix bug with multiple repeat counts in reading +namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / +(Bug found by Jim McDonald, reported by Toon Moene.) + +Fri Oct 4 10:23:51 EDT 2002 + libf2c.zip: uninit.c: on IRIX systems, omit references to shell +variables (a dreg). This only matters with f2c -trapuv . + +Thu Dec 12 22:16:00 EST 2002 + proc.c: tweak to omit "* 1" from "a_offset = 1 + a_dim1 * 1;". + libf2c.zip: uninit.c: adjust to work with HP-UX B.11.11 as well as +HP-UX B.10.20; f77vers.c not changed. + +Tue Feb 11 08:19:54 EST 2003 + Fix a fault with f2c -s on the following example of invalid Fortran +(reported by Nickolay A. Khokhlov); "function" should appear before +"cat" on the first line: + character*(*) cat(a, b) + character*(*) a, b + cat = a // b + end + Issue warnings about inappropriate uses of arrays a, b, c and pass +a temporary for d in + real a(2), b(2), c(2), d + call foo((a), 1*b, +c, +d) + end +(correcting bugs reported by Arnaud Desitter). + +Thu Mar 6 22:48:08 EST 2003 + output.c: fix a bug leading to "Unexpected tag 4 in opconv_fudge" +when f2c -s processes the real part of a complex array reference. +Example (simplified from netlib/linpack/zchdc.f): + + subroutine foo(a,work,n,k) + integer k, n + complex*16 a(n,n), work(n) + work(k) = dcmplx(dsqrt(dreal(a(k,k))),0.0d0) + end + +(Thanks to Nickolay A. Khokhlov for the bug report.) + +Thu Mar 20 13:50:12 EST 2003 + format.c: code around a bug (reported by Nelson H. F. Beebe) in +some versions of FreeBSD. Compiling with __FreeBSD__ but not +NO_FSCANF_LL_BUG #defined or with FSCANF_LL_BUG #defined causes +special logic to replace fscanf(infile, "%llx", result) with +custom logic. Here's an example (from Beebe) where the bug bit: + integer*8 m, n + m = 9223372036854775807 + end + +Fri Mar 21 13:14:05 EST 2003 + libf2c.zip: err.c: before writing to a file after reading from it, +do an f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. + +Fri Jun 6 14:56:44 EDT 2003 +libf2c.zip: add comments about libf2c.so (and a rule that works under +Linux, after an adjustment to the CFLAGS = line) to libf2c/makefile.u. + +Sat Oct 25 07:57:53 MDT 2003 +README, main.c, sysdep.c: adjust comments about libf2c and expand the +comments thereon in the C that f2c writes (since too few people read +the README files). Change makefile to makefile.u (with the +expectation that people will "cp makefile.u makefile" and edit +makefile if necessary) and add makefile.vc (for Microsoft Visual C++). + +Thu Oct 7 23:25:28 MDT 2004 +names.c: for convenience of MSVC++ users, map "cdecl" to "cdecl__". + +Fri Mar 4 18:40:48 MST 2005 +sysdep.c, makefile.u, new file sysdeptest.c: changes in response to a +message forwarded by Eric Grosse from Thierry Carrez +(who is apparently unaware of f2c's -T option) about an unlikely +security issue: that a local attacker could plant symbolic links in +/tmp corresponding to temporary file names that f2c generates and thus +cause overwriting of arbitrary files. Today's change is that if +neither -T nor the unusual debugging flag -Dn is specified and the +system is not an MS-Windows system (which cannot have symbolic links, +as far as I know), then f2c's temporary files will be written in a +temporary directory that is readable and writable only by the user and +that is removed at the end of f2c's execution. To disable today's +change, compile sysdep.c with -DNO_TEMPDIR (i.e., with NO_TEMPDIR +#defined). + +Sun Mar 27 20:06:49 MST 2005 +sysdep.c: in set_tmp_names(), fix botched placement of +"if (debugflag == 1) return;": move it below declarations. + +Sun May 1 21:45:46 MDT 2005 +sysdep.c: fix a possible fault under -DMSDOS and improper handling +of a tmpnam failure under the unusual combination of both -DNO_MKDTEMP +and -DNO_MKSTEMP (without -DNO_TEMPDIR). + +Tue Oct 4 23:38:54 MDT 2005 +libf2c.zip: uninit.c: on IA32 Linux systems, leave the rounding +precision alone rather than forcing it to 53 bits; compile with +-DUNINIT_F2C_PRECISION_53 to get the former behavior. This only +affects Fortran files translated by f2c -trapuv . + +Sun May 7 00:38:59 MDT 2006 + main.c, version.c: add options -? (or --help) that print out +pointers to usage documentation and -v (or --version) that print +the current version. + fc script: fix botch with -O[123]; recognize --version (or -v) +and --help (or -?). + Add f2c.pdf == PDF version of f2c.ps. + +Sun Oct 8 02:45:04 MDT 2006 + putpcc.c: fix glitch in subscripting complex variables: subscripts +of type integer*8 were converted to integer*4, which causes trouble +when 32-bit addressing does not suffice. + +Tue Sep 11 23:54:05 MDT 2007 + xsum.c: insert explicit "int" before main. + +Mon Dec 3 20:53:24 MST 2007 + libf2c/main.c: insert explicit "int" before main. + +Sat Apr 5 21:39:57 MDT 2008 + libf2c.zip: tweaks for political C++ and const correctness, and +to fix ctype trouble in some recent Linux versions. No behavior +should change. + +Sun Apr 6 22:38:56 MDT 2008 + libf2c.zip: adjust alternate makefiles to reflect yesterday's change. + +Wed Nov 26 23:23:27 MST 2008 + libf2c.zip: add brief discussion of MacOSX to comments in makefile.u. + +Fri Jan 2 23:13:25 MST 2009 + libf2c.zip: add -DNO_ISATTY to CFLAGS assignment in makefile.vc. + +Sat Apr 11 18:06:00 MDT 2009 + src/sysdep.c src/sysdeptest.c: tweak for MacOSX (include ). + +Wed Jul 7 10:51:12 MDT 2010 + src/data.c, src/format.c, src/p1output.c: "invisible" tweaks to +silence warnings seen in compilation under Ubuntu; version.c not changed. + +Fri Aug 27 09:14:17 MDT 2010 + format.c: make sizeof(buf) depend on MAXNAMELEN to fix a bug with long +names. Update mswin/f2c.exe.gz accordingly. + +Fri Sep 3 16:03:24 MDT 2010 + fc: have "-m ..." modify CC rather than CFLAGS (to affect linking). + +Mon Aug 1 13:46:40 MDT 2011 + README, README in libf2c.zip: update some netlib pointers. + +NOTE: the old libf77 and libi77 bundles are no longer being updated. +Use libf2c.zip instead. diff --git a/unix/f2c/f2c.1 b/unix/f2c/f2c.1 new file mode 100644 index 00000000..3bdbc8b8 --- /dev/null +++ b/unix/f2c/f2c.1 @@ -0,0 +1,222 @@ + + F2C(1) UNIX System V F2C(1) + + NAME + f2c - Convert Fortran 77 to C or C++ + + SYNOPSIS + f2c [ option ... ] file ... + + DESCRIPTION + F2c converts Fortran 77 source code in files with names end- + ing in `.f' or `.F' to C (or C++) source files in the cur- + rent directory, with `.c' substituted for the final `.f' or + `.F'. If no Fortran files are named, f2c reads Fortran from + standard input and writes C on standard output. File names + that end with `.p' or `.P' are taken to be prototype files, + as produced by option `-P', and are read first. + + The following options have the same meaning as in f77(1). + + -C Compile code to check that subscripts are within + declared array bounds. + + -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long + int. Assume the default libF77 and libI77: allow only + INTEGER*4 (and no LOGICAL) variables in INQUIREs. + Option `-I4' confirms the default rendering of INTEGER + as long int. + + -Idir + Look for a non-absolute include file first in the + directory of the current input file, then in directo- + ries specified by -I options (one directory per + option). Options -I2 and -I4 have precedence, so, + e.g., a directory named 2 should be specified by -I./2 + . + + -onetrip + Compile DO loops that are performed at least once if + reached. (Fortran 77 DO loops are not performed at all + if the upper limit is smaller than the lower limit.) + + -U Honor the case of variable and external names. Fortran + keywords must be in lower case. + + -u Make the default type of a variable `undefined' rather + than using the default Fortran rules. + + -w Suppress all warning messages, or, if the option is + `-w66', just Fortran 66 compatibility warnings. + + The following options are peculiar to f2c. + + -A Produce ANSI C (default, starting 20020621). For old- + style C, use option -K. + + Page 1 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + -a Make local variables automatic rather than static + unless they appear in a DATA, EQUIVALENCE, NAMELIST, or + SAVE statement. + + -C++ Output C++ code. + + -c Include original Fortran source as comments. + + -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and + cdsqrt as synonyms for the double complex intrinsics + zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, + nor dreal as a synonym for dble. + + -ddir + Write `.c' files in directory dir instead of the cur- + rent directory. + + -E Declare uninitialized COMMON to be Extern (overridably + defined in f2c.h as extern). + + -ec Place uninitialized COMMON blocks in separate files: + COMMON /ABC/ appears in file abc_com.c. Option `-e1c' + bundles the separate files into the output file, with + comments that give an unbundling sed(1) script. + + -ext Complain about f77(1) extensions. + + -f Assume free-format input: accept text after column 72 + and do not pad fixed-format lines shorter than 72 char- + acters with blanks. + + -72 Treat text appearing after column 72 as an error. + + -g Include original Fortran line numbers in #line lines. + + -h Emulate Fortran 66's treatment of Hollerith: try to + align character strings on word (or, if the option is + `-hd', on double-word) boundaries. + + -i2 Similar to -I2, but assume a modified libF77 and libI77 + (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- + ables may be assigned by INQUIRE and array lengths are + stored in short ints. + + -i90 Do not recognize the Fortran 90 bit-manipulation + intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, + ishft, and ishftc. + + -kr Use temporary values to enforce Fortran expression + evaluation where K&R (first edition) parenthesization + rules allow rearrangement. If the option is `-krd', + use double precision temporaries even for single- + + Page 2 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + precision operands. + + -P Write a file.P of ANSI (or C++) prototypes for defini- + tions in each input file.f or file.F. When reading + Fortran from standard input, write prototypes at the + beginning of standard output. Option -Ps implies -P + and gives exit status 4 if rerunning f2c may change + prototypes or declarations. + + -p Supply preprocessor definitions to make common-block + members look like local variables. + + -R Do not promote REAL functions and operations to DOUBLE + PRECISION. Option `-!R' confirms the default, which + imitates f77. + + -r Cast REAL arguments of intrinsic functions and values + of REAL functions (including intrinsics) to REAL. + + -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE + COMPLEX. + + -s Preserve multidimensional subscripts. Suppressed by + option `-C' . + + -Tdir + Put temporary files in directory dir. + + -trapuv + Dynamically initialize local variables, except those + appearing in SAVE or DATA statements, with values that + may help find references to uninitialized variables. + For example, with IEEE arithmetic, initialize local + floating-point variables to signaling NaNs. + + -w8 Suppress warnings when COMMON or EQUIVALENCE forces + odd-word alignment of doubles. + + -Wn Assume n characters/word (default 4) when initializing + numeric variables with character data. + + -z Do not implicitly recognize DOUBLE COMPLEX. + + -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, + \f, \n, \r, \t, \v) in character strings. + + -!c Inhibit C output, but produce -P output. + + -!I Reject include statements. + + -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', + permit INTEGER*8 but do not promote integer constants + + Page 3 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + to INTEGER*8 when they involve more than 32 bits. + + -!it Don't infer types of untyped EXTERNAL procedures from + use as parameters to previously defined or prototyped + procedures. + + -!P Do not attempt to infer ANSI or C++ prototypes from + usage. + + The resulting C invokes the support routines of f77; object + code should be loaded by f77 or with ld(1) or cc(1) options + -lF77 -lI77 -lm. Calling conventions are those of f77: see + the reference below. + + FILES + file.[fF] input file + + *.c output file + + /usr/include/f2c.h + header file + + /usr/lib/libF77.aintrinsic function library + + /usr/lib/libI77.aFortran I/O library + + /lib/libc.a C library, see section 3 + + SEE ALSO + S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 + Compiler', UNIX Time Sharing System Programmer's Manual, + Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. + + DIAGNOSTICS + The diagnostics produced by f2c are intended to be self- + explanatory. + + BUGS + Floating-point constant expressions are simplified in the + floating-point arithmetic of the machine running f2c, so + they are typically accurate to at most 16 or 17 decimal + places. + Untypable EXTERNAL functions are declared int. + There is no notation for INTEGER*8 constants. + Some intrinsic functions do not yet work with INTEGER*8 . + + Page 4 (printed 6/21/02) + diff --git a/unix/f2c/f2c.1t b/unix/f2c/f2c.1t new file mode 100644 index 00000000..d73d3347 --- /dev/null +++ b/unix/f2c/f2c.1t @@ -0,0 +1,391 @@ +. \" Definitions of F, L and LR for the benefit of systems +. \" whose -man lacks them... +.de F +.nh +.if n \%\&\\$1 +.if t \%\&\f(CW\\$1\fR +.hy 14 +.. +.de L +.nh +.if n \%`\\$1' +.if t \%\&\f(CW\\$1\fR +.hy 14 +.. +.de LR +.nh +.if n \%`\\$1'\\$2 +.if t \%\&\f(CW\\$1\fR\\$2 +.hy 14 +.. +.TH F2C 1 +.CT 1 prog_other +.SH NAME +f2c \- Convert Fortran 77 to C or C++ +. \" f\^2c changed to f2c in the previous line for the benefit of +. \" people on systems (e.g. Sun systems) whose makewhatis cannot +. \" cope with troff formatting commands. +.SH SYNOPSIS +.B f\^2c +[ +.I option ... +] +.I file ... +.SH DESCRIPTION +.I F2c +converts Fortran 77 source code in +.I files +with names ending in +.L .f +or +.L .F +to C (or C++) source files in the +current directory, with +.L .c +substituted +for the final +.L .f +or +.LR .F . +If no Fortran files are named, +.I f\^2c +reads Fortran from standard input and +writes C on standard output. +.I File +names that end with +.L .p +or +.L .P +are taken to be prototype +files, as produced by option +.LR -P , +and are read first. +.PP +The following options have the same meaning as in +.IR f\^77 (1). +.TP +.B -C +Compile code to check that subscripts are within declared array bounds. +.TP +.B -I2 +Render INTEGER and LOGICAL as short, +INTEGER\(**4 as long int. Assume the default \fIlibF77\fR +and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL) +variables in INQUIREs. Option +.L -I4 +confirms the default rendering of INTEGER as long int. +.TP +.BI -I dir +Look for a non-absolute include file first in the directory of the +current input file, then in directories specified by \f(CW-I\fP +options (one directory per option). Options +\f(CW-I2\fP and \f(CW-I4\fP +have precedence, so, e.g., a directory named \f(CW2\fP +should be specified by \f(CW-I./2\fP . +.TP +.B -onetrip +Compile DO loops that are performed at least once if reached. +(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) +.TP +.B -U +Honor the case of variable and external names. Fortran keywords must be in +.I +lower +case. +.TP +.B -u +Make the default type of a variable `undefined' rather than using the default Fortran rules. +.TP +.B -w +Suppress all warning messages, or, if the option is +.LR -w66 , +just Fortran 66 compatibility warnings. +.PP +The following options are peculiar to +.IR f\^2c . +.TP +.B -A +Produce +.SM ANSI +C (default, starting 20020621). +For old-style C, use option \f(CW-K\fP. +.TP +.B -a +Make local variables automatic rather than static +unless they appear in a +.SM "DATA, EQUIVALENCE, NAMELIST," +or +.SM SAVE +statement. +.TP +.B -C++ +Output C++ code. +.TP +.B -c +Include original Fortran source as comments. +.TP +.B -cd +Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt +as synonyms for the double complex intrinsics +zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, +nor dreal as a synonym for dble. +.TP +.BI -d dir +Write +.L .c +files in directory +.I dir +instead of the current directory. +.TP +.B -E +Declare uninitialized +.SM COMMON +to be +.B Extern +(overridably defined in +.F f2c.h +as +.B extern). +.TP +.B -ec +Place uninitialized +.SM COMMON +blocks in separate files: +.B COMMON /ABC/ +appears in file +.BR abc_com.c . +Option +.LR -e1c +bundles the separate files +into the output file, with comments that give an unbundling +.IR sed (1) +script. +.TP +.B -ext +Complain about +.IR f\^77 (1) +extensions. +.TP +.B -f +Assume free-format input: accept text after column 72 and do not +pad fixed-format lines shorter than 72 characters with blanks. +.TP +.B -72 +Treat text appearing after column 72 as an error. +.TP +.B -g +Include original Fortran line numbers in \f(CW#line\fR lines. +.TP +.B -h +Emulate Fortran 66's treatment of Hollerith: try to align character strings on +word (or, if the option is +.LR -hd , +on double-word) boundaries. +.TP +.B -i2 +Similar to +.BR -I2 , +but assume a modified +.I libF77 +and +.I libI77 +(compiled with +.BR -Df\^2c_i2 ), +so +.SM INTEGER +and +.SM LOGICAL +variables may be assigned by +.SM INQUIRE +and array lengths are stored in short ints. +.TP +.B -i90 +Do not recognize the Fortran 90 bit-manipulation intrinsics +btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. +.TP +.B -kr +Use temporary values to enforce Fortran expression evaluation +where K&R (first edition) parenthesization rules allow rearrangement. +If the option is +.LR -krd , +use double precision temporaries even for single-precision operands. +.TP +.B -P +Write a +.IB file .P +of ANSI (or C++) prototypes +for definitions in each input +.IB file .f +or +.IB file .F . +When reading Fortran from standard input, write prototypes +at the beginning of standard output. Option +.B -Ps +implies +.B -P +and gives exit status 4 if rerunning +.I f\^2c +may change prototypes or declarations. +.TP +.B -p +Supply preprocessor definitions to make common-block members +look like local variables. +.TP +.B -R +Do not promote +.SM REAL +functions and operations to +.SM DOUBLE PRECISION. +Option +.L -!R +confirms the default, which imitates +.IR f\^77 . +.TP +.B -r +Cast REAL arguments of intrinsic functions and values of REAL +functions (including intrinsics) to REAL. +.TP +.B -r8 +Promote +.SM REAL +to +.SM DOUBLE PRECISION, COMPLEX +to +.SM DOUBLE COMPLEX. +.TP +.B -s +Preserve multidimensional subscripts. Suppressed by option +.L -C +\&. +.TP +.BI -T dir +Put temporary files in directory +.I dir. +.TP +.B -trapuv +Dynamically initialize local variables, except those appearing in +.SM SAVE +or +.SM DATA +statements, with values that may help find references to +uninitialized variables. For example, with IEEE arithmetic, +initialize local floating-point variables to signaling NaNs. +.TP +.B -w8 +Suppress warnings when +.SM COMMON +or +.SM EQUIVALENCE +forces odd-word alignment of doubles. +.TP +.BI -W n +Assume +.I n +characters/word (default 4) +when initializing numeric variables with character data. +.TP +.B -z +Do not implicitly recognize +.SM DOUBLE COMPLEX. +.TP +.B -!bs +Do not recognize \fIb\fRack\fIs\fRlash escapes +(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings. +.TP +.B -!c +Inhibit C output, but produce +.B -P +output. +.TP +.B -!I +Reject +.B include +statements. +.TP +.B -!i8 +Disallow +.SM INTEGER*8 , +or, if the option is +.LR -!i8const , +permit +.SM INTEGER*8 +but do not promote integer +constants to +.SM INTEGER*8 +when they involve more than 32 bits. +.TP +.B -!it +Don't infer types of untyped +.SM EXTERNAL +procedures from use as parameters to previously defined or prototyped +procedures. +.TP +.B -!P +Do not attempt to infer +.SM ANSI +or C++ +prototypes from usage. +.PP +The resulting C invokes the support routines of +.IR f\^77 ; +object code should be loaded by +.I f\^77 +or with +.IR ld (1) +or +.IR cc (1) +options +.BR "-lF77 -lI77 -lm" . +Calling conventions +are those of +.IR f\&77 : +see the reference below. +.br +.SH FILES +.TP +.nr )I 1.75i +.IB file .[fF] +input file +.TP +.B *.c +output file +.TP +.F /usr/include/f2c.h +header file +.TP +.F /usr/lib/libF77.a +intrinsic function library +.TP +.F /usr/lib/libI77.a +Fortran I/O library +.TP +.F /lib/libc.a +C library, see section 3 +.SH "SEE ALSO" +S. I. Feldman and +P. J. Weinberger, +`A Portable Fortran 77 Compiler', +\fIUNIX Time Sharing System Programmer's Manual\fR, +Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. +.SH DIAGNOSTICS +The diagnostics produced by +.I f\^2c +are intended to be +self-explanatory. +.SH BUGS +Floating-point constant expressions are simplified in +the floating-point arithmetic of the machine running +.IR f\^2c , +so they are typically accurate to at most 16 or 17 decimal places. +.br +Untypable +.SM EXTERNAL +functions are declared +.BR int . +.br +There is no notation for +.SM INTEGER*8 +constants. +.br +Some intrinsic functions do not yet work with +.SM INTEGER*8 . diff --git a/unix/f2c/f2c.h b/unix/f2c/f2c.h new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/f2c.h @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef long int integer; +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/f2c/f2c.pdf b/unix/f2c/f2c.pdf new file mode 100644 index 00000000..757adec5 Binary files /dev/null and b/unix/f2c/f2c.pdf differ diff --git a/unix/f2c/f2c.ps b/unix/f2c/f2c.ps new file mode 100644 index 00000000..c1446802 --- /dev/null +++ b/unix/f2c/f2c.ps @@ -0,0 +1,5342 @@ +%!PS +%%Version: 3.3.1 +%%DocumentFonts: (atend) +%%Pages: (atend) +%%EndComments +% +% Version 3.3.1 prologue for troff files. +% + +/#copies 1 store +/aspectratio 1 def +/formsperpage 1 def +/landscape false def +/linewidth .3 def +/magnification 1 def +/margin 0 def +/orientation 0 def +/resolution 720 def +/rotation 1 def +/xoffset 0 def +/yoffset 0 def + +/roundpage true def +/useclippath true def +/pagebbox [0 0 612 792] def + +/R /Times-Roman def +/I /Times-Italic def +/B /Times-Bold def +/BI /Times-BoldItalic def +/H /Helvetica def +/HI /Helvetica-Oblique def +/HB /Helvetica-Bold def +/HX /Helvetica-BoldOblique def +/CW /Courier def +/CO /Courier def +/CI /Courier-Oblique def +/CB /Courier-Bold def +/CX /Courier-BoldOblique def +/PA /Palatino-Roman def +/PI /Palatino-Italic def +/PB /Palatino-Bold def +/PX /Palatino-BoldItalic def +/Hr /Helvetica-Narrow def +/Hi /Helvetica-Narrow-Oblique def +/Hb /Helvetica-Narrow-Bold def +/Hx /Helvetica-Narrow-BoldOblique def +/KR /Bookman-Light def +/KI /Bookman-LightItalic def +/KB /Bookman-Demi def +/KX /Bookman-DemiItalic def +/AR /AvantGarde-Book def +/AI /AvantGarde-BookOblique def +/AB /AvantGarde-Demi def +/AX /AvantGarde-DemiOblique def +/NR /NewCenturySchlbk-Roman def +/NI /NewCenturySchlbk-Italic def +/NB /NewCenturySchlbk-Bold def +/NX /NewCenturySchlbk-BoldItalic def +/ZD /ZapfDingbats def +/ZI /ZapfChancery-MediumItalic def +/S /S def +/S1 /S1 def +/GR /Symbol def + +/inch {72 mul} bind def +/min {2 copy gt {exch} if pop} bind def + +/setup { + counttomark 2 idiv {def} repeat pop + + landscape {/orientation 90 orientation add def} if + /scaling 72 resolution div def + linewidth setlinewidth + 1 setlinecap + + pagedimensions + xcenter ycenter translate + orientation rotation mul rotate + width 2 div neg height 2 div translate + xoffset inch yoffset inch neg translate + margin 2 div dup neg translate + magnification dup aspectratio mul scale + scaling scaling scale + + addmetrics + 0 0 moveto +} def + +/pagedimensions { + useclippath userdict /gotpagebbox known not and { + /pagebbox [clippath pathbbox newpath] def + roundpage currentdict /roundpagebbox known and {roundpagebbox} if + } if + pagebbox aload pop + 4 -1 roll exch 4 1 roll 4 copy + landscape {4 2 roll} if + sub /width exch def + sub /height exch def + add 2 div /xcenter exch def + add 2 div /ycenter exch def + userdict /gotpagebbox true put +} def + +/addmetrics { + /Symbol /S null Sdefs cf + /Times-Roman /S1 StandardEncoding dup length array copy S1defs cf +} def + +/pagesetup { + /page exch def + currentdict /pagedict known currentdict page known and { + page load pagedict exch get cvx exec + } if +} def + +/decodingdefs [ + {counttomark 2 idiv {y moveto show} repeat} + {neg /y exch def counttomark 2 idiv {y moveto show} repeat} + {neg moveto {2 index stringwidth pop sub exch div 0 32 4 -1 roll widthshow} repeat} + {neg moveto {spacewidth sub 0.0 32 4 -1 roll widthshow} repeat} + {counttomark 2 idiv {y moveto show} repeat} + {neg setfunnytext} +] def + +/setdecoding {/t decodingdefs 3 -1 roll get bind def} bind def + +/w {neg moveto show} bind def +/m {neg dup /y exch def moveto} bind def +/done {/lastpage where {pop lastpage} if} def + +/f { + dup /font exch def findfont exch + dup /ptsize exch def scaling div dup /size exch def scalefont setfont + linewidth ptsize mul scaling 10 mul div setlinewidth + /spacewidth ( ) stringwidth pop def +} bind def + +/changefont { + /fontheight exch def + /fontslant exch def + currentfont [ + 1 0 + fontheight ptsize div fontslant sin mul fontslant cos div + fontheight ptsize div + 0 0 + ] makefont setfont +} bind def + +/sf {f} bind def + +/cf { + dup length 2 idiv + /entries exch def + /chtab exch def + /newencoding exch def + /newfont exch def + + findfont dup length 1 add dict + /newdict exch def + {1 index /FID ne {newdict 3 1 roll put}{pop pop} ifelse} forall + + newencoding type /arraytype eq {newdict /Encoding newencoding put} if + + newdict /Metrics entries dict put + newdict /Metrics get + begin + chtab aload pop + 1 1 entries {pop def} for + newfont newdict definefont pop + end +} bind def + +% +% A few arrays used to adjust reference points and character widths in some +% of the printer resident fonts. If square roots are too high try changing +% the lines describing /radical and /radicalex to, +% +% /radical [0 -75 550 0] +% /radicalex [-50 -75 500 0] +% +% Move braceleftbt a bit - default PostScript character is off a bit. +% + +/Sdefs [ + /bracketlefttp [201 500] + /bracketleftbt [201 500] + /bracketrighttp [-81 380] + /bracketrightbt [-83 380] + /braceleftbt [203 490] + /bracketrightex [220 -125 500 0] + /radical [0 0 550 0] + /radicalex [-50 0 500 0] + /parenleftex [-20 -170 0 0] + /integral [100 -50 500 0] + /infinity [10 -75 730 0] +] def + +/S1defs [ + /underscore [0 80 500 0] + /endash [7 90 650 0] +] def +% +% Tries to round clipping path dimensions, as stored in array pagebbox, so they +% match one of the known sizes in the papersizes array. Lower left coordinates +% are always set to 0. +% + +/roundpagebbox { + 7 dict begin + /papersizes [8.5 inch 11 inch 14 inch 17 inch] def + + /mappapersize { + /val exch def + /slop .5 inch def + /diff slop def + /j 0 def + 0 1 papersizes length 1 sub { + /i exch def + papersizes i get val sub abs + dup diff le {/diff exch def /j i def} {pop} ifelse + } for + diff slop lt {papersizes j get} {val} ifelse + } def + + pagebbox 0 0 put + pagebbox 1 0 put + pagebbox dup 2 get mappapersize 2 exch put + pagebbox dup 3 get mappapersize 3 exch put + end +} bind def + +%%EndProlog +%%BeginSetup +mark +/landscape false def +/resolution 720 def +setup +2 setdecoding +%%EndSetup +%%Page: 1 1 +/saveobj save def +mark +1 pagesetup +10 R f +(AT&T Bell Laboratories)2 993 1 2203 1560 t +(Murray Hill, NJ 07974)3 916 1 2242 1680 t +(Computing Science Technical Report No. 149)5 1848 1 1776 2853 t +12 B f +(A Fortran-to-C Converter)2 1343 1 2028 3147 t +10 I f +(S. I. Feldman)2 538 1 2406 3411 t +10 S f +(*)2944 3361 w +10 I f +(David M. Gay)2 568 1 2416 3531 t +(Mark W. Maimone)2 751 1 2299 3651 t +(\262)3050 3601 w +(N. L. Schryer)2 533 1 2433 3771 t +10 R f +(Last updated March 22, 1995.)4 1198 1 2101 6231 t +(Originally issued May 16, 1990.)4 1294 1 2053 6351 t +10 S f +(*)1440 6831 w +10 R f +(Bell Communications Research, Morristown, NJ 07960)5 2224 1 1490 6881 t +(\262)1440 7011 w +(Carnegie-Mellon University, Pittsburgh, PA 15213)4 2044 1 1490 7061 t +cleartomark +showpage +saveobj restore +%%EndPage: 1 1 +%%Page: 1 2 +/saveobj save def +mark +2 pagesetup +12 B f +(A Fortran to C Converter)4 1323 1 2218 1220 t +10 R f +(S. I. Feldman)2 539 1 2610 1416 t +10 I f +(Bellcore)2711 1574 w +(Morristown, NJ 07960)2 909 1 2425 1694 t +10 R f +(David M. Gay)2 574 1 2593 1890 t +10 I f +(AT&T Bell Laboratories)2 985 1 2387 2048 t +(Murray Hill, New Jersey 07974)4 1268 1 2246 2168 t +10 R f +(Mark W. Maimone)2 768 1 2496 2364 t +10 I f +(Carnegie-Mellon University)1 1129 1 2315 2522 t +(Pittsburgh, PA 15213)2 870 1 2445 2642 t +10 R f +(N. L. Schryer)2 543 1 2608 2838 t +10 I f +(AT&T Bell Laboratories)2 985 1 2387 2996 t +(Murray Hill, New Jersey 07974)4 1268 1 2246 3116 t +10 R f +(ABSTRACT)2618 3389 w +(We describe)1 500 1 1080 3623 t +10 I f +(f 2c)1 138 1 1610 3623 t +10 R f +( 77 into C or C++.)5 765(, a program that translates Fortran)5 1378 2 1748 3623 t +10 I f +(F 2c)1 163 1 3947 3623 t +10 R f +(lets one port-)2 539 1 4141 3623 t +(ably mix C and Fortran and makes a large body of well-tested Fortran source code avail-)15 3600 1 1080 3743 t +(able to C environments.)3 955 1 1080 3863 t +10 B f +(1. INTRODUCTION)1 900 1 720 4136 t +10 R f +( it is)2 177( Sometimes)1 497( desirable for several reasons.)4 1190( is)1 93( 11])1 149(Automatic conversion of Fortran 77 [1] to C [10,)8 1964 6 970 4302 t +( At)1 150(useful to run a well-tested Fortran program on a machine that has a C compiler but no Fortran compiler.)18 4170 2 720 4422 t +( things are impossible to express in Fortran 77 or)9 2002( Some)1 283( and Fortran.)2 523(other times, it is convenient to mix C)7 1512 4 720 4542 t +( storage management, some character operations, arrays of)7 2396(are harder to express in Fortran than in C \(e.g.)9 1924 2 720 4662 t +( pro-)1 206(functions, heterogeneous data structures, and calls that depend on the operating system\), and some)13 4114 2 720 4782 t +( for carrying)2 502( is a large body of well tested Fortran source code)10 2020( There)1 285(grammers simply prefer C to Fortran.)5 1513 4 720 4902 t +( desirable to exploit some of this Fortran)7 1743(out a wide variety of useful calculations, and it is sometimes)10 2577 2 720 5022 t +( but the details vary)4 796( vendors provide some way of mixing C and Fortran,)9 2147( Many)1 286(source in a C environment.)4 1091 4 720 5142 t +( a)1 87( Fortran to C conversion lets one create)7 1691( Automatic)1 489(from system to system.)3 979 4 720 5262 t +10 I f +(portable)4009 5262 w +10 R f +(C program that)2 641 1 4399 5262 t +(exploits Fortran source code.)3 1159 1 720 5382 t +10 R f +( to C conversion is that it allows such tools as)10 1908(A side bene\256t of automatic Fortran 77)6 1568 2 970 5548 t +10 I f +(cyntax)4479 5548 w +10 R f +(\(1\) and)1 293 1 4747 5548 t +10 I f +(lint)720 5668 w +10 R f +( and portability checks that the)5 1289( to provide Fortran 77 programs with some of the consistency)10 2594(\(1\) [4])1 295 3 862 5668 t +( consistency checks detect errors in calling)6 1851( The)1 228(Pfort Veri\256er [13] provided to Fortran 66 programs.)7 2241 3 720 5788 t +(sequences and are thus a boon to debugging.)7 1780 1 720 5908 t +10 R f +(This paper describes)2 828 1 970 6074 t +10 I f +(f 2c)1 138 1 1828 6074 t +10 R f +(, a Fortran 77 to C converter based on Feldman's original)10 2344 1 1966 6074 t +10 I f +(f)4340 6074 w +10 R f +(77 compiler [6].)2 656 1 4384 6074 t +(We have used)2 571 1 720 6194 t +10 I f +(f 2c)1 138 1 1322 6194 t +10 R f +( large programs and subroutine libraries to C automatically \(i.e., with)10 2816(to convert various)2 733 2 1491 6194 t +(no manual intervention\); these include the)5 1714 1 720 6314 t +8 R f +(PORT3)2465 6314 w +10 R f +(subroutine library \()2 783 1 2742 6314 t +8 R f +(PORT1)3525 6314 w +10 R f +( MINOS)1 353( 8]\),)1 157(is described in [7,)3 728 3 3802 6314 t +( \257oating-point test is of particular interest, as it relies heav-)10 2381( The)1 207([12], and Schryer's \257oating-point test [14].)5 1732 3 720 6434 t +(ily on correct evaluation of parenthesized expressions and is bit-level self-testing.)10 3258 1 720 6554 t +10 R f +( compiled from the C produced)5 1256(As a debugging aid, we sought bit-level compatibility between objects)9 2814 2 970 6720 t +(by)720 6840 w +10 I f +(f 2c)1 138 1 849 6840 t +10 R f +(and objects produced by our local)5 1370 1 1016 6840 t +10 I f +(f)2415 6840 w +10 R f +( we developed)2 582( is, on the VAX where)5 918( That)1 237(77 compiler.)1 509 4 2459 6840 t +10 I f +(f 2c)1 138 1 4733 6840 t +10 R f +(, we)1 169 1 4871 6840 t +( been)1 222(sought to make it impossible to tell by running a Fortran program whether some of its modules had)17 4098 2 720 6960 t +(compiled by)1 500 1 720 7080 t +10 I f +(f 2c)1 138 1 1248 7080 t +10 R f +(or all had been compiled by)5 1122 1 1413 7080 t +10 I f +(f)2562 7080 w +10 R f +( meant that)2 448(77. This)1 355 2 2606 7080 t +10 I f +(f 2c)1 138 1 3436 7080 t +10 R f +(should follow the same calling con-)5 1439 1 3601 7080 t +(ventions as)1 447 1 720 7200 t +10 I f +(f)1192 7200 w +10 R f +(77 [6] and should use)4 860 1 1236 7200 t +10 I f +(f)2121 7200 w +10 R f +(77's support libraries,)2 874 1 2165 7200 t +10 I f +(libF77)3064 7200 w +10 R f +(and)3356 7200 w +10 I f +(libI77)3525 7200 w +10 R f +(.)3764 7200 w +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 1 2 +%%Page: 2 3 +/saveobj save def +mark +3 pagesetup +10 R f +(- 2 -)2 166 1 2797 480 t +( to make)2 370(Although we have tried)3 976 2 970 840 t +10 I f +(f 2c)1 138 1 2354 840 t +10 R f +('s output reasonably readable, our goal of strict compatibility)8 2548 1 2492 840 t +(with)720 960 w +10 I f +(f)942 960 w +10 R f +( statements, in particular, generally get)5 1645( Input/output)1 564(77 implies some nasty looking conversions.)5 1845 3 986 960 t +( of calls on routines in)5 951(expanded into a series)3 917 2 720 1080 t +10 I f +(libI77)2625 1080 w +10 R f +(,)2864 1080 w +10 I f +(f)2926 1080 w +10 R f +( the C output of)4 676( Thus)1 262(77's I/O library.)2 670 3 2970 1080 t +10 I f +(f 2c)1 138 1 4615 1080 t +10 R f +(would)4790 1080 w +( to maintain as C; it would be much more sensible to maintain the)13 2747(probably be something of a nightmare)5 1573 2 720 1200 t +( commercial vendors, e.g., those listed in)6 1685( Some)1 286( it changed.)2 479(original Fortran, translating it anew each time)6 1870 4 720 1320 t +( perform translations yielding C that one might reasonably maintain directly; these)11 3454(Appendix A, seek to)3 866 2 720 1440 t +(translations generally require some manual intervention.)5 2252 1 720 1560 t +10 R f +( conventions used)2 718( 2 describes the interlanguage)4 1186( Section)1 350(The rest of this paper is organized as follows.)8 1816 4 970 1743 t +(by)720 1863 w +10 I f +(f 2c)1 138 1 848 1863 t +10 R f +(\(and)1014 1863 w +10 I f +(f)1219 1863 w +10 R f +( summarizes some extensions to Fortran 77 that)7 1928(77\). \2473)1 311 2 1263 1863 t +10 I f +(f 2c)1 138 1 3529 1863 t +10 R f +( invocations)1 488(recognizes. Example)1 858 2 3694 1863 t +(of)720 1983 w +10 I f +(f 2c)1 138 1 833 1983 t +10 R f +( illustrates various details of)4 1147( \2475)1 155(appear in \2474.)2 528 3 1001 1983 t +10 I f +(f 2c)1 138 1 2861 1983 t +10 R f +( issues.)1 295('s translations, and \2476 considers portability)5 1746 2 2999 1983 t +(\2477 discusses the generation and use of)6 1555 1 720 2103 t +10 I f +(prototypes)2305 2103 w +10 R f +( and ANSI C compilers)4 954(, which can be used both by C++)7 1351 2 2735 2103 t +(and by)1 279 1 720 2223 t +10 I f +(f 2c)1 138 1 1034 2223 t +10 R f +( describes our experience with an experimental)6 1938( \2478)1 160(to check consistency of calling sequences.)5 1735 3 1207 2223 t +10 I f +(f 2c)1 138 1 720 2343 t +10 R f +(service provided by)2 805 1 892 2343 t +10 I f +(netlib)1731 2343 w +10 R f +( A lists some vendors)4 893( Appendix)1 452([5], and \2479 considers possible extensions.)5 1702 3 1993 2343 t +( B contains a)3 546( Appendix)1 427( Finally,)1 367(who offer conversion of Fortran to C that one might maintain as C.)12 2774 4 720 2463 t +10 I f +(man)4868 2463 w +10 R f +(page telling how to use)4 927 1 720 2583 t +10 I f +(f 2c)1 138 1 1672 2583 t +10 R f +(.)1810 2583 w +10 B f +(2. INTERLANGUAGE CONVENTIONS)2 1765 1 720 2915 t +10 R f +(Much of the material in this section is taken from [6].)10 2139 1 970 3098 t +10 B f +(Names)720 3430 w +10 R f +(An)970 3613 w +10 I f +(f 2c)1 138 1 1122 3613 t +10 R f +( \(until recently called Fortran 8x [2]\) is that long names are)11 2431(extension inspired by Fortran 90)4 1319 2 1290 3613 t +(allowed \()1 380 1 720 3733 t +10 I f +(f 2c)1 138 1 1100 3733 t +10 R f +( To)1 166( 50 characters\), and names may contain underscores.)7 2137(truncates names that are longer than)5 1468 3 1269 3733 t +( and with names that)4 875(avoid con\257ict with the names of library routines)7 2000 2 720 3853 t +10 I f +(f 2c)1 138 1 3632 3853 t +10 R f +(generates, Fortran names may)3 1233 1 3807 3853 t +( lower case \(unless the)4 967( names are forced to)4 876( Fortran)1 361(have one or two underscores appended.)5 1658 4 720 3973 t +10 CW f +(-U)4623 3973 w +10 R f +(option)4784 3973 w +( names of Fortran procedures and common)6 1767(described in Appendix B is in effect\); external names, i.e., the)10 2553 2 720 4093 t +( contain any underscores and have a pair of under-)9 2031(blocks, have a single underscore appended if they do not)9 2289 2 720 4213 t +( named)1 316( Fortran subroutines)2 853( Thus)1 274(scores appended if they do contain underscores.)6 2053 4 720 4333 t +10 CW f +(ABC)4266 4333 w +10 R f +(,)4446 4333 w +10 CW f +(A_B_C)4521 4333 w +10 R f +(, and)1 219 1 4821 4333 t +10 CW f +(A_B_C_)720 4453 w +10 R f +(result in C functions named)4 1105 1 1105 4453 t +10 CW f +(abc_)2235 4453 w +10 R f +(,)2475 4453 w +10 CW f +(a_b_c_ _)1 444 1 2525 4453 t +10 R f +(, and)1 194 1 2969 4453 t +10 CW f +(a_b_c_ _ _)2 528 1 3188 4453 t +10 R f +(.)3716 4453 w +10 B f +(Types)720 4785 w +10 R f +( use types)2 442(The table below shows corresponding Fortran and C declarations; the C declarations)11 3628 2 970 4968 t +(de\256ned in)1 414 1 720 5088 t +10 CW f +(f2c.h)1176 5088 w +10 R f +(, a header \256le upon which)5 1116 1 1476 5088 t +10 I f +(f 2c)1 138 1 2634 5088 t +10 R f +( table also shows the C types)6 1251( The)1 221( rely.)1 221('s translations)1 575 4 2772 5088 t +(de\256ned in the standard version of)5 1334 1 720 5208 t +10 CW f +(f2c.h)2079 5208 w +10 R f +(.)2379 5208 w +10 S f +(_ _______________________________________________________)1 2789 1 1485 5334 t +10 R f +( standard)1 948(Fortran C)1 1059 2 1757 5454 t +10 CW f +(f2c.h)3789 5454 w +10 R f +(integer)1535 5634 w +10 S f +(*)1812 5634 w +10 R f +( int x;)2 234( short)1 660( x;)1 103( shortint)1 742(2 x)1 125 5 1862 5634 t +( int x;)2 234( long)1 667( x;)1 103( integer)1 813(integer x)1 352 5 1535 5754 t +( int x;)2 234( long)1 635( int x;)2 234( long)1 719(logical x)1 347 5 1535 5874 t +( x;)1 103( \257oat)1 795( x;)1 103( real)1 813(real x)1 224 5 1535 5994 t +( x;)1 103( double)1 617( x;)1 103( doublereal)1 571(double precision x)2 738 5 1535 6114 t +( { \257oat r, i; } x;)6 616( struct)1 644( x;)1 103( complex)1 813(complex x)1 419 5 1535 6234 t +( { double r, i; } x;)6 710( struct)1 372( x;)1 103( doublecomplex)1 788(double complex x)2 716 5 1535 6354 t +(character)1535 6474 w +10 S f +(*)1899 6474 w +10 R f +( x[6];)1 219( char)1 650( x[6];)1 219( char)1 520(6 x)1 125 5 1949 6474 t +10 S f +( \347)1 -2789(_ _______________________________________________________)1 2789 2 1485 6494 t +(\347)1485 6434 w +(\347)1485 6334 w +(\347)1485 6234 w +(\347)1485 6134 w +(\347)1485 6034 w +(\347)1485 5934 w +(\347)1485 5834 w +(\347)1485 5734 w +(\347)1485 5634 w +(\347)1485 5534 w +(\347)1485 5434 w +(\347)4274 6494 w +(\347)4274 6434 w +(\347)4274 6334 w +(\347)4274 6234 w +(\347)4274 6134 w +(\347)4274 6034 w +(\347)4274 5934 w +(\347)4274 5834 w +(\347)4274 5734 w +(\347)4274 5634 w +(\347)4274 5534 w +(\347)4274 5434 w +10 R f +(By the rules of Fortran,)4 951 1 720 6720 t +10 CW f +(integer, logical,)1 990 1 1700 6720 t +10 R f +(and)2720 6720 w +10 CW f +(real)2894 6720 w +10 R f +(data occupy the same amount of memory, and)7 1876 1 3164 6720 t +10 CW f +(double precision)1 965 1 720 6840 t +10 R f +(and)1715 6840 w +10 CW f +(complex)1889 6840 w +10 R f +(occupy twice this amount;)3 1064 1 2339 6840 t +10 I f +(f 2c)1 138 1 3432 6840 t +10 R f +(assumes that the types in the C col-)7 1441 1 3599 6840 t +( \(in)1 151(umn above are chosen)3 931 2 720 6960 t +10 CW f +(f2c.h)1842 6960 w +10 R f +( translations of the Fortran)4 1120( The)1 220(\) so that these assumptions are valid.)6 1558 3 2142 6960 t +10 CW f +(equivalence)720 7080 w +10 R f +(and)1408 7080 w +10 CW f +(data)1580 7080 w +10 R f +( some machines, one must modify)5 1376( On)1 174(statements depend on these assumptions.)4 1643 3 1847 7080 t +10 CW f +(f2c.h)720 7200 w +10 R f +( \2476 for examples and further discussion.)6 1600( See)1 194(to make these assumptions hold.)4 1297 3 1045 7200 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 2 3 +%%Page: 3 4 +/saveobj save def +mark +4 pagesetup +10 R f +(- 3 -)2 166 1 2797 480 t +10 B f +(Return Values)1 619 1 720 840 t +10 R f +(A function of type)3 753 1 970 998 t +10 CW f +(integer)1754 998 w +10 R f +(,)2174 998 w +10 CW f +(logical)2230 998 w +10 R f +(, or)1 139 1 2650 998 t +10 CW f +(double precision)1 966 1 2820 998 t +10 R f +(must be declared as a C func-)6 1222 1 3818 998 t +( the)1 148( If)1 117(tion that returns the corresponding type.)5 1603 3 720 1118 t +10 CW f +(-R)2613 1118 w +10 R f +(option is in effect \(see Appendix B\), the same is true of a)12 2282 1 2758 1118 t +(function of type)2 694 1 720 1238 t +10 CW f +(real)1467 1238 w +10 R f +(; otherwise, a)2 591 1 1707 1238 t +10 CW f +(real)2351 1238 w +10 R f +( as a C function that returns)6 1278(function must be declared)3 1118 2 2644 1238 t +10 CW f +(doublereal)720 1358 w +10 R f +(; this hack facilitates our VAX regression testing, as it duplicates the behavior of our local)15 3720 1 1320 1358 t +(Fortran compiler \()2 738 1 720 1478 t +10 I f +(f)1458 1478 w +10 R f +(77\). A)1 283 1 1502 1478 t +10 CW f +(complex)1814 1478 w +10 R f +(or)2263 1478 w +10 CW f +(double complex)1 844 1 2375 1478 t +10 R f +(function is equivalent to a C routine with an)8 1792 1 3248 1478 t +( Thus,)1 275(additional initial argument that points to the place where the return value is to be stored.)15 3518 2 720 1598 t +9 CW f +(complex function f\( . . . \))6 1458 1 1008 1761 t +10 R f +(is equivalent to)2 611 1 720 1944 t +9 CW f +(void f_\(temp, . . .\))4 1080 1 1008 2107 t +(complex)1008 2207 w +9 S f +(*)1440 2207 w +9 CW f +(temp;)1485 2207 w +(. . .)2 270 1 1062 2307 t +10 R f +( equivalent to a C routine with two extra initial arguments: a data address and)14 3110(A character-valued function is)3 1210 2 720 2490 t +( Thus,)1 275(a length.)1 344 2 720 2610 t +9 CW f +(character)1008 2773 w +9 S f +(*)1494 2773 w +9 CW f +(15 function g\( . . . \))6 1188 1 1539 2773 t +10 R f +(is equivalent to)2 611 1 720 2956 t +9 CW f +(g_\(result, length, . . .\))4 1350 1 1008 3119 t +(char)1008 3219 w +9 S f +(*)1278 3219 w +9 CW f +(result;)1323 3219 w +(ftnlen length;)1 756 1 1008 3319 t +(. . .)2 270 1 1062 3419 t +10 R f +(and could be invoked in C by)6 1177 1 720 3602 t +9 CW f +(char chars[15];)1 810 1 1008 3765 t +(. . .)2 270 1 1062 3865 t +(g_\(chars, 15L, . . . \);)5 1242 1 1008 3965 t +10 R f +(Subroutines are invoked as if they were)6 1598 1 720 4148 t +10 CW f +(int)2346 4148 w +10 R f +(-valued functions whose value speci\256es which alternate return)7 2514 1 2526 4148 t +( an)1 125( return arguments \(statement labels\) are not passed to the function, but are used to do)15 3499( Alternate)1 428(to use.)1 268 4 720 4268 t +( entry points with alternate return argu-)6 1617( the subroutine has no)4 905( \(If)1 156(indexed branch in the calling procedure.)5 1642 4 720 4388 t +( statement)1 408( The)1 205(ments, the returned value is unde\256ned.\))5 1578 3 720 4508 t +9 CW f +(call nret\()1 540 1 1008 4671 t +9 S f +(*)1548 4671 w +9 CW f +(1,)1593 4671 w +9 S f +(*)1755 4671 w +9 CW f +(2,)1800 4671 w +9 S f +(*)1962 4671 w +9 CW f +(3\))2007 4671 w +10 R f +(is treated exactly as if it were the Fortran computed)9 2054 1 720 4854 t +10 CW f +(goto)2799 4854 w +9 CW f +( \))1 108( nret\()1 378(goto \(1, 2, 3\),)3 810 3 1008 5017 t +10 B f +(Argument Lists)1 669 1 720 5262 t +10 R f +( addition, for every non-function argument that is of)8 2115( In)1 137( address.)1 353(All Fortran arguments are passed by)5 1465 4 970 5420 t +( string lengths are)3 728( \(The)1 243( length of the value is passed.)6 1209(type character, an argument giving the)5 1565 4 720 5540 t +10 CW f +(ftnlen)4495 5540 w +10 R f +(val-)4885 5540 w +(ues, i.e.,)1 335 1 720 5660 t +10 CW f +(long int)1 485 1 1085 5660 t +10 R f +( of arguments is: extra arguments)5 1364( summary, the order)3 819( In)1 138(quantities passed by value\).)3 1119 4 1600 5660 t +( function, and a)3 621(for complex and character functions, an address for each datum or)10 2649 2 720 5780 t +10 CW f +(ftnlen)4015 5780 w +10 R f +(for each charac-)2 640 1 4400 5780 t +( the call in)3 419( Thus,)1 275(ter argument \(other than character-valued functions\).)5 2110 3 720 5900 t +9 CW f +(external f)1 540 1 1008 6063 t +(character)1008 6163 w +9 S f +(*)1494 6163 w +9 CW f +(7 s)1 162 1 1539 6163 t +(integer b\(3\))1 648 1 1008 6263 t +(. . .)2 270 1 1062 6363 t +(call sam\(f, b\(2\), s\))3 1080 1 1008 6463 t +10 R f +(is equivalent to that in)4 889 1 720 6646 t +9 CW f +(int f\(\);)1 432 1 1008 6809 t +(char s[7];)1 540 1 1008 6909 t +(long int b[3];)2 756 1 1008 7009 t +(. . .)2 270 1 1062 7109 t +(sam_\(f, &b[1], s, 7L\);)3 1188 1 1008 7209 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 3 4 +%%Page: 4 5 +/saveobj save def +mark +5 pagesetup +10 R f +(- 4 -)2 166 1 2797 480 t +( arrays begin at 1 by default.)6 1175(Note that the \256rst element of a C array always has subscript zero, but Fortran)14 3145 2 720 840 t +( whereas C arrays are stored in row-major order,)8 1983(Because Fortran arrays are stored in column-major order,)7 2337 2 720 960 t +10 I f +(f 2c)1 138 1 720 1080 t +10 R f +( arrays into one-dimensional C arrays and issues appropriate sub-)9 2681(translates multi-dimensional Fortran)2 1469 2 890 1080 t +(scripting expressions.)1 866 1 720 1200 t +10 B f +(3. EXTENSIONS TO FORTRAN 77)4 1560 1 720 1460 t +10 R f +(Since it is derived from)4 938 1 970 1622 t +10 I f +(f)1933 1622 w +10 R f +(77,)1977 1622 w +10 I f +(f 2c)1 138 1 2127 1622 t +10 R f +(supports all of the)3 719 1 2290 1622 t +10 I f +(f)3035 1622 w +10 R f +(77 extensions described in [6].)4 1227 1 3079 1622 t +10 I f +(F 2c)1 163 1 4357 1622 t +10 R f +('s extensions)1 520 1 4520 1622 t +(include the following.)2 880 1 720 1742 t +10 S f +(\267)720 1922 w +10 R f +(Type)791 1922 w +10 CW f +(double complex)1 854 1 1035 1922 t +10 R f +(\(alias)1928 1922 w +10 CW f +(complex*16)2183 1922 w +10 R f +(\) is a double-precision version of)5 1387 1 2783 1922 t +10 CW f +(complex)4209 1922 w +10 R f +(. Speci\256c)1 411 1 4629 1922 t +( for)1 148(intrinsic functions)1 733 2 791 2042 t +10 CW f +(double complex)1 847 1 1704 2042 t +10 R f +(have names that start with)4 1071 1 2583 2042 t +10 CW f +(z)3686 2042 w +10 R f +(rather than)1 436 1 3778 2042 t +10 CW f +(c)4246 2042 w +10 R f +( exception to)2 530(. An)1 204 2 4306 2042 t +(this rule is)2 425 1 791 2162 t +10 CW f +(dimag)1245 2162 w +10 R f +( of a)2 187(, which returns the imaginary part)5 1373 2 1545 2162 t +10 CW f +(double complex)1 845 1 3135 2162 t +10 R f +(value;)4010 2162 w +10 CW f +(imag)4284 2162 w +10 R f +(is the corre-)2 486 1 4554 2162 t +( generic intrinsic function)3 1035( The)1 207(sponding generic intrinsic function.)3 1430 3 791 2282 t +10 CW f +(real)3490 2282 w +10 R f +(is extended so that it returns the)6 1283 1 3757 2282 t +(real part of a)3 509 1 791 2402 t +10 CW f +(double complex)1 841 1 1326 2402 t +10 R f +(value as a)2 395 1 2193 2402 t +10 CW f +(double precision)1 961 1 2614 2402 t +10 R f +(value;)3601 2402 w +10 CW f +(dble)3871 2402 w +10 R f +(is the speci\256c intrinsic)3 903 1 4137 2402 t +(function that does this job.)4 1064 1 791 2522 t +10 S f +(\267)720 2702 w +10 R f +(The ``types'' that may appear in an)6 1425 1 791 2702 t +10 CW f +(implicit)2244 2702 w +10 R f +(statement include)1 705 1 2752 2702 t +10 CW f +(undefined)3485 2702 w +10 R f +( vari-)1 217(, which implies that)3 798 2 4025 2702 t +(ables whose names begin with the associated letters must be explicitly declared in a type statement.)15 4032 1 791 2822 t +10 I f +(F 2c)1 163 1 4877 2822 t +10 R f +(also recognizes the Fortran 90 statement)5 1611 1 791 2942 t +9 CW f +(implicit none)1 702 1 1008 3112 t +10 R f +(as equivalent to)2 627 1 791 3302 t +9 CW f +(implicit undefined\(a-z\))1 1242 1 1008 3472 t +10 R f +(The command-line option)2 1038 1 791 3662 t +10 CW f +(-u)1854 3662 w +10 R f +(has the effect of inserting)4 1014 1 1999 3662 t +9 CW f +(implicit none)1 702 1 1008 3832 t +10 R f +(at the beginning of each Fortran procedure.)6 1726 1 791 4022 t +10 S f +(\267)720 4202 w +10 R f +( themselves recursively, i.e., may call themselves either directly or indirectly through)11 3436(Procedures may call)2 813 2 791 4202 t +(a chain of other calls.)4 856 1 791 4322 t +10 S f +(\267)720 4502 w +10 R f +(The keywords)1 579 1 791 4502 t +10 CW f +(static)1406 4502 w +10 R f +(and)1802 4502 w +10 CW f +(automatic)1982 4502 w +10 R f +(act as ``types'' in type and implicit statements; they specify)9 2482 1 2558 4502 t +( of each)2 325( is exactly one copy)4 817( There)1 288(storage classes.)1 621 4 791 4622 t +10 CW f +(static)2872 4622 w +10 R f +(variable, and such variables retain their val-)6 1778 1 3262 4622 t +( of a)2 189( the other hand, each invocation)5 1300( On)1 177(ues between invocations of the procedure in which they appear.)9 2583 4 791 4742 t +(procedure gets new copies of the procedure's)6 1877 1 791 4862 t +10 CW f +(automatic)2705 4862 w +10 R f +(variables.)3282 4862 w +10 CW f +(Automatic)3729 4862 w +10 R f +(variables may not)2 734 1 4306 4862 t +(appear in)1 392 1 791 4982 t +10 CW f +(equivalence)1232 4982 w +10 R f +(,)1892 4982 w +10 CW f +(data)1967 4982 w +10 R f +(,)2207 4982 w +10 CW f +(namelist)2282 4982 w +10 R f +(, or)1 158 1 2762 4982 t +10 CW f +(save)2970 4982 w +10 R f +( command-line option)2 933(statements. The)1 677 2 3260 4982 t +10 CW f +(-a)4920 4982 w +10 R f +(changes the default storage class from)5 1526 1 791 5102 t +10 CW f +(static)2342 5102 w +10 R f +(to)2727 5102 w +10 CW f +(automatic)2830 5102 w +10 R f +(\(for all variables except those that appear)6 1645 1 3395 5102 t +(in)791 5222 w +10 CW f +(common)894 5222 w +10 R f +(,)1254 5222 w +10 CW f +(data)1304 5222 w +10 R f +(,)1544 5222 w +10 CW f +(equivalence)1594 5222 w +10 R f +(,)2254 5222 w +10 CW f +(namelist)2304 5222 w +10 R f +(, or)1 133 1 2784 5222 t +10 CW f +(save)2942 5222 w +10 R f +(statements\).)3207 5222 w +10 S f +(\267)720 5402 w +10 R f +( free-format line, which may extend beyond)6 1784(A tab in the \256rst 6 columns signi\256es that the current line is a)13 2465 2 791 5402 t +( ampersand)1 459( An)1 174(column 72.)1 452 3 791 5522 t +10 CW f +(&)1903 5522 w +10 R f +(in column 1 indicates that the current line is a free-format continuation line.)12 3050 1 1990 5522 t +( have neither an ampersand in column 1 nor a tab in the \256rst 6 columns are treated as Fortran 77)20 3852(Lines that)1 397 2 791 5642 t +( with blanks until they are 72)6 1166( shorter than 72 characters, they are padded on the right)10 2229( if)1 112(\256xed-format lines:)1 742 4 791 5762 t +( taking)1 277( After)1 262(characters long; if longer than 72 characters, the characters beyond column 72 are discarded.)13 3710 3 791 5882 t +( this is the only constraint on)6 1204(continuations into account, statements may be up to 1320 characters long;)10 3045 2 791 6002 t +( the Fortran 77 standard, which allows at most 19)9 1994( limit is implied by)4 767( \(This)1 262(the length of free-format lines.)4 1226 4 791 6122 t +(continuation lines; 1320)2 967 1 791 6242 t +10 S f +(=)1807 6242 w +10 R f +(\( 1)1 91 1 1911 6242 t +10 S f +(+)2042 6242 w +10 R f +(19 \))1 141 1 2137 6242 t +10 S f +(\264)2327 6242 w +10 R f +(66.\))2423 6242 w +10 S f +(\267)720 6422 w +10 R f +(Aside from quoted strings,)3 1066 1 791 6422 t +10 I f +(f 2c)1 138 1 1882 6422 t +10 R f +(ignores case \(unless the)3 945 1 2045 6422 t +10 CW f +(-U)3015 6422 w +10 R f +(option is in effect\).)3 760 1 3160 6422 t +10 S f +(\267)720 6602 w +10 R f +(The statement)1 563 1 791 6602 t +9 CW f +(include 'stuff')1 810 1 1008 6772 t +10 R f +(is replaced by the contents of the \256le)7 1551 1 791 6962 t +10 I f +(stuff)2379 6962 w +10 R f +(. Unless)1 359 1 2560 6962 t +10 I f +(stuff)2956 6962 w +10 R f +( \256le name,)2 445(appears to be an absolute)4 1051 2 3174 6962 t +10 I f +(f 2c)1 138 1 4708 6962 t +10 R f +(\256rst)4884 6962 w +(looks for)1 370 1 791 7082 t +10 I f +(stuff)1198 7082 w +10 R f +( to \256nd)2 308( Failing)1 346(in the directory of the \256le it is currently reading.)9 2033 3 1416 7082 t +10 I f +(stuff)4140 7082 w +10 R f +(there, it looks in)3 683 1 4357 7082 t +(directories speci\256ed by)2 934 1 791 7202 t +10 CW f +(-I)1789 7202 w +10 I f +(dir)1909 7202 w +10 R f +(command-line options; there can be several such options, each specifying)9 2984 1 2056 7202 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 4 5 +%%Page: 5 6 +/saveobj save def +mark +6 pagesetup +10 R f +(- 5 -)2 166 1 2797 480 t +(one directory.)1 558 1 791 840 t +10 CW f +(Include)1403 840 w +10 R f +( command-line option)2 889( The)1 208( depth, currently ten.)3 838(s may be nested to a reasonable)6 1282 4 1823 840 t +10 CW f +(-!I)791 960 w +10 R f +(disables)1020 960 w +10 CW f +(include)1391 960 w +10 R f +(s; this option is used by the)6 1234 1 1811 960 t +10 I f +( 2c)1 110(netlib f)1 305 2 3094 960 t +10 R f +( \(for which)2 493(service described in \2478)3 989 2 3558 960 t +10 CW f +(include)791 1080 w +10 R f +(obviously makes no sense\).)3 1099 1 1236 1080 t +10 S f +(\267)720 1260 w +10 I f +(F)791 1260 w +10 R f +(77 allows binary, octal, and hexadecimal constants to appear in)9 2598 1 860 1260 t +10 CW f +(data)3491 1260 w +10 R f +(statements;)3764 1260 w +10 I f +(f 2c)1 138 1 4247 1260 t +10 R f +(goes somewhat)1 622 1 4418 1260 t +( a decimal integer constant)4 1090(further, allowing such constants to appear anywhere; they are treated just like)11 3159 2 791 1380 t +( hexadecimal constants may assume one of two forms: a)9 2321( octal, and)2 427( Binary,)1 354(having the equivalent value.)3 1147 4 791 1500 t +( quoted string of digits, or a decimal base, followed by a sharp sign)13 2748(letter followed by a)3 797 2 791 1620 t +10 CW f +(#)4366 1620 w +10 R f +(, followed by a)3 614 1 4426 1620 t +( letter is)2 324( The)1 206(string of digits \(not quoted\).)4 1129 3 791 1740 t +10 CW f +(b)2476 1740 w +10 R f +(or)2562 1740 w +10 CW f +(B)2671 1740 w +10 R f +(for binary constants,)2 820 1 2757 1740 t +10 CW f +(o)3603 1740 w +10 R f +(or)3689 1740 w +10 CW f +(O)3798 1740 w +10 R f +(for octal constants, and)3 932 1 3884 1740 t +10 CW f +(x)4843 1740 w +10 R f +(,)4903 1740 w +10 CW f +(X)4955 1740 w +10 R f +(,)5015 1740 w +10 CW f +(z)791 1860 w +10 R f +(, or)1 185 1 851 1860 t +10 CW f +(Z)1113 1860 w +10 R f +( for example,)2 631( Thus,)1 326(for hexadecimal constants.)2 1169 3 1250 1860 t +10 CW f +(z'a7')3452 1860 w +10 R f +(,)3752 1860 w +10 CW f +(16#a7)3853 1860 w +10 R f +(,)4153 1860 w +10 CW f +(o'247')4254 1860 w +10 R f +(,)4614 1860 w +10 CW f +(8#247)4715 1860 w +10 R f +(,)5015 1860 w +10 CW f +(b'10100111')791 1980 w +10 R f +(and)1476 1980 w +10 CW f +(2#10100111)1645 1980 w +10 R f +(are all treated just like the integer)6 1336 1 2270 1980 t +10 CW f +(167)3631 1980 w +10 R f +(.)3811 1980 w +10 S f +(\267)720 2160 w +10 R f +(For compatibility with C, quoted strings may contain the following escapes:)10 3041 1 791 2160 t +10 S f +(_ __________________________________________)1 2129 1 1851 2250 t +10 CW f +(\\0)1901 2370 w +10 R f +(null)2171 2370 w +10 CW f +(\\n)3029 2370 w +10 R f +(newline)3323 2370 w +10 CW f +(\\\\)1901 2490 w +10 R f +(\\)2171 2490 w +10 CW f +(\\r)3029 2490 w +10 R f +(carriage return)1 583 1 3323 2490 t +10 CW f +(\\b)1901 2610 w +10 R f +(backspace)2171 2610 w +10 CW f +(\\t)3029 2610 w +10 R f +(tab)3323 2610 w +10 CW f +(\\f)1901 2730 w +10 R f +(form feed)1 390 1 2171 2730 t +10 CW f +(\\v)3029 2730 w +10 R f +(vertical tab)1 446 1 3323 2730 t +10 CW f +(\\')1972 2910 w +10 R f +(apostrophe \(does not terminate a string\))5 1589 1 2171 2910 t +10 CW f +(\\")1972 3030 w +10 R f +(quotation mark \(does not terminate a string\))6 1759 1 2171 3030 t +10 CW f +(\\)1972 3150 w +10 I f +(x x)1 183 1 2032 3150 t +10 R f +(, where)1 293 1 2215 3150 t +10 I f +(x)2533 3150 w +10 R f +(is any other character)3 855 1 2602 3150 t +10 S f +( \347)1 -2129(_ __________________________________________)1 2129 2 1851 3170 t +(\347)1851 3150 w +(\347)1851 3050 w +(\347)1851 2950 w +(\347)1851 2850 w +(\347)1851 2750 w +(\347)1851 2650 w +(\347)1851 2550 w +(\347)1851 2450 w +(\347)1851 2350 w +(\347)3980 3170 w +(\347)3980 3150 w +(\347)3980 3050 w +(\347)3980 2950 w +(\347)3980 2850 w +(\347)3980 2750 w +(\347)3980 2650 w +(\347)3980 2550 w +(\347)3980 2450 w +(\347)3980 2350 w +10 R f +(The)791 3360 w +10 CW f +(-!bs)971 3360 w +10 R f +(option tells)1 448 1 1236 3360 t +10 I f +(f 2c)1 138 1 1709 3360 t +10 R f +( dou-)1 209( strings may be delimited either by)6 1388( Quoted)1 344(not to recognize these escapes.)4 1227 4 1872 3360 t +(ble quotes \()2 482 1 791 3480 t +10 CW f +(")1298 3480 w +10 R f +(\) or by single quotes \()5 914 1 1383 3480 t +10 S f +(\242)2322 3480 w +10 R f +(\); if a string starts with one kind of quote, the other kind may be)14 2668 1 2372 3480 t +( possible, trans-)2 648( Where)1 324( escape.)1 324(embedded in the string without being repeated or quoted by a backslash)11 2953 4 791 3600 t +(lated strings are null-terminated.)3 1298 1 791 3720 t +10 S f +(\267)720 3900 w +10 R f +(Hollerith strings are treated as character strings.)6 1909 1 791 3900 t +10 S f +(\267)720 4080 w +10 R f +(In)791 4080 w +10 CW f +(equivalence)908 4080 w +10 R f +( given a single subscript, in which)6 1423(statements, a multiply-dimensioned array may be)5 2015 2 1602 4080 t +( subscripts are taken to be 1 \(for backward compatibility with Fortran 66\) and a warning)15 3584(case the missing)2 665 2 791 4200 t +(message is issued.)2 730 1 791 4320 t +10 S f +(\267)720 4500 w +10 R f +( library \()2 355(In a formatted read of non-character variables, the I/O)8 2172 2 791 4500 t +10 I f +(libI77)3318 4500 w +10 R f +(\) allows a \256eld to be terminated by a)8 1483 1 3557 4500 t +(comma.)791 4620 w +10 S f +(\267)720 4800 w +10 R f +(Type)791 4800 w +10 CW f +(real*4)1029 4800 w +10 R f +(is equivalent to)2 627 1 1422 4800 t +10 CW f +(real)2082 4800 w +10 R f +(,)2322 4800 w +10 CW f +(integer*4)2380 4800 w +10 R f +(to)2953 4800 w +10 CW f +(integer)3064 4800 w +10 R f +(,)3484 4800 w +10 CW f +(real*8)3542 4800 w +10 R f +(to)3935 4800 w +10 CW f +(double precision)1 969 1 4046 4800 t +10 R f +(,)5015 4800 w +10 CW f +(complex*8)791 4920 w +10 R f +(to)1356 4920 w +10 CW f +(complex)1459 4920 w +10 R f +(, and, as stated before,)4 889 1 1879 4920 t +10 CW f +(complex*16)2793 4920 w +10 R f +(to)3418 4920 w +10 CW f +(double complex)1 840 1 3521 4920 t +10 R f +(.)4361 4920 w +10 S f +(\267)720 5100 w +10 R f +(The type)1 372 1 791 5100 t +10 CW f +(integer*2)1208 5100 w +10 R f +(designates short integers \(translated to type)5 1828 1 1793 5100 t +10 CW f +(shortint)3666 5100 w +10 R f +( is)1 113(, which by default)3 781 2 4146 5100 t +10 CW f +(short int)1 562 1 791 5220 t +10 R f +( command-line)1 623( The)1 226( of storage.)2 488( integers are expected to occupy half a ``unit'')8 2020(\). Such)1 330 5 1353 5220 t +(options)791 5340 w +10 CW f +(-I2)1120 5340 w +10 R f +(and)1334 5340 w +10 CW f +(-i2)1512 5340 w +10 R f +(turn type)1 367 1 1726 5340 t +10 CW f +(integer)2127 5340 w +10 R f +(into)2581 5340 w +10 CW f +(integer*2)2771 5340 w +10 R f +(; see the)2 345 1 3311 5340 t +10 I f +(man)3690 5340 w +10 R f +(page \(appendix B\) for more)4 1144 1 3896 5340 t +(details.)791 5460 w +10 S f +(\267)720 5640 w +10 R f +(The binary intrinsic functions)3 1224 1 791 5640 t +10 CW f +(and)2053 5640 w +10 R f +(,)2233 5640 w +10 CW f +(or)2296 5640 w +10 R f +(,)2416 5640 w +10 CW f +(xor)2480 5640 w +10 R f +(,)2660 5640 w +10 CW f +(lshift)2724 5640 w +10 R f +(, and)1 208 1 3084 5640 t +10 CW f +(rshift)3331 5640 w +10 R f +(and the unary intrinsic function)4 1310 1 3730 5640 t +10 CW f +(not)791 5760 w +10 R f +(perform bitwise operations on)3 1234 1 1007 5760 t +10 CW f +(integer)2277 5760 w +10 R f +(or)2732 5760 w +10 CW f +(logical)2850 5760 w +10 R f +(operands. For)1 584 1 3305 5760 t +10 CW f +(lshift)3924 5760 w +10 R f +(and)4319 5760 w +10 CW f +(rshift)4498 5760 w +10 R f +(, the)1 182 1 4858 5760 t +(second operand tells how many bits to shift the \256rst operand.)10 2434 1 791 5880 t +10 S f +(\267)720 6060 w +10 I f +(LibF77)791 6060 w +10 R f +(provides two functions for accessing command-line arguments:)6 2655 1 1131 6060 t +10 CW f +(iargc\(dummy\))3831 6060 w +10 R f +(returns the)1 444 1 4596 6060 t +( ignores its argument\);)3 911(number of command-line arguments \(and)4 1674 2 791 6180 t +10 CW f +(getarg\(k,c\))3404 6180 w +10 R f +(sets the character string)3 948 1 4092 6180 t +10 CW f +(c)791 6300 w +10 R f +(to the)1 225 1 876 6300 t +10 I f +(k)1126 6300 w +10 R f +(th command-line argument \(or to blanks if)6 1698 1 1170 6300 t +10 I f +(k)2893 6300 w +10 R f +(is out of range\).)3 632 1 2962 6300 t +10 S f +(\267)720 6480 w +10 R f +(Variable,)791 6480 w +10 CW f +(common)1196 6480 w +10 R f +( the 50th)2 376(, and procedure names may be arbitrarily long, but they are truncated after)12 3108 2 1556 6480 t +( underscores \(in which case their translations will have a pair of)11 2712( names may contain)3 844(character. These)1 693 3 791 6600 t +(underscores appended\).)1 941 1 791 6720 t +10 S f +(\267)720 6900 w +10 R f +(MAIN programs may have arguments, which are ignored.)7 2314 1 791 6900 t +10 S f +(\267)720 7080 w +10 CW f +(Common)791 7080 w +10 R f +(variables may be initialized by a)5 1340 1 1185 7080 t +10 CW f +(data)2559 7080 w +10 R f +(statement in any module, not just in a)7 1563 1 2833 7080 t +10 CW f +(block data)1 610 1 4430 7080 t +10 R f +(subprogram.)791 7200 w +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 5 6 +%%Page: 6 7 +/saveobj save def +mark +7 pagesetup +10 R f +(- 6 -)2 166 1 2797 480 t +10 S f +(\267)720 900 w +10 R f +(The label may be omitted from a)6 1309 1 791 900 t +10 CW f +(do)2125 900 w +10 R f +(loop if the loop is terminated by an)7 1402 1 2270 900 t +10 CW f +(enddo)3697 900 w +10 R f +(statement.)4022 900 w +10 S f +(\267)720 1080 w +10 R f +(Unnamed Fortran 90)2 832 1 791 1080 t +10 CW f +(do while)1 480 1 1648 1080 t +10 R f +( a loop begins with a statement of the form)9 1712( Such)1 250(loops are allowed.)2 729 3 2153 1080 t +10 CW f +(do)2025 1200 w +10 R f +([)2205 1200 w +10 I f +(label)2238 1200 w +10 R f +(] [)1 91 1 2446 1200 t +10 CW f +(,)2537 1200 w +10 R f +(])2597 1200 w +10 CW f +(while\()2655 1200 w +10 I f +(logical expression)1 730 1 3015 1200 t +10 CW f +(\))3745 1200 w +10 R f +(and ends either after the statement labelled by)7 1832 1 791 1320 t +10 I f +(label)2648 1320 w +10 R f +(or after a matching)3 756 1 2873 1320 t +10 CW f +(enddo)3654 1320 w +10 R f +(.)3954 1320 w +10 S f +(\267)720 1500 w +10 I f +(F 2c)1 163 1 791 1500 t +10 R f +(recognizes the Fortran 90 synonyms)4 1464 1 983 1500 t +10 CW f +(<)2476 1500 w +10 R f +(,)2536 1500 w +10 CW f +(<=)2590 1500 w +10 R f +(,)2710 1500 w +10 CW f +(==)2764 1500 w +10 R f +(,)2884 1500 w +10 CW f +(>=)2938 1500 w +10 R f +(,)3058 1500 w +10 CW f +(>)3112 1500 w +10 R f +(, and)1 199 1 3172 1500 t +10 CW f +(<>)3401 1500 w +10 R f +(for the Fortran comparison operators)4 1489 1 3551 1500 t +10 CW f +(.LT.)791 1620 w +10 R f +(,)1031 1620 w +10 CW f +(.LE.)1081 1620 w +10 R f +(,)1321 1620 w +10 CW f +(.EQ.)1371 1620 w +10 R f +(,)1611 1620 w +10 CW f +(.GE.)1661 1620 w +10 R f +(,)1901 1620 w +10 CW f +(.GT.)1951 1620 w +10 R f +(, and)1 194 1 2191 1620 t +10 CW f +(.NE.)2410 1620 w +10 S f +(\267)720 1800 w +10 CW f +(Namelist)791 1800 w +10 R f +(works as in Fortran 90 [2], with a minor restriction on)10 2256 1 1306 1800 t +10 CW f +(namelist)3598 1800 w +10 R f +( must)1 231(input: subscripts)1 695 2 4114 1800 t +(have the form)2 554 1 791 1920 t +10 I f +(subscript)2240 2040 w +10 R f +([ :)1 86 1 2632 2040 t +10 I f +(subscript)2743 2040 w +10 R f +([ :)1 86 1 3135 2040 t +10 I f +(stride)3246 2040 w +10 R f +(] ])1 91 1 3499 2040 t +(For example, the Fortran)3 993 1 791 2160 t +9 CW f +(integer m\(8\))1 648 1 1008 2345 t +(real x\(10,10\))1 702 1 1008 2445 t +(namelist /xx/ m, x)3 972 1 1008 2545 t +(. . .)2 270 1 1008 2645 t +(read\(*,xx\))1008 2745 w +10 R f +(could read)1 418 1 791 2950 t +9 CW f +( = 9,10/)2 432( m\(7:8\))1 432(&xx x\(1,1\) = 2, x\(1:3,8:10:2\) = 1,2,3,4,5,6)6 2322 3 1008 3135 t +10 R f +(but would elicit error messages on the inputs)7 1790 1 791 3340 t +9 CW f +(&xx x\(:3,8:10:2\) = 1,2,3,4,5,6/)3 1674 1 1008 3525 t +( 1,2,3,4,5,6/)1 702( =)1 162(&xx x\(1:3,8::2\))1 810 3 1008 3625 t +(&xx m\(7:\) = 9,10/)3 918 1 1008 3725 t +10 R f +( with the)2 358( compatibility)1 562( For)1 192(\(which inputs would be legal in Fortran 90\).)7 1786 4 791 3930 t +10 CW f +(namelist)3718 3930 w +10 R f +(variants supplied by)2 813 1 4227 3930 t +(several vendors as Fortran 77 extensions,)5 1672 1 791 4050 t +10 I f +(f 2c)1 138 1 2492 4050 t +10 R f +('s version of)2 507 1 2630 4050 t +10 I f +(libI77)3166 4050 w +10 R f +(permits)3434 4050 w +10 CW f +($)3763 4050 w +10 R f +(to be used instead of)4 837 1 3852 4050 t +10 CW f +(&)4718 4050 w +10 R f +(and)4807 4050 w +10 CW f +(/)4980 4050 w +10 R f +(in)791 4170 w +10 CW f +(namelist)894 4170 w +10 R f +( the Fortran shown above could read)6 1458(input. Thus)1 481 2 1399 4170 t +9 CW f +( = 9,10$end)2 594( m\(7:8\))1 432($xx x\(1,1\) = 2, x\(1:3,8:10:2\) = 1,2,3,4,5,6)6 2322 3 1008 4355 t +10 S f +(\267)720 4620 w +10 R f +(Internal list-directed and namelist I/O are allowed.)6 2015 1 791 4620 t +10 S f +(\267)720 4800 w +10 R f +(In an)1 202 1 791 4800 t +10 CW f +(open)1018 4800 w +10 R f +(statement,)1283 4800 w +10 CW f +(name=)1716 4800 w +10 R f +(is treated as)2 471 1 2041 4800 t +10 CW f +(file=)2537 4800 w +10 R f +(.)2837 4800 w +10 S f +(\267)720 4980 w +10 R f +( start with a)3 469( They)1 255(Fortran 90 inline comments are allowed.)5 1620 3 791 4980 t +10 CW f +(!)3160 4980 w +10 R f +(anywhere but column 6.)3 965 1 3270 4980 t +10 B f +(4. INVOCATION EXAMPLES)2 1342 1 720 5269 t +10 R f +(To convert the Fortran \256les)4 1093 1 970 5440 t +10 CW f +(main.f)2088 5440 w +10 R f +(and)2473 5440 w +10 CW f +(subs.f)2642 5440 w +10 R f +(, one might use the UNIX)5 1032 1 3002 5440 t +10 S f +(\322)4034 5390 w +10 R f +(command:)4138 5440 w +9 CW f +(f2c main.f subs.f)2 918 1 1008 5625 t +10 R f +(This results in translated \256les suf\256xed with)6 1782 1 720 5830 t +10 CW f +(.c)2537 5830 w +10 R f +( the resulting C \256les are)5 1007(, i.e.,)1 207 2 2657 5830 t +10 CW f +(main.c)3907 5830 w +10 R f +(and)4303 5830 w +10 CW f +(subs.c)4483 5830 w +10 R f +(. To)1 197 1 4843 5830 t +( \256les in the current directory, compile the resulting C, and create an executable pro-)14 3379(translate all the Fortran)3 941 2 720 5950 t +(gram named)1 496 1 720 6070 t +10 CW f +(myprog)1241 6070 w +10 R f +(, one might use the following pair of UNIX commands:)9 2220 1 1601 6070 t +9 CW f +(f2c *.f)1 378 1 1008 6255 t +(cc -o myprog *.c -lF77 -lI77 -lm)6 1728 1 1008 6355 t +10 R f +(The above)1 430 1 720 6560 t +10 CW f +(-lF77)1187 6560 w +10 R f +(and)1524 6560 w +10 CW f +(-lI77)1705 6560 w +10 R f +(options assume that the ``standard'' Fortran support libraries)7 2511 1 2042 6560 t +10 I f +(libF77)4591 6560 w +10 R f +(and)4896 6560 w +10 I f +(libI77)720 6680 w +10 R f +(are appropriate for use with)4 1110 1 986 6680 t +10 I f +(f 2c)1 138 1 2123 6680 t +10 R f +( \2476\); if)2 274( some systems this is not the case \(as further discussed in)11 2306(. On)1 199 3 2261 6680 t +(one had installed a combination of the appropriate)7 2117 1 720 6800 t +10 I f +(libF77)2878 6800 w +10 R f +(and)3186 6800 w +10 I f +(libI77)3371 6800 w +10 R f +( the)1 164(in the appropriate place, then)4 1225 2 3651 6800 t +(above example might become)3 1195 1 720 6920 t +9 CW f +(f2c *.f)1 378 1 1008 7105 t +(cc -o myprog *.c -lf2c -lm)5 1404 1 1008 7205 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 6 7 +%%Page: 7 8 +/saveobj save def +mark +8 pagesetup +10 R f +(- 7 -)2 166 1 2797 480 t +(Sometimes it is desirable to use)5 1269 1 720 840 t +10 I f +(f 2c)1 138 1 2015 840 t +10 R f +('s)2153 840 w +10 CW f +(-R)2251 840 w +10 R f +(option, which tells)2 744 1 2397 840 t +10 I f +(f 2c)1 138 1 3167 840 t +10 R f +( all \257oating-point operations to)4 1247(not to force)2 462 2 3331 840 t +( might argue that)3 731( \(One)1 266(be done in double precision.)4 1197 3 720 960 t +10 CW f +(-R)2956 960 w +10 R f +( \256nd the current)3 683(should be the default, but we)5 1239 2 3118 960 t +(arrangement more convenient for testing)4 1624 1 720 1080 t +10 I f +(f 2c)1 138 1 2369 1080 t +10 R f +(.\) With)1 308 1 2507 1080 t +10 CW f +(-R)2840 1080 w +10 R f +(speci\256ed, the previous example becomes)4 1633 1 2985 1080 t +9 CW f +(f2c -R *.f)2 540 1 1008 1245 t +(cc -o myprog *.c -lf2c -lm)5 1404 1 1008 1345 t +10 R f +( is easily done by)4 706( This)1 230(Sometimes it is desirable to translate several Fortran source \256les into a single C \256le.)14 3384 3 720 1530 t +(using)720 1650 w +10 I f +(f 2c)1 138 1 962 1650 t +10 R f +(as a \256lter:)2 394 1 1125 1650 t +9 CW f +(cat *.f | f2c >mystuff.c)4 1296 1 1008 1815 t +10 R f +(The)720 2000 w +10 CW f +(-A)904 2000 w +10 R f +(option lets)1 424 1 1053 2000 t +10 I f +(f 2c)1 138 1 1506 2000 t +10 R f +( C when)2 343(use ANSI C constructs [3], which yields more readable)8 2236 2 1673 2000 t +10 CW f +(character)4282 2000 w +10 R f +(vari-)4852 2000 w +( both)1 203( With)1 250(ables are initialized.)2 801 3 720 2120 t +10 CW f +(-A)1999 2120 w +10 R f +(and)2144 2120 w +10 CW f +(-R)2313 2120 w +10 R f +(speci\256ed, the last example becomes)4 1428 1 2458 2120 t +9 CW f +(cat *.f | f2c -A -R >mystuff.c)6 1620 1 1008 2285 t +10 R f +(For use with C++ [15], one would specify)7 1677 1 720 2470 t +10 CW f +(-C++)2422 2470 w +10 R f +(rather than)1 429 1 2687 2470 t +10 CW f +(-A)3141 2470 w +10 R f +(; the last example would then become)6 1509 1 3261 2470 t +9 CW f +(cat *.f | f2c -C++ -R >mystuff.c)6 1728 1 1008 2635 t +10 R f +(The)720 2820 w +10 CW f +(-C++)900 2820 w +10 R f +( of character strings and)4 962(option gives ANSI-style headers and old-style C formatting)7 2384 2 1165 2820 t +10 CW f +(float)4537 2820 w +10 R f +(con-)4863 2820 w +(stants \(since some C++ compilers reject the ANSI versions of these constructs\).)11 3185 1 720 2940 t +10 R f +(With ANSI C, one can use)5 1075 1 720 3099 t +10 I f +(prototypes)1822 3099 w +10 R f +( the calling sequences of procedures,)5 1483(, i.e., a special syntax describing)5 1305 2 2252 3099 t +( make using prototypes convenient, the)5 1595( To)1 167( errors in argument passing.)4 1136(to help catch)2 524 4 720 3219 t +10 CW f +(-P)4173 3219 w +10 R f +(option causes)1 547 1 4324 3219 t +10 I f +(f 2c)1 138 1 4902 3219 t +10 R f +(to create a)2 431 1 720 3339 t +10 I f +(\256le)1187 3339 w +10 CW f +(.P)1309 3339 w +10 R f +( in each input)3 577(of prototypes for the procedures de\256ned)5 1654 2 1465 3339 t +10 I f +(\256le)3733 3339 w +10 CW f +(.f)3855 3339 w +10 R f +(\(or)4012 3339 w +10 I f +(\256le)4165 3339 w +10 CW f +(.F)4287 3339 w +10 R f +(, i.e., the suf\256x)3 633 1 4407 3339 t +(``)720 3459 w +10 CW f +(.f)786 3459 w +10 R f +('' or ``)2 271 1 906 3459 t +10 CW f +(.F)1177 3459 w +10 R f +('' is replaced by ``)4 748 1 1297 3459 t +10 CW f +(.P)2045 3459 w +10 R f +( into a header \256le)4 701( could concatenate all relevant prototype \256les)6 1831(''\). One)1 343 3 2165 3459 t +(and arrange for the header to be)6 1279 1 720 3579 t +10 CW f +(#include)2026 3579 w +10 R f +( could convert all the Fortran)5 1177( One)1 219( compiled.)1 425(d with each C \256le)4 713 4 2506 3579 t +(\256les in the current directory to ANSI C and get corresponding prototype \256les by issuing the command)16 4074 1 720 3699 t +9 CW f +(f2c -P -A *.f)3 702 1 1008 3864 t +10 R f +( an argument; thus to specify)5 1177(Several command options may be combined if none but perhaps the last takes)12 3143 2 720 4049 t +10 CW f +(-R)720 4169 w +10 R f +(and get C++ prototypes for all the \256les in the current directory, one could say either)15 3340 1 865 4169 t +9 CW f +(f2c -C++ -P -R *.f)4 972 1 1008 4334 t +10 R f +(or)720 4519 w +9 CW f +(f2c -C++PR *.f)2 756 1 1008 4684 t +10 R f +(or)720 4869 w +9 CW f +(f2c -RPC++ *.f)2 756 1 1008 5034 t +10 R f +(\320 options can come in any order.)6 1356 1 720 5219 t +10 R f +( data, the)2 369(For numeric variables initialized by character)5 1825 2 720 5378 t +10 CW f +(-W)2942 5378 w +10 R f +( num-)1 264(option speci\256es the \(machine-dependent!\))3 1686 2 3090 5378 t +( option takes a numeric argument, as in)7 1577( This)1 229( discussed in \2476.)3 664(ber of characters per word and is further)7 1616 4 720 5498 t +10 CW f +(-W8)4832 5498 w +10 R f +(;)5012 5498 w +(such an option must be listed either separately or at the end of a string of other options, as in)19 3690 1 720 5618 t +9 CW f +(f2c -C++RPW8 *.f)2 864 1 1008 5783 t +10 B f +(5. TRANSLATION DETAILS)2 1299 1 720 6034 t +10 I f +(F 2c)1 163 1 970 6193 t +10 R f +(is based on the ancient)4 960 1 1172 6193 t +10 I f +(f)2171 6193 w +10 R f +( compiler produced a C parse-tree,)5 1449( That)1 247(77 Fortran compiler of [6].)4 1129 3 2215 6193 t +( compiler has)2 550( The)1 211( converted into input for the second pass of the portable C compiler \(PCC\) [9].)14 3227(which it)1 332 4 720 6313 t +( it provided us)3 578( Thus,)1 276( of many current Fortran compilers.)5 1430(been used for many years and is the direct ancestor)9 2036 4 720 6433 t +( converter)1 401( The)1 205( base of Fortran knowledge and a nearly complete C representation.)10 2702(with a solid)2 469 4 720 6553 t +10 I f +(f 2c)1 138 1 4522 6553 t +10 R f +(is a copy)2 355 1 4685 6553 t +(of the)1 241 1 720 6673 t +10 I f +(f)997 6673 w +10 R f +( program being)2 634(77 Fortran compiler which has been altered to print out a C representation of the)14 3365 2 1041 6673 t +( program)1 371(converted. The)1 631 2 720 6793 t +10 I f +(f 2c)1 138 1 1755 6793 t +10 R f +(is a)1 144 1 1926 6793 t +10 I f +(horror)2103 6793 w +10 R f +( are only)2 363( Users)1 284( and hacked unmercifully.)3 1063(, based on ancient code)4 960 4 2370 6793 t +(supposed to look at its C output, not at its appalling inner workings.)12 2712 1 720 6913 t +10 R f +(Here are some examples that illustrate)5 1552 1 970 7072 t +10 I f +(f 2c)1 138 1 2552 7072 t +10 R f +( short but)2 390( starters, it is helpful to see a)7 1178( For)1 194('s translations.)1 588 4 2690 7072 t +(complete example:)1 757 1 720 7192 t +10 I f +(f 2c)1 138 1 1502 7192 t +10 R f +(turns the Fortran inner product routine)5 1534 1 1665 7192 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 7 8 +%%Page: 8 9 +/saveobj save def +mark +9 pagesetup +10 R f +(- 8 -)2 166 1 2797 480 t +9 CW f +(FUNCTION DOT\(N,X,Y\))1 1026 1 1332 820 t +(INTEGER N)1 486 1 1332 920 t +(REAL X\(N\),Y\(N\))1 756 1 1332 1020 t +(DOT = 0)2 378 1 1332 1120 t +(DO 10 I = 1, N)5 756 1 1332 1220 t +( = DOT + X\(I\)*Y\(I\))4 972(10 DOT)1 486 2 1116 1320 t +(END)1332 1420 w +10 R f +(into)720 1622 w +9 CW f +(/* dot.f -- translated by f2c \(version 19950314\).)7 2646 1 1008 1804 t +(You must link the resulting object file with the libraries:)9 3186 1 1170 1904 t +( that order\))2 648( \(in)1 324(-lf2c -lm)1 486 3 1440 2004 t +(*/)1008 2104 w +(#include "f2c.h")1 864 1 1008 2304 t +(doublereal dot_\(n, x, y\))3 1296 1 1008 2504 t +(integer *n;)1 594 1 1008 2604 t +(real *x, *y;)2 648 1 1008 2704 t +({)1008 2804 w +(/* System generated locals */)4 1566 1 1224 2904 t +(integer i__1;)1 702 1 1224 3004 t +(real ret_val;)1 702 1 1224 3104 t +(/* Local variables */)3 1134 1 1224 3304 t +(static integer i;)2 918 1 1224 3404 t +(/* Parameter adjustments */)3 1458 1 1224 3604 t +(--y;)1224 3704 w +(--x;)1224 3804 w +(/* Function Body */)3 1026 1 1224 4004 t +(ret_val = \(float\)0.;)2 1080 1 1224 4104 t +(i__1 = *n;)2 540 1 1224 4204 t +(for \(i = 1; i <= i__1; ++i\) {)8 1566 1 1224 4304 t +(/* L10: */)2 540 1 1008 4404 t +(ret_val += x[i] * y[i];)4 1242 1 1440 4504 t +(})1224 4604 w +(return ret_val;)1 810 1 1224 4704 t +(} /* dot_ */)3 648 1 1008 4804 t +10 R f +( by f2c'' comment and a)5 1048(The translated C always starts with a ``translated)7 2040 2 720 5106 t +10 CW f +(#include)3847 5106 w +10 R f +(of)4366 5106 w +10 CW f +(f2c.h)4488 5106 w +10 R f +(.)4788 5106 w +10 I f +(F 2c)1 163 1 4877 5106 t +10 R f +( an underscore to the external name)6 1418(forces the variable and procedure names to lower-case and appends)9 2697 2 720 5226 t +10 CW f +(dot)4860 5226 w +10 R f +( parameter adjustments ``)3 1041( The)1 213(\(to avoid possible con\257icts with library names\).)6 1955 3 720 5346 t +10 CW f +(--x)3929 5346 w +10 R f +('' and ``)2 342 1 4109 5346 t +10 CW f +(--y)4451 5346 w +10 R f +('' account)1 409 1 4631 5346 t +( labels are retained in comments for orienteering purposes.)8 2342( Unused)1 356(for the fact that C arrays start at index 0.)9 1622 3 720 5466 t +( into references to the local variable)6 1483(Within a function, Fortran references to the function name are turned)10 2837 2 720 5586 t +10 CW f +(ret_val)720 5706 w +10 R f +( the)1 150( Unless)1 325(, which holds the value to be returned.)7 1549 3 1140 5706 t +10 CW f +(-R)3192 5706 w +10 R f +(option is speci\256ed,)2 757 1 3339 5706 t +10 I f +(f 2c)1 138 1 4123 5706 t +10 R f +(converts the return)2 752 1 4288 5706 t +(type of)1 291 1 720 5826 t +10 CW f +(real)1047 5826 w +10 R f +(function values to)2 740 1 1324 5826 t +10 CW f +(doublereal)2101 5826 w +10 R f +( using the C ``op='' operators leads to greater)8 1920(. Because)1 419 2 2701 5826 t +(ef\256ciency on some machines,)3 1199 1 720 5946 t +10 I f +(f 2c)1 138 1 1950 5946 t +10 R f +(looks for opportunities to use these operators, as in the line ``)11 2502 1 2118 5946 t +10 CW f +(ret_val)4620 5946 w +(+= ...)1 360 1 720 6066 t +10 R f +('' above.)1 379 1 1080 6066 t +10 I f +(F 2c)1 163 1 970 6235 t +10 R f +( of evaluation)2 567(generally dispenses with super\257uous parentheses: ANSI C speci\256es a clear order)10 3307 2 1166 6235 t +(for \257oating-point expressions, and)3 1401 1 720 6355 t +10 I f +(f 2c)1 138 1 2156 6355 t +10 R f +(uses the ANSI C rules to decide when parentheses are required to)11 2712 1 2328 6355 t +( compilers are free to violate parenthe-)6 1605( Non-ANSI)1 497(faithfully translate a parenthesized Fortran expression.)5 2218 3 720 6475 t +(ses; by default,)2 614 1 720 6595 t +10 I f +(f 2c)1 138 1 1365 6595 t +10 R f +( to foil pernicious non-)4 936(does not attempt to break an expression into several statements)9 2570 2 1534 6595 t +( for example, the Fortran)4 995( Thus,)1 275(ANSI C compilers.)2 769 3 720 6715 t +9 CW f +(x = a*\(b*c\))2 594 1 1278 6897 t +(y = \(a*b\)*c)2 594 1 1278 6997 t +10 R f +(becomes)720 7199 w +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 8 9 +%%Page: 9 10 +/saveobj save def +mark +10 pagesetup +10 R f +(- 9 -)2 166 1 2797 480 t +9 CW f +(x = a * \(b * c\);)6 864 1 1224 820 t +(y = a * b * c;)6 756 1 1224 920 t +10 R f +(The)720 1100 w +10 CW f +(-kr)912 1100 w +10 R f +(and)1129 1100 w +10 CW f +(-krd)1310 1100 w +10 R f +(options cause)1 554 1 1587 1100 t +10 I f +(f 2c)1 138 1 2179 1100 t +10 R f +(to use temporary variables to force correct evaluation order with)9 2685 1 2355 1100 t +(non-ANSI C compilers.)2 952 1 720 1220 t +10 R f +(Fortran I/O is complicated; like)4 1296 1 970 1376 t +10 I f +(f)2301 1376 w +10 R f +(77,)2345 1376 w +10 I f +(f 2c)1 138 1 2505 1376 t +10 R f +(converts a Fortran I/O statement into calls on the Fortran)9 2362 1 2678 1376 t +(I/O library)1 426 1 720 1496 t +10 I f +(libI77)1173 1496 w +10 R f +( Fortran)1 321(. For)1 216 2 1412 1496 t +10 CW f +(read)1976 1496 w +10 R f +(s and)1 210 1 2216 1496 t +10 CW f +(write)2453 1496 w +10 R f +( to)1 104(s, there is generally one call to start the statement, one)10 2183 2 2753 1496 t +( the Fortran declarations)3 973( Given)1 294(end it, and one for each item read or written.)9 1776 3 720 1616 t +9 CW f +(integer count\(10\))1 918 1 1332 1776 t +(real val\(10\))1 648 1 1332 1876 t +10 R f +(the Fortran)1 441 1 720 2056 t +9 CW f +(read\(*,*\) count, val)2 1080 1 1332 2216 t +10 R f +(is turned into some header lines:)5 1296 1 720 2396 t +9 CW f +( = 3;)2 270( _3)1 130(static integer c_)2 918 3 1008 2556 t +( = 10;)2 324( _10)1 184(static integer c_)2 918 3 1008 2656 t +( = 4;)2 270( _4)1 130(static integer c_)2 918 3 1008 2756 t +(. . .)2 270 1 1008 2856 t +(/* Builtin functions */)3 1242 1 1224 2956 t +(integer s_rsle\(\), do_lio\(\), e_rsle\(\);)3 1998 1 1224 3056 t +(. . .)2 270 1 1008 3156 t +(/* Fortran I/O blocks */)4 1296 1 1224 3256 t +( = { 0, 5, 0, 0, 0 };)8 1134( _1)1 130(static cilist io_)2 918 3 1224 3356 t +10 R f +(and the executable lines)3 956 1 720 3536 t +9 CW f +(s_rsle\(&io_ _1\);)1 832 1 1008 3696 t +( \(char *\)&count[0], \(ftnlen\)sizeof\(integer\)\);)3 2430( _10,)1 238( &c_)1 216(do_lio\(&c_ _3,)1 724 4 1008 3796 t +( \(char *\)&val[0], \(ftnlen\)sizeof\(real\)\);)3 2160( _10,)1 238( &c_)1 216(do_lio\(&c_ _4,)1 724 4 1008 3896 t +(e_rsle\(\);)1008 3996 w +10 R f +(Implicit Fortran do-loops, e.g.)3 1205 1 720 4176 t +9 CW f +(read\(*,*\) \(count\(i\), val\(i\), i = 1, 10\))6 2106 1 1332 4336 t +10 R f +(get turned into explicit C loops:)5 1270 1 720 4516 t +9 CW f +(s_rsle\(&io_ _4\);)1 832 1 1008 4676 t +(for \(i = 1; i <= 10; ++i\) {)8 1458 1 1008 4776 t +( \(char *\)&count[i - 1], \(ftnlen\)sizeof\(integer\)\);)5 2646( _1,)1 184( &c_)1 216(do_lio\(&c_ _3,)1 724 4 1224 4876 t +( \(char *\)&val[i - 1], \(ftnlen\)sizeof\(real\)\);)5 2376( _1,)1 184( &c_)1 216(do_lio\(&c_ _4,)1 724 4 1224 4976 t +(})1008 5076 w +(e_rsle\(\);)1008 5176 w +10 R f +(The Fortran)1 478 1 720 5356 t +10 CW f +(end=)1227 5356 w +10 R f +(and)1496 5356 w +10 CW f +(err=)1669 5356 w +10 R f +( as they require tests to be)6 1067(speci\256ers make the resulting C even less readable,)7 2035 2 1938 5356 t +( example,)1 388(inserted. For)1 530 2 720 5476 t +9 CW f +(read\(*,*,err=10\) count, val)2 1458 1 1332 5636 t +(10 continue)1 702 1 1062 5736 t +10 R f +(becomes)720 5916 w +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 9 10 +%%Page: 10 11 +/saveobj save def +mark +11 pagesetup +10 R f +(- 10 -)2 216 1 2772 480 t +9 CW f +( _1\);)1 238( = s_rsle\(&io_)2 756(i_ _1)1 238 3 1224 820 t +( != 0\) {)3 432( _1)1 130(if \(i_)1 324 3 1224 920 t +(goto L10;)1 486 1 1440 1020 t +(})1224 1120 w +( \(char *\)&count[0], \(ftnlen\)sizeof\(integer\)\);)3 2430( _10,)1 238( &c_)1 216( _3,)1 184( = do_lio\(&c_)2 702(i_ _1)1 238 6 1224 1220 t +( != 0\) {)3 432( _1)1 130(if \(i_)1 324 3 1224 1320 t +(goto L10;)1 486 1 1440 1420 t +(})1224 1520 w +( \(char *\)&val[0], \(ftnlen\)sizeof\(real\)\);)3 2160( _10,)1 238( &c_)1 216( _4,)1 184( = do_lio\(&c_)2 702(i_ _1)1 238 6 1224 1620 t +( != 0\) {)3 432( _1)1 130(if \(i_)1 324 3 1224 1720 t +(goto L10;)1 486 1 1440 1820 t +(})1224 1920 w +( = e_rsle\(\);)2 648(i_ _1)1 238 2 1224 2020 t +(L10:)1008 2120 w +(;)1224 2220 w +10 R f +(A Fortran routine containing)3 1146 1 970 2400 t +10 I f +(n)2141 2400 w +10 CW f +(entry)2216 2400 w +10 R f +(statements is turned into)3 975 1 2541 2400 t +10 I f +(n)3542 2400 w +10 S f +(+)3632 2400 w +10 R f +(2 C functions, a big one contain-)6 1313 1 3727 2400 t +(ing the translation of everything but the)6 1630 1 720 2520 t +10 CW f +(entry)2383 2520 w +10 R f +(statements, and)1 624 1 2716 2520 t +10 I f +(n)3373 2520 w +10 S f +(+)3463 2520 w +10 R f +(1 little ones that invoke the big one.)7 1482 1 3558 2520 t +( to the big one to tell it where to begin; the big one starts with a)16 2676(Each little one passes a different integer)6 1644 2 720 2640 t +( instance, the Fortran)3 843( For)1 189(switch that branches to the code for the appropriate entry.)9 2300 3 720 2760 t +9 CW f +(function sine\(x\))1 864 1 1332 2920 t +(data pi/3.14159265358979324/)1 1512 1 1332 3020 t +(sine = sin\(x\))2 702 1 1332 3120 t +(return)1332 3220 w +(entry cosneg\(y\))1 810 1 1332 3320 t +(cosneg = cos\(y+pi\))2 972 1 1332 3420 t +(return)1332 3520 w +(end)1332 3620 w +10 R f +(is turned into the big procedure)5 1251 1 720 3800 t +9 CW f +( x, y\))2 324( _,)1 130(doublereal sine_0_\(n_)1 1134 3 1008 3960 t +( _;)1 130(int n_)1 324 2 1008 4060 t +(real *x, *y;)2 648 1 1008 4160 t +({)1008 4260 w +(/* Initialized data */)3 1188 1 1224 4360 t +(static real pi = \(float\)3.14159265358979324;)4 2376 1 1224 4560 t +(/* System generated locals */)4 1566 1 1224 4760 t +(real ret_val;)1 702 1 1224 4860 t +(/* Builtin functions */)3 1242 1 1224 5060 t +(double sin\(\), cos\(\);)2 1080 1 1224 5160 t +( {)1 108(switch\(n_ _\))1 616 2 1224 5360 t +(case 1: goto L_cosneg;)3 1188 1 1440 5460 t +(})1440 5560 w +(ret_val = sin\(*x\);)2 972 1 1224 5760 t +(return ret_val;)1 810 1 1224 5860 t +(L_cosneg:)1008 6060 w +(ret_val = cos\(*y + pi\);)4 1242 1 1224 6160 t +(return ret_val;)1 810 1 1224 6260 t +(} /* sine_ */)3 702 1 1008 6360 t +10 R f +(and the little invoking procedures)4 1343 1 720 6540 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 10 11 +%%Page: 11 12 +/saveobj save def +mark +12 pagesetup +10 R f +(- 11 -)2 216 1 2772 480 t +9 CW f +(doublereal sine_\(x\))1 1026 1 1008 820 t +(real *x;)1 432 1 1008 920 t +({)1008 1020 w +(return sine_0_\(0, x, \(real *\)0\);)4 1728 1 1224 1120 t +(})1224 1220 w +(doublereal cosneg_\(y\))1 1134 1 1008 1420 t +(real *y;)1 432 1 1008 1520 t +({)1008 1620 w +(return sine_0_\(1, \(real *\)0, y\);)4 1728 1 1224 1720 t +(})1224 1820 w +10 R f +(Fortran)720 2002 w +10 CW f +(common)1039 2002 w +10 R f +(regions are turned into C)4 993 1 1424 2002 t +10 CW f +(struct)2442 2002 w +10 R f +( example, the Fortran declarations)4 1361(s. For)1 253 2 2802 2002 t +9 CW f +(common /named/ c, d, r, i, m)6 1512 1 1332 2164 t +(complex c\(10\))1 702 1 1332 2264 t +(double precision d\(10\))2 1188 1 1332 2364 t +(real r\(10\))1 540 1 1332 2464 t +(integer i\(10\))1 702 1 1332 2564 t +(logical m\(10\))1 702 1 1332 2664 t +(if \(m\(i\(2\)\)\) d\(3\) = d\(4\)/d\(5\))4 1566 1 1332 2864 t +10 R f +(result in)1 325 1 720 3046 t +9 CW f +(struct {)1 432 1 1008 3208 t +(complex c[10];)1 756 1 1224 3308 t +(doublereal d[10];)1 918 1 1224 3408 t +(real r[10];)1 594 1 1224 3508 t +(integer i[10];)1 756 1 1224 3608 t +(logical m[10];)1 756 1 1224 3708 t +(} named_;)1 486 1 1008 3808 t +(#define named_1 named_)2 1188 1 1008 4008 t +(. . .)2 270 1 1008 4108 t +(if \(named_1.m[named_1.i[1] - 1]\) {)4 1836 1 1224 4308 t +(named_1.d[2] = named_1.d[3] / named_1.d[4];)4 2322 1 1440 4408 t +(})1440 4508 w +10 R f +(Under the)1 396 1 720 4690 t +10 CW f +(-p)1141 4690 w +10 R f +(option, the above)2 691 1 1286 4690 t +10 CW f +(if)2002 4690 w +10 R f +(statement becomes more readable:)3 1377 1 2147 4690 t +9 CW f +(. . .)2 270 1 1008 4852 t +(#define c \(named_1.c\))2 1134 1 1008 4952 t +(#define d \(named_1.d\))2 1134 1 1008 5052 t +(#define r \(named_1.r\))2 1134 1 1008 5152 t +(#define i \(named_1.i\))2 1134 1 1008 5252 t +(#define m \(named_1.m\))2 1134 1 1008 5352 t +(. . .)2 270 1 1008 5452 t +(if \(m[i[1] - 1]\) {)4 972 1 1224 5552 t +(d[2] = d[3] / d[4];)4 1026 1 1440 5652 t +10 R f +(If the above)2 476 1 720 5834 t +10 CW f +(common)1221 5834 w +10 R f +(block were involved in a)4 987 1 1606 5834 t +10 CW f +(block data)1 600 1 2618 5834 t +10 R f +(subprogram, e.g.)1 671 1 3243 5834 t +9 CW f +(block data)1 540 1 1332 5996 t +(common /named/ c, d, r, i, l, m)7 1674 1 1332 6096 t +(complex c\(10\))1 702 1 1332 6196 t +(double precision d\(10\))2 1188 1 1332 6296 t +(real r\(10\))1 540 1 1332 6396 t +(integer i\(10\))1 702 1 1332 6496 t +(logical m\(10\))1 702 1 1332 6596 t +(data c\(1\)/\(1.0,0e0\)/, d\(2\)/2d0/, r\(3\)/3e0/, i\(4\)/4/,)4 2808 1 1332 6696 t +(* m\(5\)/.false./)1 1026 1 1278 6796 t +(end)1332 6896 w +10 R f +(then the)1 345 1 720 7078 t +10 CW f +(struct)1116 7078 w +10 R f +(would begin ``)2 640 1 1527 7078 t +10 CW f +(struct named_1_ {)2 1072 1 2167 7078 t +10 R f +('', and)1 287 1 3239 7078 t +10 I f +(f 2c)1 138 1 3578 7078 t +10 R f +(would issue a more elaborate)4 1272 1 3768 7078 t +10 CW f +(#define)720 7198 w +10 R f +(:)1140 7198 w +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 11 12 +%%Page: 12 13 +/saveobj save def +mark +13 pagesetup +10 R f +(- 12 -)2 216 1 2772 480 t +9 CW f +(#define named_1 \(*\(struct named_1_ *\) &named_\))5 2484 1 1008 820 t +(/* Initialized data */)3 1188 1 1008 1020 t +(struct {)1 432 1 1008 1220 t +(complex e_1;)1 648 1 1224 1320 t +(doublereal fill_2[10];)1 1188 1 1224 1420 t +(doublereal e_3;)1 810 1 1224 1520 t +(doublereal fill_4[9];)1 1134 1 1224 1620 t +(real e_5;)1 486 1 1224 1720 t +(integer fill_6[10];)1 1026 1 1224 1820 t +(integer e_7;)1 648 1 1224 1920 t +(integer fill_8[11];)1 1026 1 1224 2020 t +(logical e_9;)1 648 1 1224 2120 t +(integer fill_10[5];)1 1026 1 1224 2220 t +(} named_ = { \(float\)1., \(float\)0., {0}, 2., {0}, \(float\)3., {0}, 4,)11 3618 1 1224 2320 t +( };)1 162({0}, FALSE_)1 648 2 1656 2420 t +10 R f +(In this example,)2 655 1 720 2600 t +10 I f +(f 2c)1 138 1 1407 2600 t +10 R f +( initialization rules to supply zeros to the)7 1686(relies on C's structure)3 900 2 1577 2600 t +10 CW f +(fill_)4231 2600 w +10 I f +(n)4531 2600 w +10 R f +(arrays that)1 426 1 4614 2600 t +(take up the space for which no)6 1261 1 720 2720 t +10 CW f +(data)2013 2720 w +10 R f +( logical constants)2 706( \(The)1 244(values were given.)2 757 3 2284 2720 t +10 CW f +(TRUE_)4022 2720 w +10 R f +(and)4353 2720 w +10 CW f +(FALSE_)4528 2720 w +10 R f +(are)4919 2720 w +(de\256ned in)1 397 1 720 2840 t +10 CW f +(f2c.h)1142 2840 w +10 R f +(.\))1442 2840 w +10 R f +( example,)1 390( For)1 191( of multiple-character strings generally result in function calls.)8 2509(Character manipulations)1 980 4 970 2996 t +(the Fortran)1 441 1 720 3116 t +9 CW f +(character*\(*\) function cat\(a,b\))2 1674 1 1332 3276 t +(character*\(*\) a, b)2 972 1 1332 3376 t +(cat = a // b)4 648 1 1332 3476 t +(end)1332 3576 w +10 R f +(yields)720 3756 w +9 CW f +(. . .)2 270 1 1008 3916 t +( = 2;)2 270( _2)1 130(static integer c_)2 918 3 1008 4016 t +(/* Character */ int cat_\(ret_val, ret_val_len, a, b, a_len, b_len\))9 3564 1 1008 4216 t +(char *ret_val;)1 756 1 1008 4316 t +(ftnlen ret_val_len;)1 1026 1 1008 4416 t +(char *a, *b;)2 648 1 1008 4516 t +(ftnlen a_len;)1 702 1 1008 4616 t +(ftnlen b_len;)1 702 1 1008 4716 t +({)1008 4816 w +(/* System generated locals */)4 1566 1 1224 5016 t +( _1[2];)1 346(address a_)1 540 2 1224 5116 t +( _1[2];)1 346(integer i_)1 540 2 1224 5216 t +(/* Builtin functions */)3 1242 1 1224 5416 t +(/* Subroutine */ int s_cat\(\);)4 1566 1 1224 5516 t +(/* Writing concatenation */)3 1458 1 1008 5716 t +( = a;)2 270( _1[0])1 292( = a_len, a_)3 648(i_ _1[0])1 400 4 1224 5816 t +( = b;)2 270( _1[1])1 292( = b_len, a_)3 648(i_ _1[1])1 400 4 1224 5916 t +( ret_val_len\);)1 756( _2,)1 184( &c_)1 216( _1,)1 184( i_)1 162( _1,)1 184(s_cat\(ret_val, a_)1 918 7 1224 6016 t +(} /* cat_ */)3 648 1 1008 6116 t +10 R f +( \()1 64(Note how the return-value length)4 1345 2 720 6296 t +10 CW f +(ret_val_len)2129 6296 w +10 R f +(\) and parameter lengths \()4 1021 1 2789 6296 t +10 CW f +(a_len)3810 6296 w +10 R f +(and)4141 6296 w +10 CW f +(b_len)4316 6296 w +10 R f +(\) are used.)2 424 1 4616 6296 t +( example, the body of the Fortran)6 1334( For)1 189(Single character operations are generally done in-line.)6 2158 3 720 6416 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 12 13 +%%Page: 13 14 +/saveobj save def +mark +14 pagesetup +10 R f +(- 13 -)2 216 1 2772 480 t +9 CW f +(character*1 function lastnb\(x,n\))2 1728 1 1332 820 t +(character*1 x\(n\))1 864 1 1332 920 t +(lastnb = ' ')3 648 1 1332 1020 t +(do 10 i = n, 1, -1)6 972 1 1332 1120 t +(if \(x\(i\) .ne. ' '\) then)5 1242 1 1494 1220 t +(lastnb = x\(i\))2 702 1 1656 1320 t +(return)1656 1420 w +(end if)1 324 1 1656 1520 t +(10 continue)1 864 1 1062 1620 t +(end)1332 1720 w +10 R f +(becomes)720 1970 w +9 CW f +(*ret_val = ' ';)3 810 1 1224 2200 t +(for \(i = *n; i >= 1; --i\) {)8 1458 1 1224 2300 t +(if \(x[i] != ' '\) {)5 972 1 1440 2400 t +(*ret_val = x[i];)2 864 1 1656 2500 t +(return ;)1 432 1 1656 2600 t +(})1440 2700 w +(/* L10: */)2 540 1 1008 2800 t +(})1224 2900 w +10 I f +(F 2c)1 163 1 970 3150 t +10 R f +(uses)1159 3150 w +10 CW f +(struct)1357 3150 w +10 R f +(s and)1 209 1 1717 3150 t +10 CW f +(#define)1952 3150 w +10 R f +(s to translate)2 507 1 2372 3150 t +10 CW f +(equivalence)2905 3150 w +10 R f +( complicated example show-)3 1151( a)1 70(s. For)1 254 3 3565 3150 t +(ing the interaction of)3 880 1 720 3270 t +10 CW f +(data)1640 3270 w +10 R f +(with)1920 3270 w +10 CW f +(common)2138 3270 w +10 R f +(,)2498 3270 w +10 CW f +(equivalence)2563 3270 w +10 R f +( good measure, Hollerith notation,)4 1427(, and, for)2 390 2 3223 3270 t +(consider the Fortran)2 804 1 720 3390 t +9 CW f +(common /cmname/ c)2 918 1 1332 3620 t +(complex c\(10\))1 702 1 1332 3720 t +(double precision d\(10\))2 1188 1 1332 3820 t +(real r\(10\))1 540 1 1332 3920 t +(integer i\(10\))1 702 1 1332 4020 t +(logical m\(10\))1 702 1 1332 4120 t +(equivalence \(c\(1\),d\(1\),r\(1\),i\(1\),m\(1\)\))1 2052 1 1332 4220 t +(data c\(1\)/\(1.,0.\)/)1 972 1 1332 4320 t +(data d\(2\)/2d0/, r\(5\)/3e0/, i\(6\)/4/, m\(7\)/.true./)4 2592 1 1332 4420 t +(call sam\(c,d\(1\),r\(2\),i\(3\),m\(4\),14hsome hollerith,14\))2 2808 1 1332 4520 t +(end)1332 4620 w +10 R f +(The resulting C is)3 714 1 720 4870 t +9 CW f +(. . .)2 270 1 1008 5100 t +(struct cmname_1_ {)2 972 1 1008 5200 t +(complex c[10];)1 756 1 1224 5300 t +(};)1008 5400 w +(#define cmname_1 \(*\(struct cmname_1_ *\) &cmname_\))5 2646 1 1008 5600 t +(/* Initialized data */)3 1188 1 1008 5800 t +(struct {)1 432 1 1008 6000 t +(complex e_1;)1 648 1 1224 6100 t +(doublereal e_2;)1 810 1 1224 6200 t +(real e_3;)1 486 1 1224 6300 t +(integer e_4;)1 648 1 1224 6400 t +(logical e_5;)1 648 1 1224 6500 t +(integer fill_6[13];)1 1026 1 1224 6600 t +(} cmname_ = { \(float\)1., \(float\)0., 2., \(float\)3., 4, TRUE_ };)10 3348 1 1224 6700 t +(/* Table of constant values */)5 1620 1 1008 7000 t +( = 14;)2 324( _14)1 184(static integer c_)2 918 3 1008 7200 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 13 14 +%%Page: 14 15 +/saveobj save def +mark +15 pagesetup +10 R f +(- 14 -)2 216 1 2772 480 t +9 CW f +( _\(\))1 184(/* Main program */ MAIN_)4 1296 2 1008 820 t +({)1008 920 w +(/* Local variables */)3 1134 1 1224 1120 t +(#define d \(\(doublereal *\)&cmname_1\))3 1890 1 1008 1320 t +(#define i \(\(integer *\)&cmname_1\))3 1728 1 1008 1420 t +(#define l \(\(logical *\)&cmname_1\))3 1728 1 1008 1520 t +(#define r \(\(real *\)&cmname_1\))3 1566 1 1008 1620 t +(extern /* Subroutine */ int sam_\(\);)5 1890 1 1224 1720 t +( 14L\);)1 324( _14,)1 238(sam_\(cmname_1.c, d, &r[1], &i[2], &m[3], "some hollerith", &c_)7 3348 3 1224 1920 t +( */)1 162( _)1 76(} /* MAIN_)2 540 3 1008 2020 t +(#undef r)1 432 1 1008 2220 t +(#undef l)1 432 1 1008 2320 t +(#undef i)1 432 1 1008 2420 t +(#undef d)1 432 1 1008 2520 t +10 R f +(As this example shows,)3 965 1 720 2715 t +10 I f +(f 2c)1 138 1 1717 2715 t +10 R f +( function named)2 665(turns a Fortran MAIN program into a C)7 1633 2 1887 2715 t +10 CW f +(MAIN_ _)1 384 1 4218 2715 t +10 R f +( not)1 161(. Why)1 277 2 4602 2715 t +10 CW f +(main)720 2835 w +10 R f +(? Well,)1 319 1 960 2835 t +10 I f +(libF77)1310 2835 w +10 R f +( for \256les to be closed automatically when the)8 1832(contains a C main routine that arranges)6 1600 2 1608 2835 t +( to be printed if a \257oating-point exception occurs, and)9 2183(Fortran program stops, arranges for an error message)7 2137 2 720 2955 t +(arranges for the command-line argument accessing functions)6 2463 1 720 3075 t +10 CW f +(iargc)3213 3075 w +10 R f +(and)3542 3075 w +10 CW f +(getarg)3715 3075 w +10 R f +( This)1 232(to work properly.)2 704 2 4104 3075 t +(C main routine invokes)3 936 1 720 3195 t +10 CW f +(MAIN_ _)1 384 1 1681 3195 t +10 R f +(.)2065 3195 w +10 B f +( ISSUES)1 371(6. PORTABILITY)1 826 2 720 3465 t +10 R f +(Three portability issues are relevant to)5 1543 1 970 3630 t +10 I f +(f 2c)1 138 1 2540 3630 t +10 R f +( libraries \()2 416(: the portability of the support)5 1207 2 2678 3630 t +10 I f +(libF77)4301 3630 w +10 R f +(and)4596 3630 w +10 I f +(libI77)4768 3630 w +10 R f +(\))5007 3630 w +(upon which the translated C programs rely, that of the converter)10 2559 1 720 3750 t +10 I f +(f 2c)1 138 1 3304 3750 t +10 R f +(itself, and that of the C it produces.)7 1407 1 3467 3750 t +10 R f +( vendors \(e.g., Sun and MIPS\) have changed the calling conventions)10 2812(Regarding the \256rst issue, some)4 1258 2 970 3915 t +(for their)1 330 1 720 4035 t +10 I f +(libI77)1081 4035 w +10 R f +( MIPS\) have changed the)4 1029( vendors \(e.g.,)2 580( Other)1 283(from the original conventions \(those of [6]\).)6 1797 4 1351 4035 t +10 I f +(libF77)720 4155 w +10 R f +(calling conventions \(e.g., for)3 1154 1 1014 4155 t +10 CW f +(complex)2196 4155 w +10 R f +( having libraries)2 655( Thus,)1 278(-valued functions\).)1 757 3 2616 4155 t +10 I f +(libF77)4334 4155 w +10 R f +(and)4629 4155 w +10 I f +(libI77)4801 4155 w +10 R f +(or otherwise having library routines with the names that)8 2260 1 720 4275 t +10 I f +(f 2c)1 138 1 3008 4275 t +10 R f +( using a machine)3 680( When)1 290( insuf\256cient.)1 502(expects is)1 394 4 3174 4275 t +(whose vendor provides but has gratuitously changed)6 2133 1 720 4395 t +10 I f +(libF77)2884 4395 w +10 R f +(or)3182 4395 w +10 I f +(libI77)3296 4395 w +10 R f +( objects com-)2 552(, one cannot safely mix)4 953 2 3535 4395 t +(piled from the C produced by)5 1224 1 720 4515 t +10 I f +(f 2c)1 138 1 1978 4515 t +10 R f +(with objects compiled by the vendor's Fortran compiler, and one must)10 2891 1 2149 4515 t +(use the correct libraries with programs translated by)7 2104 1 720 4635 t +10 I f +(f 2c)1 138 1 2853 4635 t +10 R f +( is to)2 205( such a case, the recommended procedure)6 1682(. In)1 162 3 2991 4635 t +(obtain source for the libraries \(e.g. from)6 1602 1 720 4755 t +10 I f +(netlib)2348 4755 w +10 R f +( them into a single library, say)6 1213(\320 see \2478\), combine)3 807 2 2610 4755 t +10 CW f +(libf2c)4655 4755 w +10 R f +(,)5015 4755 w +( a UNIX system, for example, one)6 1429( On)1 182(and install the library where it they can be conveniently accessed.)10 2709 3 720 4875 t +(might install)1 504 1 720 4995 t +10 CW f +(libf2c)1249 4995 w +10 R f +(in)1634 4995 w +10 CW f +(/usr/lib/libf2c.a)1737 4995 w +10 R f +(; then one could issue the command)6 1432 1 2757 4995 t +9 CW f +(cc *.c -lf2c -lm)3 864 1 1008 5170 t +10 R f +(to compile and link a program translated by)7 1745 1 720 5365 t +10 I f +(f 2c)1 138 1 2490 5365 t +10 R f +(.)2628 5365 w +10 R f +( IBM, MIPS,)2 549(The converter itself is reasonably portable and has run successfully on Apollo, Cray,)12 3521 2 970 5530 t +( However,)1 448( UNIX operating system.)3 1028(SGI, Sun and DEC VAX equipment, all running some version of the)11 2844 3 720 5650 t +( be portable due to subtle storage management issues in Fortran)10 2581(we shall see that the C it produces may not)9 1739 2 720 5770 t +( any case, the C output of)6 1036(77. In)1 261 2 720 5890 t +10 I f +(f 2c)1 138 1 2045 5890 t +10 R f +( least if the)3 447(will run \256ne, at)3 620 2 2211 5890 t +10 CW f +(-W)3305 5890 w +10 I f +(n)3425 5890 w +10 R f +(option \(see Appendix B\) is used to set)7 1538 1 3502 5890 t +(the number of characters per word correctly, and if C)9 2121 1 720 6010 t +10 CW f +(double)2866 6010 w +10 R f +(values may fall on an odd-word boundary.)6 1694 1 3251 6010 t +10 R f +(The Fortran 77 standard says that)5 1474 1 970 6175 t +10 CW f +(Complex)2497 6175 w +10 R f +(and)2970 6175 w +10 CW f +(Double Precision)1 989 1 3168 6175 t +10 R f +(objects occupy two)2 829 1 4211 6175 t +( may be necessary to edit the)6 1177( It)1 116(``units'' of space while other non-character data types occupy one ``unit.'')10 3027 3 720 6295 t +(header \256le)1 430 1 720 6415 t +10 CW f +(f2c.h)1187 6415 w +10 R f +( the Cray, for example,)4 972( On)1 185(to make these assumptions hold, if possible.)6 1839 3 1524 6415 t +10 CW f +(float)4558 6415 w +10 R f +(and)4896 6415 w +10 CW f +(double)720 6535 w +10 R f +( C types, and Fortran double precision, if available, would correspond to the C type)14 3416(are the same)2 512 2 1112 6535 t +10 CW f +(long double)1 660 1 720 6655 t +10 R f +( this case, changing the de\256nition of)6 1446(. In)1 158 2 1380 6655 t +10 CW f +(doublereal)3009 6655 w +10 R f +(in)3634 6655 w +10 CW f +(f2c.h)3737 6655 w +10 R f +(from)4062 6655 w +9 CW f +(typedef double doublereal;)2 1404 1 1008 6830 t +10 R f +(to)720 7025 w +9 CW f +(typedef long double doublereal;)3 1674 1 1008 7200 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 14 15 +%%Page: 15 16 +/saveobj save def +mark +16 pagesetup +10 R f +(- 15 -)2 216 1 2772 480 t +( the Think C compiler on the Macintosh, on the other hand, this line would need)15 3251( For)1 192(would be appropriate.)2 877 3 720 840 t +(to become)1 413 1 720 960 t +9 CW f +(typedef short double doublereal;)3 1728 1 1008 1135 t +10 R f +( prede\256nes symbols that could clash with translated Fortran variable names, then)11 3306(If your C compiler)3 764 2 970 1330 t +( appropriate)1 480(you should also add)3 803 2 720 1450 t +10 CW f +(#undef)2029 1450 w +10 R f +(lines to)1 293 1 2415 1450 t +10 CW f +(f2c.h)2734 1450 w +10 R f +( current default)2 611(. The)1 231 2 3034 1450 t +10 CW f +(f2c.h)3902 1450 w +10 R f +(provides the follow-)2 812 1 4228 1450 t +(ing)720 1570 w +10 CW f +(#undef)873 1570 w +10 R f +(lines for the following symbols:)4 1278 1 1258 1570 t +10 CW f +( u370 u3b5)2 780( sun2)1 510( sgi)1 330(cray mc68020)1 990 4 1575 1765 t +( unix)1 450( sun3 u3b)2 720(gcos mips sparc)2 1440 3 1575 1885 t +( u3b2 vax)2 720( sun sun4)2 960(mc68010 pdp11)1 870 3 1575 2005 t +10 R f +(As an extension to the Fortran 77 Standard,)7 1786 1 970 2200 t +10 I f +(f 2c)1 138 1 2788 2200 t +10 R f +( variables to be initialized with)5 1275(allows noncharacter)1 807 2 2958 2200 t +( extension is inherently nonportable, as the number of characters storable per ``unit'')12 3492( This)1 238(character data.)1 590 3 720 2320 t +( 32 bit machines are the most plentiful,)7 1560( Since)1 272(varies from machine to machine.)4 1311 3 720 2440 t +10 I f +(f 2c)1 138 1 3888 2440 t +10 R f +( per)1 153(assumes 4 characters)2 836 2 4051 2440 t +(Fortran ``unit'', but this assumption can be overridden by the)9 2573 1 720 2560 t +10 CW f +(-W)3332 2560 w +10 I f +(n)3452 2560 w +10 R f +( example,)1 401( For)1 202(command-line option.)1 896 3 3541 2560 t +10 CW f +(-W8)720 2680 w +10 R f +( An)1 177( Cray computers, since Crays store 8 characters per word.)9 2347(is appropriate for C that is to be run on)9 1587 3 929 2680 t +( Fortran)1 319( the)1 172(example is helpful here:)3 962 3 720 2800 t +9 CW f +(data i/'abcd'/)1 756 1 1332 2975 t +(j = i)2 270 1 1332 3075 t +(end)1332 3175 w +10 R f +(turns into)1 381 1 720 3370 t +9 CW f +(/* Initialized data */)3 1188 1 1224 3545 t +(static struct {)2 810 1 1224 3745 t +(char e_1[4];)1 648 1 1440 3845 t +(} equiv_3 = { {'a', 'b', 'c', 'd'} };)8 1998 1 1440 3945 t +(#define i \(*\(integer *\)&equiv_3\))3 1728 1 1008 4145 t +(static integer j;)2 918 1 1224 4345 t +(j = i;)2 324 1 1224 4545 t +(. . .)2 270 1 1008 4645 t +(#undef i)1 432 1 1008 4745 t +10 R f +(\(Some use of)2 533 1 720 4940 t +10 CW f +(i)1281 4940 w +10 R f +(, e.g. ``)2 291 1 1341 4940 t +10 CW f +(j = i)2 306 1 1632 4940 t +10 R f +('', is necessary or)3 712 1 1938 4940 t +10 I f +(f 2c)1 138 1 2678 4940 t +10 R f +(will see that)2 489 1 2844 4940 t +10 CW f +(i)3361 4940 w +10 R f +( If)1 120( and will not initialize it.\))5 1037(is not used)2 434 3 3449 4940 t +( Cray and the string were)5 1086(the target machine were a)4 1092 2 720 5060 t +10 CW f +('abcdefgh')2939 5060 w +10 R f +(or)3580 5060 w +10 CW f +("abcdefhg")3704 5060 w +10 R f +(, then the Fortran)3 736 1 4304 5060 t +(would run \256ne, but the C produced by)7 1577 1 720 5180 t +10 I f +(f 2c)1 138 1 2330 5180 t +10 R f +(would only store)2 688 1 2501 5180 t +10 CW f +("abcd")3222 5180 w +10 R f +( the default number of)4 923(in i, 4 being)3 502 2 3615 5180 t +( The)1 205(characters per word.)2 810 2 720 5300 t +10 I f +(f 2c)1 138 1 1760 5300 t +10 R f +(command-line option)1 858 1 1923 5300 t +10 CW f +(-W8)2806 5300 w +10 R f +(gives the correct initialization for a Cray.)6 1644 1 3011 5300 t +10 R f +( the option)2 438( Using)1 294(The initialization above is clumsy, using 4 separate characters.)8 2533 3 970 5465 t +10 CW f +(-A)4265 5465 w +10 R f +(, for ANSI, pro-)3 655 1 4385 5465 t +(duces)720 5585 w +9 CW f +(. . .)2 270 1 1008 5760 t +(} equiv_3 = { "abcd" };)5 1242 1 1440 5860 t +(. . .)2 270 1 1008 5960 t +10 R f +(See Appendix B.)2 680 1 720 6155 t +10 R f +( examples explain why the Fortran 77 standard excludes Hollerith data statements: the)12 3637(The above)1 433 2 970 6320 t +( \(For-)1 261( not speci\256ed and hence such code is not portable even in Fortran.)12 2709(number of characters per word is)5 1350 3 720 6440 t +( that Fortran)2 508( Note)1 251(tran that conservatively assumes only 1 or 2 characters per word is portable but messy.)14 3561 3 720 6560 t +(77 forbids the mixing, via)4 1056 1 720 6680 t +10 CW f +(common)1806 6680 w +10 R f +(,)2166 6680 w +10 CW f +(data)2221 6680 w +10 R f +(, or)1 138 1 2461 6680 t +10 CW f +(equivalence)2629 6680 w +10 R f +( Like)1 237( noncharacter types.)2 808(, of character and)3 706 3 3289 6680 t +(many Fortran compilers,)2 987 1 720 6800 t +10 I f +(f 2c)1 138 1 1733 6800 t +10 R f +(permits such nonportable mixing; initialization of numeric variables with Hol-)9 3143 1 1897 6800 t +(lerith data is one example of this mixing.\))7 1671 1 720 6920 t +10 R f +(Some Fortran 66 programs pass Hollerith strings to)7 2052 1 970 7085 t +10 CW f +(integer)3047 7085 w +10 R f +(variables.)3492 7085 w +10 I f +(F 2c)1 163 1 3927 7085 t +10 R f +( string)1 254(treats a Hollerith)2 671 2 4115 7085 t +( systems if the character string winds up being)8 1869(as a character string, but this may lead to bus errors on some)12 2451 2 720 7205 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 15 16 +%%Page: 16 17 +/saveobj save def +mark +17 pagesetup +10 R f +(- 16 -)2 216 1 2772 480 t +( The)1 212(improperly aligned.)1 795 2 720 840 t +10 CW f +(-h)1759 840 w +10 R f +(option instructs)1 627 1 1911 840 t +10 I f +(f 2c)1 138 1 2570 840 t +10 R f +( character variables and constants the same)6 1765(to try to give)3 535 2 2740 840 t +(alignment as)1 508 1 720 960 t +10 CW f +(integer)1253 960 w +10 R f +(s. Under)1 363 1 1673 960 t +10 CW f +(-h)2061 960 w +10 R f +( Fortran)1 319( the)1 172(, for example,)2 554 3 2181 960 t +9 CW f +(call foo\("a string"\))2 1080 1 1332 1120 t +(call goo\(8ha string\))2 1080 1 1332 1220 t +10 R f +(is translated to)2 583 1 720 1400 t +9 CW f +(static struct { integer fill; char val[8+1]; char fill2[3]; } c_b1_st = { 0,)13 4104 1 1008 1560 t +("a string" };)2 702 1 1440 1660 t +(#define c_b1 c_b1_st.val)2 1296 1 1008 1760 t +(. . .)2 270 1 1008 1860 t +(foo_\(c_b1, 8L\);)1 810 1 1224 1960 t +(goo_\(c_b1, 8L\);)1 810 1 1224 2060 t +(. . .)2 270 1 1008 2160 t +10 R f +(Some systems require that C values of type)7 1736 1 970 2340 t +10 CW f +(double)2732 2340 w +10 R f +( Fortran)1 346( double-word boundary.)2 966(be aligned on a)3 610 3 3118 2340 t +10 CW f +(common)720 2460 w +10 R f +(and)1117 2460 w +10 CW f +(equivalence)1298 2460 w +10 R f +( require some C)3 668(statements may)1 631 2 1995 2460 t +10 CW f +(double)3330 2460 w +10 R f +(values to be aligned on an odd-)6 1314 1 3726 2460 t +( if nec-)2 294( systems where double-word alignment is required, C compilers pad structures,)10 3212( On)1 177(word boundary.)1 637 4 720 2580 t +( validity of)2 441( such padding has no effect on the)7 1375( Often)1 279(essary, to arrange for the right alignment.)6 1664 4 720 2700 t +10 I f +(f 2c)1 138 1 4505 2700 t +10 R f +('s transla-)1 397 1 4643 2700 t +( using)1 243(tion, but)1 334 2 720 2820 t +10 CW f +(common)1323 2820 w +10 R f +(or)1709 2820 w +10 CW f +(equivalence)1818 2820 w +10 R f +(, it is easy to contrive examples in which the translated C works)12 2562 1 2478 2820 t +(incorrectly.)720 2940 w +10 I f +(F 2c)1 163 1 1233 2940 t +10 R f +( may cause trouble, but, like)5 1154(issues a warning message when double-word alignment)6 2260 2 1427 2940 t +10 I f +(f)4871 2940 w +10 R f +(77,)4915 2940 w +(it makes no attempt to circumvent this trouble; the run-time costs of circumvention would be substantial.)15 4192 1 720 3060 t +10 R f +(Long decimal strings in)3 950 1 970 3216 t +10 CW f +(data)1946 3216 w +10 R f +( expressions involving)2 904( However,)1 442( C unaltered.)2 517(statements are passed to)3 965 4 2212 3216 t +( a VAX 8550, the Fortran)5 1026( On)1 172(long decimal strings are rounded in a machine-dependent manner.)8 2636 3 720 3336 t +9 CW f +(x=1.2**10)1332 3496 w +(end)1332 3596 w +10 R f +(yields the C)2 478 1 720 3776 t +9 CW f +(static real x;)2 756 1 1224 3936 t +(x = \(float\)6.1917364224000008;)2 1620 1 1224 4136 t +10 R f +( external scope, such as the)5 1156(ANSI C compilers require that all but one instance of any entity with)12 2914 2 970 4316 t +10 CW f +(struct)720 4436 w +10 R f +(s into which)2 497 1 1080 4436 t +10 I f +(f 2c)1 138 1 1605 4436 t +10 R f +(translates)1771 4436 w +10 CW f +(common)2176 4436 w +10 R f +(, be declared)2 512 1 2536 4436 t +10 CW f +(extern)3076 4436 w +10 R f +(and that exactly one declaration should)5 1576 1 3464 4436 t +(de\256ne the entity, i.e., should not be declared)7 1830 1 720 4556 t +10 CW f +(extern)2584 4556 w +10 R f +( restriction.)1 465( older C compilers have no such)6 1341(. Most)1 290 3 2944 4556 t +( with ANSI usage, the)4 905(To be compatible)2 711 2 720 4676 t +10 I f +(f 2c)1 138 1 2366 4676 t +10 R f +(command-line option)1 863 1 2534 4676 t +10 CW f +(-ec)3427 4676 w +10 R f +(causes the)1 412 1 3637 4676 t +10 CW f +(struct)4079 4676 w +10 R f +(corresponding)4469 4676 w +(to an uninitialized)2 734 1 720 4796 t +10 CW f +(common)1485 4796 w +10 R f +(region to be declared)3 857 1 1876 4796 t +10 CW f +(extern)2764 4796 w +10 R f +(and makes a)2 505 1 3155 4796 t +10 CW f +(union)3691 4796 w +10 R f +( declara-)1 352(of all successive)2 666 2 4022 4796 t +(tions of that)2 498 1 720 4916 t +10 CW f +(common)1288 4916 w +10 R f +(region into a de\256ning declaration placed in a \256le with the name)11 2637 1 1683 4916 t +10 CW f +(cname_com.c)4355 4916 w +10 R f +(,)5015 4916 w +(where)720 5036 w +10 CW f +(cname)988 5036 w +10 R f +(is the name of the)4 710 1 1313 5036 t +10 CW f +(common)2048 5036 w +10 R f +( example, the Fortran)3 854(region. For)1 469 2 2433 5036 t +9 CW f +(common /cmname/ c)2 918 1 1332 5196 t +(complex c\(10\))1 702 1 1332 5296 t +(c\(1\)=cmplx\(1.,0.\))1332 5396 w +(call sam\(c\))1 594 1 1332 5496 t +(end)1332 5596 w +(subroutine sam\(c\))1 918 1 1332 5696 t +(complex c)1 486 1 1332 5796 t +(common /cmname/ca)1 918 1 1332 5896 t +(complex ca\(10\))1 756 1 1332 5996 t +(ca\(2\) = cmplx\(1e0,2e0\))2 1188 1 1332 6096 t +(return)1332 6196 w +(end)1332 6296 w +10 R f +(when converted by)2 759 1 720 6476 t +10 CW f +(f2c -ec)1 420 1 1504 6476 t +10 R f +(produces)1949 6476 w +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 16 17 +%%Page: 17 18 +/saveobj save def +mark +18 pagesetup +10 R f +(- 17 -)2 216 1 2772 480 t +9 CW f +(/* Common Block Declarations */)4 1674 1 1008 820 t +(union {)1 378 1 1008 1020 t +(struct {)1 432 1 1224 1120 t +(complex c[10];)1 756 1 1440 1220 t +(} _1;)1 270 1 1224 1320 t +(struct {)1 432 1 1224 1420 t +(complex ca[10];)1 810 1 1440 1520 t +(} _2;)1 270 1 1224 1620 t +(} cmname_;)1 540 1 1008 1720 t +(#define cmname_1 \(cmname_._1\))2 1566 1 1008 1920 t +(#define cmname_2 \(cmname_._2\))2 1566 1 1008 2020 t +( _\(\))1 184(/* Main program */ MAIN_)4 1296 2 1008 2220 t +({)1008 2320 w +(extern /* Subroutine */ int sam_\(\);)5 1890 1 1224 2520 t +(cmname_1.c[0].r = \(float\)1., cmname_1.c[0].i = \(float\)0.;)5 3078 1 1224 2720 t +(sam_\(cmname_1.c\);)1224 2820 w +( */)1 162( _)1 76(} /* MAIN_)2 540 3 1008 2920 t +(/* Subroutine */ int sam_\(c\))4 1512 1 1008 3120 t +(complex *c;)1 594 1 1008 3220 t +({)1008 3320 w +(cmname_2.ca[1].r = \(float\)1., cmname_2.ca[1].i = \(float\)2.;)5 3186 1 1224 3420 t +(return 0;)1 486 1 1224 3520 t +(} /* sam_ */)3 648 1 1008 3620 t +10 R f +(as well as the \256le)4 688 1 720 3814 t +10 CW f +(cmname_com.c)1433 3814 w +10 R f +(:)2153 3814 w +9 CW f +(#include "f2c.h")1 864 1 1008 3988 t +(union {)1 378 1 1008 4088 t +(struct {)1 432 1 1224 4188 t +(complex c[10];)1 756 1 1440 4288 t +(} _1;)1 270 1 1224 4388 t +(struct {)1 432 1 1224 4488 t +(complex ca[10];)1 810 1 1440 4588 t +(} _2;)1 270 1 1224 4688 t +(} cmname_;)1 540 1 1008 4788 t +10 R f +(The \256les)1 352 1 720 4982 t +10 CW f +(*_com.c)1102 4982 w +10 R f +(may be compiled into a library against which one can load to satisfy overly fastidious)14 3488 1 1552 4982 t +(ANSI C compilers.)2 769 1 720 5102 t +10 R f +(The rules of Fortran 77 apparently permit a situation in which)10 2539 1 970 5267 t +10 I f +(f 2c)1 138 1 3541 5267 t +10 R f +(declares a function to be of type)6 1328 1 3712 5267 t +10 CW f +(int)720 5387 w +10 R f +( that example,)2 563( In)1 134(, then de\256nes it to be of another type, as illustrated by the \256rst example in \2477.)16 3105 3 900 5387 t +10 I f +(f 2c)1 138 1 4727 5387 t +10 R f +(dis-)4890 5387 w +(covers too late that)3 757 1 720 5507 t +10 CW f +(f)1502 5507 w +10 R f +( than a warning)3 621( some C compilers, this causes nothing worse)7 1821( With)1 250(is not a subroutine.)3 761 4 1587 5507 t +( unforgiving C compilers, one can usu-)6 1580( With)1 254(message; with others, it causes the compilation to be aborted.)9 2486 3 720 5627 t +( e.g., with the)3 574(ally avoid trouble by splitting the Fortran source into one \256le per procedure,)12 3146 2 720 5747 t +10 I f +(fsplit)4475 5747 w +10 R f +(\(1\) com-)1 356 1 4684 5747 t +( solution is to use prototypes, as discussed in \2477.)9 1942( Another)1 377(mand, and converting each procedure separately.)5 1952 3 720 5867 t +10 R f +( consistent prototype declarations across separate compilations,)6 2544(With an ANSI C system that enforced)6 1526 2 970 6032 t +( translate the main program correctly in the last example just by looking at the)14 3264(it would be impossible to)4 1056 2 720 6152 t +( do enforce the consistency of prototype declarations across separate)9 2770( C++ compilers)2 629( Recent)1 330(main program.)1 591 4 720 6272 t +( sequences into the translated names of functions, except for func-)10 2731(compilations, e.g., by encoding calling)4 1589 2 720 6392 t +(tions that are declared)3 902 1 720 6512 t +10 CW f +(extern "C")1 608 1 1655 6512 t +10 R f +(and compiled separately.)2 1013 1 2297 6512 t +10 I f +(F 2c)1 163 1 3369 6512 t +10 R f +(allows one to use this escape hatch:)6 1474 1 3566 6512 t +(under)720 6632 w +10 CW f +(-C++)972 6632 w +10 R f +(,)1212 6632 w +10 I f +(f 2c)1 138 1 1262 6632 t +10 R f +(inserts)1425 6632 w +9 CW f +( _cplusplus)1 562(#ifdef _)1 432 2 1008 6806 t +(extern "C" {)2 648 1 1008 6906 t +(#endif)1008 7006 w +10 R f +(at the beginning of its C++ output and places)8 1800 1 720 7200 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 17 18 +%%Page: 18 19 +/saveobj save def +mark +19 pagesetup +10 R f +(- 18 -)2 216 1 2772 480 t +9 CW f +( _cplusplus)1 562(#ifdef _)1 432 2 1008 820 t +(})1440 920 w +(#endif)1008 1020 w +10 R f +( The)1 207(at the end of its C++ output.)6 1138 2 720 1223 t +10 CW f +( _cplusplus)1 624(#ifdef _)1 482 2 2092 1223 t +10 R f +( compil-)1 339(lines are for the bene\256t of older C++)7 1476 2 3225 1223 t +(ers that do not recognize)4 981 1 720 1343 t +10 CW f +(extern "C")1 600 1 1726 1343 t +10 R f +(.)2326 1343 w +10 B f +(7. PROTOTYPES)1 779 1 720 1629 t +10 R f +(In ANSI C and C++, a)5 935 1 970 1799 t +10 I f +(prototype)1937 1799 w +10 R f +( can save)2 381( Prototypes)1 486(describes the calling sequence of a function.)6 1813 3 2360 1799 t +( The)1 215( calling sequences.)2 771(debugging time by helping catch errors in)6 1736 3 720 1919 t +10 CW f +(-P)3477 1919 w +10 R f +(option instructs)1 630 1 3632 1919 t +10 I f +(f 2c)1 138 1 4297 1919 t +10 R f +(to emit proto-)2 570 1 4470 1919 t +( all the functions de\256ned in the C it produces; speci\256cally,)10 2409(types for)1 359 2 720 2039 t +10 I f +(f 2c)1 138 1 3521 2039 t +10 R f +(creates a)1 353 1 3692 2039 t +10 I f +(\256le)4078 2039 w +10 CW f +(.P)4200 2039 w +10 R f +(of prototypes for)2 687 1 4353 2039 t +(each input)1 417 1 720 2159 t +10 I f +(\256le)1166 2159 w +10 CW f +(.f)1288 2159 w +10 R f +(or)1437 2159 w +10 I f +(\256le)1549 2159 w +10 CW f +(.F)1671 2159 w +10 R f +( can then arrange for relevant prototype \256les to be seen by the C compiler.)14 3005(. One)1 244 2 1791 2159 t +(For instance, if)2 634 1 720 2279 t +10 I f +(f 2c)1 138 1 1395 2279 t +10 R f +('s header \256le)2 547 1 1533 2279 t +10 CW f +(f2c.h)2122 2279 w +10 R f +(is installed as)2 573 1 2464 2279 t +10 CW f +(/usr/include/f2c.h)3079 2279 w +10 R f +(, one could issue the)4 881 1 4159 2279 t +(UNIX command)1 668 1 720 2399 t +9 CW f +(cat /usr/include/f2c.h *.P >f2c.h)3 1782 1 1008 2582 t +10 R f +(to create a local copy of)5 1020 1 720 2785 t +10 CW f +(f2c.h)1778 2785 w +10 R f +(that has in it all the prototypes in)7 1405 1 2116 2785 t +10 CW f +(*.P)3559 2785 w +10 R f +( produced by)2 549( the C)2 265(. Since)1 310 3 3739 2785 t +10 I f +(f 2c)1 138 1 4902 2785 t +10 R f +(always speci\256es)1 646 1 720 2905 t +9 CW f +(#include "f2c.h")1 864 1 1008 3088 t +10 R f +(\(rather than)1 465 1 720 3291 t +10 CW f +(#include )1 963 1 1213 3291 t +10 R f +( the current directory for)4 996(\), the C compiler will look \256rst in)7 1366 2 2176 3291 t +10 CW f +(f2c.h)4567 3291 w +10 R f +(and)4896 3291 w +(thus will \256nd the local copy that contains the prototypes.)9 2266 1 720 3411 t +10 I f +(F 2c)1 163 1 970 3581 t +10 R f +( to)1 104(can also read the prototype \256les it writes; one simply speci\256es them as arguments)13 3255 2 1158 3581 t +10 I f +(f 2c)1 138 1 4543 3581 t +10 R f +( fact,)1 200(. In)1 159 2 4681 3581 t +10 I f +(f 2c)1 138 1 720 3701 t +10 R f +( multiple Fortran \256les are handled indepen-)6 1779(reads all prototype \256les before any Fortran \256les; although)8 2369 2 892 3701 t +(dently, any prototype \256le arguments apply to all of them.)9 2396 1 720 3821 t +10 I f +(F 2c)1 163 1 3179 3821 t +10 R f +( Fortran)1 333(has more detailed knowledge of)4 1327 2 3380 3821 t +( it conveys in the C it puts out; for example,)10 1758(types than)1 409 2 720 3941 t +10 CW f +(logical)2912 3941 w +10 R f +(and)3357 3941 w +10 CW f +(integer)3526 3941 w +10 R f +(are different Fortran types,)3 1069 1 3971 3941 t +( Moreover,)1 470(but are mapped to the same C type.)7 1423 2 720 4061 t +10 CW f +(character)2640 4061 w +10 R f +(,)3180 4061 w +10 CW f +(complex)3232 4061 w +10 R f +(, and)1 196 1 3652 4061 t +10 CW f +(double complex)1 843 1 3875 4061 t +10 R f +(Fortran)4746 4061 w +( translated to)2 540(functions are all)2 669 2 720 4181 t +10 CW f +(VOID)1966 4181 w +10 R f +(C functions, and, unless the)4 1153 1 2243 4181 t +10 CW f +(-R)3433 4181 w +10 R f +(option is speci\256ed, both)3 992 1 3590 4181 t +10 CW f +(real)4619 4181 w +10 R f +(and)4896 4181 w +10 CW f +(double precision)1 987 1 720 4301 t +10 R f +(Fortran functions are translated to)4 1461 1 1759 4301 t +10 CW f +(doublereal)3272 4301 w +10 R f +( Because)1 409(C functions.)1 516 2 3924 4301 t +10 I f +(f 2c)1 138 1 4902 4301 t +10 R f +( ANSI C)2 362(denotes all these types differently in its prototype \256les, it can catch errors that are invisible to an)17 3958 2 720 4421 t +(\(or C++\) compiler.)2 758 1 720 4541 t +10 R f +(The following table shows the types that)6 1621 1 970 4711 t +10 I f +(f 2c)1 138 1 2616 4711 t +10 R f +(uses for procedure arguments:)3 1205 1 2779 4711 t +10 S f +(_ _________________________________________________)1 2491 1 1634 4814 t +10 CW f +(C_fp complex)1 810 1 1684 4934 t +(D_fp doublereal)1 990 1 1684 5054 t +(E_fp real)1 630 1 1684 5174 t +10 R f +(under)2339 5174 w +10 CW f +(-!R)2591 5174 w +10 R f +(\(the default\))1 490 1 2796 5174 t +10 CW f +(H_fp character)1 930 1 1684 5294 t +(I_fp integer)1 810 1 1684 5414 t +10 R f +(or)2519 5414 w +10 CW f +(integer*4)2627 5414 w +(J_fp integer*2)1 930 1 1684 5534 t +(K_fp shortlogical)1 1110 1 1684 5654 t +10 R f +(\()2819 5654 w +10 CW f +(logical)2852 5654 w +10 R f +(under)3297 5654 w +10 CW f +(-i2)3549 5654 w +10 R f +(or)3754 5654 w +10 CW f +(-I2)3862 5654 w +10 R f +(\))4042 5654 w +10 CW f +(L_fp logical)1 810 1 1684 5774 t +(R_fp real)1 630 1 1684 5894 t +10 R f +(under)2339 5894 w +10 CW f +(-R)2591 5894 w +(S_fp subroutine)1 990 1 1684 6014 t +(U_fp)1684 6134 w +10 R f +(untyped)2074 6134 w +10 CW f +(external)2421 6134 w +(Z_fp doublecomplex)1 1170 1 1684 6254 t +10 S f +( \347)1 -2491(_ _________________________________________________)1 2491 2 1634 6274 t +(\347)1634 6214 w +(\347)1634 6114 w +(\347)1634 6014 w +(\347)1634 5914 w +(\347)1634 5814 w +(\347)1634 5714 w +(\347)1634 5614 w +(\347)1634 5514 w +(\347)1634 5414 w +(\347)1634 5314 w +(\347)1634 5214 w +(\347)1634 5114 w +(\347)1634 5014 w +(\347)1634 4914 w +(\347)4125 6274 w +(\347)4125 6214 w +(\347)4125 6114 w +(\347)4125 6014 w +(\347)4125 5914 w +(\347)4125 5814 w +(\347)4125 5714 w +(\347)4125 5614 w +(\347)4125 5514 w +(\347)4125 5414 w +(\347)4125 5314 w +(\347)4125 5214 w +(\347)4125 5114 w +(\347)4125 5014 w +(\347)4125 4914 w +10 R f +(These types are de\256ned in)4 1086 1 720 6477 t +10 CW f +(f2c.h)1842 6477 w +10 R f +( and, under)2 470(; they appear in prototypes)4 1109 2 2142 6477 t +10 CW f +(-A)3758 6477 w +10 R f +(or)3915 6477 w +10 CW f +(-C++)4035 6477 w +10 R f +(, in the C that)4 590 1 4275 6477 t +10 I f +(f 2c)1 138 1 4902 6477 t +10 R f +( also use special)3 664(writes. Prototypes)1 753 2 720 6597 t +10 CW f +(void)2167 6597 w +10 R f +(types to denote the return values of)6 1433 1 2437 6597 t +10 CW f +(complex)3900 6597 w +10 R f +(,)4320 6597 w +10 CW f +(double com-)1 665 1 4375 6597 t +(plex)720 6717 w +10 R f +(, and)1 194 1 960 6717 t +10 CW f +(character)1179 6717 w +10 R f +(functions:)1744 6717 w +10 S f +(_ _________________________)1 1270 1 2245 6820 t +10 CW f +(C_f complex)1 750 1 2295 6940 t +(H_f character)1 870 1 2295 7060 t +( complex)1 480(Z_f double)1 690 2 2295 7180 t +10 S f +( \347)1 -1270(_ _________________________)1 1270 2 2245 7200 t +(\347)2245 7120 w +(\347)2245 7020 w +(\347)2245 6920 w +(\347)3515 7200 w +(\347)3515 7120 w +(\347)3515 7020 w +(\347)3515 6920 w +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 18 19 +%%Page: 19 20 +/saveobj save def +mark +20 pagesetup +10 R f +(- 19 -)2 216 1 2772 480 t +10 I f +(F 2c)1 163 1 970 840 t +10 R f +(also writes special comments in prototype \256les giving the length of each)11 2955 1 1164 840 t +10 CW f +(common)4150 840 w +10 R f +(block; when)1 498 1 4542 840 t +( arguments,)1 472(given prototype \256les as)3 951 2 720 960 t +10 I f +(f 2c)1 138 1 2174 960 t +10 R f +(reads these special comments so it can issue a warning message if)11 2697 1 2343 960 t +(its Fortran input speci\256es a different length for some)8 2103 1 720 1080 t +10 CW f +(common)2848 1080 w +10 R f +(block.)3233 1080 w +10 R f +( speci\256es different lengths for a)5 1341(Sometimes people write otherwise valid Fortran 77 that)7 2328 2 970 1243 t +10 CW f +(common)4680 1243 w +10 R f +( and converted to C, the loader could end up giving too little)12 2436( such Fortran is split into several \256les)7 1518(block. If)1 366 3 720 1363 t +(space to the)2 499 1 720 1483 t +10 CW f +(common)1258 1483 w +10 R f +( the confusion this could cause by running)7 1795( can avoid)2 438( One)1 230(block in question.)2 742 4 1657 1483 t +10 I f +(f 2c)1 138 1 4902 1483 t +10 R f +(twice, \256rst with)2 647 1 720 1603 t +10 CW f +(-P!c)1402 1603 w +10 R f +(, then with the resulting prototypes as additional arguments; the prototypes let)11 3225 1 1642 1603 t +10 I f +(f 2c)1 138 1 4902 1603 t +10 R f +(determine \(and convey to all of its output C \256les\) the true length needed for each)15 3225 1 720 1723 t +10 CW f +(common)3970 1723 w +10 R f +(block.)4355 1723 w +10 R f +( a procedure to be)4 762(One complication with prototypes comes from Fortran subprograms that declare)9 3308 2 970 1886 t +10 CW f +(external)720 2006 w +10 R f +( specify a type for it and only pass it as a parameter to another procedure.)15 2986(but do not explicitly)3 824 2 1230 2006 t +(\(If the subprogram also invokes the)5 1417 1 720 2126 t +10 CW f +(external)2162 2126 w +10 R f +(procedure, then)1 620 1 2667 2126 t +10 I f +(f 2c)1 138 1 3312 2126 t +10 R f +(can tell whether the procedure is a sub-)7 1565 1 3475 2126 t +( it)1 81( If)1 116(routine or a function; in the latter case, Fortran's implicit typing rules specify a type for the procedure.\))17 4123 3 720 2246 t +(can do no better, then)4 866 1 720 2366 t +10 I f +(f 2c)1 138 1 1612 2366 t +10 R f +(assumes that untyped)2 857 1 1776 2366 t +10 CW f +(external)2660 2366 w +10 R f +(procedures are subroutines \(and hence become)5 1873 1 3167 2366 t +10 CW f +(int)720 2486 w +10 R f +( can cause the generated C to have multiple and inconsistent declarations)11 2947( This)1 232(-valued functions in C\).)3 961 3 900 2486 t +( example,)1 388( For)1 189(for some procedures.)2 839 3 720 2606 t +9 CW f +(external f)1 540 1 1440 2778 t +(call foo\(f\))1 594 1 1440 2878 t +(end)1440 2978 w +(function f\(x\))1 702 1 1440 3078 t +(double precision f, x)3 1134 1 1440 3178 t +(f = x)2 270 1 1440 3278 t +(end)1440 3378 w +10 R f +(results in)1 364 1 720 3570 t +10 CW f +(MAIN_ _)1 384 1 1109 3570 t +10 R f +(declaring)1518 3570 w +9 CW f +(extern /* Subroutine */ int f_\(\);)5 1782 1 1224 3742 t +10 R f +( the subsequent de\256nition of)4 1181(and in)1 258 2 720 3934 t +10 CW f +(doublereal f_\(x\))1 972 1 2196 3934 t +10 R f +( inconsistencies are)2 800( Such)1 262(in the same C \256le.)4 773 3 3205 3934 t +(grounds for some C compilers to abort compilation.)7 2071 1 720 4054 t +10 I f +(F 2c)1 163 1 970 4217 t +10 R f +('s type inferences only apply sequentially to the procedures in a \256le, because)12 3195 1 1133 4217 t +10 I f +(f 2c)1 138 1 4364 4217 t +10 R f +(writes C for)2 501 1 4539 4217 t +( procedure)1 426( as just illustrated, if)4 830( Thus,)1 279(each procedure before reading the next one.)6 1770 4 720 4337 t +10 CW f +(xyz)4053 4337 w +10 R f +(comes after)1 465 1 4261 4337 t +10 CW f +(abc)4754 4337 w +10 R f +(in)4962 4337 w +(a Fortran input \256le, then)4 997 1 720 4457 t +10 I f +(f 2c)1 138 1 1749 4457 t +10 R f +(cannot use information it gains when it sees the de\256nition of)10 2485 1 1919 4457 t +10 CW f +(xyz)4436 4457 w +10 R f +(to deduce)1 392 1 4648 4457 t +(types for)1 353 1 720 4577 t +10 CW f +(external)1099 4577 w +10 R f +(procedures passed as arguments to)4 1384 1 1605 4577 t +10 CW f +(xyz)3015 4577 w +10 R f +(by)3221 4577 w +10 CW f +(abc)3347 4577 w +10 R f +( using the)2 389(. By)1 193 2 3527 4577 t +10 CW f +(-P)4134 4577 w +10 R f +(option and running)2 761 1 4279 4577 t +10 I f +(f 2c)1 138 1 720 4697 t +10 R f +( instance, if \256le)3 661( For)1 204(several times, one can get around this de\256ciency.)7 2065 3 898 4697 t +10 CW f +(zap.f)3868 4697 w +10 R f +(contains the Fortran)2 831 1 4209 4697 t +(shown above, then the commands)4 1351 1 720 4817 t +9 CW f +(f2c -P!c zap.f)2 756 1 1440 4989 t +(f2c -A zap.[fP])2 810 1 1440 5089 t +10 R f +(result in a \256le)3 547 1 720 5281 t +10 CW f +(zap.c)1292 5281 w +10 R f +(in which)1 347 1 1617 5281 t +10 CW f +(MAIN_ _)1 384 1 1989 5281 t +10 R f +(correctly types)1 590 1 2398 5281 t +10 CW f +(f_)3013 5281 w +10 R f +(and)3158 5281 w +10 CW f +(foo_)3327 5281 w +10 R f +(as)3592 5281 w +9 CW f +(extern doublereal f_\(\);)2 1242 1 1224 5453 t +(extern /* Subroutine */ int foo_\(D_fp\);)5 2106 1 1224 5553 t +10 R f +(rather than)1 429 1 720 5745 t +9 CW f +(extern /* Subroutine */ int f_\(\);)5 1782 1 1224 5917 t +(extern /* Subroutine */ int foo_\(U_fp\);)5 2106 1 1224 6017 t +10 R f +(The \256rst invocation of)3 891 1 720 6209 t +10 I f +(f 2c)1 138 1 1636 6209 t +10 R f +(results in a \256le)3 586 1 1799 6209 t +10 CW f +(zap.P)2410 6209 w +10 R f +(containing)2735 6209 w +9 CW f +(extern doublereal f_\(doublereal *x\);)3 1944 1 1008 6381 t +(/*:ref: foo_ 10 1 200 */)5 1296 1 1008 6481 t +10 R f +(The second invocation of)3 1012 1 720 6673 t +10 I f +(f 2c)1 138 1 1757 6673 t +10 R f +(is able to type)3 558 1 1920 6673 t +10 CW f +(f_)2503 6673 w +10 R f +(and)2648 6673 w +10 CW f +(foo_)2817 6673 w +10 R f +(correctly because of the \256rst line in)6 1408 1 3082 6673 t +10 CW f +(zap.P)4515 6673 w +10 R f +(.)4815 6673 w +10 R f +(The second line in)3 735 1 970 6836 t +10 CW f +(zap.P)1730 6836 w +10 R f +( comment that records the incomplete type information that)8 2383(is a special)2 438 2 2055 6836 t +10 I f +(f 2c)1 138 1 4902 6836 t +10 R f +(has about)1 381 1 720 6956 t +10 CW f +(foo_)1126 6956 w +10 R f +(.)1366 6956 w +10 I f +(F 2c)1 163 1 1441 6956 t +10 R f +(puts one such special comment in the prototype \256le for each Fortran procedure that is)14 3411 1 1629 6956 t +( it reads prototype \256les,)4 957( When)1 292(referenced but not de\256ned in the Fortran \256le.)7 1819 3 720 7076 t +10 I f +(f 2c)1 138 1 3817 7076 t +10 R f +(deciphers these comments)2 1056 1 3984 7076 t +( untyped external pro-)3 887( it learns more about)4 829( As)1 163(and uses them to check the consistency of calling sequences.)9 2441 4 720 7196 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 19 20 +%%Page: 20 21 +/saveobj save def +mark +21 pagesetup +10 R f +(- 20 -)2 216 1 2772 480 t +(cedures,)720 840 w +10 I f +(f 2c)1 138 1 1088 840 t +10 R f +(updates the information it has on them; the)7 1811 1 1265 840 t +10 CW f +(:ref:)3116 840 w +10 R f +(comments it writes in a prototype \256le)6 1584 1 3456 840 t +(re\257ect)720 960 w +10 I f +(f 2c)1 138 1 994 960 t +10 R f +('s latest knowledge.)2 796 1 1132 960 t +10 R f +(Ordinarily)970 1124 w +10 I f +(f 2c)1 138 1 1416 1124 t +10 R f +(tries to infer the type of an untyped)7 1441 1 1584 1124 t +10 CW f +(external)3055 1124 w +10 R f +(procedure from its use as arguments)5 1474 1 3566 1124 t +( example, if)2 474( For)1 189(to procedures of known argument types.)5 1608 3 720 1244 t +10 CW f +(f.f)3016 1244 w +10 R f +(contains just)1 503 1 3221 1244 t +9 CW f +(external f)1 540 1 1440 1418 t +(call foo\(f\))1 594 1 1440 1518 t +(end)1440 1618 w +10 R f +(and if)1 230 1 720 1812 t +10 CW f +(foo.P)975 1812 w +10 R f +(contains)1300 1812 w +9 CW f +(extern int foo_\(D_fp\);)2 1188 1 1008 1986 t +10 R f +(then)720 2180 w +9 CW f +(f2c -A f.f foo.P)3 864 1 1008 2354 t +10 R f +(results in the declaration)3 979 1 720 2548 t +9 CW f +(extern doublereal f_\(\);)2 1242 1 1224 2722 t +10 R f +( can lead to erroneous error messages or to incorrect typ-)10 2281(Under unusual circumstances, such type inferences)5 2039 2 720 2916 t +( is an example:)3 602(ing. Here)1 396 2 720 3036 t +9 CW f +(subroutine zoo)1 756 1 1440 3210 t +(external f)1 540 1 1440 3310 t +(double precision f)2 972 1 1440 3410 t +(external g)1 540 1 1440 3510 t +(call zap\(1,f\))1 702 1 1440 3610 t +(call zap\(2,g\))1 702 1 1440 3710 t +(end)1440 3810 w +(subroutine goo)1 756 1 1440 3910 t +(call g)1 324 1 1440 4010 t +(end)1440 4110 w +10 I f +(F 2c)1 163 1 720 4304 t +10 R f +( a double precision function, then discovers that it must be a subroutine and issues a)15 3412(\256rst infers g to be)4 717 2 911 4304 t +(warning message about inconsistent declarations for)5 2148 1 720 4424 t +10 CW f +(g)2905 4424 w +10 R f +( example is legal Fortran 77;)5 1206(. This)1 265 2 2965 4424 t +10 CW f +(zap)4472 4424 w +10 R f +(could be)1 352 1 4688 4424 t +(de\256ned, for instance, by)3 962 1 720 4544 t +9 CW f +(subroutine zap\(n,f\))1 1026 1 1440 4718 t +(external f)1 540 1 1440 4818 t +(if \(n .le. 1\) call zap1\(f\))5 1404 1 1440 4918 t +(if \(n .ge. 2\) call zap2\(f\))5 1404 1 1440 5018 t +(end)1440 5118 w +10 R f +(In such a case one can specify the)7 1362 1 720 5312 t +10 CW f +(-!it)2109 5312 w +10 R f +(option to instruct)2 688 1 2376 5312 t +10 I f +(f 2c)1 138 1 3091 5312 t +10 R f +( of otherwise untypable)3 949(not to infer the types)4 835 2 3256 5312 t +10 CW f +(external)720 5432 w +10 R f +( is another \(some-)3 736( Here)1 249( as arguments to known procedures.)5 1466(procedures from their appearance)3 1357 4 1232 5432 t +(what far-fetched\) example where)3 1319 1 720 5552 t +10 CW f +(-!it)2064 5552 w +10 R f +(is useful:)1 364 1 2329 5552 t +9 CW f +(subroutine grok\(f,g,h\))1 1188 1 1440 5726 t +(external f, g, h)3 864 1 1440 5826 t +(logical g)1 486 1 1440 5926 t +(call foo\(1,g\))1 702 1 1440 6026 t +(call foo\(2,f\))1 702 1 1440 6126 t +(call zit\(1,f\))1 702 1 1440 6226 t +(call zit\(2,h\))1 702 1 1440 6326 t +(call zot\(f\(3\)\))1 756 1 1440 6426 t +(end)1440 6526 w +10 R f +(Without)720 6720 w +10 CW f +(-!it)1076 6720 w +10 R f +(,)1316 6720 w +10 I f +(f 2c)1 138 1 1369 6720 t +10 R f +(\256rst infers)1 411 1 1535 6720 t +10 CW f +(f_)1974 6720 w +10 R f +(to be a)2 274 1 2123 6720 t +10 CW f +(logical)2426 6720 w +10 R f +(function, then discovers that Fortran's implicit typing)6 2165 1 2875 6720 t +( a)1 92(rules require it to be)4 900 2 720 6840 t +10 CW f +(real)1760 6840 w +10 R f +(function.)2048 6840 w +10 I f +(F 2c)1 163 1 2479 6840 t +10 R f +(issues the warning message ``)4 1284 1 2690 6840 t +10 CW f +(fixing wrong type)2 1066 1 3974 6840 t +(inferred for f)2 842 1 720 6960 t +10 R f +('', which should serve as a warning that)7 1598 1 1562 6960 t +10 I f +(f 2c)1 138 1 3186 6960 t +10 R f +(may have made some incorrect type infer-)6 1690 1 3350 6960 t +( Indeed,)1 350(ences in the mean time.)4 956 2 720 7080 t +10 I f +(f 2c)1 138 1 2055 7080 t +10 R f +(ends up typing)2 597 1 2222 7080 t +10 CW f +(h_)2848 7080 w +10 R f +(as a)1 156 1 2997 7080 t +10 CW f +(logical)3182 7080 w +10 R f +(function; with)1 567 1 3631 7080 t +10 CW f +(-!it)4226 7080 w +10 R f +(speci\256ed,)4494 7080 w +10 I f +(f 2c)1 138 1 4902 7080 t +10 R f +(types)720 7200 w +10 CW f +(h_)958 7200 w +10 R f +(as an)1 204 1 1105 7200 t +10 CW f +(external)1336 7200 w +10 R f +(procedure unknown type, i.e., a)4 1266 1 1843 7200 t +10 CW f +(U_fp)3137 7200 w +10 R f +(, which to the C compiler appears to be a)9 1663 1 3377 7200 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 20 21 +%%Page: 21 22 +/saveobj save def +mark +22 pagesetup +10 R f +(- 21 -)2 216 1 2772 480 t +( with)1 205(subroutine. \(Even)1 737 2 720 840 t +10 CW f +(-!it)1689 840 w +10 R f +(speci\256ed,)1956 840 w +10 I f +(f 2c)1 138 1 2363 840 t +10 R f +( sequences)1 430(issues a warning message about inconsistent calling)6 2082 2 2528 840 t +(for)720 960 w +10 CW f +(foo)861 960 w +10 R f +(.\))1041 960 w +10 R f +(Because)970 1120 w +10 I f +(f 2c)1 138 1 1345 1120 t +10 R f +( \256les, it is easy to write a crude)8 1392(writes its latest knowledge of types into prototype)7 2122 2 1526 1120 t +(\(Bourne\) shell script that will glean the maximum possible type information:)10 3071 1 720 1240 t +9 CW f +(>f.p)1008 1407 w +(until)1008 1507 w +(f2c -Pit f.p f.f)3 864 1 1440 1607 t +(cmp -s f.p f.P)3 756 1 1440 1707 t +(do)1008 1807 w +(mv f.P f.p)2 540 1 1440 1907 t +(done)1440 2007 w +10 R f +(In such scripts, use of the)5 1080 1 720 2194 t +10 CW f +(-Ps)1838 2194 w +10 R f +(option can save an iteration;)4 1178 1 2056 2194 t +10 CW f +(-Ps)3273 2194 w +10 R f +(implies)3492 2194 w +10 CW f +(-P)3826 2194 w +10 R f +(and instructs)1 522 1 3985 2194 t +10 I f +(f 2c)1 138 1 4546 2194 t +10 R f +(to issue)1 317 1 4723 2194 t +( the following script is more)5 1130( Thus)1 250( if another iteration might change a declaration or prototype.)9 2412(return code 4)2 528 4 720 2314 t +(ef\256cient:)720 2434 w +9 CW f +(while :; do)2 594 1 1008 2601 t +(f2c -Ps f.[fP])2 756 1 1440 2701 t +(case $? in 4\) ;; *\) break;; esac)7 1728 1 1440 2801 t +(done)1440 2901 w +10 R f +( depends on the call graph of the procedures in)9 1910(The number of iterations)3 1002 2 720 3088 t +10 CW f +(f.f)3662 3088 w +10 R f +(and on their order of appear-)5 1168 1 3872 3088 t +(ance in)1 292 1 720 3208 t +10 CW f +(f.f)1044 3208 w +10 R f +( them into topological order \(so that if)7 1566(. Sorting)1 377 2 1224 3208 t +10 CW f +(abc)3198 3208 w +10 R f +(calls)3409 3208 w +10 CW f +(def)3623 3208 w +10 R f +(, then)1 228 1 3803 3208 t +10 CW f +(abc)4062 3208 w +10 R f +(precedes)4273 3208 w +10 CW f +(def)4652 3208 w +10 R f +(\) and)1 208 1 4832 3208 t +( example,)1 389( For)1 190( alternating between the two orders is probably a good heuristic.)10 2575(reverse topological order and)3 1166 4 720 3328 t +( type the)2 350(we were able to completely)4 1113 2 720 3448 t +8 R f +(PORT3)2211 3448 w +10 R f +(subroutine library in two passes by \256rst processing it in reverse)10 2555 1 2485 3448 t +( one can devise situations where arbitrarily many)7 2023( Unfortunately,)1 644( in forward order.)3 730(topological order, then)2 923 4 720 3568 t +( is slightly annoying, since with appropriate data structures \(in an extensively)11 3168( This)1 236(iterations are required.)2 916 3 720 3688 t +(reorganized version of)2 897 1 720 3808 t +10 I f +(f 2c)1 138 1 1642 3808 t +10 R f +(\), one could do this calculation in linear time.)8 1815 1 1780 3808 t +10 B f +(8. EXPERIENCE WITH)2 1065 1 720 4061 t +10 BI f +(netlib)1810 4061 w +10 R f +( the)1 150(With the help of Eric Grosse, we arranged for)8 1841 2 970 4221 t +10 I f +(netlib)2989 4221 w +10 R f +([5] server)1 387 1 3245 4221 t +10 CW f +(netlib@research.att.com)3660 4221 w +10 R f +( executing the UNIX)3 876( By)1 181(to provide an experimental Fortran-to-C translation service by electronic mail.)9 3263 3 720 4341 t +(command)720 4461 w +10 CW f +(\(echo execute f2c; cat foo.f\) | mail netlib@research.att.com)7 3600 1 1080 4641 t +10 R f +(one submits the Fortran in)4 1054 1 720 4821 t +10 CW f +(foo.f)1800 4821 w +10 R f +(to)2126 4821 w +10 I f +(netlib)2230 4821 w +10 R f +('s)2458 4821 w +10 I f +(f 2c)1 138 1 2556 4821 t +10 R f +(service;)2721 4821 w +10 I f +(netlib)3058 4821 w +10 R f +(replies with the C and diagnostic messages)6 1727 1 3313 4821 t +(produced by)1 498 1 720 4941 t +10 I f +(f 2c)1 138 1 1245 4941 t +10 R f +(from)1410 4941 w +10 CW f +(foo.f)1631 4941 w +10 R f +(. \(The)1 265 1 1931 4941 t +10 CW f +(include)2223 4941 w +10 R f +( context,)1 345(mechanism described in \2473 makes no sense in this)8 2025 2 2670 4941 t +( start using this service, one would generally execute)8 2110( To)1 161(so it is disabled.\))3 678 3 720 5061 t +10 CW f +(echo 'send index from f2c' | mail netlib@research.att.com)7 3420 1 1170 5241 t +10 R f +( the returned C, it is necessary to get a copy)10 1784( compiling)1 434( Before)1 324(to check on the current status of the service.)8 1778 4 720 5421 t +(of)720 5541 w +10 CW f +(f2c.h)828 5541 w +10 R f +(:)1128 5541 w +10 CW f +(echo 'send f2c.h from f2c' | mail netlib@research.att.com)7 3420 1 1170 5721 t +10 R f +( the versions of)3 640(Most likely it would also be necessary to obtain source for)10 2416 2 720 5901 t +10 I f +(libF77)3810 5901 w +10 R f +(and)4111 5901 w +10 I f +(libI77)4289 5901 w +10 R f +(assumed by)1 478 1 4562 5901 t +10 I f +(f 2c)1 138 1 720 6021 t +10 R f +(:)858 6021 w +10 CW f +(echo 'send libf77 libi77 from f2c' | mail netlib@research.att.com)8 3900 1 930 6201 t +10 R f +(For testing purposes, we retain the original Fortran submitted to)9 2581 1 970 6361 t +10 I f +(netlib)3579 6361 w +10 R f +('s ``)1 167 1 3807 6361 t +10 CW f +(execute f2c)1 664 1 3974 6361 t +10 R f +('' service.)1 402 1 4638 6361 t +(Observing)720 6481 w +10 I f +(f 2c)1 138 1 1162 6481 t +10 R f +( of submitted Fortran helped us \256nd many obscure bugs and)10 2398('s behavior on over 400,000 lines)5 1342 2 1300 6481 t +( a)1 70( example,)1 388( For)1 189(led us to make some of the extensions described in \2473.)10 2178 4 720 6601 t +10 CW f +(block data)1 601 1 3571 6601 t +10 R f +(subprogram initializ-)1 842 1 4198 6601 t +( appear in any)3 568(ing a variable that does not)5 1094 2 720 6721 t +10 CW f +(common)2409 6721 w +10 R f +(blocks now elicits a warning message \(rather than caus-)8 2244 1 2796 6721 t +(ing)720 6841 w +10 I f +(f 2c)1 138 1 873 6841 t +10 R f +( example is that)3 630( Another)1 377(to drop core\).)2 540 3 1036 6841 t +10 I f +(f 2c)1 138 1 2609 6841 t +10 R f +(now gives the warning message ``)5 1366 1 2773 6841 t +10 CW f +(Statement order)1 901 1 4139 6841 t +(error: declaration after DATA)3 1761 1 720 6961 t +10 R f +( a)1 75('' and declines to produce any C if a declaration comes after)11 2484 2 2481 6961 t +10 CW f +(data)720 7081 w +10 R f +(statement \(for reasons discussed in \2479\);)5 1623 1 994 7081 t +10 I f +(f 2c)1 138 1 2651 7081 t +10 R f +( and then)2 386(formerly gave a more obscure error message)6 1831 2 2823 7081 t +(produced invalid C.)2 791 1 720 7201 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 21 22 +%%Page: 22 23 +/saveobj save def +mark +23 pagesetup +10 R f +(- 22 -)2 216 1 2772 480 t +(Now that)1 380 1 970 840 t +10 I f +(netlib)1386 840 w +10 R f +(offers source for)2 680 1 1650 840 t +10 I f +(f 2c)1 138 1 2366 840 t +10 R f +(itself \(as explained in the)4 1052 1 2541 840 t +10 CW f +(index)3630 840 w +10 R f +(\256le mentioned above\), we)3 1073 1 3967 840 t +(expect to curtail)2 655 1 720 960 t +10 I f +(netlib)1406 960 w +10 R f +('s ``)1 169 1 1634 960 t +10 CW f +(execute f2c)1 666 1 1803 960 t +10 R f +('' service, perhaps limiting it to employees of AT&T and Bell-)10 2571 1 2469 960 t +(core; to learn the current state of affairs, request the current)10 2367 1 720 1080 t +10 CW f +(index)3112 1080 w +10 R f +(\256le.)3437 1080 w +10 B f +(9. POSSIBLE EXTENSIONS)2 1262 1 720 1322 t +10 R f +(Currently)970 1479 w +10 I f +(f 2c)1 138 1 1384 1479 t +10 R f +( would be nice if constant expressions were simply)8 2092( It)1 118( expressions.)1 523(simpli\256es constant)1 754 4 1553 1479 t +(passed through, and if Fortran)4 1221 1 720 1599 t +10 CW f +(parameter)1971 1599 w +10 R f +( as)1 112(s were translated)2 680 2 2511 1599 t +10 CW f +(#define)3332 1599 w +10 R f +( several things)2 585(s. Unfortunately,)1 703 2 3752 1599 t +( worst is that)3 535( Perhaps)1 373( this nearly impossible to do in full generality.)8 1903(conspire to make)2 694 4 720 1719 t +10 CW f +(parameter)4257 1719 w +10 R f +(s may)1 243 1 4797 1719 t +(be assigned)1 473 1 720 1839 t +10 CW f +(complex)1228 1839 w +10 R f +(or)1683 1839 w +10 CW f +(doublecomplex)1801 1839 w +10 R f +(expressions that might, for example, involve complex divi-)7 2425 1 2615 1839 t +(sion and exponentiation to a large integer power.)7 2022 1 720 1959 t +10 CW f +(Parameter)2802 1959 w +10 R f +(s may appear in)3 659 1 3342 1959 t +10 CW f +(data)4037 1959 w +10 R f +(statements, which)1 727 1 4313 1959 t +(may initialize)1 554 1 720 2079 t +10 CW f +(common)1306 2079 w +10 R f +( to have)2 328( Arranging)1 466( be moved near the beginning of the C output.)9 1891(variables and so)2 657 4 1698 2079 t +(the right)1 353 1 720 2199 t +10 CW f +(#define)1115 2199 w +10 R f +( Of)1 173( in this worst case, be a nightmare.)7 1510(s in effect for the data initialization would,)7 1822 3 1535 2199 t +( and)1 176(course, one could arrange to handle ``easy'' cases with unsimpli\256ed constant expressions)11 3653 2 720 2319 t +10 CW f +(#define)4581 2319 w +10 R f +(s)5001 2319 w +(for parameters.)1 603 1 720 2439 t +10 R f +( Proto-)1 311( alternate return speci\256ers.)3 1091(Prototypes and the argument consistency checks currently ignore)7 2668 3 970 2596 t +(types could be adorned with special comments indicating where alternate return speci\256ers are supposed to)14 4320 1 720 2716 t +( alternate return)2 633( Since)1 273( really matters.)2 598(come, or at least telling the number of such speci\256ers, which is all that)13 2816 4 720 2836 t +( we have so far refrained from this exer-)8 1669(speci\256ers are rarely used \(Fortran 90 calls them ``obsolescent''\),)8 2651 2 720 2956 t +(cise.)720 3076 w +10 R f +(Fortran 90 allows)2 717 1 970 3233 t +10 CW f +(data)1718 3233 w +10 R f +( would be nice if)4 695( It)1 117(statements to appear anywhere.)3 1270 3 1989 3233 t +10 I f +(f 2c)1 138 1 4102 3233 t +10 R f +( the same,)2 416(could do)1 353 2 4271 3233 t +(but that would entail major rewriting of)6 1594 1 720 3353 t +10 I f +(f 2c)1 138 1 2341 3353 t +10 R f +(. Presently)1 449 1 2479 3353 t +10 CW f +(data)2955 3353 w +10 R f +( written to a \256le as soon as they are)9 1415(values are)1 403 2 3222 3353 t +( an)1 127( If)1 124(seen; among the information in the \256le is the offset of each value.)12 2705 3 720 3473 t +10 CW f +(equivalence)3709 3473 w +10 R f +(statement could)1 638 1 4402 3473 t +(follow the)1 408 1 720 3593 t +10 CW f +(data)1153 3593 w +10 R f +(statement, then the offsets would be invalidated.)6 1931 1 1418 3593 t +10 R f +(It would be fairly straightforward to extend)6 1754 1 970 3750 t +10 I f +(f 2c)1 138 1 2753 3750 t +10 R f +( new speci\256ers introduced by)4 1190('s I/O to encompass the)4 959 2 2891 3750 t +( that would mean changing)4 1094( Unfortunately,)1 638(Fortran 90.)1 447 3 720 3870 t +10 I f +(libI77)2927 3870 w +10 R f +( would make it incompatible with)5 1357(in ways that)2 489 2 3194 3870 t +10 I f +(f)720 3990 w +10 R f +(77.)764 3990 w +10 R f +( would be nice to translate all of Fortran 90, but some of the Fortran 90 array manipula-)17 3568(Of course, it)2 502 2 970 4147 t +(tions would require new calling conventions and large enough revisions to)10 3014 1 720 4267 t +10 I f +(f 2c)1 138 1 3763 4267 t +10 R f +(that one might be better off)5 1110 1 3930 4267 t +(starting from scratch.)2 851 1 720 4387 t +10 R f +( hacking,)1 381(With suf\256cient)1 611 2 970 4544 t +10 I f +(f 2c)1 138 1 2002 4544 t +10 R f +(could be modi\256ed to recognize Fortran 90 control structures \()9 2595 1 2180 4544 t +10 CW f +(case)4775 4544 w +10 R f +(,)5015 4544 w +10 CW f +(cycle)720 4664 w +10 R f +(,)1020 4664 w +10 CW f +(exit)1077 4664 w +10 R f +(, and named loops\), local arrays of dimensions that depend on arguments and common val-)14 3723 1 1317 4664 t +(ues, and such types as)4 879 1 720 4784 t +10 CW f +(logical*1)1624 4784 w +10 R f +(,)2164 4784 w +10 CW f +(logical*2)2214 4784 w +10 R f +(,)2754 4784 w +10 CW f +(integer*1)2804 4784 w +10 R f +(or)3370 4784 w +10 CW f +(byte)3479 4784 w +10 R f +( our main concern is with)5 1023(. Since)1 298 2 3719 4784 t +( so far refrained from these further)6 1420(making portable Fortran 77 libraries available to the C world, we have)11 2900 2 720 4904 t +( commercial vendors will wish to provide some of these extensions.)10 2711(extensions. Perhaps)1 813 2 720 5024 t +10 B f +(10. REFERENCES)1 823 1 720 5266 t +10 R f +([1])720 5423 w +10 I f +(American National Standard Programming Language FORTRAN,)5 2786 1 970 5423 t +10 R f +(American National Standards)2 1233 1 3807 5423 t +( X3.9-1978.)1 480( ANSI)1 283(Institute, New York, NY, 1978.)4 1265 3 970 5543 t +10 R f +([2])720 5700 w +10 I f +(American National Standard for Information Systems Programming Language Fortran,)8 3648 1 970 5700 t +10 R f +(CBEMA,)4659 5700 w +( S8, Version 112.)3 697(1989. Draft)1 485 2 970 5820 t +10 R f +([3])720 5977 w +10 I f +(American National Standard for Information Systems \320 Programming Language \320 C,)10 3638 1 970 5977 t +10 R f +(American)4647 5977 w +( X3.159-1989.)1 580( ANSI)1 283(National Standards Institute, New York, NY, 1990.)6 2053 3 970 6097 t +10 R f +([4])720 6254 w +10 I f +( Manual,)1 368(UNIX Time Sharing System Programmer's)4 1739 2 970 6254 t +10 R f +( Edition,)1 352( Tenth)1 290(AT&T Bell Laboratories, 1990.)3 1289 3 3109 6254 t +(Volume 1.)1 422 1 970 6374 t +10 R f +( of Mathematical Software by Electronic Mail,'')6 1950( J. Dongarra and E. Grosse, ``Distribution)6 1684([5] J.)1 314 3 720 6531 t +10 I f +(Commu-)4696 6531 w +(nications of the ACM)3 853 1 970 6651 t +10 B f +(30)1848 6651 w +10 R f +(#5 \(May 1987\), pp. 403\261407.)4 1174 1 1973 6651 t +10 R f +( P. J. Weinberger, ``A Portable Fortran 77 Compiler,'' in)9 2286( I. Feldman and)3 627([6] S.)1 331 3 720 6808 t +10 I f +(Unix Programmer's Man-)2 1050 1 3990 6808 t +(ual, Volume II)2 574 1 970 6928 t +10 R f +(, Holt, Rinehart and Winston \(1983\).)5 1471 1 1544 6928 t +10 R f +( A. Fox, A. D. Hall, and N. L. Schryer, ``Algorithm 528: Framework for a Portable Library,'')16 3751([7] P.)1 331 2 720 7085 t +10 I f +(ACM)4829 7085 w +(Trans. Math. Software)2 901 1 970 7205 t +10 B f +(4)1896 7205 w +10 R f +(\(June 1978\), pp. 177\261188.)3 1049 1 1971 7205 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 22 23 +%%Page: 23 24 +/saveobj save def +mark +24 pagesetup +10 R f +(- 23 -)2 216 1 2772 480 t +( D. Hall, and N. L. Schryer, ``The)7 1478( A. Fox, A.)3 501([8] P.)1 331 3 720 840 t +8 R f +(PORT)3073 840 w +10 R f +(Mathematical Subroutine Library,'')2 1464 1 3322 840 t +10 I f +(ACM)4829 840 w +(Trans. Math. Software)2 901 1 970 960 t +10 B f +(4)1896 960 w +10 R f +(\(June 1978\), pp. 104\261126.)3 1049 1 1971 960 t +10 R f +( in)1 114( C. Johnson, ``A Portable Compiler: Theory and Practice,'' pp. 97\261104)10 2941([9] S.)1 331 3 720 1116 t +10 I f +(Conference Record of)2 898 1 4142 1116 t +( Languages)1 469(the Fifth Annual ACM Symposium on Principles of Programming)8 2670 2 970 1236 t +10 R f +(, Association for Com-)3 931 1 4109 1236 t +(puting Machinery \(1978\).)2 1029 1 970 1356 t +10 R f +( W. Kernighan and D. M. Ritchie,)6 1359([10] B.)1 342 2 720 1512 t +10 I f +(The C Programming Language,)3 1278 1 2446 1512 t +10 R f +(Prentice-Hall, 1978.)1 807 1 3749 1512 t +10 R f +( D. M. Ritchie,)3 633( W. Kernighan and)3 789([11] B.)1 342 3 720 1668 t +10 I f +(The C Programming Language,)3 1311 1 2520 1668 t +10 R f +( Second)1 355(Prentice-Hall, 1988.)1 818 2 3867 1668 t +(Edition)970 1788 w +10 R f +( M. A. Saunders, ``MINOS 5.1 User's Guide,'' Technical Report SOL 83-20R)11 3282( A. Murtagh and)3 696([12] B.)1 342 3 720 1944 t +( CA.)1 189( Stanford,)1 419( Optimization Laboratory, Stanford University,)4 1887(\(1987\), Systems)1 675 4 970 2064 t +10 R f +( G. Ryder, ``The PFORT Veri\256er,'')5 1425([13] B.)1 342 2 720 2220 t +10 I f +(Software Practice and Experience)3 1367 1 2512 2220 t +10 B f +(4)3904 2220 w +10 R f +(\(1974\), pp. 359\261377.)2 841 1 3979 2220 t +10 R f +( Test of a Computer's Floating-point Arithmetic Unit,'' in)8 2388( L. Schryer, ``A)3 655([14] N.)1 347 3 720 2376 t +10 I f +(Sources and Develop-)2 897 1 4143 2376 t +(ment of Mathematical Software)3 1258 1 970 2496 t +10 R f +(, ed. W. Cowell, Prentice-Hall \(1981\).)5 1525 1 2228 2496 t +10 R f +( Stroustrup,)1 467([15] B.)1 342 2 720 2652 t +10 I f +(The C++ Programming Language,)3 1414 1 1554 2652 t +10 R f +(Addison-Wesley, 1986.)1 946 1 2993 2652 t +10 B f +(Appendix A: Commercial Fortran-to-C Vendors)4 2069 1 720 2892 t +10 R f +( following vendors offer Fortran to C conversion ser-)8 2132(At the time of this writing, we are aware that the)10 1938 2 970 3048 t +( include them in updated ver-)5 1193( vendors are invited to inform us of their existence, so we may)12 2553(vice. Omitted)1 574 3 720 3168 t +(sions of this appendix.)3 900 1 720 3288 t +(Cobalt Blue)1 481 1 2520 3528 t +(875 Old Roswell Road)3 914 1 2520 3648 t +(Suite D400)1 453 1 2520 3768 t +(Roswell, GA 30076)2 797 1 2520 3888 t +(\(404\) 518\2611116; FAX \(404\) 640\2611182)4 1560 1 2520 4008 t +(PROMULA Development Corporation)2 1560 1 2520 4368 t +(Columbus, OH)1 606 1 2520 4488 t +(\(614\) 263\2615454)1 641 1 2520 4608 t +(Rapitech Systems)1 714 1 2520 4968 t +(Of\256ce Center at Montebello)3 1123 1 2520 5088 t +(400 Rella Blvd.)2 631 1 2520 5208 t +(Suffern, NY 10901)2 768 1 2520 5328 t +(\(914\) 368\2613000)1 641 1 2520 5448 t +10 R f +(March 22, 1995)2 635 1 2550 7560 t +cleartomark +showpage +saveobj restore +%%EndPage: 23 24 +%%Page: 1 25 +/saveobj save def +mark +25 pagesetup +9 B f +( \( 1 \))3 126( F2C)1 1621( \))1 37( B)1 83( Appendix)1 382( \()1 68( System V)2 386( UNIX)1 1686(F2C \( 1 \))3 291 9 540 480 t +(NAME)540 960 w +10 R f +(f2c \261 Convert Fortran 77 to C or C++)8 1500 1 900 1080 t +9 B f +(SYNOPSIS)540 1248 w +10 B f +(f 2c)1 135 1 900 1368 t +10 R f +([)1060 1368 w +10 I f +(option ...)1 356 1 1118 1368 t +10 R f +(])1499 1368 w +10 I f +(\256le ...)1 222 1 1557 1368 t +9 B f +(DESCRIPTION)540 1536 w +10 I f +(F2c)900 1656 w +10 R f +(converts Fortran 77 source code in)5 1413 1 1086 1656 t +10 I f +(\256les)2530 1656 w +10 R f +( in)1 110(with names ending)2 767 2 2722 1656 t +10 CW f +(.f)3631 1656 w +10 R f +(or)3783 1656 w +10 CW f +(.F)3898 1656 w +10 R f +(to C \(or C++\) source \256les in)6 1170 1 4050 1656 t +(the current directory, with)3 1069 1 900 1776 t +10 CW f +(.c)2003 1776 w +10 R f +(substituted for the \256nal)3 949 1 2156 1776 t +10 CW f +(.f)3138 1776 w +10 R f +(or)3291 1776 w +10 CW f +(.F)3407 1776 w +10 R f +( no Fortran \256les are named,)5 1138(. If)1 149 2 3527 1776 t +10 I f +(f 2c)1 130 1 4847 1776 t +10 R f +(reads)5010 1776 w +(Fortran from standard input and writes C on standard output.)9 2458 1 900 1896 t +10 I f +(File)3411 1896 w +10 R f +(names that end with)3 814 1 3601 1896 t +10 CW f +(.p)4444 1896 w +10 R f +(or)4593 1896 w +10 CW f +(.P)4705 1896 w +10 R f +(are taken)1 366 1 4854 1896 t +(to be prototype \256les, as produced by option)7 1732 1 900 2016 t +10 CW f +(-P)2657 2016 w +10 R f +(, and are read \256rst.)4 742 1 2777 2016 t +(The following options have the same meaning as in)8 2059 1 900 2184 t +10 I f +(f 77)1 136 1 2984 2184 t +10 R f +(\(1\).)3128 2184 w +10 B f +(-C)900 2352 w +10 R f +(Compile code to check that subscripts are within declared array bounds.)10 2875 1 1260 2352 t +10 B f +(-I2)900 2520 w +10 R f +(Render INTEGER and LOGICAL as short, INTEGER)6 2224 1 1260 2520 t +10 S f +(*)3484 2520 w +10 R f +( the default)2 465( Assume)1 380(4 as long int.)3 541 3 3534 2520 t +10 I f +(libF77)4953 2520 w +10 R f +(and)1260 2640 w +10 I f +(libI77)1442 2640 w +10 R f +( only INTEGER)2 681(: allow)1 313 2 1681 2640 t +10 S f +(*)2675 2640 w +10 R f +( Option)1 340(4 \(and no LOGICAL\) variables in INQUIREs.)6 1938 2 2725 2640 t +10 CW f +(-I4)5040 2640 w +10 R f +(con\256rms the default rendering of INTEGER as long int.)8 2233 1 1260 2760 t +10 B f +(-I)900 2928 w +10 I f +(dir)972 2928 w +10 R f +( in directo-)2 452(Look for a non-absolute include \256le \256rst in the directory of the current input \256le, then)15 3508 2 1260 2928 t +(ries speci\256ed by)2 661 1 1260 3048 t +10 CW f +(-I)1952 3048 w +10 R f +( Options)1 372( option\).)1 344(options \(one directory per)3 1052 3 2103 3048 t +10 CW f +(-I2)3936 3048 w +10 R f +(and)4146 3048 w +10 CW f +(-I4)4320 3048 w +10 R f +(have precedence,)1 690 1 4530 3048 t +(so, e.g., a directory named)4 1053 1 1260 3168 t +10 CW f +(2)2338 3168 w +10 R f +(should be speci\256ed by)3 891 1 2423 3168 t +10 CW f +(-I./2)3339 3168 w +10 R f +(.)3664 3168 w +10 B f +(-onetrip)900 3336 w +10 R f +( 77 DO loops are not per-)6 1050( \(Fortran)1 382( that are performed at least once if reached.)8 1764(Compile DO loops)2 764 4 1260 3456 t +(formed at all if the upper limit is smaller than the lower limit.\))12 2490 1 1260 3576 t +10 B f +(-U)900 3744 w +10 R f +( keywords must be in)4 855( Fortran)1 344(Honor the case of variable and external names.)7 1872 3 1260 3744 t +10 I f +(lower)4356 3744 w +10 R f +(case.)4609 3744 w +10 B f +(-u)900 3912 w +10 R f +(Make the default type of a variable `unde\256ned' rather than using the default Fortran rules.)14 3589 1 1260 3912 t +10 B f +(-w)900 4080 w +10 R f +(Suppress all warning messages, or, if the option is)8 2004 1 1260 4080 t +10 CW f +(-w66)3289 4080 w +10 R f +(, just Fortran 66 compatibility warnings.)5 1614 1 3529 4080 t +(The following options are peculiar to)5 1484 1 900 4248 t +10 I f +(f 2c)1 130 1 2409 4248 t +10 R f +(.)2547 4248 w +10 B f +(-A)900 4416 w +10 R f +(Produce)1260 4416 w +9 R f +(ANSI)1610 4416 w +10 R f +( is old-style C.)3 584(C. Default)1 441 2 1845 4416 t +10 B f +(-a)900 4584 w +10 R f +( appear in a)3 489(Make local variables automatic rather than static unless they)8 2476 2 1260 4584 t +9 R f +(DATA, EQUIVALENCE,)1 963 1 4257 4584 t +(NAMELIST,)1260 4704 w +10 R f +(or)1763 4704 w +9 R f +(SAVE)1869 4704 w +10 R f +(statement.)2129 4704 w +10 B f +(-C++)900 4872 w +10 R f +(Output C++ code.)2 720 1 1260 4872 t +10 B f +(-c)900 5040 w +10 R f +(Include original Fortran source as comments.)5 1808 1 1260 5040 t +10 B f +(-cd)900 5208 w +10 R f +( com-)1 238(Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for the double)14 3722 2 1260 5208 t +(plex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively.)9 2634 1 1260 5328 t +10 B f +(-d)900 5496 w +10 I f +(dir)989 5496 w +10 R f +(Write)1260 5496 w +10 CW f +(.c)1512 5496 w +10 R f +(\256les in directory)2 655 1 1657 5496 t +10 I f +(dir)2337 5496 w +10 R f +(instead of the current directory.)4 1255 1 2479 5496 t +10 B f +(-E)900 5664 w +10 R f +(Declare uninitialized)1 834 1 1260 5664 t +9 R f +(COMMON)2117 5664 w +10 R f +(to be)1 197 1 2557 5664 t +10 B f +(Extern)2779 5664 w +10 R f +(\(overridably de\256ned in)2 915 1 3098 5664 t +10 CW f +(f2c.h)4038 5664 w +10 R f +(as)4363 5664 w +10 B f +(extern\).)4471 5664 w +(-ec)900 5832 w +10 R f +(Place uninitialized)1 780 1 1260 5832 t +9 R f +(COMMON)2102 5832 w +10 R f +(blocks in separate \256les:)3 1052 1 2581 5832 t +10 B f +(COMMON /ABC/)1 819 1 3697 5832 t +10 R f +(appears in \256le)2 640 1 4580 5832 t +10 B f +(abc)1260 5952 w +10 S f +(_)1410 5952 w +10 B f +(com.c)1460 5952 w +10 R f +(. Option)1 359 1 1706 5952 t +10 CW f +(-e1c)2096 5952 w +10 R f +(bundles the separate \256les into the output \256le, with comments that give)11 2854 1 2366 5952 t +(an unbundling)1 575 1 1260 6072 t +10 I f +(sed)1860 6072 w +10 R f +(\(1\) script.)1 388 1 2001 6072 t +10 B f +(-ext)900 6240 w +10 R f +(Complain about)1 642 1 1260 6240 t +10 I f +(f 77)1 136 1 1927 6240 t +10 R f +(\(1\) extensions.)1 588 1 2071 6240 t +10 B f +(-f)900 6408 w +10 R f +( 72 and do not pad \256xed-format lines shorter)8 1861(Assume free-format input: accept text after column)6 2099 2 1260 6408 t +(than 72 characters with blanks.)4 1239 1 1260 6528 t +10 B f +(-72)900 6696 w +10 R f +(Treat text appearing after column 72 as an error.)8 1930 1 1260 6696 t +10 B f +(-g)900 6864 w +10 R f +(Include original Fortran line numbers in)5 1601 1 1260 6864 t +10 CW f +(#line)2886 6864 w +10 R f +(lines.)3211 6864 w +10 B f +(-h)900 7032 w +10 R f +( strings on word \(or, if the option)7 1334(Emulate Fortran 66's treatment of Hollerith: try to align character)9 2626 2 1260 7032 t +(is)1260 7152 w +10 CW f +(-hd)1352 7152 w +10 R f +(, on double-word\) boundaries.)3 1206 1 1532 7152 t +( 24)1 125( Page)1 3997(May 12, 1996)2 558 3 540 7680 t +cleartomark +showpage +saveobj restore +%%EndPage: 1 25 +%%Page: 25 26 +/saveobj save def +mark +26 pagesetup +9 B f +( \( 1 \))3 126( F2C)1 1621( \))1 37( B)1 83( Appendix)1 382( \()1 68( System V)2 386( UNIX)1 1686(F2C \( 1 \))3 291 9 540 480 t +10 B f +(-i2)900 960 w +10 R f +(Similar to)1 407 1 1260 960 t +10 B f +(-I2)1701 960 w +10 R f +( assume a modi\256ed)3 799(, but)1 187 2 1823 960 t +10 I f +(libF77)2844 960 w +10 R f +(and)3146 960 w +10 I f +(libI77)3325 960 w +10 R f +(\(compiled with)1 618 1 3599 960 t +10 B f +(-Df 2c)1 240 1 4252 960 t +10 S f +(_)4492 960 w +10 B f +(i2)4542 960 w +10 R f +(\), so)1 182 1 4620 960 t +9 R f +(INTEGER)4835 960 w +10 R f +(and)1260 1080 w +9 R f +(LOGICAL)1427 1080 w +10 R f +(variables may be assigned by)4 1170 1 1847 1080 t +9 R f +(INQUIRE)3040 1080 w +10 R f +(and array lengths are stored in short ints.)7 1625 1 3435 1080 t +10 B f +(-i90)900 1248 w +10 R f +( iand, ibclr, ibits, ibset, ieor, ior,)6 1319(Do not recognize the Fortran 90 bit-manipulation intrinsics btest,)8 2641 2 1260 1248 t +(ishft, and ishftc.)2 644 1 1260 1368 t +10 B f +(-kr)900 1536 w +10 R f +( where K&R \(\256rst edition\) paren-)5 1389(Use temporary values to enforce Fortran expression evaluation)7 2571 2 1260 1536 t +( the option is)3 562( If)1 130(thesization rules allow rearrangement.)3 1566 3 1260 1656 t +10 CW f +(-krd)3557 1656 w +10 R f +(, use double precision temporaries)4 1423 1 3797 1656 t +(even for single-precision operands.)3 1402 1 1260 1776 t +10 B f +(-P)900 1944 w +10 R f +(Write a)1 310 1 1260 1944 t +10 I f +(\256le)1609 1944 w +10 B f +(.P)1739 1944 w +10 R f +(of ANSI \(or C++\) prototypes for de\256nitions in each input)9 2422 1 1864 1944 t +10 I f +(\256le)4325 1944 w +10 B f +(.f)4455 1944 w +10 R f +(or)4553 1944 w +10 I f +(\256le)4676 1944 w +10 B f +(.F)4806 1944 w +10 I f +(.)4892 1944 w +10 R f +(When)4982 1944 w +( Option)1 332( from standard input, write prototypes at the beginning of standard output.)11 3005(reading Fortran)1 623 3 1260 2064 t +10 B f +(-Ps)1260 2184 w +10 R f +(implies)1418 2184 w +10 B f +(-P)1738 2184 w +10 R f +(and gives exit status 4 if rerunning)6 1382 1 1857 2184 t +10 I f +(f 2c)1 130 1 3264 2184 t +10 R f +(may change prototypes or declarations.)4 1566 1 3419 2184 t +10 B f +(-p)900 2352 w +10 R f +(Supply preprocessor de\256nitions to make common-block members look like local variables.)10 3638 1 1260 2352 t +10 B f +(-R)900 2520 w +10 R f +(Do not promote)2 633 1 1260 2520 t +9 R f +(REAL)1916 2520 w +10 R f +(functions and operations to)3 1085 1 2176 2520 t +9 R f +(DOUBLE PRECISION.)1 877 1 3284 2520 t +10 R f +(Option)4212 2520 w +10 CW f +(-!R)4516 2520 w +10 R f +(con\256rms the)1 498 1 4722 2520 t +(default, which imitates)2 913 1 1260 2640 t +10 I f +(f 77)1 136 1 2198 2640 t +10 R f +(.)2342 2640 w +10 B f +(-r)900 2808 w +10 R f +(Cast values of REAL functions \(including intrinsics\) to REAL.)8 2524 1 1260 2808 t +10 B f +(-r8)900 2976 w +10 R f +(Promote)1260 2976 w +9 R f +(REAL)1622 2976 w +10 R f +(to)1882 2976 w +9 R f +(DOUBLE PRECISION, COMPLEX)2 1329 1 1983 2976 t +10 R f +(to)3337 2976 w +9 R f +(DOUBLE COMPLEX.)1 841 1 3438 2976 t +10 B f +(-s)900 3144 w +10 R f +( by option)2 406( Suppressed)1 505(Preserve multidimensional subscripts.)2 1519 3 1260 3144 t +10 CW f +(-C)3715 3144 w +10 R f +(.)3860 3144 w +10 B f +(-T)900 3312 w +10 I f +(dir)1000 3312 w +10 R f +(Put temporary \256les in directory)4 1249 1 1260 3312 t +10 I f +(dir.)2534 3312 w +10 B f +(-w8)900 3480 w +10 R f +(Suppress warnings when)2 993 1 1260 3480 t +9 R f +(COMMON)2276 3480 w +10 R f +(or)2716 3480 w +9 R f +(EQUIVALENCE)2822 3480 w +10 R f +(forces odd-word alignment of doubles.)4 1550 1 3482 3480 t +10 B f +(-W)900 3648 w +10 I f +(n)1033 3648 w +10 R f +(Assume)1260 3648 w +10 I f +(n)1607 3648 w +10 R f +(characters/word \(default 4\) when initializing numeric variables with character data.)9 3324 1 1682 3648 t +10 B f +(-z)900 3816 w +10 R f +(Do not implicitly recognize)3 1102 1 1260 3816 t +9 R f +(DOUBLE COMPLEX.)1 841 1 2385 3816 t +10 B f +(-!bs)900 3984 w +10 R f +(Do not recognize)2 687 1 1260 3984 t +10 I f +(b)1972 3984 w +10 R f +(ack)2022 3984 w +10 I f +(s)2160 3984 w +10 R f +(lash escapes \(\\", \\', \\0, \\\\, \\b, \\f, \\n, \\r, \\t, \\v\) in character strings.)14 2516 1 2199 3984 t +10 B f +(-!c)900 4152 w +10 R f +(Inhibit C output, but produce)4 1164 1 1260 4152 t +10 B f +(-P)2449 4152 w +10 R f +(output.)2568 4152 w +10 B f +(-!I)900 4320 w +10 R f +(Reject)1260 4320 w +10 B f +(include)1540 4320 w +10 R f +(statements.)1877 4320 w +10 B f +(-!i8)900 4488 w +10 R f +(Disallow)1260 4488 w +9 R f +(INTEGER)1644 4488 w +9 S f +(*)2029 4488 w +9 R f +(8.)2074 4488 w +10 B f +(-!it)900 4656 w +10 R f +(Don't infer types of untyped)4 1149 1 1260 4656 t +9 R f +(EXTERNAL)2435 4656 w +10 R f +(procedures from use as parameters to previously de\256ned)7 2281 1 2939 4656 t +(or prototyped procedures.)2 1028 1 1260 4776 t +10 B f +(-!P)900 4944 w +10 R f +(Do not attempt to infer)4 916 1 1260 4944 t +9 R f +(ANSI)2199 4944 w +10 R f +(or C++ prototypes from usage.)4 1230 1 2434 4944 t +(The resulting C invokes the support routines of)7 1927 1 900 5112 t +10 I f +(f 77)1 136 1 2858 5112 t +10 R f +( be loaded by)3 556(; object code should)3 820 2 3002 5112 t +10 I f +(f 77)1 136 1 4410 5112 t +10 R f +(or with)1 293 1 4578 5112 t +10 I f +(ld)4903 5112 w +10 R f +(\(1\) or)1 231 1 4989 5112 t +10 I f +(cc)900 5232 w +10 R f +(\(1\) options)1 436 1 996 5232 t +10 B f +(-lF77 -lI77 -lm)2 616 1 1457 5232 t +10 R f +( conventions are those of)4 998(. Calling)1 370 2 2073 5232 t +10 I f +(f77)3466 5232 w +10 R f +(: see the reference below.)4 1015 1 3602 5232 t +9 B f +(FILES)540 5400 w +10 I f +(\256le)900 5520 w +10 B f +(.[fF])1030 5520 w +10 R f +(input \256le)1 359 1 2160 5520 t +10 S f +(*)900 5688 w +10 B f +(.c)950 5688 w +10 R f +(output \256le)1 409 1 2160 5688 t +10 CW f +(/usr/include/f2c.h)900 5856 w +10 R f +(header \256le)1 418 1 2160 5856 t +10 CW f +(/usr/lib/libF77.a)900 6024 w +10 R f +(intrinsic function library)2 977 1 2160 6024 t +10 CW f +(/usr/lib/libI77.a)900 6192 w +10 R f +(Fortran I/O library)2 743 1 2160 6192 t +10 CW f +(/lib/libc.a)900 6360 w +10 R f +(C library, see section 3)4 918 1 2160 6360 t +9 B f +(SEE ALSO)1 438 1 540 6528 t +10 R f +(S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 Compiler',)11 3091 1 900 6648 t +10 I f +( Sharing System)2 696(UNIX Time)1 483 2 4041 6648 t +(Programmer's Manual)1 924 1 900 6768 t +10 R f +(, Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.)8 2368 1 1824 6768 t +9 B f +(DIAGNOSTICS)540 6936 w +10 R f +(The diagnostics produced by)3 1151 1 900 7056 t +10 I f +(f 2c)1 130 1 2076 7056 t +10 R f +(are intended to be self-explanatory.)4 1410 1 2231 7056 t +( 12, 1996)2 375( May)1 3986(Page 25)1 319 3 540 7680 t +cleartomark +showpage +saveobj restore +%%EndPage: 25 26 +%%Page: 26 27 +/saveobj save def +mark +27 pagesetup +9 B f +( \( 1 \))3 126( F2C)1 1621( \))1 37( B)1 83( Appendix)1 382( \()1 68( System V)2 386( UNIX)1 1686(F2C \( 1 \))3 291 9 540 480 t +(BUGS)540 960 w +10 R f +( machine running)2 721(Floating-point constant expressions are simpli\256ed in the \257oating-point arithmetic of the)10 3599 2 900 1080 t +10 I f +(f 2c)1 130 1 900 1200 t +10 R f +(, so they are typically accurate to at most 16 or 17 decimal places.)13 2631 1 1038 1200 t +(Untypable)900 1320 w +9 R f +(EXTERNAL)1339 1320 w +10 R f +(functions are declared)2 880 1 1839 1320 t +10 B f +(int)2744 1320 w +10 R f +(.)2861 1320 w +( 26)1 125( Page)1 3997(May 12, 1996)2 558 3 540 7680 t +cleartomark +showpage +saveobj restore +%%EndPage: 26 27 +%%Trailer +done +%%Pages: 27 +%%DocumentFonts: Times-Italic Times-Roman Symbol Times-BoldItalic Courier Times-Bold diff --git a/unix/f2c/fc b/unix/f2c/fc new file mode 100644 index 00000000..1f71e598 --- /dev/null +++ b/unix/f2c/fc @@ -0,0 +1,366 @@ +#! /bin/sh + +# NOTE: you may need to adjust the references to /usr/local/... below +# (or remove them if they're not needed on your system). +# You may need to add something like "-Olimit 2000" to the -O +# processing below or change it to something more suitable for your +# system. See also the comments starting with ### below. + +# Note that with some shells, invocations of the form +# CFLAGS='system-specific stuff' fc ... +# may be useful as way to pass system-specific stuff to the C compiler. +# The script below simply appends to the initial CFLAGS value. + +PATH=/usr/local/bin:/bin:/usr/bin + +# f77-style shell script to compile and load fortran, C, and assembly codes + +# usage: f77 [options] files [-l library] + +# Options: + +# -o objfile Override default executable name a.out. + +# -a use automatic variable storage (on the stack) +# by default -- rather than static storage + +# -c Do not call linker, leave relocatables in *.o. + +# -C Check that subscripts are in bounds. + +# -S leave assembler output on file.s + +# -L libdir (passed to ld) + +# -l library (passed to ld) + +# -u complain about undeclared variables + +# -w omit all warning messages + +# -w66 omit Fortran 66 compatibility warning messages + +# files FORTRAN source files ending in .f . +# FORTRAN with cpp preprocessor directives +# ending in .F . +# C source files ending in .c . +# Assembly language files ending in .s . +# efl source files ending in .e . +# RATFOR files ending in .r . +# Object files ending in .o . +# Shared libraries ending in .so . + +# f2c prototype files ending in .P ; such +# files only affect subsequent files. + +# -D def passed to C compiler (for .c files) +# or to cpp (for .F files) + +# -I includepath passed to C compiler (for .c files) +# or to cpp (for .F files), and to f2c + +# -m xxx passed to C compiler as -mxxx + +# -N tnnn allow nnn entries in table t + +# -P emit .P files + +# -r8 promote real to double precision and +# complex to double complex + +# -s strip executable + +# -trapuv Initialize floating-point variables to +# signaling NaNs (on machines with IEEE +# arithmetic) unless they appear in save, +# common, or data statements. Initialize +# other kinds of variables to values that +# may attract attention if used without +# being assigned proper values. + +# -U def passed to C compiler (for .c files) +# or to cpp (for .F files) to remove def + +# -v show current f2c version +# --version same as -v + +s=/tmp/stderr_$$ +t=/tmp/f77_$$.o +### On some systems (e.g., IRIX), -common prevents complaints +### about multiple definitions of COMMON blocks. +#CC=${CC_f2c:-'cc -common'} +CC=${CC_f2c:-'cc'} +EFL=${EFL:-efl} +EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'} +RATFOR=${RATFOR:-ratfor} +RFLAGS=${RFLAGS:-'-6&'} +F2C=${F2C:-/usr/local/bin/f2c} +show_fc_help=0 +case $1 in + --help) show_fc_help=1;; + --version) show_fc_help=2;; + '-?') show_fc_help=1;; + -h) show_fc_help=1;; + -v) show_fc_help=2;; + esac +case $show_fc_help in + 1) + echo 'f77 script based on f2c' + echo 'For usage details, see comments at the beginning of' $0 . + echo 'For pointers to f2c documentation, invoke' $F2C --help + exit 0;; + 2) + echo $0 'script based on f2c:'; $F2C -v + exit 0;; + esac +F2CFLAGS=${F2CFLAGS:='-ARw8 -Nn802 -Nq300 -Nx400'} +CPP=${CPP:-/lib/cpp} +rc=0 +trap "rm -f $s $t; exit \$rc" 0 +OUTF=a.out +OUTO= +cOPT=1 +set -- `getopt acCD:gI:L:m:N:O:U:o:r:sSt:uw6 "$@"` +case $? in 0);; *) rc=$?; exit;; esac +CPPFLAGS=${CPPFLAGS:-'-I/usr/local/include'} +CFLAGSF2C=${CFLAGSF2C:-'-I/usr/local/include'} +OFILES= +trapuv= +strip= +LIBS="-lf2c -lm" +while + test X"$1" != X-- +do + case "$1" + in + -a) F2CFLAGS="$F2CFLAGS -a" + shift;; + + -C) F2CFLAGS="$F2CFLAGS -C" + shift;; + + -c) cOPT=0 + shift + ;; + + -D) CPPFLAGS="$CPPFLAGS -D$2" + shift 2 + ;; + + -g) CFLAGS="$CFLAGS -g" + F2CFLAGS="$F2CFLAGS -g" + shift;; + + -I) CPPFLAGS="$CPPFLAGS -I$2" + F2CFLAGS="$F2CFLAGS -I$2" + shift 2 + ;; + + -m) CC="$CC -m$2" + shift 2 + ;; + + -U) CPPFLAGS="$CPPFLAGS -U$2" + shift 2 + ;; + + -o) OUTF=$2 + OUTO=$2 + shift 2 + ;; + + -O) case $2 in 1) O=-O1;; 2) O=-O2;; 3) O=-O3;; *) O=-O;; esac + case $O in -O);; *) shift;; esac + CFLAGS="$CFLAGS $O" +# CFLAGS="$CFLAGS $O -Olimit 2000" + shift + ;; + + -r) case $2 in 8) F2CFLAGS="$F2CFLAGS -r8";; + *) echo "Ignoring -r$2";; esac + shift; shift + ;; + + -s) strip=1 + shift + ;; + + -u) F2CFLAGS="$F2CFLAGS -u" + shift + ;; + + -w) F2CFLAGS="$F2CFLAGS -w" + case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift + case $2 in -6) shift;; esac;; esac + shift + ;; + + -L) OFILES="$OFILES $1$2" + shift 2 + case $cOPT in 1) cOPT=2;; esac + ;; + + -L*) OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + + -N) F2CFLAGS="$F2CFLAGS $1""$2" + shift 2 + ;; + + -P) F2CFLAGS="$F2CFLAGS $1" + shift + ;; + + + -S) CFLAGS="$CFLAGS -S" + cOPT=0 + shift + ;; + + -t) + case $2 in + rapuv) + F2CFLAGS="$F2CFLAGS -trapuv" + trapuv=1 +# LIBS="$LIBS -lfpe" + shift 2;; + *) + echo "invalid parameter $1" 1>&2 + shift;; + esac + ;; + + '') echo $0: 'unexpected null argument'; exit 1;; + + *) + echo "invalid parameter $1" 1>&2 + shift + ;; + esac +done +shift +case $cOPT in 0) case $OUTO in '');; *) CFLAGS="$CFLAGS -o $OUTO";; esac;; esac +while + test -n "$1" +do + case "$1" + in + *.[fF]) + case "$1" in *.f) f=".f";; *.F) f=".F";; esac + case "$1" in + *.f) b=`basename $1 .f` + $F2C $F2CFLAGS $1 + rc=$? + ;; + *.F) b=`basename $1 .F` + $CPP $CPPFLAGS $1 >$b.i + rc=$? + case $rc in 0) + $F2C $F2CFLAGS <$b.i >$b.c + rc=$? + ;;esac + rm $b.i + ;; + esac + case $rc in 0);; *) exit;; esac + $CC -c $CFLAGSF2C $CFLAGS $b.c 2>$s + rc=$? + sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2 + case $rc in 0);; *) exit;; esac + OFILES="$OFILES $b.o" + rm $b.c + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.e) + b=`basename $1 .e` + $EFL $EFLFLAGS $1 >$b.f + case $? in 0);; *) rc=$?; exit;; esac + $F2C $F2CFLAGS $b.f + case $? in 0);; *) rc=$?; exit;; esac + $CC -c $CFLAGSF2C $CFLAGS $b.c + case $? in 0);; *) rc=$?; exit;; esac + OFILES="$OFILES $b.o" + rm $b.[cf] + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.r) + b=`basename $1 .r` + $RATFOR $RFLAGS $1 >$b.f + case $? in 0);; *) rc=$?; exit;; esac + $F2C $F2CFLAGS $b.f + case $? in 0);; *) rc=$?; exit;; esac + $CC -c $CFLAGSF2C $CFLAGS $b.c + case $? in 0);; *) rc=$?; exit;; esac + OFILES="$OFILES $b.o" + rm $b.[cf] + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.s) + echo $1: 1>&2 + OFILE=`basename $1 .s`.o + ${AS:-as} -o $OFILE $AFLAGS $1 + case $? in 0);; *) rc=$?; exit;; esac + OFILES="$OFILES $OFILE" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.c) + echo $1: 1>&2 + OFILE=`basename $1 .c`.o + $CC -c $CFLAGSF2C $CPPFLAGS $CFLAGS $1 + rc=$?; case $rc in 0);; *) rc=$?; exit;; esac + OFILES="$OFILES $OFILE" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.o) + OFILES="$OFILES $1" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.so) + OFILES="$OFILES $1" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + -[lL]) + OFILES="$OFILES $1$2" + shift 2 + case $cOPT in 1) cOPT=2;; esac + ;; + -[lL]*) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + -o) + case $cOPT in 0) CFLAGS="$CFLAGS -o $2";; *) OUTF=$2;; esac + shift 2;; + *.P) + F2CFLAGS="$F2CFLAGS $1" + shift + ;; + *) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + esac +done + +### On some (IRIX) systems, -Wl,-dont_warn_unused prevents complaints +### about unnecessary -l options. + +case $cOPT in 2) +# case $trapuv in 1) OFILES="$OFILES -lfpe";; esac +# $CC -Wl,-dont_warn_unused -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS + $CC -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS + case $strip in 1) strip $OUTF;; esac + ;; esac +rc=$? +exit $rc diff --git a/unix/f2c/getopt.c b/unix/f2c/getopt.c new file mode 100644 index 00000000..6c97b59d --- /dev/null +++ b/unix/f2c/getopt.c @@ -0,0 +1,102 @@ +/**************************************************************** +Copyright 1996 by Lucent Technologies. + +Permission to use, copy, modify, and distribute this software and +its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of Bell Laboratories or Lucent +Technologies or any of their entities not be used in advertising +or publicity pertaining to distribution of the software without +specific, written prior permission. + +Lucent disclaims all warranties with regard to this software, +including all implied warranties of merchantability and fitness. +In no event shall Lucent be liable for any special, indirect or +consequential damages or any damages whatsoever resulting from +loss of use, data or profits, whether in an action of contract, +negligence or other tortious action, arising out of or in +connection with the use or performance of this software. +****************************************************************/ + +/* Source for a "getopt" command, as invoked by the "fc" script. */ + +#include + +static char opts[256]; /* assume 8-bit bytes */ + + int +#ifdef KR_headers +main(argc, argv) int argc; char **argv; +#else +main(int argc, char **argv) +#endif +{ + char **av, *fmt, *s, *s0; + int i; + + if (argc < 2) { + fprintf(stderr, "Usage: getopt optstring arg1 arg2...\n"); + return 1; + } + for(s = argv[1]; *s; ) { + i = *(unsigned char *)s++; + if (!opts[i]) + opts[i] = 1; + if (*s == ':') { + s++; + opts[i] = 2; + } + } + /* scan for legal args */ + av = argv + 2; + nextarg: + while(s = *av++) { + if (*s++ != '-' || s[0] == '-' && s[1] == 0) + break; + while(i = *(unsigned char *)s++) { + switch(opts[i]) { + case 0: + fprintf(stderr, + "getopt: Illegal option -- %c\n", s[-1]); + return 1; + case 2: + s0 = s - 1; + if (*s || *av++) + goto nextarg; + fprintf(stderr, + "getopt: Option requires an argument -- %c\n", + *s0); + return 1; + } + } + } + /* output modified args */ + av = argv + 2; + fmt = "-%c"; + nextarg1: + while(s = *av++) { + if (s[0] != '-') + break; + if (*++s == '-' && !s[1]) { + s = *av++; + break; + } + while(*s) { + printf(fmt, *s); + fmt = " -%c"; + if (opts[*(unsigned char *)s++] == 2) { + if (!*s) + s = *av++; + printf(" %s", s); + goto nextarg1; + } + } + } + printf(*fmt == ' ' ? " --" : "--"); + for(; s; s = *av++) + printf(" %s", s); + printf("\n"); + return 0; + } diff --git a/unix/f2c/index b/unix/f2c/index new file mode 100644 index 00000000..b207d367 --- /dev/null +++ b/unix/f2c/index @@ -0,0 +1,45 @@ +file f2c/changes + +file f2c/f2c.1 +lang man page + +file f2c/f2c.1t +lang troff -man source for man page + +file f2c/f2c.h + +file f2c/f2c.ps +lang Postscript + +file f2c/f2c.pdf + +file f2c/fc +lang Bourne shell script + +file f2c/getopt.c +for Source for "getopt" command used by fc (for systems lacking getopt) + +file f2c/index + +file f2c/libf77 +lang C (bundle of source) + +file f2c/libi77 +lang C (bundle of source) + +file f2c/libf2c.zip +for combined libf77, libi77, with several makefile variants +size 102 KB +# DO NOT REQUEST BY EMAIL, USE FTP! + +lib f2c/msdos +for MS-DOS f2c binaries (ftp only) + +lib f2c/mswin +for Win32 f2c binaries (ftp only) + +lib f2c/src +for f2c source + +file f2c/README + diff --git a/unix/f2c/index.html b/unix/f2c/index.html new file mode 100644 index 00000000..01a7571d --- /dev/null +++ b/unix/f2c/index.html @@ -0,0 +1,57 @@ + +f2c + + +

f2c

+

+Click here to see the number of accesses to this library. +

+
+file	changes
+
+file	f2c.1
+lang	man page
+
+file	f2c.1t
+lang	troff -man source for man page
+
+file	f2c.h
+
+file	f2c.ps
+lang	Postscript
+
+file	f2c.pdf
+
+file	fc
+lang	Bourne shell script
+
+file	getopt.c
+for	Source for "getopt" command used by fc (for systems lacking getopt)
+
+file	index
+
+file	libf77
+lang	C (bundle of source)
+
+file	libi77
+lang	C (bundle of source)
+
+file	libf2c.zip
+for	combined libf77, libi77, with several makefile variants
+size	102 KB
+#	DO NOT REQUEST BY EMAIL, USE FTP!
+
+lib	msdos
+for	MS-DOS f2c binaries (ftp only)
+
+lib	mswin
+for	Win32 f2c binaries (ftp only)
+
+lib	src
+for	f2c source
+
+file	README
+
+
+ + diff --git a/unix/f2c/libf2c/1 b/unix/f2c/libf2c/1 new file mode 100644 index 00000000..f9db547c --- /dev/null +++ b/unix/f2c/libf2c/1 @@ -0,0 +1 @@ +make: *** No rule to make target `_spool'. Stop. diff --git a/unix/f2c/libf2c/Notice b/unix/f2c/libf2c/Notice new file mode 100644 index 00000000..261b719b --- /dev/null +++ b/unix/f2c/libf2c/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/unix/f2c/libf2c/README b/unix/f2c/libf2c/README new file mode 100644 index 00000000..c163b877 --- /dev/null +++ b/unix/f2c/libf2c/README @@ -0,0 +1,374 @@ +As shipped, "makefile" is a copy of "makefile.u", a Unix makefile. +Variants for other systems have names of the form makefile.* and +have initial comments saying how to invoke them. You may wish to +copy one of the other makefile.* files to makefile. + +If you use a C++ compiler, first say + + make hadd + +to create a suitable f2c.h from f2c.h0 and f2ch.add. Otherwise, + + make f2c.h + +will just copy f2c.h0 to f2c.h . + +If your compiler does not recognize ANSI C headers, +compile with KR_headers defined: either add -DKR_headers +to the definition of CFLAGS in the makefile, or insert + +#define KR_headers + +at the top of f2c.h . + +If your system lacks onexit() and you are not using an ANSI C +compiler, then you should compile main.c with NO_ONEXIT defined. +See the comments about onexit in makefile.u. + +If your system has a double drem() function such that drem(a,b) +is the IEEE remainder function (with double a, b), then you may +wish to compile r_mod.c and d_mod.c with IEEE_drem defined. + +To check for transmission errors, issue the command + make check +or + make -f makefile.u check + +This assumes you have the xsum program whose source, xsum.c, +is distributed as part of "all from f2c/src", and that it +is installed somewhere in your search path. If you do not +have xsum, you can obtain xsum.c by sending the following E-mail +message to netlib@netlib.org + send xsum.c from f2c/src + +For convenience, the f2c.h0 in this directory is a copy of netlib's +"f2c.h from f2c". It is best to install f2c.h in a standard place, +so "include f2c.h" will work in any directory without further ado. +Beware that the makefiles do not cause recompilation when f2c.h is +changed. + +On machines, such as those using a DEC Alpha processor, on which +sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and +sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by +removing the first occurrence of "long " on each line containing +"long ". On Unix systems, you can do this by issuing the commands + mv f2c.h f2c.h0 + sed 's/long int /int /' f2c.h0 >f2c.h +On such machines, one can enable INTEGER*8 by uncommenting the typedefs +of longint and ulongint in f2c.h and adjusting them, so they read + typedef long longint; + typedef unsigned long ulongint; +and by compiling libf2c with -DAllow_TYQUAD, as discussed below. + + +Most of the routines in libf2c are support routines for Fortran +intrinsic functions or for operations that f2c chooses not +to do "in line". There are a few exceptions, summarized below -- +functions and subroutines that appear to your program as ordinary +external Fortran routines. + +If you use the REAL valued functions listed below (ERF, ERFC, +DTIME, and ETIME) with "f2c -R", then you need to compile the +corresponding source files with -DREAL=float. To do this, it is +perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile. + +1. CALL ABORT prints a message and causes a core dump. + +2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION + error functions (with x REAL and d DOUBLE PRECISION); + DERF must be declared DOUBLE PRECISION in your program. + Both ERF and DERF assume your C library provides the + underlying erf() function (which not all systems do). + +3. ERFC(r) and DERFC(d) are the complementary error functions: + ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d) + (except that their results may be more accurate than + explicitly evaluating the above formulae would give). + Again, ERFC and r are REAL, and DERFC and d are DOUBLE + PRECISION (and must be declared as such in your program), + and ERFC and DERFC rely on your system's erfc(). + +4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER + variable, sets s to the n-th command-line argument (or to + all blanks if there are fewer than n command-line arguments); + CALL GETARG(0,s) sets s to the name of the program (on systems + that support this feature). See IARGC below. + +5. CALL GETENV(name, value), where name and value are of type + CHARACTER, sets value to the environment value, $name, of + name (or to blanks if $name has not been set). + +6. NARGS = IARGC() sets NARGS to the number of command-line + arguments (an INTEGER value). + +7. CALL SIGNAL(n,func), where n is an INTEGER and func is an + EXTERNAL procedure, arranges for func to be invoked when n + occurs (on systems where this makes sense). + +If your compiler complains about the signal calls in main.c, s_paus.c, +and signal_.c, you may need to adjust signal1.h suitably. See the +comments in signal1.h. + +8. ETIME(ARR) and DTIME(ARR) are REAL functions that return + execution times. ARR is declared REAL ARR(2). The elapsed + user and system CPU times are stored in ARR(1) and ARR(2), + respectively. ETIME returns the total elapsed CPU time, + i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU + time since the previous call on DTIME. + +9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes + cmd to the system's command processor (on systems where + this can be done). + +10. CALL FLUSH flushes all buffers. + +11. FTELL(i) is an INTEGER function that returns the current + offset of Fortran unit i (or -1 if unit i is not open). + +12. CALL FSEEK(i, offset, whence, *errlab) attemps to move + Fortran unit i to the specified offset: absolute offset + if whence = 0; relative to the current offset if whence = 1; + relative to the end of the file if whence = 2. It branches + to label errlab if unit i is not open or if the call + otherwise fails. + +The routines whose objects are makefile.u's $(I77) are for I/O. +The following comments apply to them. + +If your system lacks /usr/include/local.h , +then you should create an appropriate local.h in +this directory. An appropriate local.h may simply +be empty, or it may #define VAX or #define CRAY +(or whatever else you must do to make fp.h work right). +Alternatively, edit fp.h to suite your machine. + +If your system lacks /usr/include/fcntl.h , then you +should simply create an empty fcntl.h in this directory. +If your compiler then complains about creat and open not +having a prototype, compile with OPEN_DECL defined. +On many systems, open and creat are declared in fcntl.h . + +If your system's sprintf does not work the way ANSI C +specifies -- specifically, if it does not return the +number of characters transmitted -- then insert the line + +#define USE_STRLEN + +at the end of fmt.h . This is necessary with +at least some versions of Sun software. +In particular, if you get a warning about an improper +pointer/integer combination in compiling wref.c, then +you need to compile with -DUSE_STRLEN . + +If your system's fopen does not like the ANSI binary +reading and writing modes "rb" and "wb", then you should +compile open.c with NON_ANSI_RW_MODES #defined. + +If you get error messages about references to cf->_ptr +and cf->_base when compiling wrtfmt.c and wsfe.c or to +stderr->_flag when compiling err.c, then insert the line + +#define NON_UNIX_STDIO + +at the beginning of fio.h, and recompile everything (or +at least those modules that contain NON_UNIX_STDIO). + +Unformatted sequential records consist of a length of record +contents, the record contents themselves, and the length of +record contents again (for backspace). Prior to 17 Oct. 1991, +the length was of type int; now it is of type long, but you +can change it back to int by inserting + +#define UIOLEN_int + +at the beginning of fio.h. This affects only sue.c and uio.c . + +If you have a really ancient K&R C compiler that does not understand +void, add -Dvoid=int to the definition of CFLAGS in the makefile. + +On VAX, Cray, or Research Tenth-Edition Unix systems, you may +need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS +to make fp.h work correctly. Alternatively, you may need to +edit fp.h to suit your machine. + +If your compiler complains about the signal calls in main.c, s_paus.c, +and signal_.c, you may need to adjust signal1.h suitably. See the +comments in signal1.h. + +You may need to supply the following non-ANSI routines: + + fstat(int fileds, struct stat *buf) is similar +to stat(char *name, struct stat *buf), except that +the first argument, fileds, is the file descriptor +returned by open rather than the name of the file. +fstat is used in the system-dependent routine +canseek (in the libf2c source file err.c), which +is supposed to return 1 if it's possible to issue +seeks on the file in question, 0 if it's not; you may +need to suitably modify err.c . On non-UNIX systems, +you can avoid references to fstat and stat by compiling +with NON_UNIX_STDIO defined; in that case, you may need +to supply access(char *Name,0), which is supposed to +return 0 if file Name exists, nonzero otherwise. + + char * mktemp(char *buf) is supposed to replace the +6 trailing X's in buf with a unique number and then +return buf. The idea is to get a unique name for +a temporary file. + +On non-UNIX systems, you may need to change a few other, +e.g.: the form of name computed by mktemp() in endfile.c and +open.c; the use of the open(), close(), and creat() system +calls in endfile.c, err.c, open.c; and the modes in calls on +fopen() and fdopen() (and perhaps the use of fdopen() itself +-- it's supposed to return a FILE* corresponding to a given +an integer file descriptor) in err.c and open.c (component ufmt +of struct unit is 1 for formatted I/O -- text mode on some systems +-- and 0 for unformatted I/O -- binary mode on some systems). +Compiling with -DNON_UNIX_STDIO omits all references to creat() +and almost all references to open() and close(), the exception +being in the function f__isdev() (in open.c). + +If you wish to use translated Fortran that has funny notions +of record length for direct unformatted I/O (i.e., that assumes +RECL= values in OPEN statements are not bytes but rather counts +of some other units -- e.g., 4-character words for VMS), then you +should insert an appropriate #define for url_Adjust at the +beginning of open.c . For VMS Fortran, for example, +#define url_Adjust(x) x *= 4 +would suffice. + +By default, Fortran I/O units 5, 6, and 0 are pre-connected to +stdin, stdout, and stderr, respectively. You can change this +behavior by changing f_init() in err.c to suit your needs. +Note that f2c assumes READ(*... means READ(5... and WRITE(*... +means WRITE(6... . Moreover, an OPEN(n,... statement that does +not specify a file name (and does not specify STATUS='SCRATCH') +assumes FILE='fort.n' . You can change this by editing open.c +and endfile.c suitably. + +Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units +0, 1, ..., 99 are available, i.e., the highest allowed unit number +is MXUNIT - 1. + +Lines protected from compilation by #ifdef Allow_TYQUAD +are for a possible extension to 64-bit integers in which +integer = int = 32 bits and longint = long = 64 bits. + +The makefile does not attempt to compile pow_qq.c, qbitbits.c, +and qbitshft.c, which are meant for use with INTEGER*8. To use +INTEGER*8, you must modify f2c.h to declare longint and ulongint +appropriately; then add $(QINT) to the end of the makefile's +dependency list for libf2c.a (if makefile is a copy of makefile.u; +for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj +to the library's dependency list and adjust libf2c.lbc or libf2c.sy +accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS +assignment. To make longint and ulongint available, it may suffice +to add -DINTEGER_STAR_8 to the CFLAGS assignment. + +Following Fortran 90, s_cat.c and s_copy.c allow the target of a +(character string) assignment to be appear on its right-hand, at +the cost of some extra overhead for all run-time concatenations. +If you prefer the extra efficiency that comes with the Fortran 77 +requirement that the left-hand side of a character assignment not +be involved in the right-hand side, compile s_cat.c and s_copy.c +with -DNO_OVERWRITE . + +Extensions (Feb. 1993) to NAMELIST processing: + 1. Reading a ? instead of &name (the start of a namelist) causes +the namelist being sought to be written to stdout (unit 6); +to omit this feature, compile rsne.c with -DNo_Namelist_Questions. + 2. Reading the wrong namelist name now leads to an error message +and an attempt to skip input until the right namelist name is found; +to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. + 3. Namelist writes now insert newlines before each variable; to omit +this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. + 4. (Sept. 1995) When looking for the &name that starts namelist +input, lines whose first non-blank character is something other +than &, $, or ? are treated as comment lines and ignored, unless +rsne.c is compiled with -DNo_Namelist_Comments. + +Nonstandard extension (Feb. 1993) to open: for sequential files, +ACCESS='APPEND' (or access='anything else starting with "A" or "a"') +causes the file to be positioned at end-of-file, so a write will +append to the file. + +Some buggy Fortran programs use unformatted direct I/O to write +an incomplete record and later read more from that record than +they have written. For records other than the last, the unwritten +portion of the record reads as binary zeros. The last record is +a special case: attempting to read more from it than was written +gives end-of-file -- which may help one find a bug. Some other +Fortran I/O libraries treat the last record no differently than +others and thus give no help in finding the bug of reading more +than was written. If you wish to have this behavior, compile +uio.c with -DPad_UDread . + +If you want to be able to catch write failures (e.g., due to a +disk being full) with an ERR= specifier, compile dfe.c, due.c, +sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to +slower execution and more I/O, but should make ERR= work as +expected, provided fflush returns an error return when its +physical write fails. + +Carriage controls are meant to be interpreted by the UNIX col +program (or a similar program). Sometimes it's convenient to use +only ' ' as the carriage control character (normal single spacing). +If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted +external output lines will have an initial ' ' quietly omitted, +making use of the col program unnecessary with output that only +has ' ' for carriage control. + +The Fortran 77 Standard leaves it up to the implementation whether +formatted writes of floating-point numbers of absolute value < 1 have +a zero before the decimal point. By default, libI77 omits such +superfluous zeros, but you can cause them to appear by compiling +lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . + +If your (Unix) system lacks a ranlib command, you don't need it. +Either comment out the makefile's ranlib invocation, or install +a harmless "ranlib" command somewhere in your PATH, such as the +one-line shell script + + exit 0 + +or (on some systems) + + exec /usr/bin/ar lts $1 >/dev/null + +By default, the routines that implement complex and double complex +division, c_div.c and z_div.c, call sig_die to print an error message +and exit if they see a divisor of 0, as this is sometimes helpful for +debugging. On systems with IEEE arithmetic, compiling c_div.c and +z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both +the real and imaginary parts of the result to +INFINITY if the +numerator is nonzero, or to NaN if it vanishes. + +Nowadays most Unix and Linux systems have function + int ftruncate(int fildes, off_t len); +defined in system header file unistd.h that adjusts the length of file +descriptor fildes to length len. Unless endfile.c is compiled with +-DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if +necessary to shorten files. If your system lacks ftruncate(), compile +endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more +portable scheme of shortening a file by copying to a temporary file +and back again. + +The initializations for "f2c -trapuv" are done by _uninit_f2c(), +whose source is uninit.c, introduced June 2001. On IEEE-arithmetic +systems, _uninit_f2c should initialize floating-point variables to +signaling NaNs and, at its first invocation, should enable the +invalid operation exception. Alas, the rules for distinguishing +signaling from quiet NaNs were not specified in the IEEE P754 standard, +nor were the precise means of enabling and disabling IEEE-arithmetic +exceptions, and these details are thus system dependent. There are +#ifdef's in uninit.c that specify them for some popular systems. If +yours is not one of these systems, it may take some detective work to +discover the appropriate details for your system. Sometimes it helps +to look in the standard include directories for header files with +relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and +it may be simplest to run experiments to see what distinguishes a +signaling from a quiet NaN. (If x is initialized to a signaling +NaN and the invalid operation exception is masked off, as it should +be by default on IEEE-arithmetic systems, then computing, say, +y = x + 1 will yield a quiet NaN.) diff --git a/unix/f2c/libf2c/abort_.c b/unix/f2c/libf2c/abort_.c new file mode 100644 index 00000000..92c841a7 --- /dev/null +++ b/unix/f2c/libf2c/abort_.c @@ -0,0 +1,22 @@ +#include "stdio.h" +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); + +int abort_() +#else +extern void sig_die(const char*,int); + +int abort_(void) +#endif +{ +sig_die("Fortran abort routine called", 1); +return 0; /* not reached */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/arith.h b/unix/f2c/libf2c/arith.h new file mode 100644 index 00000000..a199f927 --- /dev/null +++ b/unix/f2c/libf2c/arith.h @@ -0,0 +1,9 @@ +#define IEEE_8087 +#define Arith_Kind_ASL 1 +#define Long int +#define Intcast (int)(long) +#define Double_Align +#define X64_bit_pointers +#define NANCHECK +#define QNaN0 0x0 +#define QNaN1 0xfff80000 diff --git a/unix/f2c/libf2c/arithchk.c b/unix/f2c/libf2c/arithchk.c new file mode 100644 index 00000000..8e15722a --- /dev/null +++ b/unix/f2c/libf2c/arithchk.c @@ -0,0 +1,248 @@ +/**************************************************************** +Copyright (C) 1997, 1998, 2000 Lucent Technologies +All Rights Reserved + +Permission to use, copy, modify, and distribute this software and +its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the name of Lucent or any of its entities +not be used in advertising or publicity pertaining to +distribution of the software without specific, written prior +permission. + +LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, +INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. +IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY +SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER +IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. +****************************************************************/ + +/* Try to deduce arith.h from arithmetic properties. */ + +#include +#include +#include + +#ifdef NO_FPINIT +#define fpinit_ASL() +#else +#ifndef KR_headers +extern +#ifdef __cplusplus + "C" +#endif + void fpinit_ASL(void); +#endif /*KR_headers*/ +#endif /*NO_FPINIT*/ + + static int dalign; + typedef struct +Akind { + char *name; + int kind; + } Akind; + + static Akind +IEEE_8087 = { "IEEE_8087", 1 }, +IEEE_MC68k = { "IEEE_MC68k", 2 }, +IBM = { "IBM", 3 }, +VAX = { "VAX", 4 }, +CRAY = { "CRAY", 5}; + + static double t_nan; + + static Akind * +Lcheck(void) +{ + union { + double d; + long L[2]; + } u; + struct { + double d; + long L; + } x[2]; + + if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) + dalign = 1; + u.L[0] = u.L[1] = 0; + u.d = 1e13; + if (u.L[0] == 1117925532 && u.L[1] == -448790528) + return &IEEE_MC68k; + if (u.L[1] == 1117925532 && u.L[0] == -448790528) + return &IEEE_8087; + if (u.L[0] == -2065213935 && u.L[1] == 10752) + return &VAX; + if (u.L[0] == 1267827943 && u.L[1] == 704643072) + return &IBM; + return 0; + } + + static Akind * +icheck(void) +{ + union { + double d; + int L[2]; + } u; + struct { + double d; + int L; + } x[2]; + + if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) + dalign = 1; + u.L[0] = u.L[1] = 0; + u.d = 1e13; + if (u.L[0] == 1117925532 && u.L[1] == -448790528) + return &IEEE_MC68k; + if (u.L[1] == 1117925532 && u.L[0] == -448790528) + return &IEEE_8087; + if (u.L[0] == -2065213935 && u.L[1] == 10752) + return &VAX; + if (u.L[0] == 1267827943 && u.L[1] == 704643072) + return &IBM; + return 0; + } + +char *emptyfmt = ""; /* avoid possible warning message with printf("") */ + + static Akind * +ccheck(void) +{ + union { + double d; + long L; + } u; + long Cray1; + + /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ + Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; + if (printf(emptyfmt, Cray1) >= 0) + Cray1 = 1000000*Cray1 + 693716; + if (printf(emptyfmt, Cray1) >= 0) + Cray1 = 1000000*Cray1 + 115456; + u.d = 1e13; + if (u.L == Cray1) + return &CRAY; + return 0; + } + + static int +fzcheck(void) +{ + double a, b; + int i; + + a = 1.; + b = .1; + for(i = 155;; b *= b, i >>= 1) { + if (i & 1) { + a *= b; + if (i == 1) + break; + } + } + b = a * a; + return b == 0.; + } + + static int +need_nancheck(void) +{ + double t; + + errno = 0; + t = log(t_nan); + if (errno == 0) + return 1; + errno = 0; + t = sqrt(t_nan); + return errno == 0; + } + + void +get_nanbits(unsigned int *b, int k) +{ + union { double d; unsigned int z[2]; } u, u1, u2; + + k = 2 - k; + u1.z[k] = u2.z[k] = 0x7ff00000; + u1.z[1-k] = u2.z[1-k] = 0; + u.d = u1.d - u2.d; /* Infinity - Infinity */ + b[0] = u.z[0]; + b[1] = u.z[1]; + } + + int +main(void) +{ + FILE *f; + Akind *a = 0; + int Ldef = 0; + unsigned int nanbits[2]; + + fpinit_ASL(); +#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ + f = fopen("arith.h", "w"); + if (!f) { + printf("Cannot open arith.h\n"); + return 1; + } +#else + f = stdout; +#endif + + if (sizeof(double) == 2*sizeof(long)) + a = Lcheck(); + else if (sizeof(double) == 2*sizeof(int)) { + Ldef = 1; + a = icheck(); + } + else if (sizeof(double) == sizeof(long)) + a = ccheck(); + if (a) { + fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", + a->name, a->kind); + if (Ldef) + fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); + if (dalign) + fprintf(f, "#define Double_Align\n"); + if (sizeof(char*) == 8) + fprintf(f, "#define X64_bit_pointers\n"); +#ifndef NO_LONG_LONG + if (sizeof(long long) > sizeof(long) + && sizeof(long long) == sizeof(void*)) + fprintf(f, "#define LONG_LONG_POINTERS\n"); + if (sizeof(long long) < 8) +#endif + fprintf(f, "#define NO_LONG_LONG\n"); + if (a->kind <= 2) { + if (fzcheck()) + fprintf(f, "#define Sudden_Underflow\n"); + t_nan = -a->kind; + if (need_nancheck()) + fprintf(f, "#define NANCHECK\n"); + if (sizeof(double) == 2*sizeof(unsigned int)) { + get_nanbits(nanbits, a->kind); + fprintf(f, "#define QNaN0 0x%x\n", nanbits[0]); + fprintf(f, "#define QNaN1 0x%x\n", nanbits[1]); + } + } + return 0; + } + fprintf(f, "/* Unknown arithmetic */\n"); + return 1; + } + +#ifdef __sun +#ifdef __i386 +/* kludge for Intel Solaris */ +void fpsetprec(int x) { } +#endif +#endif diff --git a/unix/f2c/libf2c/backspac.c b/unix/f2c/libf2c/backspac.c new file mode 100644 index 00000000..908a6189 --- /dev/null +++ b/unix/f2c/libf2c/backspac.c @@ -0,0 +1,76 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +integer f_back(a) alist *a; +#else +integer f_back(alist *a) +#endif +{ unit *b; + OFF_T v, w, x, y, z; + uiolen n; + FILE *f; + + f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ + if(a->aunit >= MXUNIT || a->aunit < 0) + err(a->aerr,101,"backspace") + if(b->useek==0) err(a->aerr,106,"backspace") + if(b->ufd == NULL) { + fk_open(1, 1, a->aunit); + return(0); + } + if(b->uend==1) + { b->uend=0; + return(0); + } + if(b->uwrt) { + t_runc(a); + if (f__nowreading(b)) + err(a->aerr,errno,"backspace") + } + f = b->ufd; /* may have changed in t_runc() */ + if(b->url>0) + { + x=FTELL(f); + y = x % b->url; + if(y == 0) x--; + x /= b->url; + x *= b->url; + (void) FSEEK(f,x,SEEK_SET); + return(0); + } + + if(b->ufmt==0) + { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); + fread((char *)&n,sizeof(uiolen),1,f); + FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); + return(0); + } + w = x = FTELL(f); + z = 0; + loop: + while(x) { + x -= x < 64 ? x : 64; + FSEEK(f,x,SEEK_SET); + for(y = x; y < w; y++) { + if (getc(f) != '\n') + continue; + v = FTELL(f); + if (v == w) { + if (z) + goto break2; + goto loop; + } + z = v; + } + err(a->aerr,(EOF),"backspace") + } + break2: + FSEEK(f, z, SEEK_SET); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_abs.c b/unix/f2c/libf2c/c_abs.c new file mode 100644 index 00000000..858f2c8b --- /dev/null +++ b/unix/f2c/libf2c/c_abs.c @@ -0,0 +1,20 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern double f__cabs(); + +double c_abs(z) complex *z; +#else +extern double f__cabs(double, double); + +double c_abs(complex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_cos.c b/unix/f2c/libf2c/c_cos.c new file mode 100644 index 00000000..29fe49e3 --- /dev/null +++ b/unix/f2c/libf2c/c_cos.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_cos(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_cos(complex *r, complex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = cos(zr) * cosh(zi); + r->i = - sin(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_div.c b/unix/f2c/libf2c/c_div.c new file mode 100644 index 00000000..9463a43d --- /dev/null +++ b/unix/f2c/libf2c/c_div.c @@ -0,0 +1,53 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); +VOID c_div(c, a, b) +complex *a, *b, *c; +#else +extern void sig_die(const char*,int); +void c_div(complex *c, complex *a, complex *b) +#endif +{ + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) + { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + float af, bf; + af = bf = abr; + if (a->i != 0 || a->r != 0) + af = 1.; + c->i = c->r = af / bf; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = (double)b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + + else + { + ratio = (double)b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_exp.c b/unix/f2c/libf2c/c_exp.c new file mode 100644 index 00000000..f46508d3 --- /dev/null +++ b/unix/f2c/libf2c/c_exp.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double exp(), cos(), sin(); + + VOID c_exp(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_exp(complex *r, complex *z) +#endif +{ + double expx, zi = z->i; + + expx = exp(z->r); + r->r = expx * cos(zi); + r->i = expx * sin(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_log.c b/unix/f2c/libf2c/c_log.c new file mode 100644 index 00000000..a0ba3f0d --- /dev/null +++ b/unix/f2c/libf2c/c_log.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double log(), f__cabs(), atan2(); +VOID c_log(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); + +void c_log(complex *r, complex *z) +#endif +{ + double zi, zr; + r->i = atan2(zi = z->i, zr = z->r); + r->r = log( f__cabs(zr, zi) ); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_sin.c b/unix/f2c/libf2c/c_sin.c new file mode 100644 index 00000000..c8bc30f2 --- /dev/null +++ b/unix/f2c/libf2c/c_sin.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_sin(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_sin(complex *r, complex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = sin(zr) * cosh(zi); + r->i = cos(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_sqrt.c b/unix/f2c/libf2c/c_sqrt.c new file mode 100644 index 00000000..1678c534 --- /dev/null +++ b/unix/f2c/libf2c/c_sqrt.c @@ -0,0 +1,41 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sqrt(), f__cabs(); + +VOID c_sqrt(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); + +void c_sqrt(complex *r, complex *z) +#endif +{ + double mag, t; + double zi = z->i, zr = z->r; + + if( (mag = f__cabs(zr, zi)) == 0.) + r->r = r->i = 0.; + else if(zr > 0) + { + r->r = t = sqrt(0.5 * (mag + zr) ); + t = zi / t; + r->i = 0.5 * t; + } + else + { + t = sqrt(0.5 * (mag - zr) ); + if(zi < 0) + t = -t; + r->i = t; + t = zi / t; + r->r = 0.5 * t; + } + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/cabs.c b/unix/f2c/libf2c/cabs.c new file mode 100644 index 00000000..84750d50 --- /dev/null +++ b/unix/f2c/libf2c/cabs.c @@ -0,0 +1,33 @@ +#ifdef KR_headers +extern double sqrt(); +double f__cabs(real, imag) double real, imag; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double f__cabs(double real, double imag) +#endif +{ +double temp; + +if(real < 0) + real = -real; +if(imag < 0) + imag = -imag; +if(imag > real){ + temp = real; + real = imag; + imag = temp; +} +if((real+imag) == real) + return(real); + +temp = imag/real; +temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ +return(temp); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/close.c b/unix/f2c/libf2c/close.c new file mode 100644 index 00000000..e958c717 --- /dev/null +++ b/unix/f2c/libf2c/close.c @@ -0,0 +1,101 @@ +#include "f2c.h" +#include "fio.h" +#ifdef KR_headers +integer f_clos(a) cllist *a; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef NON_UNIX_STDIO +#ifndef unlink +#define unlink remove +#endif +#else +#ifdef MSDOS +#include "io.h" +#else +#ifdef __cplusplus +extern "C" int unlink(const char*); +#else +extern int unlink(const char*); +#endif +#endif +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +integer f_clos(cllist *a) +#endif +{ unit *b; + + if(a->cunit >= MXUNIT) return(0); + b= &f__units[a->cunit]; + if(b->ufd==NULL) + goto done; + if (b->uscrtch == 1) + goto Delete; + if (!a->csta) + goto Keep; + switch(*a->csta) { + default: + Keep: + case 'k': + case 'K': + if(b->uwrt == 1) + t_runc((alist *)a); + if(b->ufnm) { + fclose(b->ufd); + free(b->ufnm); + } + break; + case 'd': + case 'D': + Delete: + fclose(b->ufd); + if(b->ufnm) { + unlink(b->ufnm); /*SYSDEP*/ + free(b->ufnm); + } + } + b->ufd=NULL; + done: + b->uend=0; + b->ufnm=NULL; + return(0); + } + void +#ifdef KR_headers +f_exit() +#else +f_exit(void) +#endif +{ int i; + static cllist xx; + if (!xx.cerr) { + xx.cerr=1; + xx.csta=NULL; + for(i=0;i +#else /*{*/ +#ifndef My_ctype_DEF +extern char My_ctype[]; +#else /*{*/ +char My_ctype[264] = { + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 2, 2, 2, 2, 2, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 2, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0}; +#endif /*}*/ + +#define isdigit(x) (My_ctype[(x)+8] & 1) +#define isspace(x) (My_ctype[(x)+8] & 2) +#endif diff --git a/unix/f2c/libf2c/d_abs.c b/unix/f2c/libf2c/d_abs.c new file mode 100644 index 00000000..2f7a153c --- /dev/null +++ b/unix/f2c/libf2c/d_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_abs(x) doublereal *x; +#else +double d_abs(doublereal *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_acos.c b/unix/f2c/libf2c/d_acos.c new file mode 100644 index 00000000..69005b56 --- /dev/null +++ b/unix/f2c/libf2c/d_acos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double d_acos(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_acos(doublereal *x) +#endif +{ +return( acos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_asin.c b/unix/f2c/libf2c/d_asin.c new file mode 100644 index 00000000..d5196ab1 --- /dev/null +++ b/unix/f2c/libf2c/d_asin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double d_asin(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_asin(doublereal *x) +#endif +{ +return( asin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_atan.c b/unix/f2c/libf2c/d_atan.c new file mode 100644 index 00000000..d8856f8d --- /dev/null +++ b/unix/f2c/libf2c/d_atan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double d_atan(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_atan(doublereal *x) +#endif +{ +return( atan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_atn2.c b/unix/f2c/libf2c/d_atn2.c new file mode 100644 index 00000000..56113850 --- /dev/null +++ b/unix/f2c/libf2c/d_atn2.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double d_atn2(x,y) doublereal *x, *y; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_atn2(doublereal *x, doublereal *y) +#endif +{ +return( atan2(*x,*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_cnjg.c b/unix/f2c/libf2c/d_cnjg.c new file mode 100644 index 00000000..38471d9b --- /dev/null +++ b/unix/f2c/libf2c/d_cnjg.c @@ -0,0 +1,19 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +d_cnjg(r, z) doublecomplex *r, *z; +#else +d_cnjg(doublecomplex *r, doublecomplex *z) +#endif +{ + doublereal zi = z->i; + r->r = z->r; + r->i = -zi; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_cos.c b/unix/f2c/libf2c/d_cos.c new file mode 100644 index 00000000..12def9ad --- /dev/null +++ b/unix/f2c/libf2c/d_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double d_cos(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_cos(doublereal *x) +#endif +{ +return( cos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_cosh.c b/unix/f2c/libf2c/d_cosh.c new file mode 100644 index 00000000..9214c7a0 --- /dev/null +++ b/unix/f2c/libf2c/d_cosh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double d_cosh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_cosh(doublereal *x) +#endif +{ +return( cosh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_dim.c b/unix/f2c/libf2c/d_dim.c new file mode 100644 index 00000000..627ddb69 --- /dev/null +++ b/unix/f2c/libf2c/d_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_dim(a,b) doublereal *a, *b; +#else +double d_dim(doublereal *a, doublereal *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_exp.c b/unix/f2c/libf2c/d_exp.c new file mode 100644 index 00000000..e9ab5d44 --- /dev/null +++ b/unix/f2c/libf2c/d_exp.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double d_exp(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_exp(doublereal *x) +#endif +{ +return( exp(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_imag.c b/unix/f2c/libf2c/d_imag.c new file mode 100644 index 00000000..d17b9dd5 --- /dev/null +++ b/unix/f2c/libf2c/d_imag.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_imag(z) doublecomplex *z; +#else +double d_imag(doublecomplex *z) +#endif +{ +return(z->i); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_int.c b/unix/f2c/libf2c/d_int.c new file mode 100644 index 00000000..6da4ce35 --- /dev/null +++ b/unix/f2c/libf2c/d_int.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_int(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_int(doublereal *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_lg10.c b/unix/f2c/libf2c/d_lg10.c new file mode 100644 index 00000000..664c19d9 --- /dev/null +++ b/unix/f2c/libf2c/d_lg10.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double d_lg10(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_lg10(doublereal *x) +#endif +{ +return( log10e * log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_log.c b/unix/f2c/libf2c/d_log.c new file mode 100644 index 00000000..e74be02c --- /dev/null +++ b/unix/f2c/libf2c/d_log.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double d_log(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_log(doublereal *x) +#endif +{ +return( log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_mod.c b/unix/f2c/libf2c/d_mod.c new file mode 100644 index 00000000..3766d9fa --- /dev/null +++ b/unix/f2c/libf2c/d_mod.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double d_mod(x,y) doublereal *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif +double d_mod(doublereal *x, doublereal *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = *x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_nint.c b/unix/f2c/libf2c/d_nint.c new file mode 100644 index 00000000..66f2dd0e --- /dev/null +++ b/unix/f2c/libf2c/d_nint.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_nint(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_nint(doublereal *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_prod.c b/unix/f2c/libf2c/d_prod.c new file mode 100644 index 00000000..f9f348b0 --- /dev/null +++ b/unix/f2c/libf2c/d_prod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_prod(x,y) real *x, *y; +#else +double d_prod(real *x, real *y) +#endif +{ +return( (*x) * (*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sign.c b/unix/f2c/libf2c/d_sign.c new file mode 100644 index 00000000..d06e0d19 --- /dev/null +++ b/unix/f2c/libf2c/d_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_sign(a,b) doublereal *a, *b; +#else +double d_sign(doublereal *a, doublereal *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sin.c b/unix/f2c/libf2c/d_sin.c new file mode 100644 index 00000000..ebd4eec5 --- /dev/null +++ b/unix/f2c/libf2c/d_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double d_sin(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sin(doublereal *x) +#endif +{ +return( sin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sinh.c b/unix/f2c/libf2c/d_sinh.c new file mode 100644 index 00000000..2479a6fa --- /dev/null +++ b/unix/f2c/libf2c/d_sinh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double d_sinh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sinh(doublereal *x) +#endif +{ +return( sinh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sqrt.c b/unix/f2c/libf2c/d_sqrt.c new file mode 100644 index 00000000..a7fa66c0 --- /dev/null +++ b/unix/f2c/libf2c/d_sqrt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double d_sqrt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sqrt(doublereal *x) +#endif +{ +return( sqrt(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_tan.c b/unix/f2c/libf2c/d_tan.c new file mode 100644 index 00000000..7d252c4d --- /dev/null +++ b/unix/f2c/libf2c/d_tan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double d_tan(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_tan(doublereal *x) +#endif +{ +return( tan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_tanh.c b/unix/f2c/libf2c/d_tanh.c new file mode 100644 index 00000000..415b5850 --- /dev/null +++ b/unix/f2c/libf2c/d_tanh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double d_tanh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_tanh(doublereal *x) +#endif +{ +return( tanh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/derf_.c b/unix/f2c/libf2c/derf_.c new file mode 100644 index 00000000..d935d315 --- /dev/null +++ b/unix/f2c/libf2c/derf_.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double erf(); +double derf_(x) doublereal *x; +#else +extern double erf(double); +double derf_(doublereal *x) +#endif +{ +return( erf(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/derfc_.c b/unix/f2c/libf2c/derfc_.c new file mode 100644 index 00000000..18f5c619 --- /dev/null +++ b/unix/f2c/libf2c/derfc_.c @@ -0,0 +1,20 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern double erfc(); + +double derfc_(x) doublereal *x; +#else +extern double erfc(double); + +double derfc_(doublereal *x) +#endif +{ +return( erfc(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/dfe.c b/unix/f2c/libf2c/dfe.c new file mode 100644 index 00000000..c6b10d0e --- /dev/null +++ b/unix/f2c/libf2c/dfe.c @@ -0,0 +1,151 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +y_rsk(Void) +{ + if(f__curunit->uend || f__curunit->url <= f__recpos + || f__curunit->url == 1) return 0; + do { + getc(f__cf); + } while(++f__recpos < f__curunit->url); + return 0; +} + + int +y_getc(Void) +{ + int ch; + if(f__curunit->uend) return(-1); + if((ch=getc(f__cf))!=EOF) + { + f__recpos++; + if(f__curunit->url>=f__recpos || + f__curunit->url==1) + return(ch); + else return(' '); + } + if(feof(f__cf)) + { + f__curunit->uend=1; + errno=0; + return(-1); + } + err(f__elist->cierr,errno,"readingd"); +} + + static int +y_rev(Void) +{ + if (f__recpos < f__hiwater) + f__recpos = f__hiwater; + if (f__curunit->url > 1) + while(f__recpos < f__curunit->url) + (*f__putn)(' '); + if (f__recpos) + f__putbuf(0); + f__recpos = 0; + return(0); +} + + static int +y_err(Void) +{ + err(f__elist->cierr, 110, "dfe"); +} + + static int +y_newrec(Void) +{ + y_rev(); + f__hiwater = f__cursor = 0; + return(1); +} + + int +#ifdef KR_headers +c_dfe(a) cilist *a; +#else +c_dfe(cilist *a) +#endif +{ + f__sequential=0; + f__formatted=f__external=1; + f__elist=a; + f__cursor=f__scale=f__recpos=0; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit>MXUNIT || a->ciunit<0) + err(a->cierr,101,"startchk"); + if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) + err(a->cierr,104,"dfe"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,102,"dfe") + if(!f__curunit->useek) err(a->cierr,104,"dfe") + f__fmtbuf=a->cifmt; + if(a->cirec <= 0) + err(a->cierr,130,"dfe") + FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdfe(a) cilist *a; +#else +integer s_rdfe(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=1; + if(n=c_dfe(a))return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + f__getn = y_getc; + f__doed = rd_ed; + f__doned = rd_ned; + f__dorevert = f__donewrec = y_err; + f__doend = y_rsk; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"read start"); + fmt_bg(); + return(0); +} +#ifdef KR_headers +integer s_wdfe(a) cilist *a; +#else +integer s_wdfe(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=0; + if(n=c_dfe(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"startwrt"); + f__putn = x_putc; + f__doed = w_ed; + f__doned= w_ned; + f__dorevert = y_err; + f__donewrec = y_newrec; + f__doend = y_rev; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"startwrt"); + fmt_bg(); + return(0); +} +integer e_rdfe(Void) +{ + en_fio(); + return 0; +} +integer e_wdfe(Void) +{ + return en_fio(); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/dolio.c b/unix/f2c/libf2c/dolio.c new file mode 100644 index 00000000..4070d879 --- /dev/null +++ b/unix/f2c/libf2c/dolio.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +extern int (*f__lioproc)(); + +integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; +#else +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); + +integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) +#endif +{ + return((*f__lioproc)(number,ptr,len,*type)); +} +#ifdef __cplusplus + } +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/dtime_.c b/unix/f2c/libf2c/dtime_.c new file mode 100644 index 00000000..6a09b3e9 --- /dev/null +++ b/unix/f2c/libf2c/dtime_.c @@ -0,0 +1,63 @@ +#include "time.h" + +#ifdef MSDOS +#undef USE_CLOCK +#define USE_CLOCK +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifndef USE_CLOCK +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/times.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + REAL +#ifdef KR_headers +dtime_(tarray) float *tarray; +#else +dtime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + static double t0; + double t = clock(); + tarray[1] = 0; + tarray[0] = (t - t0) / CLOCKS_PER_SECOND; + t0 = t; + return tarray[0]; +#else + struct tms t; + static struct tms t0; + + times(&t); + tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz; + tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz; + t0 = t; + return tarray[0] + tarray[1]; +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/due.c b/unix/f2c/libf2c/due.c new file mode 100644 index 00000000..a7f4cec4 --- /dev/null +++ b/unix/f2c/libf2c/due.c @@ -0,0 +1,77 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +#ifdef KR_headers +c_due(a) cilist *a; +#else +c_due(cilist *a) +#endif +{ + if(!f__init) f_init(); + f__sequential=f__formatted=f__recpos=0; + f__external=1; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,102,"cdue") + if(!f__curunit->useek) err(a->cierr,104,"cdue") + if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue") + if(a->cirec <= 0) + err(a->cierr,130,"due") + FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdue(a) cilist *a; +#else +integer s_rdue(cilist *a) +#endif +{ + int n; + f__reading=1; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + return(0); +} +#ifdef KR_headers +integer s_wdue(a) cilist *a; +#else +integer s_wdue(cilist *a) +#endif +{ + int n; + f__reading=0; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +integer e_rdue(Void) +{ + if(f__curunit->url==1 || f__recpos==f__curunit->url) + return(0); + FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR); + if(FTELL(f__cf)%f__curunit->url) + err(f__elist->cierr,200,"syserr"); + return(0); +} +integer e_wdue(Void) +{ +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr,errno,"write end"); +#endif + return(e_rdue()); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ef1asc_.c b/unix/f2c/libf2c/ef1asc_.c new file mode 100644 index 00000000..70be0bc2 --- /dev/null +++ b/unix/f2c/libf2c/ef1asc_.c @@ -0,0 +1,25 @@ +/* EFL support routine to copy string b to string a */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + +#define M ( (long) (sizeof(long) - 1) ) +#define EVEN(x) ( ( (x)+ M) & (~M) ) + +#ifdef KR_headers +extern VOID s_copy(); +ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern void s_copy(char*,char*,ftnlen,ftnlen); +int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +return 0; /* ignored return value */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ef1cmc_.c b/unix/f2c/libf2c/ef1cmc_.c new file mode 100644 index 00000000..4b420ae6 --- /dev/null +++ b/unix/f2c/libf2c/ef1cmc_.c @@ -0,0 +1,20 @@ +/* EFL support routine to compare two character strings */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern integer s_cmp(char*,char*,ftnlen,ftnlen); +integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/endfile.c b/unix/f2c/libf2c/endfile.c new file mode 100644 index 00000000..04020d38 --- /dev/null +++ b/unix/f2c/libf2c/endfile.c @@ -0,0 +1,160 @@ +#include "f2c.h" +#include "fio.h" + +/* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */ +/* if it does not define int truncate(const char *name, off_t). */ + +#ifdef MSDOS +#undef NO_TRUNCATE +#define NO_TRUNCATE +#endif + +#ifndef NO_TRUNCATE +#include "unistd.h" +#endif + +#ifdef KR_headers +extern char *strcpy(); +extern FILE *tmpfile(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +extern char *f__r_mode[], *f__w_mode[]; + +#ifdef KR_headers +integer f_end(a) alist *a; +#else +integer f_end(alist *a) +#endif +{ + unit *b; + FILE *tf; + + if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); + b = &f__units[a->aunit]; + if(b->ufd==NULL) { + char nbuf[10]; + sprintf(nbuf,"fort.%ld",(long)a->aunit); + if (tf = FOPEN(nbuf, f__w_mode[0])) + fclose(tf); + return(0); + } + b->uend=1; + return(b->useek ? t_runc(a) : 0); +} + +#ifdef NO_TRUNCATE + static int +#ifdef KR_headers +copy(from, len, to) FILE *from, *to; register long len; +#else +copy(FILE *from, register long len, FILE *to) +#endif +{ + int len1; + char buf[BUFSIZ]; + + while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { + if (!fwrite(buf, len1, 1, to)) + return 1; + if ((len -= len1) <= 0) + break; + } + return 0; + } +#endif /* NO_TRUNCATE */ + + int +#ifdef KR_headers +t_runc(a) alist *a; +#else +t_runc(alist *a) +#endif +{ + OFF_T loc, len; + unit *b; + int rc; + FILE *bf; +#ifdef NO_TRUNCATE + FILE *tf; +#endif + + b = &f__units[a->aunit]; + if(b->url) + return(0); /*don't truncate direct files*/ + loc=FTELL(bf = b->ufd); + FSEEK(bf,(OFF_T)0,SEEK_END); + len=FTELL(bf); + if (loc >= len || b->useek == 0) + return(0); +#ifdef NO_TRUNCATE + if (b->ufnm == NULL) + return 0; + rc = 0; + fclose(b->ufd); + if (!loc) { + if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt]))) + rc = 1; + if (b->uwrt) + b->uwrt = 1; + goto done; + } + if (!(bf = FOPEN(b->ufnm, f__r_mode[0])) + || !(tf = tmpfile())) { +#ifdef NON_UNIX_STDIO + bad: +#endif + rc = 1; + goto done; + } + if (copy(bf, (long)loc, tf)) { + bad1: + rc = 1; + goto done1; + } + if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf))) + goto bad1; + rewind(tf); + if (copy(tf, (long)loc, bf)) + goto bad1; + b->uwrt = 1; + b->urw = 2; +#ifdef NON_UNIX_STDIO + if (b->ufmt) { + fclose(bf); + if (!(bf = FOPEN(b->ufnm, f__w_mode[3]))) + goto bad; + FSEEK(bf,(OFF_T)0,SEEK_END); + b->urw = 3; + } +#endif +done1: + fclose(tf); +done: + f__cf = b->ufd = bf; +#else /* NO_TRUNCATE */ + if (b->urw & 2) + fflush(b->ufd); /* necessary on some Linux systems */ +#ifndef FTRUNCATE +#define FTRUNCATE ftruncate +#endif + rc = FTRUNCATE(fileno(b->ufd), loc); + /* The following FSEEK is unnecessary on some systems, */ + /* but should be harmless. */ + FSEEK(b->ufd, (OFF_T)0, SEEK_END); +#endif /* NO_TRUNCATE */ + if (rc) + err(a->aerr,111,"endfile"); + return 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/erf_.c b/unix/f2c/libf2c/erf_.c new file mode 100644 index 00000000..532fec61 --- /dev/null +++ b/unix/f2c/libf2c/erf_.c @@ -0,0 +1,22 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifdef KR_headers +double erf(); +REAL erf_(x) real *x; +#else +extern double erf(double); +REAL erf_(real *x) +#endif +{ +return( erf((double)*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/erfc_.c b/unix/f2c/libf2c/erfc_.c new file mode 100644 index 00000000..6f6c9f10 --- /dev/null +++ b/unix/f2c/libf2c/erfc_.c @@ -0,0 +1,22 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifdef KR_headers +double erfc(); +REAL erfc_(x) real *x; +#else +extern double erfc(double); +REAL erfc_(real *x) +#endif +{ +return( erfc((double)*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/err.c b/unix/f2c/libf2c/err.c new file mode 100644 index 00000000..80a3b749 --- /dev/null +++ b/unix/f2c/libf2c/err.c @@ -0,0 +1,293 @@ +#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +#include "f2c.h" +#ifdef KR_headers +#define Const /*nothing*/ +extern char *malloc(); +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif +#include "fio.h" +#include "fmt.h" /* for struct syl */ + +/* Compile this with -DNO_ISATTY if unistd.h does not exist or */ +/* if it does not define int isatty(int). */ +#ifdef NO_ISATTY +#define isatty(x) 0 +#else +#include +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/*global definitions*/ +unit f__units[MXUNIT]; /*unit table*/ +flag f__init; /*0 on entry, 1 after initializations*/ +cilist *f__elist; /*active external io list*/ +icilist *f__svic; /*active internal io list*/ +flag f__reading; /*1 if reading, 0 if writing*/ +flag f__cplus,f__cblank; +Const char *f__fmtbuf; +flag f__external; /*1 if external io, 0 if internal */ +#ifdef KR_headers +int (*f__doed)(),(*f__doned)(); +int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); +int (*f__getn)(); /* for formatted input */ +void (*f__putn)(); /* for formatted output */ +#else +int (*f__getn)(void); /* for formatted input */ +void (*f__putn)(int); /* for formatted output */ +int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); +#endif +flag f__sequential; /*1 if sequential io, 0 if direct*/ +flag f__formatted; /*1 if formatted io, 0 if unformatted*/ +FILE *f__cf; /*current file*/ +unit *f__curunit; /*current unit*/ +int f__recpos; /*place in current record*/ +OFF_T f__cursor, f__hiwater; +int f__scale; +char *f__icptr; + +/*error messages*/ +Const char *F_err[] = +{ + "error in format", /* 100 */ + "illegal unit number", /* 101 */ + "formatted io not allowed", /* 102 */ + "unformatted io not allowed", /* 103 */ + "direct io not allowed", /* 104 */ + "sequential io not allowed", /* 105 */ + "can't backspace file", /* 106 */ + "null file name", /* 107 */ + "can't stat file", /* 108 */ + "unit not connected", /* 109 */ + "off end of record", /* 110 */ + "truncation failed in endfile", /* 111 */ + "incomprehensible list input", /* 112 */ + "out of free space", /* 113 */ + "unit not connected", /* 114 */ + "read unexpected character", /* 115 */ + "bad logical input field", /* 116 */ + "bad variable type", /* 117 */ + "bad namelist name", /* 118 */ + "variable not in namelist", /* 119 */ + "no end record", /* 120 */ + "variable count incorrect", /* 121 */ + "subscript for scalar variable", /* 122 */ + "invalid array section", /* 123 */ + "substring out of bounds", /* 124 */ + "subscript out of bounds", /* 125 */ + "can't read file", /* 126 */ + "can't write file", /* 127 */ + "'new' file exists", /* 128 */ + "can't append to file", /* 129 */ + "non-positive record number", /* 130 */ + "nmLbuf overflow" /* 131 */ +}; +#define MAXERR (sizeof(F_err)/sizeof(char *)+100) + + int +#ifdef KR_headers +f__canseek(f) FILE *f; /*SYSDEP*/ +#else +f__canseek(FILE *f) /*SYSDEP*/ +#endif +{ +#ifdef NON_UNIX_STDIO + return !isatty(fileno(f)); +#else + struct STAT_ST x; + + if (FSTAT(fileno(f),&x) < 0) + return(0); +#ifdef S_IFMT + switch(x.st_mode & S_IFMT) { + case S_IFDIR: + case S_IFREG: + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + case S_IFCHR: + if(isatty(fileno(f))) + return(0); + return(1); +#ifdef S_IFBLK + case S_IFBLK: + return(1); +#endif + } +#else +#ifdef S_ISDIR + /* POSIX version */ + if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + } + if (S_ISCHR(x.st_mode)) { + if(isatty(fileno(f))) + return(0); + return(1); + } + if (S_ISBLK(x.st_mode)) + return(1); +#else + Help! How does fstat work on this system? +#endif +#endif + return(0); /* who knows what it is? */ +#endif +} + + void +#ifdef KR_headers +f__fatal(n,s) char *s; +#else +f__fatal(int n, const char *s) +#endif +{ + if(n<100 && n>=0) perror(s); /*SYSDEP*/ + else if(n >= (int)MAXERR || n < -1) + { fprintf(stderr,"%s: illegal error number %d\n",s,n); + } + else if(n == -1) fprintf(stderr,"%s: end of file\n",s); + else + fprintf(stderr,"%s: %s\n",s,F_err[n-100]); + if (f__curunit) { + fprintf(stderr,"apparent state: unit %d ", + (int)(f__curunit-f__units)); + fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", + f__curunit->ufnm); + } + else + fprintf(stderr,"apparent state: internal I/O\n"); + if (f__fmtbuf) + fprintf(stderr,"last format: %s\n",f__fmtbuf); + fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", + f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", + f__external?"external":"internal"); + sig_die(" IO", 1); +} +/*initialization routine*/ + VOID +f_init(Void) +{ unit *p; + + f__init=1; + p= &f__units[0]; + p->ufd=stderr; + p->useek=f__canseek(stderr); + p->ufmt=1; + p->uwrt=1; + p = &f__units[5]; + p->ufd=stdin; + p->useek=f__canseek(stdin); + p->ufmt=1; + p->uwrt=0; + p= &f__units[6]; + p->ufd=stdout; + p->useek=f__canseek(stdout); + p->ufmt=1; + p->uwrt=1; +} + + int +#ifdef KR_headers +f__nowreading(x) unit *x; +#else +f__nowreading(unit *x) +#endif +{ + OFF_T loc; + int ufmt, urw; + extern char *f__r_mode[], *f__w_mode[]; + + if (x->urw & 1) + goto done; + if (!x->ufnm) + goto cantread; + ufmt = x->url ? 0 : x->ufmt; + loc = FTELL(x->ufd); + urw = 3; + if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { + urw = 1; + if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) { + cantread: + errno = 126; + return 1; + } + } + FSEEK(x->ufd,loc,SEEK_SET); + x->urw = urw; + done: + x->uwrt = 0; + return 0; +} + + int +#ifdef KR_headers +f__nowwriting(x) unit *x; +#else +f__nowwriting(unit *x) +#endif +{ + OFF_T loc; + int ufmt; + extern char *f__w_mode[]; + + if (x->urw & 2) { + if (x->urw & 1) + FSEEK(x->ufd, (OFF_T)0, SEEK_CUR); + goto done; + } + if (!x->ufnm) + goto cantwrite; + ufmt = x->url ? 0 : x->ufmt; + if (x->uwrt == 3) { /* just did write, rewind */ + if (!(f__cf = x->ufd = + FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd))) + goto cantwrite; + x->urw = 2; + } + else { + loc=FTELL(x->ufd); + if (!(f__cf = x->ufd = + FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) + { + x->ufd = NULL; + cantwrite: + errno = 127; + return(1); + } + x->urw = 3; + FSEEK(x->ufd,loc,SEEK_SET); + } + done: + x->uwrt = 1; + return 0; +} + + int +#ifdef KR_headers +err__fl(f, m, s) int f, m; char *s; +#else +err__fl(int f, int m, const char *s) +#endif +{ + if (!f) + f__fatal(m, s); + if (f__doend) + (*f__doend)(); + return errno = m; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/etime_.c b/unix/f2c/libf2c/etime_.c new file mode 100644 index 00000000..2d9a36d8 --- /dev/null +++ b/unix/f2c/libf2c/etime_.c @@ -0,0 +1,57 @@ +#include "time.h" + +#ifdef MSDOS +#undef USE_CLOCK +#define USE_CLOCK +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifndef USE_CLOCK +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/times.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + REAL +#ifdef KR_headers +etime_(tarray) float *tarray; +#else +etime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + double t = clock(); + tarray[1] = 0; + return tarray[0] = t / CLOCKS_PER_SECOND; +#else + struct tms t; + + times(&t); + return (tarray[0] = (double)t.tms_utime/Hz) + + (tarray[1] = (double)t.tms_stime/Hz); +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/exit_.c b/unix/f2c/libf2c/exit_.c new file mode 100644 index 00000000..08e9d070 --- /dev/null +++ b/unix/f2c/libf2c/exit_.c @@ -0,0 +1,43 @@ +/* This gives the effect of + + subroutine exit(rc) + integer*4 rc + stop + end + + * with the added side effect of supplying rc as the program's exit code. + */ + +#include "f2c.h" +#undef abs +#undef min +#undef max +#ifndef KR_headers +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern void f_exit(void); +#endif + + void +#ifdef KR_headers +exit_(rc) integer *rc; +#else +exit_(integer *rc) +#endif +{ +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(*rc); + } +#ifdef __cplusplus +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/f2c.h b/unix/f2c/libf2c/f2c.h new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/libf2c/f2c.h @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef long int integer; +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/f2c/libf2c/f2c.h0 b/unix/f2c/libf2c/f2c.h0 new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/libf2c/f2c.h0 @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef long int integer; +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/f2c/libf2c/f2ch.add b/unix/f2c/libf2c/f2ch.add new file mode 100644 index 00000000..a2acc17a --- /dev/null +++ b/unix/f2c/libf2c/f2ch.add @@ -0,0 +1,162 @@ +/* If you are using a C++ compiler, append the following to f2c.h + for compiling libF77 and libI77. */ + +#ifdef __cplusplus +extern "C" { +extern int abort_(void); +extern double c_abs(complex *); +extern void c_cos(complex *, complex *); +extern void c_div(complex *, complex *, complex *); +extern void c_exp(complex *, complex *); +extern void c_log(complex *, complex *); +extern void c_sin(complex *, complex *); +extern void c_sqrt(complex *, complex *); +extern double d_abs(double *); +extern double d_acos(double *); +extern double d_asin(double *); +extern double d_atan(double *); +extern double d_atn2(double *, double *); +extern void d_cnjg(doublecomplex *, doublecomplex *); +extern double d_cos(double *); +extern double d_cosh(double *); +extern double d_dim(double *, double *); +extern double d_exp(double *); +extern double d_imag(doublecomplex *); +extern double d_int(double *); +extern double d_lg10(double *); +extern double d_log(double *); +extern double d_mod(double *, double *); +extern double d_nint(double *); +extern double d_prod(float *, float *); +extern double d_sign(double *, double *); +extern double d_sin(double *); +extern double d_sinh(double *); +extern double d_sqrt(double *); +extern double d_tan(double *); +extern double d_tanh(double *); +extern double derf_(double *); +extern double derfc_(double *); +extern integer do_fio(ftnint *, char *, ftnlen); +extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +extern integer do_uio(ftnint *, char *, ftnlen); +extern integer e_rdfe(void); +extern integer e_rdue(void); +extern integer e_rsfe(void); +extern integer e_rsfi(void); +extern integer e_rsle(void); +extern integer e_rsli(void); +extern integer e_rsue(void); +extern integer e_wdfe(void); +extern integer e_wdue(void); +extern integer e_wsfe(void); +extern integer e_wsfi(void); +extern integer e_wsle(void); +extern integer e_wsli(void); +extern integer e_wsue(void); +extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern double erf(double); +extern double erf_(float *); +extern double erfc(double); +extern double erfc_(float *); +extern integer f_back(alist *); +extern integer f_clos(cllist *); +extern integer f_end(alist *); +extern void f_exit(void); +extern integer f_inqu(inlist *); +extern integer f_open(olist *); +extern integer f_rew(alist *); +extern int flush_(void); +extern void getarg_(integer *, char *, ftnlen); +extern void getenv_(char *, char *, ftnlen, ftnlen); +extern short h_abs(short *); +extern short h_dim(short *, short *); +extern short h_dnnt(double *); +extern short h_indx(char *, char *, ftnlen, ftnlen); +extern short h_len(char *, ftnlen); +extern short h_mod(short *, short *); +extern short h_nint(float *); +extern short h_sign(short *, short *); +extern short hl_ge(char *, char *, ftnlen, ftnlen); +extern short hl_gt(char *, char *, ftnlen, ftnlen); +extern short hl_le(char *, char *, ftnlen, ftnlen); +extern short hl_lt(char *, char *, ftnlen, ftnlen); +extern integer i_abs(integer *); +extern integer i_dim(integer *, integer *); +extern integer i_dnnt(double *); +extern integer i_indx(char *, char *, ftnlen, ftnlen); +extern integer i_len(char *, ftnlen); +extern integer i_mod(integer *, integer *); +extern integer i_nint(float *); +extern integer i_sign(integer *, integer *); +extern integer iargc_(void); +extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +extern void pow_ci(complex *, complex *, integer *); +extern double pow_dd(double *, double *); +extern double pow_di(double *, integer *); +extern short pow_hh(short *, shortint *); +extern integer pow_ii(integer *, integer *); +extern double pow_ri(float *, integer *); +extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +extern double r_abs(float *); +extern double r_acos(float *); +extern double r_asin(float *); +extern double r_atan(float *); +extern double r_atn2(float *, float *); +extern void r_cnjg(complex *, complex *); +extern double r_cos(float *); +extern double r_cosh(float *); +extern double r_dim(float *, float *); +extern double r_exp(float *); +extern double r_imag(complex *); +extern double r_int(float *); +extern double r_lg10(float *); +extern double r_log(float *); +extern double r_mod(float *, float *); +extern double r_nint(float *); +extern double r_sign(float *, float *); +extern double r_sin(float *); +extern double r_sinh(float *); +extern double r_sqrt(float *); +extern double r_tan(float *); +extern double r_tanh(float *); +extern void s_cat(char *, char **, integer *, integer *, ftnlen); +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +extern void s_copy(char *, char *, ftnlen, ftnlen); +extern int s_paus(char *, ftnlen); +extern integer s_rdfe(cilist *); +extern integer s_rdue(cilist *); +extern integer s_rnge(char *, integer, char *, integer); +extern integer s_rsfe(cilist *); +extern integer s_rsfi(icilist *); +extern integer s_rsle(cilist *); +extern integer s_rsli(icilist *); +extern integer s_rsne(cilist *); +extern integer s_rsni(icilist *); +extern integer s_rsue(cilist *); +extern int s_stop(char *, ftnlen); +extern integer s_wdfe(cilist *); +extern integer s_wdue(cilist *); +extern integer s_wsfe(cilist *); +extern integer s_wsfi(icilist *); +extern integer s_wsle(cilist *); +extern integer s_wsli(icilist *); +extern integer s_wsne(cilist *); +extern integer s_wsni(icilist *); +extern integer s_wsue(cilist *); +extern void sig_die(char *, int); +extern integer signal_(integer *, void (*)(int)); +extern integer system_(char *, ftnlen); +extern double z_abs(doublecomplex *); +extern void z_cos(doublecomplex *, doublecomplex *); +extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +extern void z_exp(doublecomplex *, doublecomplex *); +extern void z_log(doublecomplex *, doublecomplex *); +extern void z_sin(doublecomplex *, doublecomplex *); +extern void z_sqrt(doublecomplex *, doublecomplex *); + } +#endif diff --git a/unix/f2c/libf2c/f77_aloc.c b/unix/f2c/libf2c/f77_aloc.c new file mode 100644 index 00000000..f5360990 --- /dev/null +++ b/unix/f2c/libf2c/f77_aloc.c @@ -0,0 +1,44 @@ +#include "f2c.h" +#undef abs +#undef min +#undef max +#include "stdio.h" + +static integer memfailure = 3; + +#ifdef KR_headers +extern char *malloc(); +extern void exit_(); + + char * +F77_aloc(Len, whence) integer Len; char *whence; +#else +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern void exit_(integer*); +#ifdef __cplusplus + } +#endif + + char * +F77_aloc(integer Len, const char *whence) +#endif +{ + char *rv; + unsigned int uLen = (unsigned int) Len; /* for K&R C */ + + if (!(rv = (char*)malloc(uLen))) { + fprintf(stderr, "malloc(%u) failure in %s\n", + uLen, whence); + exit_(&memfailure); + } + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/f77vers.c b/unix/f2c/libf2c/f77vers.c new file mode 100644 index 00000000..70cd6fe7 --- /dev/null +++ b/unix/f2c/libf2c/f77vers.c @@ -0,0 +1,97 @@ + char +_libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20051004\n"; + +/* +2.00 11 June 1980. File version.c added to library. +2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed + [ d]erf[c ] added + 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c + 29 Nov. 1989: s_cmp returns long (for f2c) + 30 Nov. 1989: arg types from f2c.h + 12 Dec. 1989: s_rnge allows long names + 19 Dec. 1989: getenv_ allows unsorted environment + 28 Mar. 1990: add exit(0) to end of main() + 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main + 17 Oct. 1990: abort() calls changed to sig_die(...,1) + 22 Oct. 1990: separate sig_die from main + 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die + 31 May 1991: make system_ return status + 18 Dec. 1991: change long to ftnlen (for -i2) many places + 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) + 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c + and m**n in pow_hh.c and pow_ii.c; + catch SIGTRAP in main() for error msg before abort + 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined + 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); + change Cabs to f__cabs. + 12 March 1993: various tweaks for C++ + 2 June 1994: adjust so abnormal terminations invoke f_exit just once + 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. + 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS + 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines + that sign-extend right shifts when i is the most + negative integer. + 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side + of character assignments to appear on the right-hand + side (unless compiled with -DNO_OVERWRITE). + 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever + possible (for better cache behavior). + 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. + 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. + 6 Sept. 1995: fix return type of system_ under -DKR_headers. + 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. + 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. + 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). + 19 June 1996: add casts to unsigned in [lq]bitshft.c. + 26 Feb. 1997: adjust functions with a complex output argument + to permit aliasing it with input arguments. + (For now, at least, this is just for possible + benefit of g77.) + 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may + affect systems using gratuitous extra precision). + 19 Sept. 1997: [de]time_.c (Unix systems only): change return + type to double. + 2 May 1999: getenv_.c: omit environ in favor of getenv(). + c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c, + z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with + overlapping arguments caused by equivalence. + 3 May 1999: "invisible" tweaks to omit compiler warnings in + abort_.c, ef1asc_.c, s_rnge.c, s_stop.c. + + 7 Sept. 1999: [cz]_div.c: arrange for compilation under + -DIEEE_COMPLEX_DIVIDE to make these routines + avoid calling sig_die when the denominator + vanishes; instead, they return pairs of NaNs + or Infinities, depending whether the numerator + also vanishes or not. VERSION not changed. + 15 Nov. 1999: s_rnge.c: add casts for the case of + sizeof(ftnint) == sizeof(int) < sizeof(long). + 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g., + z near (+-1,eps) with |eps| small. For the old + evaluation, compile with -DPre20000310 . + 20 April 2000: s_cat.c: tweak argument types to accord with + calls by f2c when ftnint and ftnlen are of + different sizes (different numbers of bits). + 4 July 2000: adjustments to permit compilation by C++ compilers; + VERSION string remains unchanged. + 29 Sept. 2000: dtime_.c, etime_.c: use floating-point divide. + dtime_.d, erf_.c, erfc_.c, etime.c: for use with + "f2c -R", compile with -DREAL=float. + 23 June 2001: add uninit.c; [fi]77vers.c: make version strings + visible as extern char _lib[fi]77_version_f2c[]. + 5 July 2001: modify uninit.c for __mc68k__ under Linux. + 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain. + 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type, + missing ~ on y in return value. + 14 March 2002: z_log.c: add code to cope with buggy compilers + (e.g., some versions of gcc under -O2 or -O3) + that do floating-point comparisons against values + computed into extended-precision registers on some + systems (such as Intel IA32 systems). Compile with + -DNO_DOUBLE_EXTENDED to omit the new logic. + 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables. + 10 Oct 2005: uninit.c: on IA32 Linux systems, leave the rounding + precision alone rather than forcing it to 53 bits; + compile with -DUNINIT_F2C_PRECISION_53 to get the + former behavior. +*/ diff --git a/unix/f2c/libf2c/fio.h b/unix/f2c/libf2c/fio.h new file mode 100644 index 00000000..ebf76965 --- /dev/null +++ b/unix/f2c/libf2c/fio.h @@ -0,0 +1,141 @@ +#ifndef SYSDEP_H_INCLUDED +#include "sysdep1.h" +#endif +#include "stdio.h" +#include "errno.h" +#ifndef NULL +/* ANSI C */ +#include "stddef.h" +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +#ifndef FOPEN +#define FOPEN fopen +#endif + +#ifndef FREOPEN +#define FREOPEN freopen +#endif + +#ifndef FSEEK +#define FSEEK fseek +#endif + +#ifndef FSTAT +#define FSTAT fstat +#endif + +#ifndef FTELL +#define FTELL ftell +#endif + +#ifndef OFF_T +#define OFF_T long +#endif + +#ifndef STAT_ST +#define STAT_ST stat +#endif + +#ifndef STAT +#define STAT stat +#endif + +#ifdef MSDOS +#ifndef NON_UNIX_STDIO +#define NON_UNIX_STDIO +#endif +#endif + +#ifdef UIOLEN_int +typedef int uiolen; +#else +typedef long uiolen; +#endif + +/*units*/ +typedef struct +{ FILE *ufd; /*0=unconnected*/ + char *ufnm; +#ifndef MSDOS + long uinode; + int udev; +#endif + int url; /*0=sequential*/ + flag useek; /*true=can backspace, use dir, ...*/ + flag ufmt; + flag urw; /* (1 for can read) | (2 for can write) */ + flag ublnk; + flag uend; + flag uwrt; /*last io was write*/ + flag uscrtch; +} unit; + +#undef Void +#ifdef KR_headers +#define Void /*void*/ +extern int (*f__getn)(); /* for formatted input */ +extern void (*f__putn)(); /* for formatted output */ +extern void x_putc(); +extern long f__inode(); +extern VOID sig_die(); +extern int (*f__donewrec)(), t_putc(), x_wSL(); +extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); +#else +#define Void void +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__getn)(void); /* for formatted input */ +extern void (*f__putn)(int); /* for formatted output */ +extern void x_putc(int); +extern long f__inode(char*,int*); +extern void sig_die(const char*,int); +extern void f__fatal(int, const char*); +extern int t_runc(alist*); +extern int f__nowreading(unit*), f__nowwriting(unit*); +extern int fk_open(int,int,ftnint); +extern int en_fio(void); +extern void f_init(void); +extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); +extern void b_char(const char*,char*,ftnlen), g_char(const char*,ftnlen,char*); +extern int c_sfe(cilist*), z_rnew(void); +extern int err__fl(int,int,const char*); +extern int xrd_SL(void); +extern int f__putbuf(int); +#endif +extern flag f__init; +extern cilist *f__elist; /*active external io list*/ +extern flag f__reading,f__external,f__sequential,f__formatted; +extern int (*f__doend)(Void); +extern FILE *f__cf; /*current file*/ +extern unit *f__curunit; /*current unit*/ +extern unit f__units[]; +#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);} +#define errfl(f,m,s) return err__fl((int)f,m,s) + +/*Table sizes*/ +#define MXUNIT 100 + +extern int f__recpos; /*position in current record*/ +extern OFF_T f__cursor; /* offset to move to */ +extern OFF_T f__hiwater; /* so TL doesn't confuse us */ +#ifdef __cplusplus + } +#endif + +#define WRITE 1 +#define READ 2 +#define SEQ 3 +#define DIR 4 +#define FMT 5 +#define UNF 6 +#define EXT 7 +#define INT 8 + +#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) diff --git a/unix/f2c/libf2c/fmt.c b/unix/f2c/libf2c/fmt.c new file mode 100644 index 00000000..286c98f3 --- /dev/null +++ b/unix/f2c/libf2c/fmt.c @@ -0,0 +1,530 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif +#define skip(s) while(*s==' ') s++ +#ifdef interdata +#define SYLMX 300 +#endif +#ifdef pdp11 +#define SYLMX 300 +#endif +#ifdef vax +#define SYLMX 300 +#endif +#ifndef SYLMX +#define SYLMX 300 +#endif +#define GLITCH '\2' + /* special quote character for stu */ +extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ +static struct syl f__syl[SYLMX]; +int f__parenlvl,f__pc,f__revloc; +#ifdef KR_headers +#define Const /*nothing*/ +#else +#define Const const +#endif + + static +#ifdef KR_headers +char *ap_end(s) char *s; +#else +const char *ap_end(const char *s) +#endif +{ char quote; + quote= *s++; + for(;*s;s++) + { if(*s!=quote) continue; + if(*++s!=quote) return(s); + } + if(f__elist->cierr) { + errno = 100; + return(NULL); + } + f__fatal(100, "bad string"); + /*NOTREACHED*/ return 0; +} + static int +#ifdef KR_headers +op_gen(a,b,c,d) +#else +op_gen(int a, int b, int c, int d) +#endif +{ struct syl *p= &f__syl[f__pc]; + if(f__pc>=SYLMX) + { fprintf(stderr,"format too complicated:\n"); + sig_die(f__fmtbuf, 1); + } + p->op=a; + p->p1=b; + p->p2.i[0]=c; + p->p2.i[1]=d; + return(f__pc++); +} +#ifdef KR_headers +static char *f_list(); +static char *gt_num(s,n,n1) char *s; int *n, n1; +#else +static const char *f_list(const char*); +static const char *gt_num(const char *s, int *n, int n1) +#endif +{ int m=0,f__cnt=0; + char c; + for(c= *s;;c = *s) + { if(c==' ') + { s++; + continue; + } + if(c>'9' || c<'0') break; + m=10*m+c-'0'; + f__cnt++; + s++; + } + if(f__cnt==0) { + if (!n1) + s = 0; + *n=n1; + } + else *n=m; + return(s); +} + + static +#ifdef KR_headers +char *f_s(s,curloc) char *s; +#else +const char *f_s(const char *s, int curloc) +#endif +{ + skip(s); + if(*s++!='(') + { + return(NULL); + } + if(f__parenlvl++ ==1) f__revloc=curloc; + if(op_gen(RET1,curloc,0,0)<0 || + (s=f_list(s))==NULL) + { + return(NULL); + } + skip(s); + return(s); +} + + static int +#ifdef KR_headers +ne_d(s,p) char *s,**p; +#else +ne_d(const char *s, const char **p) +#endif +{ int n,x,sign=0; + struct syl *sp; + switch(*s) + { + default: + return(0); + case ':': (void) op_gen(COLON,0,0,0); break; + case '$': + (void) op_gen(NONL, 0, 0, 0); break; + case 'B': + case 'b': + if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); + else (void) op_gen(BN,0,0,0); + break; + case 'S': + case 's': + if(*(s+1)=='s' || *(s+1) == 'S') + { x=SS; + s++; + } + else if(*(s+1)=='p' || *(s+1) == 'P') + { x=SP; + s++; + } + else x=S; + (void) op_gen(x,0,0,0); + break; + case '/': (void) op_gen(SLASH,0,0,0); break; + case '-': sign=1; + case '+': s++; /*OUTRAGEOUS CODING TRICK*/ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if (!(s=gt_num(s,&n,0))) { + bad: *p = 0; + return 1; + } + switch(*s) + { + default: + return(0); + case 'P': + case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; + case 'X': + case 'x': (void) op_gen(X,n,0,0); break; + case 'H': + case 'h': + sp = &f__syl[op_gen(H,n,0,0)]; + sp->p2.s = (char*)s + 1; + s+=n; + break; + } + break; + case GLITCH: + case '"': + case '\'': + sp = &f__syl[op_gen(APOS,0,0,0)]; + sp->p2.s = (char*)s; + if((*p = ap_end(s)) == NULL) + return(0); + return(1); + case 'T': + case 't': + if(*(s+1)=='l' || *(s+1) == 'L') + { x=TL; + s++; + } + else if(*(s+1)=='r'|| *(s+1) == 'R') + { x=TR; + s++; + } + else x=T; + if (!(s=gt_num(s+1,&n,0))) + goto bad; + s--; + (void) op_gen(x,n,0,0); + break; + case 'X': + case 'x': (void) op_gen(X,1,0,0); break; + case 'P': + case 'p': (void) op_gen(P,1,0,0); break; + } + s++; + *p=s; + return(1); +} + + static int +#ifdef KR_headers +e_d(s,p) char *s,**p; +#else +e_d(const char *s, const char **p) +#endif +{ int i,im,n,w,d,e,found=0,x=0; + Const char *sv=s; + s=gt_num(s,&n,1); + (void) op_gen(STACK,n,0,0); + switch(*s++) + { + default: break; + case 'E': + case 'e': x=1; + case 'G': + case 'g': + found=1; + if (!(s=gt_num(s,&w,0))) { + bad: + *p = 0; + return 1; + } + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + if(*s!='E' && *s != 'e') + (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ + else { + if (!(s=gt_num(s+1,&e,0))) + goto bad; + (void) op_gen(x==1?EE:GE,w,d,e); + } + break; + case 'O': + case 'o': + i = O; + im = OM; + goto finish_I; + case 'Z': + case 'z': + i = Z; + im = ZM; + goto finish_I; + case 'L': + case 'l': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + (void) op_gen(L,w,0,0); + break; + case 'A': + case 'a': + found=1; + skip(s); + if(*s>='0' && *s<='9') + { s=gt_num(s,&w,1); + if(w==0) break; + (void) op_gen(AW,w,0,0); + break; + } + (void) op_gen(A,0,0,0); + break; + case 'F': + case 'f': + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(F,w,d,0); + break; + case 'D': + case 'd': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(D,w,d,0); + break; + case 'I': + case 'i': + i = I; + im = IM; + finish_I: + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s!='.') + { (void) op_gen(i,w,0,0); + break; + } + if (!(s=gt_num(s+1,&d,0))) + goto bad; + (void) op_gen(im,w,d,0); + break; + } + if(found==0) + { f__pc--; /*unSTACK*/ + *p=sv; + return(0); + } + *p=s; + return(1); +} + static +#ifdef KR_headers +char *i_tem(s) char *s; +#else +const char *i_tem(const char *s) +#endif +{ const char *t; + int n,curloc; + if(*s==')') return(s); + if(ne_d(s,&t)) return(t); + if(e_d(s,&t)) return(t); + s=gt_num(s,&n,1); + if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); + return(f_s(s,curloc)); +} + + static +#ifdef KR_headers +char *f_list(s) char *s; +#else +const char *f_list(const char *s) +#endif +{ + for(;*s!=0;) + { skip(s); + if((s=i_tem(s))==NULL) return(NULL); + skip(s); + if(*s==',') s++; + else if(*s==')') + { if(--f__parenlvl==0) + { + (void) op_gen(REVERT,f__revloc,0,0); + return(++s); + } + (void) op_gen(GOTO,0,0,0); + return(++s); + } + } + return(NULL); +} + + int +#ifdef KR_headers +pars_f(s) char *s; +#else +pars_f(const char *s) +#endif +{ + f__parenlvl=f__revloc=f__pc=0; + if(f_s(s,0) == NULL) + { + return(-1); + } + return(0); +} +#define STKSZ 10 +int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; +flag f__workdone, f__nonl; + + static int +#ifdef KR_headers +type_f(n) +#else +type_f(int n) +#endif +{ + switch(n) + { + default: + return(n); + case RET1: + return(RET1); + case REVERT: return(REVERT); + case GOTO: return(GOTO); + case STACK: return(STACK); + case X: + case SLASH: + case APOS: case H: + case T: case TL: case TR: + return(NED); + case F: + case I: + case IM: + case A: case AW: + case O: case OM: + case L: + case E: case EE: case D: + case G: case GE: + case Z: case ZM: + return(ED); + } +} +#ifdef KR_headers +integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +#else +integer do_fio(ftnint *number, char *ptr, ftnlen len) +#endif +{ struct syl *p; + int n,i; + for(i=0;i<*number;i++,ptr+=len) + { +loop: switch(type_f((p= &f__syl[f__pc])->op)) + { + default: + fprintf(stderr,"unknown code in do_fio: %d\n%s\n", + p->op,f__fmtbuf); + err(f__elist->cierr,100,"do_fio"); + case NED: + if((*f__doned)(p)) + { f__pc++; + goto loop; + } + f__pc++; + continue; + case ED: + if(f__cnt[f__cp]<=0) + { f__cp--; + f__pc++; + goto loop; + } + if(ptr==NULL) + return((*f__doend)()); + f__cnt[f__cp]--; + f__workdone=1; + if((n=(*f__doed)(p,ptr,len))>0) + errfl(f__elist->cierr,errno,"fmt"); + if(n<0) + err(f__elist->ciend,(EOF),"fmt"); + continue; + case STACK: + f__cnt[++f__cp]=p->p1; + f__pc++; + goto loop; + case RET1: + f__ret[++f__rp]=p->p1; + f__pc++; + goto loop; + case GOTO: + if(--f__cnt[f__cp]<=0) + { f__cp--; + f__rp--; + f__pc++; + goto loop; + } + f__pc=1+f__ret[f__rp--]; + goto loop; + case REVERT: + f__rp=f__cp=0; + f__pc = p->p1; + if(ptr==NULL) + return((*f__doend)()); + if(!f__workdone) return(0); + if((n=(*f__dorevert)()) != 0) return(n); + goto loop; + case COLON: + if(ptr==NULL) + return((*f__doend)()); + f__pc++; + goto loop; + case NONL: + f__nonl = 1; + f__pc++; + goto loop; + case S: + case SS: + f__cplus=0; + f__pc++; + goto loop; + case SP: + f__cplus = 1; + f__pc++; + goto loop; + case P: f__scale=p->p1; + f__pc++; + goto loop; + case BN: + f__cblank=0; + f__pc++; + goto loop; + case BZ: + f__cblank=1; + f__pc++; + goto loop; + } + } + return(0); +} + + int +en_fio(Void) +{ ftnint one=1; + return(do_fio(&one,(char *)NULL,(ftnint)0)); +} + + VOID +fmt_bg(Void) +{ + f__workdone=f__cp=f__rp=f__pc=f__cursor=0; + f__cnt[0]=f__ret[0]=0; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/fmt.h b/unix/f2c/libf2c/fmt.h new file mode 100644 index 00000000..ddfa551d --- /dev/null +++ b/unix/f2c/libf2c/fmt.h @@ -0,0 +1,105 @@ +struct syl +{ int op; + int p1; + union { int i[2]; char *s;} p2; + }; +#define RET1 1 +#define REVERT 2 +#define GOTO 3 +#define X 4 +#define SLASH 5 +#define STACK 6 +#define I 7 +#define ED 8 +#define NED 9 +#define IM 10 +#define APOS 11 +#define H 12 +#define TL 13 +#define TR 14 +#define T 15 +#define COLON 16 +#define S 17 +#define SP 18 +#define SS 19 +#define P 20 +#define BN 21 +#define BZ 22 +#define F 23 +#define E 24 +#define EE 25 +#define D 26 +#define G 27 +#define GE 28 +#define L 29 +#define A 30 +#define AW 31 +#define O 32 +#define NONL 33 +#define OM 34 +#define Z 35 +#define ZM 36 +typedef union +{ real pf; + doublereal pd; +} ufloat; +typedef union +{ short is; +#ifndef KR_headers + signed +#endif + char ic; + integer il; +#ifdef Allow_TYQUAD + longint ili; +#endif +} Uint; +#ifdef KR_headers +extern int (*f__doed)(),(*f__doned)(); +extern int (*f__dorevert)(); +extern int rd_ed(),rd_ned(); +extern int w_ed(),w_ned(); +extern int signbit_f2c(); +extern char *f__fmtbuf; +#else +#ifdef __cplusplus +extern "C" { +#define Cextern extern "C" +#else +#define Cextern extern +#endif +extern const char *f__fmtbuf; +extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +extern int (*f__dorevert)(void); +extern void fmt_bg(void); +extern int pars_f(const char*); +extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); +extern int signbit_f2c(double*); +extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); +extern int wrt_E(ufloat*, int, int, int, ftnlen); +extern int wrt_F(ufloat*, int, int, ftnlen); +extern int wrt_L(Uint*, int, ftnlen); +#endif +extern int f__pc,f__parenlvl,f__revloc; +extern flag f__cblank,f__cplus,f__workdone, f__nonl; +extern int f__scale; +#ifdef __cplusplus + } +#endif +#define GET(x) if((x=(*f__getn)())<0) return(x) +#define VAL(x) (x!='\n'?x:' ') +#define PUT(x) (*f__putn)(x) + +#undef TYQUAD +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#else +#define TYQUAD 14 +#endif + +#ifdef KR_headers +extern char *f__icvt(); +#else +Cextern char *f__icvt(longint, int*, int*, int); +#endif diff --git a/unix/f2c/libf2c/fmtlib.c b/unix/f2c/libf2c/fmtlib.c new file mode 100644 index 00000000..279f66f4 --- /dev/null +++ b/unix/f2c/libf2c/fmtlib.c @@ -0,0 +1,51 @@ +/* @(#)fmtlib.c 1.2 */ +#define MAXINTLENGTH 23 + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#undef ulongint +#define ulongint unsigned long +#endif + +#ifdef KR_headers +char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; + register int base; +#else +char *f__icvt(longint value, int *ndigit, int *sign, int base) +#endif +{ + static char buf[MAXINTLENGTH+1]; + register int i; + ulongint uvalue; + + if(value > 0) { + uvalue = value; + *sign = 0; + } + else if (value < 0) { + uvalue = -value; + *sign = 1; + } + else { + *sign = 0; + *ndigit = 1; + buf[MAXINTLENGTH-1] = '0'; + return &buf[MAXINTLENGTH-1]; + } + i = MAXINTLENGTH; + do { + buf[--i] = (uvalue%base) + '0'; + uvalue /= base; + } + while(uvalue > 0); + *ndigit = MAXINTLENGTH - i; + return &buf[i]; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/fp.h b/unix/f2c/libf2c/fp.h new file mode 100644 index 00000000..40743d79 --- /dev/null +++ b/unix/f2c/libf2c/fp.h @@ -0,0 +1,28 @@ +#define FMAX 40 +#define EXPMAXDIGS 8 +#define EXPMAX 99999999 +/* FMAX = max number of nonzero digits passed to atof() */ +/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ + +#ifdef V10 /* Research Tenth-Edition Unix */ +#include "local.h" +#endif + +/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily + tight) on the maximum number of digits to the right and left of + * the decimal point. + */ + +#ifdef VAX +#define MAXFRACDIGS 56 +#define MAXINTDIGS 38 +#else +#ifdef CRAY +#define MAXFRACDIGS 9880 +#define MAXINTDIGS 9864 +#else +/* values that suffice for IEEE double */ +#define MAXFRACDIGS 344 +#define MAXINTDIGS 308 +#endif +#endif diff --git a/unix/f2c/libf2c/ftell64_.c b/unix/f2c/libf2c/ftell64_.c new file mode 100644 index 00000000..9cc00cba --- /dev/null +++ b/unix/f2c/libf2c/ftell64_.c @@ -0,0 +1,52 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + static FILE * +#ifdef KR_headers +unit_chk(Unit, who) integer Unit; char *who; +#else +unit_chk(integer Unit, char *who) +#endif +{ + if (Unit >= MXUNIT || Unit < 0) + f__fatal(101, who); + return f__units[Unit].ufd; + } + + longint +#ifdef KR_headers +ftell64_(Unit) integer *Unit; +#else +ftell64_(integer *Unit) +#endif +{ + FILE *f; + return (f = unit_chk(*Unit, "ftell")) ? FTELL(f) : -1L; + } + + int +#ifdef KR_headers +fseek64_(Unit, offset, whence) integer *Unit, *whence; longint *offset; +#else +fseek64_(integer *Unit, longint *offset, integer *whence) +#endif +{ + FILE *f; + int w = (int)*whence; +#ifdef SEEK_SET + static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +#endif + if (w < 0 || w > 2) + w = 0; +#ifdef SEEK_SET + w = wohin[w]; +#endif + return !(f = unit_chk(*Unit, "fseek")) + || FSEEK(f, (OFF_T)*offset, w) ? 1 : 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ftell_.c b/unix/f2c/libf2c/ftell_.c new file mode 100644 index 00000000..0acd60fe --- /dev/null +++ b/unix/f2c/libf2c/ftell_.c @@ -0,0 +1,52 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + static FILE * +#ifdef KR_headers +unit_chk(Unit, who) integer Unit; char *who; +#else +unit_chk(integer Unit, const char *who) +#endif +{ + if (Unit >= MXUNIT || Unit < 0) + f__fatal(101, who); + return f__units[Unit].ufd; + } + + integer +#ifdef KR_headers +ftell_(Unit) integer *Unit; +#else +ftell_(integer *Unit) +#endif +{ + FILE *f; + return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; + } + + int +#ifdef KR_headers +fseek_(Unit, offset, whence) integer *Unit, *offset, *whence; +#else +fseek_(integer *Unit, integer *offset, integer *whence) +#endif +{ + FILE *f; + int w = (int)*whence; +#ifdef SEEK_SET + static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +#endif + if (w < 0 || w > 2) + w = 0; +#ifdef SEEK_SET + w = wohin[w]; +#endif + return !(f = unit_chk(*Unit, "fseek")) + || fseek(f, *offset, w) ? 1 : 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/getarg_.c b/unix/f2c/libf2c/getarg_.c new file mode 100644 index 00000000..2b69a1e1 --- /dev/null +++ b/unix/f2c/libf2c/getarg_.c @@ -0,0 +1,36 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* + * subroutine getarg(k, c) + * returns the kth unix command argument in fortran character + * variable argument c +*/ + +#ifdef KR_headers +VOID getarg_(n, s, ls) ftnint *n; char *s; ftnlen ls; +#define Const /*nothing*/ +#else +#define Const const +void getarg_(ftnint *n, char *s, ftnlen ls) +#endif +{ + extern int xargc; + extern char **xargv; + Const char *t; + int i; + + if(*n>=0 && *n +#include +#ifdef __cplusplus +extern "C" { +#endif +extern char *F77_aloc(ftnlen, const char*); +#endif + +/* + * getenv - f77 subroutine to return environment variables + * + * called by: + * call getenv (ENV_NAME, char_var) + * where: + * ENV_NAME is the name of an environment variable + * char_var is a character variable which will receive + * the current value of ENV_NAME, or all blanks + * if ENV_NAME is not defined + */ + +#ifdef KR_headers + VOID +getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen; +#else + void +getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen) +#endif +{ + char buf[256], *ep, *fp; + integer i; + + if (flen <= 0) + goto add_blanks; + for(i = 0; i < sizeof(buf); i++) { + if (i == flen || (buf[i] = fname[i]) == ' ') { + buf[i] = 0; + ep = getenv(buf); + goto have_ep; + } + } + while(i < flen && fname[i] != ' ') + i++; + strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i); + fp[i] = 0; + ep = getenv(fp); + free(fp); + have_ep: + if (ep) + while(*ep && vlen-- > 0) + *value++ = *ep++; + add_blanks: + while(vlen-- > 0) + *value++ = ' '; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_abs.c b/unix/f2c/libf2c/h_abs.c new file mode 100644 index 00000000..db690686 --- /dev/null +++ b/unix/f2c/libf2c/h_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_abs(x) shortint *x; +#else +shortint h_abs(shortint *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_dim.c b/unix/f2c/libf2c/h_dim.c new file mode 100644 index 00000000..443427a9 --- /dev/null +++ b/unix/f2c/libf2c/h_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_dim(a,b) shortint *a, *b; +#else +shortint h_dim(shortint *a, shortint *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_dnnt.c b/unix/f2c/libf2c/h_dnnt.c new file mode 100644 index 00000000..1ec641c5 --- /dev/null +++ b/unix/f2c/libf2c/h_dnnt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_dnnt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +shortint h_dnnt(doublereal *x) +#endif +{ +return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_indx.c b/unix/f2c/libf2c/h_indx.c new file mode 100644 index 00000000..018f2f43 --- /dev/null +++ b/unix/f2c/libf2c/h_indx.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return((shortint)i+1); + no: ; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_len.c b/unix/f2c/libf2c/h_len.c new file mode 100644 index 00000000..8b0aea99 --- /dev/null +++ b/unix/f2c/libf2c/h_len.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_len(s, n) char *s; ftnlen n; +#else +shortint h_len(char *s, ftnlen n) +#endif +{ +return(n); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_mod.c b/unix/f2c/libf2c/h_mod.c new file mode 100644 index 00000000..611ef0aa --- /dev/null +++ b/unix/f2c/libf2c/h_mod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_mod(a,b) short *a, *b; +#else +shortint h_mod(short *a, short *b) +#endif +{ +return( *a % *b); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_nint.c b/unix/f2c/libf2c/h_nint.c new file mode 100644 index 00000000..9e2282f2 --- /dev/null +++ b/unix/f2c/libf2c/h_nint.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +shortint h_nint(real *x) +#endif +{ +return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_sign.c b/unix/f2c/libf2c/h_sign.c new file mode 100644 index 00000000..4e214380 --- /dev/null +++ b/unix/f2c/libf2c/h_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_sign(a,b) shortint *a, *b; +#else +shortint h_sign(shortint *a, shortint *b) +#endif +{ +shortint x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_ge.c b/unix/f2c/libf2c/hl_ge.c new file mode 100644 index 00000000..8c72f03d --- /dev/null +++ b/unix/f2c/libf2c/hl_ge.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_gt.c b/unix/f2c/libf2c/hl_gt.c new file mode 100644 index 00000000..a448522d --- /dev/null +++ b/unix/f2c/libf2c/hl_gt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_le.c b/unix/f2c/libf2c/hl_le.c new file mode 100644 index 00000000..31cbc431 --- /dev/null +++ b/unix/f2c/libf2c/hl_le.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_lt.c b/unix/f2c/libf2c/hl_lt.c new file mode 100644 index 00000000..7ad3c714 --- /dev/null +++ b/unix/f2c/libf2c/hl_lt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i77vers.c b/unix/f2c/libf2c/i77vers.c new file mode 100644 index 00000000..60cc24ee --- /dev/null +++ b/unix/f2c/libf2c/i77vers.c @@ -0,0 +1,343 @@ + char +_libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n"; + +/* +2.01 $ format added +2.02 Coding bug in open.c repaired +2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c + and lio.h (e-format conforming to spec) +2.04 changed open.c and err.c (fopen and freopen respectively) to + update to new c-library (append mode) +2.05 added namelist capability +2.06 allow internal list and namelist I/O +*/ + +/* +close.c: + allow upper-case STATUS= values +endfile.c + create fort.nnn if unit nnn not open; + else if (file length == 0) use creat() rather than copy; + use local copy() rather than forking /bin/cp; + rewind, fseek to clear buffer (for no reading past EOF) +err.c + use neither setbuf nor setvbuf; make stderr buffered +fio.h + #define _bufend +inquire.c + upper case responses; + omit byfile test from SEQUENTIAL= + answer "YES" to DIRECT= for unopened file (open to debate) +lio.c + flush stderr, stdout at end of each stmt + space before character strings in list output only at line start +lio.h + adjust LEW, LED consistent with old libI77 +lread.c + use atof() + allow "nnn*," when reading complex constants +open.c + try opening for writing when open for read fails, with + special uwrt value (2) delaying creat() to first write; + set curunit so error messages don't drop core; + no file name ==> fort.nnn except for STATUS='SCRATCH' +rdfmt.c + use atof(); trust EOF == end-of-file (so don't read past + end-of-file after endfile stmt) +sfe.c + flush stderr, stdout at end of each stmt +wrtfmt.c: + use upper case + put wrt_E and wrt_F into wref.c, use sprintf() + rather than ecvt() and fcvt() [more accurate on VAX] +*/ + +/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ + +/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ + +/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ +/* 29 Nov. 1989: change various int return types to long for f2c */ +/* 30 Nov. 1989: various types from f2c.h */ +/* 6 Dec. 1989: types corrected various places */ +/* 19 Dec. 1989: make iostat= work right for internal I/O */ +/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ +/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white + space as blank */ +/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads + of logical values reject letters other than fFtT; + have nowwriting reset cf */ +/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ +/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as + blank='z...' when reopening an open file */ +/* 30 Aug. 1990: prevent embedded blanks in list output of complex values; + omit exponent field in list output of values of + magnitude between 10 and 1e8; prevent writing stdin + and reading stdout or stderr; don't close stdin, stdout, + or stderr when reopening units 5, 6, 0. */ +/* 18 Sep. 1990: add component udev to unit and consider old == new file + iff uinode and udev values agree; use stat rather than + access to check existence of file (when STATUS='OLD')*/ +/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write + don't clobber the file. */ +/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; + adjust g_char in util.c for segmented memories. */ +/* 17 Oct. 1990: replace abort() and _cleanup() with calls on + sig_die(...,1) (defined in main.c). */ +/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the + file already exists; allow file= to be omitted in open stmts + and allow status='replace' (Fortran 90 extensions). */ +/* 11 Dec. 1990: adjustments for POSIX. */ +/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from + strings in read-only memory. */ +/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ +/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ +/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ +/* 17 Oct. 1991: change type of length field in sequential unformatted + records from int to long (for systems where sizeof(int) + can vary, depending on the compiler or compiler options). */ +/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ +/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to + sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ +/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); + adjust an error return from EOF to off end of record */ +/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused + the last character of each record to be ignored. + iio.c: adjust error message in internal formatted + input from "end-of-file" to "off end of record" if + the format specifies more characters than the + record contains. */ +/* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input, + treat "r* ," and "r*," alike (where r is a + positive integer constant), and fix a bug in + handling null values following items with repeat + counts (e.g., 2*1,,3); for namelist reading + of a numeric array, allow a new name-value subsequence + to terminate the current one (as though the current + one ended with the right number of null values). + lio.h, lwrite.c: omit insignificant zeros in + list and namelist output. To get the old + behavior, compile with -DOld_list_output . */ +/* 18 Jan. 1992: make list output consistent with F format by + printing .1 rather than 0.1 (introduced yesterday). */ +/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the + character following a comma to be ignored. */ +/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= + work with internal list and formatted I/O. */ +/* 18 July 1992: adjust rsne.c to allow namelist input to stop at + an & (e.g. &end). */ +/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; + recognize Z format (assuming 8-bit bytes). */ +/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ +/* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c + (so end-of-file on other files won't confuse namelist + reads of external files). Prepend f__ to external + names that are only of internal interest to lib[FI]77. */ +/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd + buffer == '\n'. + endfile.c: guard against tiny L_tmpnam; close and reopen + files in t_runc(). + lio.h: lengthen LINTW (buffer size in lwrite.c). + err.c, open.c: more prepending of f__ (to [rw]_mode). */ +/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being + sought; namelists of the wrong name are skipped (after + an error message; xwsne.c: namelist writes have a + newline before each new variable. + open.c: ACCESS='APPEND' positions sequential files + at EOF (nonstandard extension -- that doesn't require + changing data structures). */ +/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. + err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) + when the unit has another file descriptor for name. */ +/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; + open.c: always give f__w_mode[] 4 elements for use + in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ +/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential + unformatted reads to respond to err= rather than end=. */ +/* 12 March 1993: various tweaks for C++ */ +/* 6 April 1993: adjust error returns for formatted inputs to flush + the current input line when err=label is specified. + To restore the old behavior (input left mid-line), + either adjust the #definition of errfl in fio.h or + omit the invocation of f__doend in err__fl (in err.c). */ +/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ +/* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for + logical data (during list or namelist input). + Change struct f__syl to struct syl (for buggy compilers). */ +/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete + logical arrays. */ +/* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete + array of numeric data followed by another namelist + item whose name starts with 'd', 'D', 'e', or 'E'. */ +/* 8 Sept. 1993: open.c: protect #include "sys/..." with + #ifndef NON_UNIX_STDIO; Version date not changed. */ +/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ +/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat + short records as though padded with blanks + (rather than causing an "off end of record" error). */ +/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ +/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct + formatted files (avoiding any confusion regarding \n). */ +/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files + under NON_UNIX_STDIO. */ +/* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an + optimization that requires exponents to have 2 digits + when 2 digits suffice. + lwrite.c wsfe.c (list and formatted external output): + omit ' ' carriage-control when compiled with + -DOMIT_BLANK_CC . Off-by-one bug fixed in character + count for list output of character strings. + Omit '.' in list-directed printing of Nan, Infinity. */ +/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather + than " .0000E+00". */ +/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an + oversize item to an empty line. */ +/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept + ERR= (in list- or format-directed input) from working + after a NAMELIST READ. */ +/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, + INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 + in NAMELISTs. */ +/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ +/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ +/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when + GOOD_SPRINTF_EXPONENT is not #defined. */ +/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow + internal reading of characters with high-bit set + (on machines that sign-extend characters). */ +/* 14 March 1995:lread.c and rsfe.c: adjust s_rsle and s_rsfe to + check for end-of-file (to prevent infinite loops + with empty read statements). */ +/* 26 May 1995: iio.c: z_wnew: fix bug in handling T format items + in internal writes whose last item is written to + an earlier position than some previous item. */ +/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ +/* 6 Sept. 1995: Adjust namelist input to treat a subscripted name + whose subscripts do not involve colons similarly + to the name without a subscript: accept several + values, stored in successive elements starting at + the indicated subscript. Adjust namelist output + to quote character strings (avoiding confusion with + arrays of character strings). Adjust f_init calls + for people who don't use libF77's main(); now open and + namelist read statements invoke f_init if needed. */ +/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). + Add -DNo_Namelist_Comments lines to rsne.c. */ +/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not + always zeroed in mv_cur). */ +/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c + to err.c */ +/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ + +/* 13 May 1996: add ftell_.c and fseek_.c */ +/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with + too few items in the input string will honor end= . */ +/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ +/* 25 Sept. 1995:fmt.h: for formatted writes of negative integer*1 values, + make ic signed on ANSI systems. If formatted writes of + integer*1 values trouble you when using a K&R C compiler, + switch to an ANSI compiler or use a compiler flag that + makes characters signed. */ +/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= + in direct read and write statements. + ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ +/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use + SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ +/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats + (but still treat missing ".nnn" as ".0"). */ +/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather + than fully buffered. (Buffering is needed for format + items T and TR.) */ +/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be + treated as 2 on some systems). */ +/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X + draft (in 1990 or 1991) that rescinded permission to elide + quote marks in namelist input of character data; compile + with -DF8X_NML_ELIDE_QUOTES to get the old behavior. + wrtfmt.o: wrt_G: tweak to print the right number of 0's + for zero under G format. */ +/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character + strings that sometimes caused one more array element than + required by the format to be blank-filled. Example: + format(1x). */ +/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines + with 64-bit pointers and 32-bit ints that did not 64-bit + align struct syl (e.g., Linux on the DEC Alpha). */ +/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to + sizeof(uiolen). On machines where this would make a + difference, it is best for portability to compile libI77 with + -DUIOLEN_int (which will render the change invisible). */ +/* 4 March 1998: open.c: fix glitch in comparing file names under + -DNON_UNIX_STDIO */ +/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(), + unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). + New buffering scheme independent of NON_UNIX_STDIO for + handling T format items. Now -DNON_UNIX_STDIO is no + longer be necessary for Linux, and libf2c no longer + causes stderr to be buffered -- the former setbuf or + setvbuf call for stderr was to make T format items work. + open.c: use the Posix access() function to check existence + or nonexistence of files, except under -DNON_POSIX_STDIO, + where trial fopen calls are used. */ +/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the + changes of 17 March 1998. */ +/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: + set f__curunit sooner so various error messages will + correctly identify the I/O unit involved. */ +/* 17 June 1998: lread.c: unless compiled with + ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat + floating-point numbers (containing either a decimal point + or an exponent field) as errors when they appear as list + input for integer data. */ +/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally. + Why did it ever move to sfe.c? */ +/* 2 May 1999: open.c: set f__external (to get "external" versus "internal" + right in the error message if we cannot open the file). + err.c: cast a pointer difference to (int) for %d. + rdfmt.c: omit fixed-length buffer that could be overwritten + by formats Inn or Lnn with nn > 83. */ +/* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */ +/* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */ +/* 27 June 1999: rsne.c: fix bug in namelist input: a misplaced increment */ +/* could cause wrong array elements to be assigned; e.g., */ +/* "&input k(5)=10*1 &end" assigned k(5) and k(15..23) */ +/* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */ +/* endfile statement requires copying the file. */ +/* (Otherwise an immediately following rewind statement */ +/* could make the file appear empty.) Also, supply a */ +/* missing (long) cast in the sprintf call. */ +/* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */ +/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */ +/* any data in buffers should the program fault. It also */ +/* makes the program run more slowly. */ +/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */ +/* ftnlen are of different fundamental types (different numbers */ +/* of bits). Since these files will not compile when this */ +/* change matters, the above VERSION string remains unchanged. */ +/* 4 July 2000: adjustments to permit compilation by C++ compilers; */ +/* VERSION string remains unchanged. */ +/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */ +/* treat Tstuff= and Fstuff= as new assignments rather than as */ +/* logical constants. */ +/* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */ +/* -DNO_TRUNCATE (or with -DMSDOS). */ +/* 1 March 2001: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), */ +/* thus permitting truncation of scratch files on true Unix */ +/* systems, where scratch files have no name. Add an fflush() */ +/* (surprisingly) needed on some Linux systems. */ +/* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */ +/* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */ +/* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */ +/* respectively, in fio.h unless otherwise #defined), and use */ +/* type OFF_T (#defined to be long unless otherwise #defined) */ +/* to permit handling files over 2GB long where possible, */ +/* with suitable -D options, provided for some systems in new */ +/* header file sysdep1.h (copied from sysdep1.h0 by default). */ +/* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */ +/* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */ +/* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */ +/* comments in makefile or (better) libf2c/makefile.* . */ +/* 6 Sept. 2002: rsne.c: fix bug with multiple repeat counts in reading */ +/* namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / */ +/* 21 March 2003: err.c: before writing to a file after reading from it, */ +/* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */ diff --git a/unix/f2c/libf2c/i_abs.c b/unix/f2c/libf2c/i_abs.c new file mode 100644 index 00000000..2b92c4aa --- /dev/null +++ b/unix/f2c/libf2c/i_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_abs(x) integer *x; +#else +integer i_abs(integer *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_dim.c b/unix/f2c/libf2c/i_dim.c new file mode 100644 index 00000000..60ed4d8c --- /dev/null +++ b/unix/f2c/libf2c/i_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_dim(a,b) integer *a, *b; +#else +integer i_dim(integer *a, integer *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_dnnt.c b/unix/f2c/libf2c/i_dnnt.c new file mode 100644 index 00000000..3abc2dc4 --- /dev/null +++ b/unix/f2c/libf2c/i_dnnt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_dnnt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +integer i_dnnt(doublereal *x) +#endif +{ +return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_indx.c b/unix/f2c/libf2c/i_indx.c new file mode 100644 index 00000000..19256393 --- /dev/null +++ b/unix/f2c/libf2c/i_indx.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +integer i_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return(i+1); + no: ; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_len.c b/unix/f2c/libf2c/i_len.c new file mode 100644 index 00000000..0f7b188d --- /dev/null +++ b/unix/f2c/libf2c/i_len.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_len(s, n) char *s; ftnlen n; +#else +integer i_len(char *s, ftnlen n) +#endif +{ +return(n); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_mod.c b/unix/f2c/libf2c/i_mod.c new file mode 100644 index 00000000..4a9b5609 --- /dev/null +++ b/unix/f2c/libf2c/i_mod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_mod(a,b) integer *a, *b; +#else +integer i_mod(integer *a, integer *b) +#endif +{ +return( *a % *b); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_nint.c b/unix/f2c/libf2c/i_nint.c new file mode 100644 index 00000000..fe9fd68a --- /dev/null +++ b/unix/f2c/libf2c/i_nint.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +integer i_nint(real *x) +#endif +{ +return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_sign.c b/unix/f2c/libf2c/i_sign.c new file mode 100644 index 00000000..4c20e949 --- /dev/null +++ b/unix/f2c/libf2c/i_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_sign(a,b) integer *a, *b; +#else +integer i_sign(integer *a, integer *b) +#endif +{ +integer x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/iargc_.c b/unix/f2c/libf2c/iargc_.c new file mode 100644 index 00000000..2f29da0e --- /dev/null +++ b/unix/f2c/libf2c/iargc_.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +ftnint iargc_() +#else +ftnint iargc_(void) +#endif +{ +extern int xargc; +return ( xargc - 1 ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/iio.c b/unix/f2c/libf2c/iio.c new file mode 100644 index 00000000..8553efcf --- /dev/null +++ b/unix/f2c/libf2c/iio.c @@ -0,0 +1,159 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *f__icptr; +char *f__icend; +extern icilist *f__svic; +int f__icnum; + + int +z_getc(Void) +{ + if(f__recpos++ < f__svic->icirlen) { + if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); + return(*(unsigned char *)f__icptr++); + } + return '\n'; +} + + void +#ifdef KR_headers +z_putc(c) +#else +z_putc(int c) +#endif +{ + if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen) + *f__icptr++ = c; +} + + int +z_rnew(Void) +{ + f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + return 1; +} + + static int +z_endp(Void) +{ + (*f__donewrec)(); + return 0; + } + + int +#ifdef KR_headers +c_si(a) icilist *a; +#else +c_si(icilist *a) +#endif +{ + f__elist = (cilist *)a; + f__fmtbuf=a->icifmt; + f__curunit = 0; + f__sequential=f__formatted=1; + f__external=0; + if(pars_f(f__fmtbuf)<0) + err(a->icierr,100,"startint"); + fmt_bg(); + f__cblank=f__cplus=f__scale=0; + f__svic=a; + f__icnum=f__recpos=0; + f__cursor = 0; + f__hiwater = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__cf = 0; + return(0); +} + + int +iw_rev(Void) +{ + if(f__workdone) + z_endp(); + f__hiwater = f__recpos = f__cursor = 0; + return(f__workdone=0); + } + +#ifdef KR_headers +integer s_rsfi(a) icilist *a; +#else +integer s_rsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=1; + f__doed=rd_ed; + f__doned=rd_ned; + f__getn=z_getc; + f__dorevert = z_endp; + f__donewrec = z_rnew; + f__doend = z_endp; + return(0); +} + + int +z_wnew(Void) +{ + if (f__recpos < f__hiwater) { + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + } + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + f__icnum++; + return 1; +} +#ifdef KR_headers +integer s_wsfi(a) icilist *a; +#else +integer s_wsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=0; + f__doed=w_ed; + f__doned=w_ned; + f__putn=z_putc; + f__dorevert = iw_rev; + f__donewrec = z_wnew; + f__doend = z_endp; + return(0); +} +integer e_rsfi(Void) +{ int n = en_fio(); + f__fmtbuf = NULL; + return(n); +} +integer e_wsfi(Void) +{ + int n; + n = en_fio(); + f__fmtbuf = NULL; + if(f__svic->icirnum != 1 + && (f__icnum > f__svic->icirnum + || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) + err(f__svic->icierr,110,"inwrite"); + if (f__recpos < f__hiwater) + f__recpos = f__hiwater; + if (f__recpos >= f__svic->icirlen) + err(f__svic->icierr,110,"recend"); + if (!f__recpos && f__icnum) + return n; + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + return n; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ilnw.c b/unix/f2c/libf2c/ilnw.c new file mode 100644 index 00000000..e8b3d49c --- /dev/null +++ b/unix/f2c/libf2c/ilnw.c @@ -0,0 +1,83 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum; +#ifdef KR_headers +extern void z_putc(); +#else +extern void z_putc(int); +#endif + + static int +z_wSL(Void) +{ + while(f__recpos < f__svic->icirlen) + z_putc(' '); + return z_rnew(); + } + + static void +#ifdef KR_headers +c_liw(a) icilist *a; +#else +c_liw(icilist *a) +#endif +{ + f__reading = 0; + f__external = 0; + f__formatted = 1; + f__putn = z_putc; + L_len = a->icirlen; + f__donewrec = z_wSL; + f__svic = a; + f__icnum = f__recpos = 0; + f__cursor = 0; + f__cf = 0; + f__curunit = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__elist = (cilist *)a; + } + + integer +#ifdef KR_headers +s_wsni(a) icilist *a; +#else +s_wsni(icilist *a) +#endif +{ + cilist ca; + + c_liw(a); + ca.cifmt = a->icifmt; + x_wsne(&ca); + z_wSL(); + return 0; + } + + integer +#ifdef KR_headers +s_wsli(a) icilist *a; +#else +s_wsli(icilist *a) +#endif +{ + f__lioproc = l_write; + c_liw(a); + return(0); + } + +integer e_wsli(Void) +{ + z_wSL(); + return(0); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/inquire.c b/unix/f2c/libf2c/inquire.c new file mode 100644 index 00000000..5936a674 --- /dev/null +++ b/unix/f2c/libf2c/inquire.c @@ -0,0 +1,117 @@ +#include "f2c.h" +#include "fio.h" +#include "string.h" +#ifdef NON_UNIX_STDIO +#ifndef MSDOS +#include "unistd.h" /* for access() */ +#endif +#endif +#ifdef KR_headers +integer f_inqu(a) inlist *a; +#else +#ifdef __cplusplus +extern "C" integer f_inqu(inlist*); +#endif +#ifdef MSDOS +#undef abs +#undef min +#undef max +#include "io.h" +#endif +integer f_inqu(inlist *a) +#endif +{ flag byfile; + int i; +#ifndef NON_UNIX_STDIO + int n; +#endif + unit *p; + char buf[256]; + long x; + if(a->infile!=NULL) + { byfile=1; + g_char(a->infile,a->infilen,buf); +#ifdef NON_UNIX_STDIO + x = access(buf,0) ? -1 : 0; + for(i=0,p=NULL;iinunitinunit>=0) + { + p= &f__units[a->inunit]; + } + else + { + p=NULL; + } + } + if(a->inex!=NULL) + if(byfile && x != -1 || !byfile && p!=NULL) + *a->inex=1; + else *a->inex=0; + if(a->inopen!=NULL) + if(byfile) *a->inopen=(p!=NULL); + else *a->inopen=(p!=NULL && p->ufd!=NULL); + if(a->innum!=NULL) *a->innum= p-f__units; + if(a->innamed!=NULL) + if(byfile || p!=NULL && p->ufnm!=NULL) + *a->innamed=1; + else *a->innamed=0; + if(a->inname!=NULL) + if(byfile) + b_char(buf,a->inname,a->innamlen); + else if(p!=NULL && p->ufnm!=NULL) + b_char(p->ufnm,a->inname,a->innamlen); + if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) + if(p->url) + b_char("DIRECT",a->inacc,a->inacclen); + else b_char("SEQUENTIAL",a->inacc,a->inacclen); + if(a->inseq!=NULL) + if(p!=NULL && p->url) + b_char("NO",a->inseq,a->inseqlen); + else b_char("YES",a->inseq,a->inseqlen); + if(a->indir!=NULL) + if(p==NULL || p->url) + b_char("YES",a->indir,a->indirlen); + else b_char("NO",a->indir,a->indirlen); + if(a->infmt!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("UNFORMATTED",a->infmt,a->infmtlen); + else b_char("FORMATTED",a->infmt,a->infmtlen); + if(a->inform!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("NO",a->inform,a->informlen); + else b_char("YES",a->inform,a->informlen); + if(a->inunf) + if(p!=NULL && p->ufmt==0) + b_char("YES",a->inunf,a->inunflen); + else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); + else b_char("UNKNOWN",a->inunf,a->inunflen); + if(a->inrecl!=NULL && p!=NULL) + *a->inrecl=p->url; + if(a->innrec!=NULL && p!=NULL && p->url>0) + *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1); + if(a->inblank && p!=NULL && p->ufmt) + if(p->ublnk) + b_char("ZERO",a->inblank,a->inblanklen); + else b_char("NULL",a->inblank,a->inblanklen); + return(0); +} diff --git a/unix/f2c/libf2c/l_ge.c b/unix/f2c/libf2c/l_ge.c new file mode 100644 index 00000000..a84f0ee4 --- /dev/null +++ b/unix/f2c/libf2c/l_ge.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/l_gt.c b/unix/f2c/libf2c/l_gt.c new file mode 100644 index 00000000..ae6950d1 --- /dev/null +++ b/unix/f2c/libf2c/l_gt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/l_le.c b/unix/f2c/libf2c/l_le.c new file mode 100644 index 00000000..625b49a9 --- /dev/null +++ b/unix/f2c/libf2c/l_le.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/l_lt.c b/unix/f2c/libf2c/l_lt.c new file mode 100644 index 00000000..ab21b362 --- /dev/null +++ b/unix/f2c/libf2c/l_lt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/lbitbits.c b/unix/f2c/libf2c/lbitbits.c new file mode 100644 index 00000000..5b6ccf72 --- /dev/null +++ b/unix/f2c/libf2c/lbitbits.c @@ -0,0 +1,68 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + + integer +#ifdef KR_headers +lbit_bits(a, b, len) integer a, b, len; +#else +lbit_bits(integer a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + unsigned long x, y; + + x = (unsigned long) a; + y = (unsigned long)-1L; + x >>= b; + y <<= len; + return (integer)(x & ~y); + } + + integer +#ifdef KR_headers +lbit_cshift(a, b, len) integer a, b, len; +#else +lbit_cshift(integer a, integer b, integer len) +#endif +{ + unsigned long x, y, z; + + x = (unsigned long)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONGBITS) { + full_len: + if (b >= 0) { + b %= LONGBITS; + return (integer)(x << b | x >> LONGBITS -b ); + } + b = -b; + b %= LONGBITS; + return (integer)(x << LONGBITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (integer)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (integer)(y | z & (x >> b | x << len - b)); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/lbitshft.c b/unix/f2c/libf2c/lbitshft.c new file mode 100644 index 00000000..fbee94f1 --- /dev/null +++ b/unix/f2c/libf2c/lbitshft.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + integer +#ifdef KR_headers +lbit_shift(a, b) integer a; integer b; +#else +lbit_shift(integer a, integer b) +#endif +{ + return b >= 0 ? a << b : (integer)((uinteger)a >> -b); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/libf2c.lbc b/unix/f2c/libf2c/libf2c.lbc new file mode 100644 index 00000000..c51c0aab --- /dev/null +++ b/unix/f2c/libf2c/libf2c.lbc @@ -0,0 +1,153 @@ +abort_.obj +backspac.obj +c_abs.obj +c_cos.obj +c_div.obj +c_exp.obj +c_log.obj +c_sin.obj +c_sqrt.obj +cabs.obj +close.obj +d_abs.obj +d_acos.obj +d_asin.obj +d_atan.obj +d_atn2.obj +d_cnjg.obj +d_cos.obj +d_cosh.obj +d_dim.obj +d_exp.obj +d_imag.obj +d_int.obj +d_lg10.obj +d_log.obj +d_mod.obj +d_nint.obj +d_prod.obj +d_sign.obj +d_sin.obj +d_sinh.obj +d_sqrt.obj +d_tan.obj +d_tanh.obj +derf_.obj +derfc_.obj +dfe.obj +dolio.obj +dtime_.obj +due.obj +ef1asc_.obj +ef1cmc_.obj +endfile.obj +erf_.obj +erfc_.obj +err.obj +etime_.obj +exit_.obj +f77_aloc.obj +f77vers.obj +fmt.obj +fmtlib.obj +ftell_.obj +getarg_.obj +getenv_.obj +h_abs.obj +h_dim.obj +h_dnnt.obj +h_indx.obj +h_len.obj +h_mod.obj +h_nint.obj +h_sign.obj +hl_ge.obj +hl_gt.obj +hl_le.obj +hl_lt.obj +i77vers.obj +i_abs.obj +i_dim.obj +i_dnnt.obj +i_indx.obj +i_len.obj +i_mod.obj +i_nint.obj +i_sign.obj +iargc_.obj +iio.obj +ilnw.obj +inquire.obj +l_ge.obj +l_gt.obj +l_le.obj +l_lt.obj +lbitbits.obj +lbitshft.obj +lread.obj +lwrite.obj +main.obj +open.obj +pow_ci.obj +pow_dd.obj +pow_di.obj +pow_hh.obj +pow_ii.obj +pow_ri.obj +pow_zi.obj +pow_zz.obj +r_abs.obj +r_acos.obj +r_asin.obj +r_atan.obj +r_atn2.obj +r_cnjg.obj +r_cos.obj +r_cosh.obj +r_dim.obj +r_exp.obj +r_imag.obj +r_int.obj +r_lg10.obj +r_log.obj +r_mod.obj +r_nint.obj +r_sign.obj +r_sin.obj +r_sinh.obj +r_sqrt.obj +r_tan.obj +r_tanh.obj +rdfmt.obj +rewind.obj +rsfe.obj +rsli.obj +rsne.obj +s_cat.obj +s_cmp.obj +s_copy.obj +s_paus.obj +s_rnge.obj +s_stop.obj +sfe.obj +sig_die.obj +signal_.obj +sue.obj +system_.obj +typesize.obj +uio.obj +uninit.obj +util.obj +wref.obj +wrtfmt.obj +wsfe.obj +wsle.obj +wsne.obj +xwsne.obj +z_abs.obj +z_cos.obj +z_div.obj +z_exp.obj +z_log.obj +z_sin.obj +z_sqrt.obj diff --git a/unix/f2c/libf2c/libf2c.sy b/unix/f2c/libf2c/libf2c.sy new file mode 100644 index 00000000..bcba643b --- /dev/null +++ b/unix/f2c/libf2c/libf2c.sy @@ -0,0 +1,153 @@ ++abort_.obj & ++backspac.obj & ++c_abs.obj & ++c_cos.obj & ++c_div.obj & ++c_exp.obj & ++c_log.obj & ++c_sin.obj & ++c_sqrt.obj & ++cabs.obj & ++close.obj & ++d_abs.obj & ++d_acos.obj & ++d_asin.obj & ++d_atan.obj & ++d_atn2.obj & ++d_cnjg.obj & ++d_cos.obj & ++d_cosh.obj & ++d_dim.obj & ++d_exp.obj & ++d_imag.obj & ++d_int.obj & ++d_lg10.obj & ++d_log.obj & ++d_mod.obj & ++d_nint.obj & ++d_prod.obj & ++d_sign.obj & ++d_sin.obj & ++d_sinh.obj & ++d_sqrt.obj & ++d_tan.obj & ++d_tanh.obj & ++derf_.obj & ++derfc_.obj & ++dfe.obj & ++dolio.obj & ++dtime_.obj & ++due.obj & ++ef1asc_.obj & ++ef1cmc_.obj & ++endfile.obj & ++erf_.obj & ++erfc_.obj & ++err.obj & ++etime_.obj & ++exit_.obj & ++f77_aloc.obj & ++f77vers.obj & ++fmt.obj & ++fmtlib.obj & ++ftell_.obj & ++getarg_.obj & ++getenv_.obj & ++h_abs.obj & ++h_dim.obj & ++h_dnnt.obj & ++h_indx.obj & ++h_len.obj & ++h_mod.obj & ++h_nint.obj & ++h_sign.obj & ++hl_ge.obj & ++hl_gt.obj & ++hl_le.obj & ++hl_lt.obj & ++i77vers.obj & ++i_abs.obj & ++i_dim.obj & ++i_dnnt.obj & ++i_indx.obj & ++i_len.obj & ++i_mod.obj & ++i_nint.obj & ++i_sign.obj & ++iargc_.obj & ++iio.obj & ++ilnw.obj & ++inquire.obj & ++l_ge.obj & ++l_gt.obj & ++l_le.obj & ++l_lt.obj & ++lbitbits.obj & ++lbitshft.obj & ++lread.obj & ++lwrite.obj & ++main.obj & ++open.obj & ++pow_ci.obj & ++pow_dd.obj & ++pow_di.obj & ++pow_hh.obj & ++pow_ii.obj & ++pow_ri.obj & ++pow_zi.obj & ++pow_zz.obj & ++r_abs.obj & ++r_acos.obj & ++r_asin.obj & ++r_atan.obj & ++r_atn2.obj & ++r_cnjg.obj & ++r_cos.obj & ++r_cosh.obj & ++r_dim.obj & ++r_exp.obj & ++r_imag.obj & ++r_int.obj & ++r_lg10.obj & ++r_log.obj & ++r_mod.obj & ++r_nint.obj & ++r_sign.obj & ++r_sin.obj & ++r_sinh.obj & ++r_sqrt.obj & ++r_tan.obj & ++r_tanh.obj & ++rdfmt.obj & ++rewind.obj & ++rsfe.obj & ++rsli.obj & ++rsne.obj & ++s_cat.obj & ++s_cmp.obj & ++s_copy.obj & ++s_paus.obj & ++s_rnge.obj & ++s_stop.obj & ++sfe.obj & ++sig_die.obj & ++signal_.obj & ++sue.obj & ++system_.obj & ++typesize.obj & ++uio.obj & ++uninit.obj & ++util.obj & ++wref.obj & ++wrtfmt.obj & ++wsfe.obj & ++wsle.obj & ++wsne.obj & ++xwsne.obj & ++z_abs.obj & ++z_cos.obj & ++z_div.obj & ++z_exp.obj & ++z_log.obj & ++z_sin.obj & ++z_sqrt.obj diff --git a/unix/f2c/libf2c/lio.h b/unix/f2c/libf2c/lio.h new file mode 100644 index 00000000..f9fd1cda --- /dev/null +++ b/unix/f2c/libf2c/lio.h @@ -0,0 +1,74 @@ +/* copy of ftypes from the compiler */ +/* variable types + * numeric assumptions: + * int < reals < complexes + * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX + */ + +/* 0-10 retain their old (pre LOGICAL*1, etc.) */ +/* values to allow mixing old and new objects. */ + +#define TYUNKNOWN 0 +#define TYADDR 1 +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYLOGICAL 8 +#define TYCHAR 9 +#define TYSUBR 10 +#define TYINT1 11 +#define TYLOGICAL1 12 +#define TYLOGICAL2 13 +#ifdef Allow_TYQUAD +#undef TYQUAD +#define TYQUAD 14 +#endif + +#define LINTW 24 +#define LINE 80 +#define LLOGW 2 +#ifdef Old_list_output +#define LLOW 1.0 +#define LHIGH 1.e9 +#define LEFMT " %# .8E" +#define LFFMT " %# .9g" +#else +#define LGFMT "%.9G" +#endif +/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ +#define LEFBL 24 + +typedef union +{ + char flchar; + short flshort; + ftnint flint; +#ifdef Allow_TYQUAD + longint fllongint; +#endif + real flreal; + doublereal fldouble; +} flex; +#ifdef KR_headers +extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +extern int l_read(), l_write(); +#else +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +extern int l_write(ftnint*, char*, ftnlen, ftnint); +extern void x_wsne(cilist*); +extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); +extern int l_read(ftnint*,char*,ftnlen,ftnint); +extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); +extern int z_rnew(void); +#endif +extern ftnint L_len; +extern int f__scale; +#ifdef __cplusplus + } +#endif diff --git a/unix/f2c/libf2c/lread.c b/unix/f2c/libf2c/lread.c new file mode 100644 index 00000000..699cda16 --- /dev/null +++ b/unix/f2c/libf2c/lread.c @@ -0,0 +1,806 @@ +#include "f2c.h" +#include "fio.h" + +/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ +/* marks in namelist input a la the Fortran 8X Draft published in */ +/* the May 1989 issue of Fortran Forum. */ + + +#ifdef Allow_TYQUAD +static longint f__llx; +#endif + +#ifdef KR_headers +extern double atof(); +extern char *malloc(), *realloc(); +int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif + +#include "fmt.h" +#include "lio.h" +#include "ctype.h" +#include "fp.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern char *f__fmtbuf; +#else +extern const char *f__fmtbuf; +int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), + (*l_ungetc)(int,FILE*); +#endif + +int l_eof; + +#define isblnk(x) (f__ltab[x+1]&B) +#define issep(x) (f__ltab[x+1]&SX) +#define isapos(x) (f__ltab[x+1]&AX) +#define isexp(x) (f__ltab[x+1]&EX) +#define issign(x) (f__ltab[x+1]&SG) +#define iswhit(x) (f__ltab[x+1]&WH) +#define SX 1 +#define B 2 +#define AX 4 +#define EX 8 +#define SG 16 +#define WH 32 +char f__ltab[128+1] = { /* offset one for EOF */ + 0, + 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,EX,EX,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, + AX,0,0,0,EX,EX,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 +}; + +#ifdef ungetc + static int +#ifdef KR_headers +un_getc(x,f__cf) int x; FILE *f__cf; +#else +un_getc(int x, FILE *f__cf) +#endif +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +#ifdef KR_headers + extern int ungetc(); +#else +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + + int +t_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + if((ch=getc(f__cf))!=EOF) return(ch); + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return(EOF); +} +integer e_rsle(Void) +{ + int ch; + if(f__curunit->uend) return(0); + while((ch=t_getc())!='\n') + if (ch == EOF) { + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return EOF; + } + return(0); +} + +flag f__lquit; +int f__lcount,f__ltype,nml_read; +char *f__lchar; +double f__lx,f__ly; +#define ERR(x) if(n=(x)) return(n) +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +#ifdef KR_headers +l_R(poststar, reqint) int poststar, reqint; +#else +l_R(int poststar, int reqint) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + long e, exp; + int havenum, havestar, se; + + if (!poststar) { + if (f__lcount > 0) + return(0); + f__lcount = 1; + } +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + f__ltype = 0; + exp = 0; + havestar = 0; +retry: + sp1 = sp = s; + spe = sp + FMAX; + havenum = 0; + + switch(GETC(ch)) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + GETC(ch); + } + while(ch == '0') { + ++havenum; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) *sp++ = ch; + else ++exp; + GETC(ch); + } + if (ch == '*' && !poststar) { + if (sp == sp1 || exp || *s == '-') { + errfl(f__elist->cierr,112,"bad repetition count"); + } + poststar = havestar = 1; + *sp = 0; + f__lcount = atoi(s); + goto retry; + } + if (ch == '.') { +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + if (reqint) + errfl(f__elist->cierr,115,"invalid integer"); +#endif + GETC(ch); + if (sp == sp1) + while(ch == '0') { + ++havenum; + --exp; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) + { *sp++ = ch; --exp; } + GETC(ch); + } + } + havenum += sp - sp1; + se = 0; + if (issign(ch)) + goto signonly; + if (havenum && isexp(ch)) { +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + if (reqint) + errfl(f__elist->cierr,115,"invalid integer"); +#endif + GETC(ch); + if (issign(ch)) { +signonly: + if (ch == '-') se = 1; + GETC(ch); + } + if (!isdigit(ch)) { +bad: + errfl(f__elist->cierr,112,"exponent field"); + } + + e = ch - '0'; + while(isdigit(GETC(ch))) { + e = 10*e + ch - '0'; + if (e > EXPMAX) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + } + (void) Ungetc(ch, f__cf); + if (sp > sp1) { + ++havenum; + while(*--sp == '0') + ++exp; + if (exp) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + f__lx = atof(s); +#ifdef Allow_TYQUAD + if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { + /* Assuming 64-bit longint and 32-bit long. */ + if (exp < 0) + sp += exp; + if (sp1 <= sp) { + f__llx = *sp1 - '0'; + while(++sp1 <= sp) + f__llx = 10*f__llx + (*sp1 - '0'); + } + while(--exp >= 0) + f__llx *= 10; + if (*s == '-') + f__llx = -f__llx; + } +#endif + } + else + f__lx = 0.; + if (havenum) + f__ltype = TYLONG; + else + switch(ch) { + case ',': + case '/': + break; + default: + if (havestar && ( ch == ' ' + ||ch == '\t' + ||ch == '\n')) + break; + if (nml_read > 1) { + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"invalid number"); + } + return 0; + } + + static int +#ifdef KR_headers +rd_count(ch) register int ch; +#else +rd_count(register int ch) +#endif +{ + if (ch < '0' || ch > '9') + return 1; + f__lcount = ch - '0'; + while(GETC(ch) >= '0' && ch <= '9') + f__lcount = 10*f__lcount + ch - '0'; + Ungetc(ch,f__cf); + return f__lcount <= 0; + } + + static int +l_C(Void) +{ int ch, nml_save; + double lz; + if(f__lcount>0) return(0); + f__ltype=0; + GETC(ch); + if(ch!='(') + { + if (nml_read > 1 && (ch < '0' || ch > '9')) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + if (rd_count(ch)) + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"complex format"); + else + err(f__elist->cierr,(EOF),"lread"); + if(GETC(ch)!='*') + { + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + } + if(GETC(ch)!='(') + { Ungetc(ch,f__cf); + return(0); + } + } + else + f__lcount = 1; + while(iswhit(GETC(ch))); + Ungetc(ch,f__cf); + nml_save = nml_read; + nml_read = 0; + if (ch = l_R(1,0)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no real part"); + lz = f__lx; + while(iswhit(GETC(ch))); + if(ch!=',') + { (void) Ungetc(ch,f__cf); + errfl(f__elist->cierr,112,"no comma"); + } + while(iswhit(GETC(ch))); + (void) Ungetc(ch,f__cf); + if (ch = l_R(1,0)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no imaginary part"); + while(iswhit(GETC(ch))); + if(ch!=')') errfl(f__elist->cierr,112,"no )"); + f__ly = f__lx; + f__lx = lz; +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + nml_read = nml_save; + return(0); +} + + static char nmLbuf[256], *nmL_next; + static int (*nmL_getc_save)(Void); +#ifdef KR_headers + static int (*nmL_ungetc_save)(/* int, FILE* */); +#else + static int (*nmL_ungetc_save)(int, FILE*); +#endif + + static int +nmL_getc(Void) +{ + int rv; + if (rv = *nmL_next++) + return rv; + l_getc = nmL_getc_save; + l_ungetc = nmL_ungetc_save; + return (*l_getc)(); + } + + static int +#ifdef KR_headers +nmL_ungetc(x, f) int x; FILE *f; +#else +nmL_ungetc(int x, FILE *f) +#endif +{ + f = f; /* banish non-use warning */ + return *--nmL_next = x; + } + + static int +#ifdef KR_headers +Lfinish(ch, dot, rvp) int ch, dot, *rvp; +#else +Lfinish(int ch, int dot, int *rvp) +#endif +{ + char *s, *se; + static char what[] = "namelist input"; + + s = nmLbuf + 2; + se = nmLbuf + sizeof(nmLbuf) - 1; + *s++ = ch; + while(!issep(GETC(ch)) && ch!=EOF) { + if (s >= se) { + nmLbuf_ovfl: + return *rvp = err__fl(f__elist->cierr,131,what); + } + *s++ = ch; + if (ch != '=') + continue; + if (dot) + return *rvp = err__fl(f__elist->cierr,112,what); + got_eq: + *s = 0; + nmL_getc_save = l_getc; + l_getc = nmL_getc; + nmL_ungetc_save = l_ungetc; + l_ungetc = nmL_ungetc; + nmLbuf[1] = *(nmL_next = nmLbuf) = ','; + *rvp = f__lcount = 0; + return 1; + } + if (dot) + goto done; + for(;;) { + if (s >= se) + goto nmLbuf_ovfl; + *s++ = ch; + if (!isblnk(ch)) + break; + if (GETC(ch) == EOF) + goto done; + } + if (ch == '=') + goto got_eq; + done: + Ungetc(ch, f__cf); + return 0; + } + + static int +l_L(Void) +{ + int ch, rv, sawdot; + + if(f__lcount>0) + return(0); + f__lcount = 1; + f__ltype=0; + GETC(ch); + if(isdigit(ch)) + { + rd_count(ch); + if(GETC(ch)!='*') + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + GETC(ch); + } + sawdot = 0; + if(ch == '.') { + sawdot = 1; + GETC(ch); + } + switch(ch) + { + case 't': + case 'T': + if (nml_read && Lfinish(ch, sawdot, &rv)) + return rv; + f__lx=1; + break; + case 'f': + case 'F': + if (nml_read && Lfinish(ch, sawdot, &rv)) + return rv; + f__lx=0; + break; + default: + if(isblnk(ch) || issep(ch) || ch==EOF) + { (void) Ungetc(ch,f__cf); + return(0); + } + if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"logical"); + } + f__ltype=TYLONG; + while(!issep(GETC(ch)) && ch!=EOF); + Ungetc(ch, f__cf); + return(0); +} + +#define BUFSIZE 128 + + static int +l_CHAR(Void) +{ int ch,size,i; + static char rafail[] = "realloc failure"; + char quote,*p; + if(f__lcount>0) return(0); + f__ltype=0; + if(f__lchar!=NULL) free(f__lchar); + size=BUFSIZE; + p=f__lchar = (char *)malloc((unsigned int)size); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,"no space"); + + GETC(ch); + if(isdigit(ch)) { + /* allow Fortran 8x-style unquoted string... */ + /* either find a repetition count or the string */ + f__lcount = ch - '0'; + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case '*': + if (f__lcount == 0) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) + goto no_quote; +#endif + goto noquote; + } + p = f__lchar; + goto have_lcount; + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__lcount = 1; + f__ltype = TYCHAR; + return *p = 0; + } + if (!isdigit(ch)) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) { + no_quote: + errfl(f__elist->cierr,112, + "undelimited character string"); + } +#endif + goto noquote; + } + *p++ = ch; + f__lcount = 10*f__lcount + ch - '0'; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + else (void) Ungetc(ch,f__cf); + have_lcount: + if(GETC(ch)=='\'' || ch=='"') quote=ch; + else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { + Ungetc(ch,f__cf); + return 0; + } +#ifndef F8X_NML_ELIDE_QUOTES + else if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } +#endif + else { + /* Fortran 8x-style unquoted string */ + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__ltype = TYCHAR; + return *p = 0; + } + noquote: + *p++ = ch; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + f__ltype=TYCHAR; + for(i=0;;) + { while(GETC(ch)!=quote && ch!='\n' + && ch!=EOF && ++icierr,113,rafail); + p=f__lchar+i-1; + *p++ = ch; + } + else if(ch==EOF) return(EOF); + else if(ch=='\n') + { if(*(p-1) != '\\') continue; + i--; + p--; + if(++iciunit]; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"stler"); + f__scale=f__recpos=0; + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) + err(a->cierr,102,"lio"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,103,"lio") + return(0); +} + + int +#ifdef KR_headers +l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i,n,ch; + doublereal *yy; + real *xx; + for(i=0;i<*number;i++) + { + if(f__lquit) return(0); + if(l_eof) + err(f__elist->ciend, EOF, "list in") + if(f__lcount == 0) { + f__ltype = 0; + for(;;) { + GETC(ch); + switch(ch) { + case EOF: + err(f__elist->ciend,(EOF),"list in") + case ' ': + case '\t': + case '\n': + continue; + case '/': + f__lquit = 1; + goto loopend; + case ',': + f__lcount = 1; + goto loopend; + default: + (void) Ungetc(ch, f__cf); + goto rddata; + } + } + } + rddata: + switch((int)type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + ERR(l_R(0,1)); + break; +#endif + case TYREAL: + case TYDREAL: + ERR(l_R(0,0)); + break; +#ifdef TYQUAD + case TYQUAD: + n = l_R(0,2); + if (n) + return n; + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + ERR(l_C()); + break; + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + ERR(l_L()); + break; + case TYCHAR: + ERR(l_CHAR()); + break; + } + while (GETC(ch) == ' ' || ch == '\t'); + if (ch != ',' || f__lcount > 1) + Ungetc(ch,f__cf); + loopend: + if(f__lquit) return(0); + if(f__cf && ferror(f__cf)) { + clearerr(f__cf); + errfl(f__elist->cierr,errno,"list in"); + } + if(f__ltype==0) goto bump; + switch((int)type) + { + case TYINT1: + case TYLOGICAL1: + Ptr->flchar = (char)f__lx; + break; + case TYLOGICAL2: + case TYSHORT: + Ptr->flshort = (short)f__lx; + break; + case TYLOGICAL: + case TYLONG: + Ptr->flint = (ftnint)f__lx; + break; +#ifdef Allow_TYQUAD + case TYQUAD: + if (!(Ptr->fllongint = f__llx)) + Ptr->fllongint = f__lx; + break; +#endif + case TYREAL: + Ptr->flreal=f__lx; + break; + case TYDREAL: + Ptr->fldouble=f__lx; + break; + case TYCOMPLEX: + xx=(real *)ptr; + *xx++ = f__lx; + *xx = f__ly; + break; + case TYDCOMPLEX: + yy=(doublereal *)ptr; + *yy++ = f__lx; + *yy = f__ly; + break; + case TYCHAR: + b_char(f__lchar,ptr,len); + break; + } + bump: + if(f__lcount>0) f__lcount--; + ptr += len; + if (nml_read) + nml_read++; + } + return(0); +#undef Ptr +} +#ifdef KR_headers +integer s_rsle(a) cilist *a; +#else +integer s_rsle(cilist *a) +#endif +{ + int n; + + f__reading=1; + f__external=1; + f__formatted=1; + if(n=c_le(a)) return(n); + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + l_eof = 0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/lwrite.c b/unix/f2c/libf2c/lwrite.c new file mode 100644 index 00000000..9e0d93de --- /dev/null +++ b/unix/f2c/libf2c/lwrite.c @@ -0,0 +1,314 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif + +ftnint L_len; +int f__Aquote; + + static VOID +donewrec(Void) +{ + if (f__recpos) + (*f__donewrec)(); + } + + static VOID +#ifdef KR_headers +lwrt_I(n) longint n; +#else +lwrt_I(longint n) +#endif +{ + char *p; + int ndigit, sign; + + p = f__icvt(n, &ndigit, &sign, 10); + if(f__recpos + ndigit >= L_len) + donewrec(); + PUT(' '); + if (sign) + PUT('-'); + while(*p) + PUT(*p++); +} + static VOID +#ifdef KR_headers +lwrt_L(n, len) ftnint n; ftnlen len; +#else +lwrt_L(ftnint n, ftnlen len) +#endif +{ + if(f__recpos+LLOGW>=L_len) + donewrec(); + wrt_L((Uint *)&n,LLOGW, len); +} + static VOID +#ifdef KR_headers +lwrt_A(p,len) char *p; ftnlen len; +#else +lwrt_A(char *p, ftnlen len) +#endif +{ + int a; + char *p1, *pe; + + a = 0; + pe = p + len; + if (f__Aquote) { + a = 3; + if (len > 1 && p[len-1] == ' ') { + while(--len > 1 && p[len-1] == ' '); + pe = p + len; + } + p1 = p; + while(p1 < pe) + if (*p1++ == '\'') + a++; + } + if(f__recpos+len+a >= L_len) + donewrec(); + if (a +#ifndef OMIT_BLANK_CC + || !f__recpos +#endif + ) + PUT(' '); + if (a) { + PUT('\''); + while(p < pe) { + if (*p == '\'') + PUT('\''); + PUT(*p++); + } + PUT('\''); + } + else + while(p < pe) + PUT(*p++); +} + + static int +#ifdef KR_headers +l_g(buf, n) char *buf; double n; +#else +l_g(char *buf, double n) +#endif +{ +#ifdef Old_list_output + doublereal absn; + char *fmt; + + absn = n; + if (absn < 0) + absn = -absn; + fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; +#ifdef USE_STRLEN + sprintf(buf, fmt, n); + return strlen(buf); +#else + return sprintf(buf, fmt, n); +#endif + +#else + register char *b, c, c1; + + b = buf; + *b++ = ' '; + if (n < 0) { + *b++ = '-'; + n = -n; + } + else + *b++ = ' '; + if (n == 0) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&n)) + *b++ = '-'; +#endif + *b++ = '0'; + *b++ = '.'; + *b = 0; + goto f__ret; + } + sprintf(b, LGFMT, n); + switch(*b) { +#ifndef WANT_LEAD_0 + case '0': + while(b[0] = b[1]) + b++; + break; +#endif + case 'i': + case 'I': + /* Infinity */ + case 'n': + case 'N': + /* NaN */ + while(*++b); + break; + + default: + /* Fortran 77 insists on having a decimal point... */ + for(;; b++) + switch(*b) { + case 0: + *b++ = '.'; + *b = 0; + goto f__ret; + case '.': + while(*++b); + goto f__ret; + case 'E': + for(c1 = '.', c = 'E'; *b = c1; + c1 = c, c = *++b); + goto f__ret; + } + } + f__ret: + return b - buf; +#endif + } + + static VOID +#ifdef KR_headers +l_put(s) register char *s; +#else +l_put(register char *s) +#endif +{ +#ifdef KR_headers + register void (*pn)() = f__putn; +#else + register void (*pn)(int) = f__putn; +#endif + register int c; + + while(c = *s++) + (*pn)(c); + } + + static VOID +#ifdef KR_headers +lwrt_F(n) double n; +#else +lwrt_F(double n) +#endif +{ + char buf[LEFBL]; + + if(f__recpos + l_g(buf,n) >= L_len) + donewrec(); + l_put(buf); +} + static VOID +#ifdef KR_headers +lwrt_C(a,b) double a,b; +#else +lwrt_C(double a, double b) +#endif +{ + char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; + int al, bl; + + al = l_g(bufa, a); + for(ba = bufa; *ba == ' '; ba++) + --al; + bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ + for(bb = bufb; *bb == ' '; bb++) + --bl; + if(f__recpos + al + bl + 3 >= L_len) + donewrec(); +#ifdef OMIT_BLANK_CC + else +#endif + PUT(' '); + PUT('('); + l_put(ba); + PUT(','); + if (f__recpos + bl >= L_len) { + (*f__donewrec)(); +#ifndef OMIT_BLANK_CC + PUT(' '); +#endif + } + l_put(bb); + PUT(')'); +} + + int +#ifdef KR_headers +l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i; + longint x; + double y,z; + real *xx; + doublereal *yy; + for(i=0;i< *number; i++) + { + switch((int)type) + { + default: f__fatal(117,"unknown type in lio"); + case TYINT1: + x = Ptr->flchar; + goto xint; + case TYSHORT: + x=Ptr->flshort; + goto xint; +#ifdef Allow_TYQUAD + case TYQUAD: + x = Ptr->fllongint; + goto xint; +#endif + case TYLONG: + x=Ptr->flint; + xint: lwrt_I(x); + break; + case TYREAL: + y=Ptr->flreal; + goto xfloat; + case TYDREAL: + y=Ptr->fldouble; + xfloat: lwrt_F(y); + break; + case TYCOMPLEX: + xx= &Ptr->flreal; + y = *xx++; + z = *xx; + goto xcomplex; + case TYDCOMPLEX: + yy = &Ptr->fldouble; + y= *yy++; + z = *yy; + xcomplex: + lwrt_C(y,z); + break; + case TYLOGICAL1: + x = Ptr->flchar; + goto xlog; + case TYLOGICAL2: + x = Ptr->flshort; + goto xlog; + case TYLOGICAL: + x = Ptr->flint; + xlog: lwrt_L(Ptr->flint, len); + break; + case TYCHAR: + lwrt_A(ptr,len); + break; + } + ptr += len; + } + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/main.c b/unix/f2c/libf2c/main.c new file mode 100644 index 00000000..d95fdc92 --- /dev/null +++ b/unix/f2c/libf2c/main.c @@ -0,0 +1,148 @@ +/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ + +#include "stdio.h" +#include "signal1.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifndef KR_headers +#undef VOID +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#ifndef VOID +#define VOID void +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef NO__STDC +#define ONEXIT onexit +extern VOID f_exit(); +#else +#ifndef KR_headers +extern void f_exit(void); +#ifndef NO_ONEXIT +#define ONEXIT atexit +extern int atexit(void (*)(void)); +#endif +#else +#ifndef NO_ONEXIT +#define ONEXIT onexit +extern VOID f_exit(); +#endif +#endif +#endif + +#ifdef KR_headers +extern VOID f_init(), sig_die(); +extern int MAIN__(); +#define Int /* int */ +#else +extern void f_init(void), sig_die(const char*, int); +extern int MAIN__(void); +#define Int int +#endif + +static VOID sigfdie(Sigarg) +{ +Use_Sigarg; +sig_die("Floating Exception", 1); +} + + +static VOID sigidie(Sigarg) +{ +Use_Sigarg; +sig_die("IOT Trap", 1); +} + +#ifdef SIGQUIT +static VOID sigqdie(Sigarg) +{ +Use_Sigarg; +sig_die("Quit signal", 1); +} +#endif + + +static VOID sigindie(Sigarg) +{ +Use_Sigarg; +sig_die("Interrupt", 0); +} + +static VOID sigtdie(Sigarg) +{ +Use_Sigarg; +sig_die("Killed", 0); +} + +#ifdef SIGTRAP +static VOID sigtrdie(Sigarg) +{ +Use_Sigarg; +sig_die("Trace trap", 1); +} +#endif + + +int xargc; +char **xargv; + +#ifdef __cplusplus + } +#endif + + int +#ifdef KR_headers +main(argc, argv) int argc; char **argv; +#else +main(int argc, char **argv) +#endif +{ +xargc = argc; +xargv = argv; +signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ +#ifdef SIGIOT +signal1(SIGIOT, sigidie); +#endif +#ifdef SIGTRAP +signal1(SIGTRAP, sigtrdie); +#endif +#ifdef SIGQUIT +if(signal1(SIGQUIT,sigqdie) == SIG_IGN) + signal1(SIGQUIT, SIG_IGN); +#endif +if(signal1(SIGINT, sigindie) == SIG_IGN) + signal1(SIGINT, SIG_IGN); +signal1(SIGTERM,sigtdie); + +#ifdef pdp11 + ldfps(01200); /* detect overflow as an exception */ +#endif + +f_init(); +#ifndef NO_ONEXIT +ONEXIT(f_exit); +#endif +MAIN__(); +#ifdef NO_ONEXIT +f_exit(); +#endif +exit(0); /* exit(0) rather than return(0) to bypass Cray bug */ +return 0; /* For compilers that complain of missing return values; */ + /* others will complain that this is unreachable code. */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/makefile.sy b/unix/f2c/libf2c/makefile.sy new file mode 100644 index 00000000..0e009eff --- /dev/null +++ b/unix/f2c/libf2c/makefile.sy @@ -0,0 +1,190 @@ +# For making f2c.lib (here called syf2c.lib) with Symantec C++ . +# Invoke with "make -f makefile.sy" . +# In the CFLAGS line below, "-mn" is for NT and W9x. +# For 32-bit addressing with MSDOS, change "-mn" to "-mx". +# With Symantec, it is necessary to explicitly load main.obj . + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj +# to the objects in the "w =" list below. + +CC = sc +CFLAGS = -DMSDOS -D_POSIX_SOURCE -DNO_ONEXIT -s -mn -DUSE_CLOCK -DNO_My_ctype + +.c.obj: + $(CC) -c $(CFLAGS) $*.c + +w = \ + abort_.obj \ + backspac.obj \ + c_abs.obj \ + c_cos.obj \ + c_div.obj \ + c_exp.obj \ + c_log.obj \ + c_sin.obj \ + c_sqrt.obj \ + cabs.obj \ + close.obj \ + d_abs.obj \ + d_acos.obj \ + d_asin.obj \ + d_atan.obj \ + d_atn2.obj \ + d_cnjg.obj \ + d_cos.obj \ + d_cosh.obj \ + d_dim.obj \ + d_exp.obj \ + d_imag.obj \ + d_int.obj \ + d_lg10.obj \ + d_log.obj \ + d_mod.obj \ + d_nint.obj \ + d_prod.obj \ + d_sign.obj \ + d_sin.obj \ + d_sinh.obj \ + d_sqrt.obj \ + d_tan.obj \ + d_tanh.obj \ + derf_.obj \ + derfc_.obj \ + dfe.obj \ + dolio.obj \ + dtime_.obj \ + due.obj \ + ef1asc_.obj \ + ef1cmc_.obj \ + endfile.obj \ + erf_.obj \ + erfc_.obj \ + err.obj \ + etime_.obj \ + exit_.obj \ + f77_aloc.obj \ + f77vers.obj \ + fmt.obj \ + fmtlib.obj \ + ftell_.obj \ + getarg_.obj \ + getenv_.obj \ + h_abs.obj \ + h_dim.obj \ + h_dnnt.obj \ + h_indx.obj \ + h_len.obj \ + h_mod.obj \ + h_nint.obj \ + h_sign.obj \ + hl_ge.obj \ + hl_gt.obj \ + hl_le.obj \ + hl_lt.obj \ + i77vers.obj \ + i_abs.obj \ + i_dim.obj \ + i_dnnt.obj \ + i_indx.obj \ + i_len.obj \ + i_mod.obj \ + i_nint.obj \ + i_sign.obj \ + iargc_.obj \ + iio.obj \ + ilnw.obj \ + inquire.obj \ + l_ge.obj \ + l_gt.obj \ + l_le.obj \ + l_lt.obj \ + lbitbits.obj \ + lbitshft.obj \ + lread.obj \ + lwrite.obj \ + main.obj \ + open.obj \ + pow_ci.obj \ + pow_dd.obj \ + pow_di.obj \ + pow_hh.obj \ + pow_ii.obj \ + pow_ri.obj \ + pow_zi.obj \ + pow_zz.obj \ + r_abs.obj \ + r_acos.obj \ + r_asin.obj \ + r_atan.obj \ + r_atn2.obj \ + r_cnjg.obj \ + r_cos.obj \ + r_cosh.obj \ + r_dim.obj \ + r_exp.obj \ + r_imag.obj \ + r_int.obj \ + r_lg10.obj \ + r_log.obj \ + r_mod.obj \ + r_nint.obj \ + r_sign.obj \ + r_sin.obj \ + r_sinh.obj \ + r_sqrt.obj \ + r_tan.obj \ + r_tanh.obj \ + rdfmt.obj \ + rewind.obj \ + rsfe.obj \ + rsli.obj \ + rsne.obj \ + s_cat.obj \ + s_cmp.obj \ + s_copy.obj \ + s_paus.obj \ + s_rnge.obj \ + s_stop.obj \ + sfe.obj \ + sig_die.obj \ + signal_.obj \ + sue.obj \ + system_.obj \ + typesize.obj \ + uio.obj \ + util.obj \ + uninit.obj \ + wref.obj \ + wrtfmt.obj \ + wsfe.obj \ + wsle.obj \ + wsne.obj \ + xwsne.obj \ + z_abs.obj \ + z_cos.obj \ + z_div.obj \ + z_exp.obj \ + z_log.obj \ + z_sin.obj \ + z_sqrt.obj + +syf2c.lib: f2c.h signal1.h sysdep1.h $w + lib /B /C syf2c.lib @libf2c.sy + +f2c.h: f2c.h0 + copy f2c.h0 f2c.h + +signal1.h: signal1.h0 + copy signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + copy sysdep1.h0 sysdep1.h + +signbit.obj uninit.obj: arith.h + +arith.h: arithchk.c + scomptry.bat $(CC) $(CFLAGS) arithchk.c + arithchk + del arithchk.exe + del arithchk.obj diff --git a/unix/f2c/libf2c/makefile.u b/unix/f2c/libf2c/makefile.u new file mode 100644 index 00000000..6d05dc6e --- /dev/null +++ b/unix/f2c/libf2c/makefile.u @@ -0,0 +1,219 @@ +# Unix makefile: see README. +# For C++, first "make hadd". +# If your compiler does not recognize ANSI C, add +# -DKR_headers +# to the CFLAGS = line below. +# On Sun and other BSD systems that do not provide an ANSI sprintf, add +# -DUSE_STRLEN +# to the CFLAGS = line below. +# On Linux systems, add +# -DNON_UNIX_STDIO +# to the CFLAGS = line below. For libf2c.so under Linux, also add +# -fPIC +# to the CFLAGS = line below. + +.SUFFIXES: .c .o +CC = cc +SHELL = /bin/sh +CFLAGS = -O -w $(HSI_CF) + +# compile, then strip unnecessary symbols +.c.o: + $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c + ld -r -x -o $*.xxx $*.o + mv $*.xxx $*.o +## Under Solaris (and other systems that do not understand ld -x), +## omit -x in the ld line above. +## If your system does not have the ld command, comment out +## or remove both the ld and mv lines above. + +MISC = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\ + getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o ctype.o\ + derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.o +POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o +CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ + r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ + r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ + r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ + d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ + d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ + d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ + d_sqrt.o d_tan.o d_tanh.o +INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o\ + lbitbits.o lbitshft.o +HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +EFL = ef1asc_.o ef1cmc_.o +CHAR = f77_aloc.o s_cat.o s_cmp.o s_copy.o +I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\ + fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\ + open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\ + typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o +QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o +TIME = dtime_.o etime_.o + +# If you get an error compiling dtime_.c or etime_.c, try adding +# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work, +# omit $(TIME) from OFILES = assignment below. + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.o +# to the end of the OFILES = assignment below. + +# For INTEGER*8 support (which requires system-dependent adjustments to +# f2c.h), add $(QINT) to the OFILES = assignment below... + +OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME) + +all: f2c.h signal1.h sysdep1.h libf2c.a + +libf2c.a: $(OFILES) + ar r libf2c.a $? + -ranlib libf2c.a + +## Shared-library variant: the following rule works on Linux +## systems. Details are system-dependent. Under Linux, -fPIC +## must appear in the CFLAGS assignment when making libf2c.so. +## Under Solaris, use -Kpic in CFLAGS and use "ld -G" instead +## of "$(CC) -shared". +## For MacOSX 10.4 and 10.5 (and perhaps other versions >= 10.3), use +## "MACOSX_DEPLOYMENT_TARGET=10.3 libtool -dynamic -undefined dynamic_lookup -single_module" +## instead of "$(CC) -shared", and when running programs linked against libf2c.so, +## arrange for $DYLD_LIBRARY_PATH to include the directory containing libf2c.so. + +libf2c.so: $(OFILES) + $(CC) -shared -o libf2c.so $(OFILES) + +### If your system lacks ranlib, you don't need it; see README. + +f77vers.o: f77vers.c + $(CC) -c f77vers.c + +i77vers.o: i77vers.c + $(CC) -c i77vers.c + +# To get an "f2c.h" for use with "f2c -C++", first "make hadd" +hadd: f2c.h0 f2ch.add + cat f2c.h0 f2ch.add >f2c.h + +# For use with "f2c" and "f2c -A": +f2c.h: f2c.h0 + cp f2c.h0 f2c.h + +# You may need to adjust signal1.h and sysdep1.h suitably for your system... +signal1.h: signal1.h0 + cp signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + cp sysdep1.h0 sysdep1.h + +# If your system lacks onexit() and you are not using an +# ANSI C compiler, then you should uncomment the following +# two lines (for compiling main.o): +#main.o: main.c +# $(CC) -c -DNO_ONEXIT -DSkip_f2c_Undefs main.c +# On at least some Sun systems, it is more appropriate to +# uncomment the following two lines: +#main.o: main.c +# $(CC) -c -Donexit=on_exit -DSkip_f2c_Undefs main.c + +install: libf2c.a + cp libf2c.a $(LIBDIR) + -ranlib $(LIBDIR)/libf2c.a + +clean: + rm -f libf2c.a *.o arith.h signal1.h sysdep1.h + +backspac.o: fio.h +close.o: fio.h +dfe.o: fio.h +dfe.o: fmt.h +due.o: fio.h +endfile.o: fio.h rawio.h +err.o: fio.h rawio.h +fmt.o: fio.h +fmt.o: fmt.h +iio.o: fio.h +iio.o: fmt.h +ilnw.o: fio.h +ilnw.o: lio.h +inquire.o: fio.h +lread.o: fio.h +lread.o: fmt.h +lread.o: lio.h +lread.o: fp.h +lwrite.o: fio.h +lwrite.o: fmt.h +lwrite.o: lio.h +open.o: fio.h rawio.h +rdfmt.o: fio.h +rdfmt.o: fmt.h +rdfmt.o: fp.h +rewind.o: fio.h +rsfe.o: fio.h +rsfe.o: fmt.h +rsli.o: fio.h +rsli.o: lio.h +rsne.o: fio.h +rsne.o: lio.h +sfe.o: fio.h +signbit.o: arith.h +sue.o: fio.h +uio.o: fio.h +uninit.o: arith.h +util.o: fio.h +wref.o: fio.h +wref.o: fmt.h +wref.o: fp.h +wrtfmt.o: fio.h +wrtfmt.o: fmt.h +wsfe.o: fio.h +wsfe.o: fmt.h +wsle.o: fio.h +wsle.o: fmt.h +wsle.o: lio.h +wsne.o: fio.h +wsne.o: lio.h +xwsne.o: fio.h +xwsne.o: lio.h +xwsne.o: fmt.h + +arith.h: arithchk.c + $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\ + $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm + ./a.out >arith.h + rm -f a.out arithchk.o + +check: + xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \ + c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \ + ctype.c ctype.h \ + d_abs.c d_acos.c d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c \ + d_dim.c d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c \ + d_nint.c d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c \ + d_tanh.c derf_.c derfc_.c dfe.c dolio.c dtime_.c due.c ef1asc_.c \ + ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \ + f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \ + fp.h ftell_.c ftell64_.c \ + getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ + h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ + i77vers.c i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c \ + i_nint.c i_sign.c iargc_.c iio.c ilnw.c inquire.c l_ge.c l_gt.c \ + l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \ + lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \ + makefile.wat math.hvc mkfile.plan9 open.c pow_ci.c pow_dd.c \ + pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c pow_zi.c pow_zz.c \ + qbitbits.c qbitshft.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ + r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ + r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ + r_tan.c r_tanh.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \ + s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c scomptry.bat sfe.c \ + sig_die.c signal1.h0 signal_.c signbit.c sue.c sysdep1.h0 system_.c \ + typesize.c \ + uio.c uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \ + z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out diff --git a/unix/f2c/libf2c/makefile.vc b/unix/f2c/libf2c/makefile.vc new file mode 100644 index 00000000..b3dd90c1 --- /dev/null +++ b/unix/f2c/libf2c/makefile.vc @@ -0,0 +1,195 @@ +# For making f2c.lib (here called vcf2c.lib) with Microsoft Visual C++ . +# Invoke with "nmake -f makefile.vc" . + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj +# to the objects in the "w =" list below. + +CC = cl +CFLAGS = -DUSE_CLOCK -DMSDOS -DNO_ONEXIT -Ot1 -DNO_My_ctype -DNO_ISATTY + +.c.obj: + $(CC) -c $(CFLAGS) $*.c + +w = \ + abort_.obj \ + backspac.obj \ + c_abs.obj \ + c_cos.obj \ + c_div.obj \ + c_exp.obj \ + c_log.obj \ + c_sin.obj \ + c_sqrt.obj \ + cabs.obj \ + close.obj \ + d_abs.obj \ + d_acos.obj \ + d_asin.obj \ + d_atan.obj \ + d_atn2.obj \ + d_cnjg.obj \ + d_cos.obj \ + d_cosh.obj \ + d_dim.obj \ + d_exp.obj \ + d_imag.obj \ + d_int.obj \ + d_lg10.obj \ + d_log.obj \ + d_mod.obj \ + d_nint.obj \ + d_prod.obj \ + d_sign.obj \ + d_sin.obj \ + d_sinh.obj \ + d_sqrt.obj \ + d_tan.obj \ + d_tanh.obj \ + derf_.obj \ + derfc_.obj \ + dfe.obj \ + dolio.obj \ + dtime_.obj \ + due.obj \ + ef1asc_.obj \ + ef1cmc_.obj \ + endfile.obj \ + erf_.obj \ + erfc_.obj \ + err.obj \ + etime_.obj \ + exit_.obj \ + f77_aloc.obj \ + f77vers.obj \ + fmt.obj \ + fmtlib.obj \ + ftell_.obj \ + getarg_.obj \ + getenv_.obj \ + h_abs.obj \ + h_dim.obj \ + h_dnnt.obj \ + h_indx.obj \ + h_len.obj \ + h_mod.obj \ + h_nint.obj \ + h_sign.obj \ + hl_ge.obj \ + hl_gt.obj \ + hl_le.obj \ + hl_lt.obj \ + i77vers.obj \ + i_abs.obj \ + i_dim.obj \ + i_dnnt.obj \ + i_indx.obj \ + i_len.obj \ + i_mod.obj \ + i_nint.obj \ + i_sign.obj \ + iargc_.obj \ + iio.obj \ + ilnw.obj \ + inquire.obj \ + l_ge.obj \ + l_gt.obj \ + l_le.obj \ + l_lt.obj \ + lbitbits.obj \ + lbitshft.obj \ + lread.obj \ + lwrite.obj \ + main.obj \ + open.obj \ + pow_ci.obj \ + pow_dd.obj \ + pow_di.obj \ + pow_hh.obj \ + pow_ii.obj \ + pow_ri.obj \ + pow_zi.obj \ + pow_zz.obj \ + r_abs.obj \ + r_acos.obj \ + r_asin.obj \ + r_atan.obj \ + r_atn2.obj \ + r_cnjg.obj \ + r_cos.obj \ + r_cosh.obj \ + r_dim.obj \ + r_exp.obj \ + r_imag.obj \ + r_int.obj \ + r_lg10.obj \ + r_log.obj \ + r_mod.obj \ + r_nint.obj \ + r_sign.obj \ + r_sin.obj \ + r_sinh.obj \ + r_sqrt.obj \ + r_tan.obj \ + r_tanh.obj \ + rdfmt.obj \ + rewind.obj \ + rsfe.obj \ + rsli.obj \ + rsne.obj \ + s_cat.obj \ + s_cmp.obj \ + s_copy.obj \ + s_paus.obj \ + s_rnge.obj \ + s_stop.obj \ + sfe.obj \ + sig_die.obj \ + signal_.obj \ + sue.obj \ + system_.obj \ + typesize.obj \ + uio.obj \ + uninit.obj \ + util.obj \ + wref.obj \ + wrtfmt.obj \ + wsfe.obj \ + wsle.obj \ + wsne.obj \ + xwsne.obj \ + z_abs.obj \ + z_cos.obj \ + z_div.obj \ + z_exp.obj \ + z_log.obj \ + z_sin.obj \ + z_sqrt.obj + +all: f2c.h math.h signal1.h sysdep1.h vcf2c.lib + +f2c.h: f2c.h0 + copy f2c.h0 f2c.h + +math.h: math.hvc + copy math.hvc math.h + +signal1.h: signal1.h0 + copy signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + copy sysdep1.h0 sysdep1.h + +vcf2c.lib: $w + lib -out:vcf2c.lib @libf2c.lbc + +open.obj: open.c + $(CC) -c $(CFLAGS) -DMSDOS open.c + +signbit.obj uninit.obj: arith.h + +arith.h: arithchk.c + comptry.bat $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c + arithchk >arith.h + del arithchk.exe + del arithchk.obj diff --git a/unix/f2c/libf2c/makefile.wat b/unix/f2c/libf2c/makefile.wat new file mode 100644 index 00000000..a81c06d6 --- /dev/null +++ b/unix/f2c/libf2c/makefile.wat @@ -0,0 +1,189 @@ +# For making f2c.lib (here called watf2c.lib) with WATCOM C/C++ . +# Invoke with "wmake -u -f makefile.wat" . +# In the CFLAGS line below, "-bt=nt" is for NT and W9x. +# With WATCOM, it is necessary to explicitly load main.obj . + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj +# to the objects in the "w =" list below. + +CC = wcc386 +CFLAGS = -fpd -DMSDOS -DUSE_CLOCK -DNO_ONEXIT -bt=nt -DNO_My_ctype + +.c.obj: + $(CC) $(CFLAGS) $*.c + +w = \ + abort_.obj \ + backspac.obj \ + c_abs.obj \ + c_cos.obj \ + c_div.obj \ + c_exp.obj \ + c_log.obj \ + c_sin.obj \ + c_sqrt.obj \ + cabs.obj \ + close.obj \ + d_abs.obj \ + d_acos.obj \ + d_asin.obj \ + d_atan.obj \ + d_atn2.obj \ + d_cnjg.obj \ + d_cos.obj \ + d_cosh.obj \ + d_dim.obj \ + d_exp.obj \ + d_imag.obj \ + d_int.obj \ + d_lg10.obj \ + d_log.obj \ + d_mod.obj \ + d_nint.obj \ + d_prod.obj \ + d_sign.obj \ + d_sin.obj \ + d_sinh.obj \ + d_sqrt.obj \ + d_tan.obj \ + d_tanh.obj \ + derf_.obj \ + derfc_.obj \ + dfe.obj \ + dolio.obj \ + dtime_.obj \ + due.obj \ + ef1asc_.obj \ + ef1cmc_.obj \ + endfile.obj \ + erf_.obj \ + erfc_.obj \ + err.obj \ + etime_.obj \ + exit_.obj \ + f77_aloc.obj \ + f77vers.obj \ + fmt.obj \ + fmtlib.obj \ + ftell_.obj \ + getarg_.obj \ + getenv_.obj \ + h_abs.obj \ + h_dim.obj \ + h_dnnt.obj \ + h_indx.obj \ + h_len.obj \ + h_mod.obj \ + h_nint.obj \ + h_sign.obj \ + hl_ge.obj \ + hl_gt.obj \ + hl_le.obj \ + hl_lt.obj \ + i77vers.obj \ + i_abs.obj \ + i_dim.obj \ + i_dnnt.obj \ + i_indx.obj \ + i_len.obj \ + i_mod.obj \ + i_nint.obj \ + i_sign.obj \ + iargc_.obj \ + iio.obj \ + ilnw.obj \ + inquire.obj \ + l_ge.obj \ + l_gt.obj \ + l_le.obj \ + l_lt.obj \ + lbitbits.obj \ + lbitshft.obj \ + lread.obj \ + lwrite.obj \ + main.obj \ + open.obj \ + pow_ci.obj \ + pow_dd.obj \ + pow_di.obj \ + pow_hh.obj \ + pow_ii.obj \ + pow_ri.obj \ + pow_zi.obj \ + pow_zz.obj \ + r_abs.obj \ + r_acos.obj \ + r_asin.obj \ + r_atan.obj \ + r_atn2.obj \ + r_cnjg.obj \ + r_cos.obj \ + r_cosh.obj \ + r_dim.obj \ + r_exp.obj \ + r_imag.obj \ + r_int.obj \ + r_lg10.obj \ + r_log.obj \ + r_mod.obj \ + r_nint.obj \ + r_sign.obj \ + r_sin.obj \ + r_sinh.obj \ + r_sqrt.obj \ + r_tan.obj \ + r_tanh.obj \ + rdfmt.obj \ + rewind.obj \ + rsfe.obj \ + rsli.obj \ + rsne.obj \ + s_cat.obj \ + s_cmp.obj \ + s_copy.obj \ + s_paus.obj \ + s_rnge.obj \ + s_stop.obj \ + sfe.obj \ + sig_die.obj \ + signal_.obj \ + sue.obj \ + system_.obj \ + typesize.obj \ + uio.obj \ + uninit.obj \ + util.obj \ + wref.obj \ + wrtfmt.obj \ + wsfe.obj \ + wsle.obj \ + wsne.obj \ + xwsne.obj \ + z_abs.obj \ + z_cos.obj \ + z_div.obj \ + z_exp.obj \ + z_log.obj \ + z_sin.obj \ + z_sqrt.obj + +watf2c.lib: f2c.h signal1.h sysdep1.h $w + wlib -c watf2c.lib @libf2c + +f2c.h: f2c.h0 + copy f2c.h0 f2c.h + +signal1.h: signal1.h0 + copy signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + copy sysdep1.h0 sysdep1.h + +signbit.obj uninit.obj: arith.h + +arith.h: arithchk.c + comptry.bat wcl386 -DNO_FPINIT arithchk.c + arithchk >arith.h + del arithchk.exe + del arithchk.obj diff --git a/unix/f2c/libf2c/math.hvc b/unix/f2c/libf2c/math.hvc new file mode 100644 index 00000000..52cfcee0 --- /dev/null +++ b/unix/f2c/libf2c/math.hvc @@ -0,0 +1,3 @@ +/* for VC 4.2 */ +#include +#undef complex diff --git a/unix/f2c/libf2c/mkfile.plan9 b/unix/f2c/libf2c/mkfile.plan9 new file mode 100644 index 00000000..645e33d6 --- /dev/null +++ b/unix/f2c/libf2c/mkfile.plan9 @@ -0,0 +1,162 @@ +# Plan 9 mkfile for libf2c.a$O + +f2c.h + +# For use with "f2c" and "f2c -A": +f2c.h: f2c.h0 + cp f2c.h0 f2c.h + +# You may need to adjust signal1.h suitably for your system... +signal1.h: signal1.h0 + cp signal1.h0 signal1.h + +clean: + rm -f libf2c.a$O *.$O arith.h + +backspac.$O: fio.h +close.$O: fio.h +dfe.$O: fio.h +dfe.$O: fmt.h +due.$O: fio.h +endfile.$O: fio.h rawio.h +err.$O: fio.h rawio.h +fmt.$O: fio.h +fmt.$O: fmt.h +iio.$O: fio.h +iio.$O: fmt.h +ilnw.$O: fio.h +ilnw.$O: lio.h +inquire.$O: fio.h +lread.$O: fio.h +lread.$O: fmt.h +lread.$O: lio.h +lread.$O: fp.h +lwrite.$O: fio.h +lwrite.$O: fmt.h +lwrite.$O: lio.h +open.$O: fio.h rawio.h +rdfmt.$O: fio.h +rdfmt.$O: fmt.h +rdfmt.$O: fp.h +rewind.$O: fio.h +rsfe.$O: fio.h +rsfe.$O: fmt.h +rsli.$O: fio.h +rsli.$O: lio.h +rsne.$O: fio.h +rsne.$O: lio.h +sfe.$O: fio.h +sue.$O: fio.h +uio.$O: fio.h +uninit.$O: arith.h +util.$O: fio.h +wref.$O: fio.h +wref.$O: fmt.h +wref.$O: fp.h +wrtfmt.$O: fio.h +wrtfmt.$O: fmt.h +wsfe.$O: fio.h +wsfe.$O: fmt.h +wsle.$O: fio.h +wsle.$O: fmt.h +wsle.$O: lio.h +wsne.$O: fio.h +wsne.$O: lio.h +xwsne.$O: fio.h +xwsne.$O: lio.h +xwsne.$O: fmt.h + +arith.h: arithchk.c + pcc -DNO_FPINIT -o arithchk arithchk.c + arithchk >$target + rm arithchk + +xsum.out:V: check + +check: + xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \ + c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \ + d_abs.c d_acos.c d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c \ + d_dim.c d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c \ + d_nint.c d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c \ + d_tanh.c derf_.c derfc_.c dfe.c dolio.c dtime_.c due.c ef1asc_.c \ + ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \ + f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \ + fp.h ftell_.c \ + getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ + h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ + i77vers.c i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c \ + i_nint.c i_sign.c iargc_.c iio.c ilnw.c inquire.c l_ge.c l_gt.c \ + l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \ + lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \ + makefile.wat math.hvc mkfile.plan9 open.c pow_ci.c pow_dd.c \ + pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c pow_zi.c pow_zz.c \ + qbitbits.c qbitshft.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ + r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ + r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ + r_tan.c r_tanh.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \ + s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c sfe.c \ + sig_die.c signal1.h0 signal_.c sue.c system_.c typesize.c uio.c \ + uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \ + z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out diff --git a/unix/f2c/libf2c/mkpkg.sh b/unix/f2c/libf2c/mkpkg.sh new file mode 100644 index 00000000..39438572 --- /dev/null +++ b/unix/f2c/libf2c/mkpkg.sh @@ -0,0 +1,5 @@ +# Bootstrap the F2C compiler and libraries. + +make -f makefile.u +mv libf2c.a ../../bin/ +rm *.[aeo] diff --git a/unix/f2c/libf2c/open.c b/unix/f2c/libf2c/open.c new file mode 100644 index 00000000..a06428dd --- /dev/null +++ b/unix/f2c/libf2c/open.c @@ -0,0 +1,301 @@ +#include "f2c.h" +#include "fio.h" +#include "string.h" +#ifndef NON_POSIX_STDIO +#ifdef MSDOS +#include "io.h" +#else +#include "unistd.h" /* for access */ +#endif +#endif + +#ifdef KR_headers +extern char *malloc(); +#ifdef NON_ANSI_STDIO +extern char *mktemp(); +#endif +extern integer f_clos(); +#define Const /*nothing*/ +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +extern int f__canseek(FILE*); +extern integer f_clos(cllist*); +#endif + +#ifdef NON_ANSI_RW_MODES +Const char *f__r_mode[2] = {"r", "r"}; +Const char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; +#else +Const char *f__r_mode[2] = {"rb", "r"}; +Const char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; +#endif + + static char f__buf0[400], *f__buf = f__buf0; + int f__buflen = (int)sizeof(f__buf0); + + static void +#ifdef KR_headers +f__bufadj(n, c) int n, c; +#else +f__bufadj(int n, int c) +#endif +{ + unsigned int len; + char *nbuf, *s, *t, *te; + + if (f__buf == f__buf0) + f__buflen = 1024; + while(f__buflen <= n) + f__buflen <<= 1; + len = (unsigned int)f__buflen; + if (len != f__buflen || !(nbuf = (char*)malloc(len))) + f__fatal(113, "malloc failure"); + s = nbuf; + t = f__buf; + te = t + c; + while(t < te) + *s++ = *t++; + if (f__buf != f__buf0) + free(f__buf); + f__buf = nbuf; + } + + int +#ifdef KR_headers +f__putbuf(c) int c; +#else +f__putbuf(int c) +#endif +{ + char *s, *se; + int n; + + if (f__hiwater > f__recpos) + f__recpos = f__hiwater; + n = f__recpos + 1; + if (n >= f__buflen) + f__bufadj(n, f__recpos); + s = f__buf; + se = s + f__recpos; + if (c) + *se++ = c; + *se = 0; + for(;;) { + fputs(s, f__cf); + s += strlen(s); + if (s >= se) + break; /* normally happens the first time */ + putc(*s++, f__cf); + } + return 0; + } + + void +#ifdef KR_headers +x_putc(c) +#else +x_putc(int c) +#endif +{ + if (f__recpos >= f__buflen) + f__bufadj(f__recpos, f__buflen); + f__buf[f__recpos++] = c; + } + +#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);} + + static void +#ifdef KR_headers +opn_err(m, s, a) int m; char *s; olist *a; +#else +opn_err(int m, const char *s, olist *a) +#endif +{ + if (a->ofnm) { + /* supply file name to error message */ + if (a->ofnmlen >= f__buflen) + f__bufadj((int)a->ofnmlen, 0); + g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); + } + f__fatal(m, s); + } + +#ifdef KR_headers +integer f_open(a) olist *a; +#else +integer f_open(olist *a) +#endif +{ unit *b; + integer rv; + char buf[256], *s; + cllist x; + int ufmt; + FILE *tf; +#ifndef NON_UNIX_STDIO + int n; +#endif + f__external = 1; + if(a->ounit>=MXUNIT || a->ounit<0) + err(a->oerr,101,"open") + if (!f__init) + f_init(); + f__curunit = b = &f__units[a->ounit]; + if(b->ufd) { + if(a->ofnm==0) + { + same: if (a->oblnk) + b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; + return(0); + } +#ifdef NON_UNIX_STDIO + if (b->ufnm + && strlen(b->ufnm) == a->ofnmlen + && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) + goto same; +#else + g_char(a->ofnm,a->ofnmlen,buf); + if (f__inode(buf,&n) == b->uinode && n == b->udev) + goto same; +#endif + x.cunit=a->ounit; + x.csta=0; + x.cerr=a->oerr; + if ((rv = f_clos(&x)) != 0) + return rv; + } + b->url = (int)a->orl; + b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); + if(a->ofm==0) + { if(b->url>0) b->ufmt=0; + else b->ufmt=1; + } + else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; + else b->ufmt=0; + ufmt = b->ufmt; +#ifdef url_Adjust + if (b->url && !ufmt) + url_Adjust(b->url); +#endif + if (a->ofnm) { + g_char(a->ofnm,a->ofnmlen,buf); + if (!buf[0]) + opnerr(a->oerr,107,"open") + } + else + sprintf(buf, "fort.%ld", (long)a->ounit); + b->uscrtch = 0; + b->uend=0; + b->uwrt = 0; + b->ufd = 0; + b->urw = 3; + switch(a->osta ? *a->osta : 'u') + { + case 'o': + case 'O': +#ifdef NON_POSIX_STDIO + if (!(tf = FOPEN(buf,"r"))) + opnerr(a->oerr,errno,"open") + fclose(tf); +#else + if (access(buf,0)) + opnerr(a->oerr,errno,"open") +#endif + break; + case 's': + case 'S': + b->uscrtch=1; +#ifdef NON_ANSI_STDIO + (void) strcpy(buf,"tmp.FXXXXXX"); + (void) mktemp(buf); + goto replace; +#else + if (!(b->ufd = tmpfile())) + opnerr(a->oerr,errno,"open") + b->ufnm = 0; +#ifndef NON_UNIX_STDIO + b->uinode = b->udev = -1; +#endif + b->useek = 1; + return 0; +#endif + + case 'n': + case 'N': +#ifdef NON_POSIX_STDIO + if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) { + fclose(tf); + opnerr(a->oerr,128,"open") + } +#else + if (!access(buf,0)) + opnerr(a->oerr,128,"open") +#endif + /* no break */ + case 'r': /* Fortran 90 replace option */ + case 'R': +#ifdef NON_ANSI_STDIO + replace: +#endif + if (tf = FOPEN(buf,f__w_mode[0])) + fclose(tf); + } + + b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); + if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); + (void) strcpy(b->ufnm,buf); + if ((s = a->oacc) && b->url) + ufmt = 0; + if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) { + if (tf = FOPEN(buf, f__r_mode[ufmt])) + b->urw = 1; + else if (tf = FOPEN(buf, f__w_mode[ufmt])) { + b->uwrt = 1; + b->urw = 2; + } + else + err(a->oerr, errno, "open"); + } + b->useek = f__canseek(b->ufd = tf); +#ifndef NON_UNIX_STDIO + if((b->uinode = f__inode(buf,&b->udev)) == -1) + opnerr(a->oerr,108,"open") +#endif + if(b->useek) + if (a->orl) + rewind(b->ufd); + else if ((s = a->oacc) && (*s == 'a' || *s == 'A') + && FSEEK(b->ufd, 0L, SEEK_END)) + opnerr(a->oerr,129,"open"); + return(0); +} + + int +#ifdef KR_headers +fk_open(seq,fmt,n) ftnint n; +#else +fk_open(int seq, int fmt, ftnint n) +#endif +{ char nbuf[10]; + olist a; + (void) sprintf(nbuf,"fort.%ld",(long)n); + a.oerr=1; + a.ounit=n; + a.ofnm=nbuf; + a.ofnmlen=strlen(nbuf); + a.osta=NULL; + a.oacc= (char*)(seq==SEQ?"s":"d"); + a.ofm = (char*)(fmt==FMT?"f":"u"); + a.orl = seq==DIR?1:0; + a.oblnk=NULL; + return(f_open(&a)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_ci.c b/unix/f2c/libf2c/pow_ci.c new file mode 100644 index 00000000..574e0b1e --- /dev/null +++ b/unix/f2c/libf2c/pow_ci.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID pow_ci(p, a, b) /* p = a**b */ + complex *p, *a; integer *b; +#else +extern void pow_zi(doublecomplex*, doublecomplex*, integer*); +void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */ +#endif +{ +doublecomplex p1, a1; + +a1.r = a->r; +a1.i = a->i; + +pow_zi(&p1, &a1, b); + +p->r = p1.r; +p->i = p1.i; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_dd.c b/unix/f2c/libf2c/pow_dd.c new file mode 100644 index 00000000..08fc2088 --- /dev/null +++ b/unix/f2c/libf2c/pow_dd.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double pow(); +double pow_dd(ap, bp) doublereal *ap, *bp; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double pow_dd(doublereal *ap, doublereal *bp) +#endif +{ +return(pow(*ap, *bp) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_di.c b/unix/f2c/libf2c/pow_di.c new file mode 100644 index 00000000..abf36cb7 --- /dev/null +++ b/unix/f2c/libf2c/pow_di.c @@ -0,0 +1,41 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double pow_di(ap, bp) doublereal *ap; integer *bp; +#else +double pow_di(doublereal *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_hh.c b/unix/f2c/libf2c/pow_hh.c new file mode 100644 index 00000000..88216850 --- /dev/null +++ b/unix/f2c/libf2c/pow_hh.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint pow_hh(ap, bp) shortint *ap, *bp; +#else +shortint pow_hh(shortint *ap, shortint *bp) +#endif +{ + shortint pow, x, n; + unsigned u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_ii.c b/unix/f2c/libf2c/pow_ii.c new file mode 100644 index 00000000..748d1217 --- /dev/null +++ b/unix/f2c/libf2c/pow_ii.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer pow_ii(ap, bp) integer *ap, *bp; +#else +integer pow_ii(integer *ap, integer *bp) +#endif +{ + integer pow, x, n; + unsigned long u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_qq.c b/unix/f2c/libf2c/pow_qq.c new file mode 100644 index 00000000..09fe18ec --- /dev/null +++ b/unix/f2c/libf2c/pow_qq.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +longint pow_qq(ap, bp) longint *ap, *bp; +#else +longint pow_qq(longint *ap, longint *bp) +#endif +{ + longint pow, x, n; + unsigned long long u; /* system-dependent */ + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_ri.c b/unix/f2c/libf2c/pow_ri.c new file mode 100644 index 00000000..e29d416e --- /dev/null +++ b/unix/f2c/libf2c/pow_ri.c @@ -0,0 +1,41 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double pow_ri(ap, bp) real *ap; integer *bp; +#else +double pow_ri(real *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_zi.c b/unix/f2c/libf2c/pow_zi.c new file mode 100644 index 00000000..1c0a4b07 --- /dev/null +++ b/unix/f2c/libf2c/pow_zi.c @@ -0,0 +1,60 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID pow_zi(p, a, b) /* p = a**b */ + doublecomplex *p, *a; integer *b; +#else +extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); +void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ +#endif +{ + integer n; + unsigned long u; + double t; + doublecomplex q, x; + static doublecomplex one = {1.0, 0.0}; + + n = *b; + q.r = 1; + q.i = 0; + + if(n == 0) + goto done; + if(n < 0) + { + n = -n; + z_div(&x, &one, a); + } + else + { + x.r = a->r; + x.i = a->i; + } + + for(u = n; ; ) + { + if(u & 01) + { + t = q.r * x.r - q.i * x.i; + q.i = q.r * x.i + q.i * x.r; + q.r = t; + } + if(u >>= 1) + { + t = x.r * x.r - x.i * x.i; + x.i = 2 * x.r * x.i; + x.r = t; + } + else + break; + } + done: + p->i = q.i; + p->r = q.r; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_zz.c b/unix/f2c/libf2c/pow_zz.c new file mode 100644 index 00000000..b5ffd334 --- /dev/null +++ b/unix/f2c/libf2c/pow_zz.c @@ -0,0 +1,29 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), exp(), cos(), sin(), atan2(), f__cabs(); +VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double,double); +void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b) +#endif +{ +double logr, logi, x, y; + +logr = log( f__cabs(a->r, a->i) ); +logi = atan2(a->i, a->r); + +x = exp( logr * b->r - logi * b->i ); +y = logr * b->i + logi * b->r; + +r->r = x * cos(y); +r->i = x * sin(y); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/qbitbits.c b/unix/f2c/libf2c/qbitbits.c new file mode 100644 index 00000000..ba1b5bd0 --- /dev/null +++ b/unix/f2c/libf2c/qbitbits.c @@ -0,0 +1,72 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + +#ifndef LONG8BITS +#define LONG8BITS (2*LONGBITS) +#endif + + longint +#ifdef KR_headers +qbit_bits(a, b, len) longint a; integer b, len; +#else +qbit_bits(longint a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + ulongint x, y; + + x = (ulongint) a; + y = (ulongint)-1L; + x >>= b; + y <<= len; + return (longint)(x & ~y); + } + + longint +#ifdef KR_headers +qbit_cshift(a, b, len) longint a; integer b, len; +#else +qbit_cshift(longint a, integer b, integer len) +#endif +{ + ulongint x, y, z; + + x = (ulongint)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONG8BITS) { + full_len: + if (b >= 0) { + b %= LONG8BITS; + return (longint)(x << b | x >> LONG8BITS - b ); + } + b = -b; + b %= LONG8BITS; + return (longint)(x << LONG8BITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (longint)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (longint)(y | z & (x >> b | x << len - b)); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/qbitshft.c b/unix/f2c/libf2c/qbitshft.c new file mode 100644 index 00000000..78e7b951 --- /dev/null +++ b/unix/f2c/libf2c/qbitshft.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + longint +#ifdef KR_headers +qbit_shift(a, b) longint a; integer b; +#else +qbit_shift(longint a, integer b) +#endif +{ + return b >= 0 ? a << b : (longint)((ulongint)a >> -b); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_abs.c b/unix/f2c/libf2c/r_abs.c new file mode 100644 index 00000000..f3291fb4 --- /dev/null +++ b/unix/f2c/libf2c/r_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_abs(x) real *x; +#else +double r_abs(real *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_acos.c b/unix/f2c/libf2c/r_acos.c new file mode 100644 index 00000000..103c7ff0 --- /dev/null +++ b/unix/f2c/libf2c/r_acos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double r_acos(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_acos(real *x) +#endif +{ +return( acos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_asin.c b/unix/f2c/libf2c/r_asin.c new file mode 100644 index 00000000..432b9406 --- /dev/null +++ b/unix/f2c/libf2c/r_asin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double r_asin(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_asin(real *x) +#endif +{ +return( asin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_atan.c b/unix/f2c/libf2c/r_atan.c new file mode 100644 index 00000000..7656982d --- /dev/null +++ b/unix/f2c/libf2c/r_atan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double r_atan(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_atan(real *x) +#endif +{ +return( atan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_atn2.c b/unix/f2c/libf2c/r_atn2.c new file mode 100644 index 00000000..ab957b89 --- /dev/null +++ b/unix/f2c/libf2c/r_atn2.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double r_atn2(x,y) real *x, *y; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_atn2(real *x, real *y) +#endif +{ +return( atan2(*x,*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_cnjg.c b/unix/f2c/libf2c/r_cnjg.c new file mode 100644 index 00000000..cef0e4b0 --- /dev/null +++ b/unix/f2c/libf2c/r_cnjg.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID r_cnjg(r, z) complex *r, *z; +#else +VOID r_cnjg(complex *r, complex *z) +#endif +{ + real zi = z->i; + r->r = z->r; + r->i = -zi; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_cos.c b/unix/f2c/libf2c/r_cos.c new file mode 100644 index 00000000..4418f0c1 --- /dev/null +++ b/unix/f2c/libf2c/r_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double r_cos(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_cos(real *x) +#endif +{ +return( cos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_cosh.c b/unix/f2c/libf2c/r_cosh.c new file mode 100644 index 00000000..f5478355 --- /dev/null +++ b/unix/f2c/libf2c/r_cosh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double r_cosh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_cosh(real *x) +#endif +{ +return( cosh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_dim.c b/unix/f2c/libf2c/r_dim.c new file mode 100644 index 00000000..d573ca36 --- /dev/null +++ b/unix/f2c/libf2c/r_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_dim(a,b) real *a, *b; +#else +double r_dim(real *a, real *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_exp.c b/unix/f2c/libf2c/r_exp.c new file mode 100644 index 00000000..4e679794 --- /dev/null +++ b/unix/f2c/libf2c/r_exp.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double r_exp(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_exp(real *x) +#endif +{ +return( exp(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_imag.c b/unix/f2c/libf2c/r_imag.c new file mode 100644 index 00000000..1b4de143 --- /dev/null +++ b/unix/f2c/libf2c/r_imag.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_imag(z) complex *z; +#else +double r_imag(complex *z) +#endif +{ +return(z->i); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_int.c b/unix/f2c/libf2c/r_int.c new file mode 100644 index 00000000..bff87176 --- /dev/null +++ b/unix/f2c/libf2c/r_int.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_int(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_int(real *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_lg10.c b/unix/f2c/libf2c/r_lg10.c new file mode 100644 index 00000000..64ffddf4 --- /dev/null +++ b/unix/f2c/libf2c/r_lg10.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double r_lg10(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_lg10(real *x) +#endif +{ +return( log10e * log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_log.c b/unix/f2c/libf2c/r_log.c new file mode 100644 index 00000000..94c79b05 --- /dev/null +++ b/unix/f2c/libf2c/r_log.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double r_log(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_log(real *x) +#endif +{ +return( log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_mod.c b/unix/f2c/libf2c/r_mod.c new file mode 100644 index 00000000..63ed1753 --- /dev/null +++ b/unix/f2c/libf2c/r_mod.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double r_mod(x,y) real *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif +double r_mod(real *x, real *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = (double)*x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_nint.c b/unix/f2c/libf2c/r_nint.c new file mode 100644 index 00000000..7cc3f1b5 --- /dev/null +++ b/unix/f2c/libf2c/r_nint.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_nint(real *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sign.c b/unix/f2c/libf2c/r_sign.c new file mode 100644 index 00000000..797db1a4 --- /dev/null +++ b/unix/f2c/libf2c/r_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_sign(a,b) real *a, *b; +#else +double r_sign(real *a, real *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sin.c b/unix/f2c/libf2c/r_sin.c new file mode 100644 index 00000000..37e0df25 --- /dev/null +++ b/unix/f2c/libf2c/r_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double r_sin(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sin(real *x) +#endif +{ +return( sin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sinh.c b/unix/f2c/libf2c/r_sinh.c new file mode 100644 index 00000000..39878f03 --- /dev/null +++ b/unix/f2c/libf2c/r_sinh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double r_sinh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sinh(real *x) +#endif +{ +return( sinh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sqrt.c b/unix/f2c/libf2c/r_sqrt.c new file mode 100644 index 00000000..e7b2c1c7 --- /dev/null +++ b/unix/f2c/libf2c/r_sqrt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double r_sqrt(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sqrt(real *x) +#endif +{ +return( sqrt(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_tan.c b/unix/f2c/libf2c/r_tan.c new file mode 100644 index 00000000..1774bed7 --- /dev/null +++ b/unix/f2c/libf2c/r_tan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double r_tan(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_tan(real *x) +#endif +{ +return( tan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_tanh.c b/unix/f2c/libf2c/r_tanh.c new file mode 100644 index 00000000..7739c6ce --- /dev/null +++ b/unix/f2c/libf2c/r_tanh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double r_tanh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_tanh(real *x) +#endif +{ +return( tanh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rawio.h b/unix/f2c/libf2c/rawio.h new file mode 100644 index 00000000..fd36a482 --- /dev/null +++ b/unix/f2c/libf2c/rawio.h @@ -0,0 +1,41 @@ +#ifndef KR_headers +#ifdef MSDOS +#include "io.h" +#ifndef WATCOM +#define close _close +#define creat _creat +#define open _open +#define read _read +#define write _write +#endif /*WATCOM*/ +#endif /*MSDOS*/ +#ifdef __cplusplus +extern "C" { +#endif +#ifndef MSDOS +#ifdef OPEN_DECL +extern int creat(const char*,int), open(const char*,int); +#endif +extern int close(int); +extern int read(int,void*,size_t), write(int,void*,size_t); +extern int unlink(const char*); +#ifndef _POSIX_SOURCE +#ifndef NON_UNIX_STDIO +extern FILE *fdopen(int, const char*); +#endif +#endif +#endif /*KR_HEADERS*/ + +extern char *mktemp(char*); + +#ifdef __cplusplus + } +#endif +#endif + +#include "fcntl.h" + +#ifndef O_WRONLY +#define O_RDONLY 0 +#define O_WRONLY 1 +#endif diff --git a/unix/f2c/libf2c/rdfmt.c b/unix/f2c/libf2c/rdfmt.c new file mode 100644 index 00000000..09f3ccfc --- /dev/null +++ b/unix/f2c/libf2c/rdfmt.c @@ -0,0 +1,553 @@ +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +extern double atof(); +#define Const /*nothing*/ +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif + +#include "fmt.h" +#include "fp.h" +#include "ctype.h" +#ifdef __cplusplus +extern "C" { +#endif + + static int +#ifdef KR_headers +rd_Z(n,w,len) Uint *n; ftnlen len; +#else +rd_Z(Uint *n, int w, ftnlen len) +#endif +{ + long x[9]; + char *s, *s0, *s1, *se, *t; + Const char *sc; + int ch, i, w1, w2; + static char hex[256]; + static int one = 1; + int bad = 0; + + if (!hex['0']) { + sc = "0123456789"; + while(ch = *sc++) + hex[ch] = ch - '0' + 1; + sc = "ABCDEF"; + while(ch = *sc++) + hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; + } + s = s0 = (char *)x; + s1 = (char *)&x[4]; + se = (char *)&x[8]; + if (len > 4*sizeof(long)) + return errno = 117; + while (w) { + GET(ch); + if (ch==',' || ch=='\n') + break; + w--; + if (ch > ' ') { + if (!hex[ch & 0xff]) + bad++; + *s++ = ch; + if (s == se) { + /* discard excess characters */ + for(t = s0, s = s1; t < s1;) + *t++ = *s++; + s = s1; + } + } + } + if (bad) + return errno = 115; + w = (int)len; + w1 = s - s0; + w2 = w1+1 >> 1; + t = (char *)n; + if (*(char *)&one) { + /* little endian */ + t += w - 1; + i = -1; + } + else + i = 1; + for(; w > w2; t += i, --w) + *t = 0; + if (!w) + return 0; + if (w < w2) + s0 = s - (w << 1); + else if (w1 & 1) { + *t = hex[*s0++ & 0xff] - 1; + if (!--w) + return 0; + t += i; + } + do { + *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; + t += i; + s0 += 2; + } + while(--w); + return 0; + } + + static int +#ifdef KR_headers +rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; +#else +rd_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ + int ch, sign; + longint x = 0; + + if (w <= 0) + goto have_x; + for(;;) { + GET(ch); + if (ch != ' ') + break; + if (!--w) + goto have_x; + } + sign = 0; + switch(ch) { + case ',': + case '\n': + w = 0; + goto have_x; + case '-': + sign = 1; + case '+': + break; + default: + if (ch >= '0' && ch <= '9') { + x = ch - '0'; + break; + } + goto have_x; + } + while(--w) { + GET(ch); + if (ch >= '0' && ch <= '9') { + x = x*base + ch - '0'; + continue; + } + if (ch != ' ') { + if (ch == '\n' || ch == ',') + w = 0; + break; + } + if (f__cblank) + x *= base; + } + if (sign) + x = -x; + have_x: + if(len == sizeof(integer)) + n->il=x; + else if(len == sizeof(char)) + n->ic = (char)x; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) + n->ili = x; +#endif + else + n->is = (short)x; + if (w) { + while(--w) + GET(ch); + return errno = 115; + } + return 0; +} + + static int +#ifdef KR_headers +rd_L(n,w,len) ftnint *n; ftnlen len; +#else +rd_L(ftnint *n, int w, ftnlen len) +#endif +{ int ch, dot, lv; + + if (w <= 0) + goto bad; + for(;;) { + GET(ch); + --w; + if (ch != ' ') + break; + if (!w) + goto bad; + } + dot = 0; + retry: + switch(ch) { + case '.': + if (dot++ || !w) + goto bad; + GET(ch); + --w; + goto retry; + case 't': + case 'T': + lv = 1; + break; + case 'f': + case 'F': + lv = 0; + break; + default: + bad: + for(; w > 0; --w) + GET(ch); + /* no break */ + case ',': + case '\n': + return errno = 116; + } + switch(len) { + case sizeof(char): *(char *)n = (char)lv; break; + case sizeof(short): *(short *)n = (short)lv; break; + default: *n = lv; + } + while(w-- > 0) { + GET(ch); + if (ch == ',' || ch == '\n') + break; + } + return 0; +} + + static int +#ifdef KR_headers +rd_F(p, w, d, len) ufloat *p; ftnlen len; +#else +rd_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + double x; + int scale1, se; + long e, exp; + + sp1 = sp = s; + spe = sp + FMAX; + exp = -d; + x = 0.; + + do { + GET(ch); + w--; + } while (ch == ' ' && w); + switch(ch) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + if (!w) goto zero; + --w; + GET(ch); + } + while(ch == ' ') { +blankdrop: + if (!w--) goto zero; GET(ch); } + while(ch == '0') + { if (!w--) goto zero; GET(ch); } + if (ch == ' ' && f__cblank) + goto blankdrop; + scale1 = f__scale; + while(isdigit(ch)) { +digloop1: + if (sp < spe) *sp++ = ch; + else ++exp; +digloop1e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop1; } + goto digloop1e; + } + if (ch == '.') { + exp += d; + if (!w--) goto done; + GET(ch); + if (sp == sp1) { /* no digits yet */ + while(ch == '0') { +skip01: + --exp; +skip0: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) goto skip01; + goto skip0; + } + } + while(isdigit(ch)) { +digloop2: + if (sp < spe) + { *sp++ = ch; --exp; } +digloop2e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop2; } + goto digloop2e; + } + } + switch(ch) { + default: + break; + case '-': se = 1; goto signonly; + case '+': se = 0; goto signonly; + case 'e': + case 'E': + case 'd': + case 'D': + if (!w--) + goto bad; + GET(ch); + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + se = 0; + switch(ch) { + case '-': se = 1; + case '+': +signonly: + if (!w--) + goto bad; + GET(ch); + } + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + if (!isdigit(ch)) + goto bad; + + e = ch - '0'; + for(;;) { + if (!w--) + { ch = '\n'; break; } + GET(ch); + if (!isdigit(ch)) { + if (ch == ' ') { + if (f__cblank) + ch = '0'; + else continue; + } + else + break; + } + e = 10*e + ch - '0'; + if (e > EXPMAX && sp > sp1) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + scale1 = 0; + } + switch(ch) { + case '\n': + case ',': + break; + default: +bad: + return (errno = 115); + } +done: + if (sp > sp1) { + while(*--sp == '0') + ++exp; + if (exp -= scale1) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + x = atof(s); + } +zero: + if (len == sizeof(real)) + p->pf = x; + else + p->pd = x; + return(0); + } + + + static int +#ifdef KR_headers +rd_A(p,len) char *p; ftnlen len; +#else +rd_A(char *p, ftnlen len) +#endif +{ int i,ch; + for(i=0;i=len) + { for(i=0;i0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); + if(f__cursor<0) + { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ + f__cursor = -f__recpos; /* is this in the standard? */ + if(f__external == 0) { + extern char *f__icptr; + f__icptr += f__cursor; + } + else if(f__curunit && f__curunit->useek) + (void) FSEEK(f__cf, f__cursor,SEEK_CUR); + else + err(f__elist->cierr,106,"fmt"); + f__recpos += f__cursor; + f__cursor=0; + } + switch(p->op) + { + default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case IM: + case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); + break; + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case OM: + case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); + break; + case L: ch = rd_L((ftnint *)ptr,p->p1,len); + break; + case A: ch = rd_A(ptr,len); + break; + case AW: + ch = rd_AW(ptr,p->p1,len); + break; + case E: case EE: + case D: + case G: + case GE: + case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); + break; + + /* Z and ZM assume 8-bit bytes. */ + + case ZM: + case Z: + ch = rd_Z((Uint *)ptr, p->p1, len); + break; + } + if(ch == 0) return(ch); + else if(ch == EOF) return(EOF); + if (f__cf) + clearerr(f__cf); + return(errno); +} + + int +#ifdef KR_headers +rd_ned(p) struct syl *p; +#else +rd_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case APOS: + return(rd_POS(p->p2.s)); + case H: return(rd_H(p->p1,p->p2.s)); + case SLASH: return((*f__donewrec)()); + case TR: + case X: f__cursor += p->p1; + return(1); + case T: f__cursor=p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + } +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rewind.c b/unix/f2c/libf2c/rewind.c new file mode 100644 index 00000000..9a0e07e6 --- /dev/null +++ b/unix/f2c/libf2c/rewind.c @@ -0,0 +1,30 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +integer f_rew(a) alist *a; +#else +integer f_rew(alist *a) +#endif +{ + unit *b; + if(a->aunit>=MXUNIT || a->aunit<0) + err(a->aerr,101,"rewind"); + b = &f__units[a->aunit]; + if(b->ufd == NULL || b->uwrt == 3) + return(0); + if(!b->useek) + err(a->aerr,106,"rewind") + if(b->uwrt) { + (void) t_runc(a); + b->uwrt = 3; + } + rewind(b->ufd); + b->uend=0; + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rsfe.c b/unix/f2c/libf2c/rsfe.c new file mode 100644 index 00000000..abe9724a --- /dev/null +++ b/unix/f2c/libf2c/rsfe.c @@ -0,0 +1,91 @@ +/* read sequential formatted external */ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +xrd_SL(Void) +{ int ch; + if(!f__curunit->uend) + while((ch=getc(f__cf))!='\n') + if (ch == EOF) { + f__curunit->uend = 1; + break; + } + f__cursor=f__recpos=0; + return(1); +} + + int +x_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + ch = getc(f__cf); + if(ch!=EOF && ch!='\n') + { f__recpos++; + return(ch); + } + if(ch=='\n') + { (void) ungetc(ch,f__cf); + return(ch); + } + if(f__curunit->uend || feof(f__cf)) + { errno=0; + f__curunit->uend=1; + return(-1); + } + return(-1); +} + + int +x_endp(Void) +{ + xrd_SL(); + return f__curunit->uend == 1 ? EOF : 0; +} + + int +x_rev(Void) +{ + (void) xrd_SL(); + return(0); +} +#ifdef KR_headers +integer s_rsfe(a) cilist *a; /* start */ +#else +integer s_rsfe(cilist *a) /* start */ +#endif +{ int n; + if(!f__init) f_init(); + f__reading=1; + f__sequential=1; + f__formatted=1; + f__external=1; + if(n=c_sfe(a)) return(n); + f__elist=a; + f__cursor=f__recpos=0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__getn= x_getc; + f__doed= rd_ed; + f__doned= rd_ned; + fmt_bg(); + f__doend=x_endp; + f__donewrec=xrd_SL; + f__dorevert=x_rev; + f__cblank=f__curunit->ublnk; + f__cplus=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rsli.c b/unix/f2c/libf2c/rsli.c new file mode 100644 index 00000000..3d4ea428 --- /dev/null +++ b/unix/f2c/libf2c/rsli.c @@ -0,0 +1,109 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" /* for f__doend */ +#ifdef __cplusplus +extern "C" { +#endif + +extern flag f__lquit; +extern int f__lcount; +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum, f__recpos; + +static int i_getc(Void) +{ + if(f__recpos >= f__svic->icirlen) { + if (f__recpos++ == f__svic->icirlen) + return '\n'; + z_rnew(); + } + f__recpos++; + if(f__icptr >= f__icend) + return EOF; + return(*f__icptr++); + } + + static +#ifdef KR_headers +int i_ungetc(ch, f) int ch; FILE *f; +#else +int i_ungetc(int ch, FILE *f) +#endif +{ + if (--f__recpos == f__svic->icirlen) + return '\n'; + if (f__recpos < -1) + err(f__svic->icierr,110,"recend"); + /* *--icptr == ch, and icptr may point to read-only memory */ + return *--f__icptr /* = ch */; + } + + static void +#ifdef KR_headers +c_lir(a) icilist *a; +#else +c_lir(icilist *a) +#endif +{ + extern int l_eof; + f__reading = 1; + f__external = 0; + f__formatted = 1; + f__svic = a; + L_len = a->icirlen; + f__recpos = -1; + f__icnum = f__recpos = 0; + f__cursor = 0; + l_getc = i_getc; + l_ungetc = i_ungetc; + l_eof = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__cf = 0; + f__curunit = 0; + f__elist = (cilist *)a; + } + + +#ifdef KR_headers +integer s_rsli(a) icilist *a; +#else +integer s_rsli(icilist *a) +#endif +{ + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + c_lir(a); + f__doend = 0; + return(0); + } + +integer e_rsli(Void) +{ return 0; } + +#ifdef KR_headers +integer s_rsni(a) icilist *a; +#else +extern int x_rsne(cilist*); + +integer s_rsni(icilist *a) +#endif +{ + extern int nml_read; + integer rv; + cilist ca; + ca.ciend = a->iciend; + ca.cierr = a->icierr; + ca.cifmt = a->icifmt; + c_lir(a); + rv = x_rsne(&ca); + nml_read = 0; + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rsne.c b/unix/f2c/libf2c/rsne.c new file mode 100644 index 00000000..e8e9daea --- /dev/null +++ b/unix/f2c/libf2c/rsne.c @@ -0,0 +1,618 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + +#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ +#define MAXDIM 20 /* maximum number of subscripts */ + + struct dimen { + ftnlen extent; + ftnlen curval; + ftnlen delta; + ftnlen stride; + }; + typedef struct dimen dimen; + + struct hashentry { + struct hashentry *next; + char *name; + Vardesc *vd; + }; + typedef struct hashentry hashentry; + + struct hashtab { + struct hashtab *next; + Namelist *nl; + int htsize; + hashentry *tab[1]; + }; + typedef struct hashtab hashtab; + + static hashtab *nl_cache; + static int n_nlcache; + static hashentry **zot; + static int colonseen; + extern ftnlen f__typesize[]; + + extern flag f__lquit; + extern int f__lcount, nml_read; + extern int t_getc(Void); + +#ifdef KR_headers + extern char *malloc(), *memset(); +#define Const /*nothing*/ + +#ifdef ungetc + static int +un_getc(x,f__cf) int x; FILE *f__cf; +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc + extern int ungetc(); +#endif + +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef ungetc + static int +un_getc(int x, FILE *f__cf) +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + + static Vardesc * +#ifdef KR_headers +hash(ht, s) hashtab *ht; register char *s; +#else +hash(hashtab *ht, register char *s) +#endif +{ + register int c, x; + register hashentry *h; + char *s0 = s; + + for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) + x += c; + for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) + if (!strcmp(s0, h->name)) + return h->vd; + return 0; + } + + hashtab * +#ifdef KR_headers +mk_hashtab(nl) Namelist *nl; +#else +mk_hashtab(Namelist *nl) +#endif +{ + int nht, nv; + hashtab *ht; + Vardesc *v, **vd, **vde; + hashentry *he; + + hashtab **x, **x0, *y; + for(x = &nl_cache; y = *x; x0 = x, x = &y->next) + if (nl == y->nl) + return y; + if (n_nlcache >= MAX_NL_CACHE) { + /* discard least recently used namelist hash table */ + y = *x0; + free((char *)y->next); + y->next = 0; + } + else + n_nlcache++; + nv = nl->nvars; + if (nv >= 0x4000) + nht = 0x7fff; + else { + for(nht = 1; nht < nv; nht <<= 1); + nht += nht - 1; + } + ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) + + nv*sizeof(hashentry)); + if (!ht) + return 0; + he = (hashentry *)&ht->tab[nht]; + ht->nl = nl; + ht->htsize = nht; + ht->next = nl_cache; + nl_cache = ht; + memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); + vd = nl->vars; + vde = vd + nv; + while(vd < vde) { + v = *vd++; + if (!hash(ht, v->name)) { + he->next = *zot; + *zot = he; + he->name = v->name; + he->vd = v; + he++; + } + } + return ht; + } + +static char Alpha[256], Alphanum[256]; + + static VOID +nl_init(Void) { + Const char *s; + int c; + + if(!f__init) + f_init(); + for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) + Alpha[c] + = Alphanum[c] + = Alpha[c + 'a' - 'A'] + = Alphanum[c + 'a' - 'A'] + = c; + for(s = "0123456789_"; c = *s++; ) + Alphanum[c] = c; + } + +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +#ifdef KR_headers +getname(s, slen) register char *s; int slen; +#else +getname(register char *s, int slen) +#endif +{ + register char *se = s + slen - 1; + register int ch; + + GETC(ch); + if (!(*s++ = Alpha[ch & 0xff])) { + if (ch != EOF) + ch = 115; + errfl(f__elist->cierr, ch, "namelist read"); + } + while(*s = Alphanum[GETC(ch) & 0xff]) + if (s < se) + s++; + if (ch == EOF) + err(f__elist->cierr, EOF, "namelist read"); + if (ch > ' ') + Ungetc(ch,f__cf); + return *s = 0; + } + + static int +#ifdef KR_headers +getnum(chp, val) int *chp; ftnlen *val; +#else +getnum(int *chp, ftnlen *val) +#endif +{ + register int ch, sign; + register ftnlen x; + + while(GETC(ch) <= ' ' && ch >= 0); + if (ch == '-') { + sign = 1; + GETC(ch); + } + else { + sign = 0; + if (ch == '+') + GETC(ch); + } + x = ch - '0'; + if (x < 0 || x > 9) + return 115; + while(GETC(ch) >= '0' && ch <= '9') + x = 10*x + ch - '0'; + while(ch <= ' ' && ch >= 0) + GETC(ch); + if (ch == EOF) + return EOF; + *val = sign ? -x : x; + *chp = ch; + return 0; + } + + static int +#ifdef KR_headers +getdimen(chp, d, delta, extent, x1) + int *chp; dimen *d; ftnlen delta, extent, *x1; +#else +getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) +#endif +{ + register int k; + ftnlen x2, x3; + + if (k = getnum(chp, x1)) + return k; + x3 = 1; + if (*chp == ':') { + if (k = getnum(chp, &x2)) + return k; + x2 -= *x1; + if (*chp == ':') { + if (k = getnum(chp, &x3)) + return k; + if (!x3) + return 123; + x2 /= x3; + colonseen = 1; + } + if (x2 < 0 || x2 >= extent) + return 123; + d->extent = x2 + 1; + } + else + d->extent = 1; + d->curval = 0; + d->delta = delta; + d->stride = x3; + return 0; + } + +#ifndef No_Namelist_Questions + static Void +#ifdef KR_headers +print_ne(a) cilist *a; +#else +print_ne(cilist *a) +#endif +{ + flag intext = f__external; + int rpsave = f__recpos; + FILE *cfsave = f__cf; + unit *usave = f__curunit; + cilist t; + t = *a; + t.ciunit = 6; + s_wsne(&t); + fflush(f__cf); + f__external = intext; + f__reading = 1; + f__recpos = rpsave; + f__cf = cfsave; + f__curunit = usave; + f__elist = a; + } +#endif + + static char where0[] = "namelist read start "; + + int +#ifdef KR_headers +x_rsne(a) cilist *a; +#else +x_rsne(cilist *a) +#endif +{ + int ch, got1, k, n, nd, quote, readall; + Namelist *nl; + static char where[] = "namelist read"; + char buf[64]; + hashtab *ht; + Vardesc *v; + dimen *dn, *dn0, *dn1; + ftnlen *dims, *dims1; + ftnlen b, b0, b1, ex, no, nomax, size, span; + ftnint no1, no2, type; + char *vaddr; + long iva, ivae; + dimen dimens[MAXDIM], substr; + + if (!Alpha['a']) + nl_init(); + f__reading=1; + f__formatted=1; + got1 = 0; + top: + for(;;) switch(GETC(ch)) { + case EOF: + eof: + err(a->ciend,(EOF),where0); + case '&': + case '$': + goto have_amp; +#ifndef No_Namelist_Questions + case '?': + print_ne(a); + continue; +#endif + default: + if (ch <= ' ' && ch >= 0) + continue; +#ifndef No_Namelist_Comments + while(GETC(ch) != '\n') + if (ch == EOF) + goto eof; +#else + errfl(a->cierr, 115, where0); +#endif + } + have_amp: + if (ch = getname(buf,sizeof(buf))) + return ch; + nl = (Namelist *)a->cifmt; + if (strcmp(buf, nl->name)) +#ifdef No_Bad_Namelist_Skip + errfl(a->cierr, 118, where0); +#else + { + fprintf(stderr, + "Skipping namelist \"%s\": seeking namelist \"%s\".\n", + buf, nl->name); + fflush(stderr); + for(;;) switch(GETC(ch)) { + case EOF: + err(a->ciend, EOF, where0); + case '/': + case '&': + case '$': + if (f__external) + e_rsle(); + else + z_rnew(); + goto top; + case '"': + case '\'': + quote = ch; + more_quoted: + while(GETC(ch) != quote) + if (ch == EOF) + err(a->ciend, EOF, where0); + if (GETC(ch) == quote) + goto more_quoted; + Ungetc(ch,f__cf); + default: + continue; + } + } +#endif + ht = mk_hashtab(nl); + if (!ht) + errfl(f__elist->cierr, 113, where0); + for(;;) { + for(;;) switch(GETC(ch)) { + case EOF: + if (got1) + return 0; + err(a->ciend, EOF, where0); + case '/': + case '$': + case '&': + return 0; + default: + if (ch <= ' ' && ch >= 0 || ch == ',') + continue; + Ungetc(ch,f__cf); + if (ch = getname(buf,sizeof(buf))) + return ch; + goto havename; + } + havename: + v = hash(ht,buf); + if (!v) + errfl(a->cierr, 119, where); + while(GETC(ch) <= ' ' && ch >= 0); + vaddr = v->addr; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + ivae = size; + iva = readall = 0; + if (ch == '(' /*)*/ ) { + dn = dimens; + if (!(dims = v->dims)) { + if (type != TYCHAR) + errfl(a->cierr, 122, where); + if (k = getdimen(&ch, dn, (ftnlen)size, + (ftnlen)size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = dn->extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + goto scalar; + } + nd = (int)dims[0]; + nomax = span = dims[1]; + ivae = iva + size*nomax; + colonseen = 0; + if (k = getdimen(&ch, dn, size, nomax, &b)) + errfl(a->cierr, k, where); + no = dn->extent; + b0 = dims[2]; + dims1 = dims += 3; + ex = 1; + for(n = 1; n++ < nd; dims++) { + if (ch != ',') + errfl(a->cierr, 115, where); + dn1 = dn + 1; + span /= *dims; + if (k = getdimen(&ch, dn1, dn->delta**dims, + span, &b1)) + errfl(a->cierr, k, where); + ex *= *dims; + b += b1*ex; + no *= dn1->extent; + dn = dn1; + } + if (ch != ')') + errfl(a->cierr, 115, where); + readall = 1 - colonseen; + b -= b0; + if (b < 0 || b >= nomax) + errfl(a->cierr, 125, where); + iva += size * b; + dims = dims1; + while(GETC(ch) <= ' ' && ch >= 0); + no1 = 1; + dn0 = dimens; + if (type == TYCHAR && ch == '(' /*)*/) { + if (k = getdimen(&ch, &substr, size, size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = substr.extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + b0 = size; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + if (b1 < b0) + goto delta_adj; + } + if (readall) + goto delta_adj; + for(; dn0 < dn; dn0++) { + if (dn0->extent != *dims++ || dn0->stride != 1) + break; + no1 *= dn0->extent; + } + if (dn0 == dimens && dimens[0].stride == 1) { + no1 = dimens[0].extent; + dn0++; + } + delta_adj: + ex = 0; + for(dn1 = dn0; dn1 <= dn; dn1++) + ex += (dn1->extent-1) + * (dn1->delta *= dn1->stride); + for(dn1 = dn; dn1 > dn0; dn1--) { + ex -= (dn1->extent - 1) * dn1->delta; + dn1->delta -= ex; + } + } + else if (dims = v->dims) { + no = no1 = dims[1]; + ivae = iva + no*size; + } + else + scalar: + no = no1 = 1; + if (ch != '=') + errfl(a->cierr, 115, where); + got1 = nml_read = 1; + f__lcount = 0; + readloop: + for(;;) { + if (iva >= ivae || iva < 0) { + f__lquit = 1; + goto mustend; + } + else if (iva + no1*size > ivae) + no1 = (ivae - iva)/size; + f__lquit = 0; + if (k = l_read(&no1, vaddr + iva, size, type)) + return k; + if (f__lquit == 1) + return 0; + if (readall) { + iva += dn0->delta; + if (f__lcount > 0) { + no2 = (ivae - iva)/size; + if (no2 > f__lcount) + no2 = f__lcount; + if (k = l_read(&no2, vaddr + iva, + size, type)) + return k; + iva += no2 * dn0->delta; + } + } + mustend: + GETC(ch); + if (readall) + if (iva >= ivae) + readall = 0; + else for(;;) { + switch(ch) { + case ' ': + case '\t': + case '\n': + GETC(ch); + continue; + } + break; + } + if (ch == '/' || ch == '$' || ch == '&') { + f__lquit = 1; + return 0; + } + else if (f__lquit) { + while(ch <= ' ' && ch >= 0) + GETC(ch); + Ungetc(ch,f__cf); + if (!Alpha[ch & 0xff] && ch >= 0) + errfl(a->cierr, 125, where); + break; + } + Ungetc(ch,f__cf); + if (readall && !Alpha[ch & 0xff]) + goto readloop; + if ((no -= no1) <= 0) + break; + for(dn1 = dn0; dn1 <= dn; dn1++) { + if (++dn1->curval < dn1->extent) { + iva += dn1->delta; + goto readloop; + } + dn1->curval = 0; + } + break; + } + } + } + + integer +#ifdef KR_headers +s_rsne(a) cilist *a; +#else +s_rsne(cilist *a) +#endif +{ + extern int l_eof; + int n; + + f__external=1; + l_eof = 0; + if(n = c_le(a)) + return n; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,where0); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + n = x_rsne(a); + nml_read = 0; + if (n) + return n; + return e_rsle(); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_cat.c b/unix/f2c/libf2c/s_cat.c new file mode 100644 index 00000000..8d92a637 --- /dev/null +++ b/unix/f2c/libf2c/s_cat.c @@ -0,0 +1,86 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the + * target of a concatenation to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90). + */ + +#include "f2c.h" +#ifndef NO_OVERWRITE +#include "stdio.h" +#undef abs +#ifdef KR_headers + extern char *F77_aloc(); + extern void free(); + extern void exit_(); +#else +#undef min +#undef max +#include "stdlib.h" +extern +#ifdef __cplusplus + "C" +#endif + char *F77_aloc(ftnlen, const char*); +#endif +#include "string.h" +#endif /* NO_OVERWRITE */ + +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll; +#else +s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) +#endif +{ + ftnlen i, nc; + char *rp; + ftnlen n = *np; +#ifndef NO_OVERWRITE + ftnlen L, m; + char *lp0, *lp1; + + lp0 = 0; + lp1 = lp; + L = ll; + i = 0; + while(i < n) { + rp = rpp[i]; + m = rnp[i++]; + if (rp >= lp1 || rp + m <= lp) { + if ((L -= m) <= 0) { + n = i; + break; + } + lp1 += m; + continue; + } + lp0 = lp; + lp = lp1 = F77_aloc(L = ll, "s_cat"); + break; + } + lp1 = lp; +#endif /* NO_OVERWRITE */ + for(i = 0 ; i < n ; ++i) { + nc = ll; + if(rnp[i] < nc) + nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while(--nc >= 0) + *lp++ = *rp++; + } + while(--ll >= 0) + *lp++ = ' '; +#ifndef NO_OVERWRITE + if (lp0) { + memcpy(lp0, lp1, L); + free(lp1); + } +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_cmp.c b/unix/f2c/libf2c/s_cmp.c new file mode 100644 index 00000000..3a2ea67d --- /dev/null +++ b/unix/f2c/libf2c/s_cmp.c @@ -0,0 +1,50 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* compare two strings */ + +#ifdef KR_headers +integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; +#else +integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +#endif +{ +register unsigned char *a, *aend, *b, *bend; +a = (unsigned char *)a0; +b = (unsigned char *)b0; +aend = a + la; +bend = b + lb; + +if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + + while(b < bend) + if(*b != ' ') + return( ' ' - *b ); + else ++b; + } + +else + { + while(b < bend) + if(*a == *b) + { ++a; ++b; } + else + return( *a - *b ); + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else ++a; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_copy.c b/unix/f2c/libf2c/s_copy.c new file mode 100644 index 00000000..9dacfc7d --- /dev/null +++ b/unix/f2c/libf2c/s_copy.c @@ -0,0 +1,57 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the + * target of an assignment to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90), + * as in a(2:5) = a(4:7) . + */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* assign strings: a = b */ + +#ifdef KR_headers +VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; +#else +void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +#endif +{ + register char *aend, *bend; + + aend = a + la; + + if(la <= lb) +#ifndef NO_OVERWRITE + if (a <= b || a >= b + la) +#endif + while(a < aend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else + for(b += la; a < aend; ) + *--aend = *--b; +#endif + + else { + bend = b + lb; +#ifndef NO_OVERWRITE + if (a <= b || a >= bend) +#endif + while(b < bend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else { + a += lb; + while(b < bend) + *--a = *--bend; + a += lb; + } +#endif + while(a < aend) + *a++ = ' '; + } + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_paus.c b/unix/f2c/libf2c/s_paus.c new file mode 100644 index 00000000..51d80eb0 --- /dev/null +++ b/unix/f2c/libf2c/s_paus.c @@ -0,0 +1,96 @@ +#include "stdio.h" +#include "f2c.h" +#define PAUSESIG 15 + +#include "signal1.h" +#ifdef KR_headers +#define Void /* void */ +#define Int /* int */ +#else +#define Void void +#define Int int +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern int getpid(void), isatty(int), pause(void); +#endif + +extern VOID f_exit(Void); + +#ifndef MSDOS + static VOID +waitpause(Sigarg) +{ Use_Sigarg; + return; + } +#endif + + static VOID +#ifdef KR_headers +s_1paus(fin) FILE *fin; +#else +s_1paus(FILE *fin) +#endif +{ + fprintf(stderr, + "To resume execution, type go. Other input will terminate the job.\n"); + fflush(stderr); + if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) { + fprintf(stderr, "STOP\n"); +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(0); + } + } + + int +#ifdef KR_headers +s_paus(s, n) char *s; ftnlen n; +#else +s_paus(char *s, ftnlen n) +#endif +{ + fprintf(stderr, "PAUSE "); + if(n > 0) + fprintf(stderr, " %.*s", (int)n, s); + fprintf(stderr, " statement executed\n"); + if( isatty(fileno(stdin)) ) + s_1paus(stdin); + else { +#ifdef MSDOS + FILE *fin; + fin = fopen("con", "r"); + if (!fin) { + fprintf(stderr, "s_paus: can't open con!\n"); + fflush(stderr); + exit(1); + } + s_1paus(fin); + fclose(fin); +#else + fprintf(stderr, + "To resume execution, execute a kill -%d %d command\n", + PAUSESIG, getpid() ); + signal1(PAUSESIG, waitpause); + fflush(stderr); + pause(); +#endif + } + fprintf(stderr, "Execution resumes after PAUSE.\n"); + fflush(stderr); + return 0; /* NOT REACHED */ +#ifdef __cplusplus + } +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_rnge.c b/unix/f2c/libf2c/s_rnge.c new file mode 100644 index 00000000..3dbc5135 --- /dev/null +++ b/unix/f2c/libf2c/s_rnge.c @@ -0,0 +1,32 @@ +#include "stdio.h" +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* called when a subscript is out of range */ + +#ifdef KR_headers +extern VOID sig_die(); +integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; +#else +extern VOID sig_die(const char*,int); +integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) +#endif +{ +register int i; + +fprintf(stderr, "Subscript out of range on file line %ld, procedure ", + (long)line); +while((i = *procn) && i != '_' && i != ' ') + putc(*procn++, stderr); +fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", + (long)offset+1); +while((i = *varn) && i != ' ') + putc(*varn++, stderr); +sig_die(".", 1); +return 0; /* not reached */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_stop.c b/unix/f2c/libf2c/s_stop.c new file mode 100644 index 00000000..68233aea --- /dev/null +++ b/unix/f2c/libf2c/s_stop.c @@ -0,0 +1,48 @@ +#include "stdio.h" +#include "f2c.h" + +#ifdef KR_headers +extern void f_exit(); +int s_stop(s, n) char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +void f_exit(void); + +int s_stop(char *s, ftnlen n) +#endif +{ +int i; + +if(n > 0) + { + fprintf(stderr, "STOP "); + for(i = 0; iciunit]; + if(a->ciunit >= MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") + if(!p->ufmt) err(a->cierr,102,"sfe") + return(0); +} +integer e_wsfe(Void) +{ + int n = en_fio(); + f__fmtbuf = NULL; +#ifdef ALWAYS_FLUSH + if (!n && fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + return n; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/sig_die.c b/unix/f2c/libf2c/sig_die.c new file mode 100644 index 00000000..63a73d91 --- /dev/null +++ b/unix/f2c/libf2c/sig_die.c @@ -0,0 +1,51 @@ +#include "stdio.h" +#include "signal.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifdef KR_headers +void sig_die(s, kill) char *s; int kill; +#else +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif + extern void f_exit(void); + +void sig_die(const char *s, int kill) +#endif +{ + /* print error message, then clear buffers */ + fprintf(stderr, "%s\n", s); + + if(kill) + { + fflush(stderr); + f_exit(); + fflush(stderr); + /* now get a core */ +#ifdef SIGIOT + signal(SIGIOT, SIG_DFL); +#endif + abort(); + } + else { +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(1); + } + } +#ifdef __cplusplus +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/signal1.h b/unix/f2c/libf2c/signal1.h new file mode 100644 index 00000000..a383774b --- /dev/null +++ b/unix/f2c/libf2c/signal1.h @@ -0,0 +1,35 @@ +/* You may need to adjust the definition of signal1 to supply a */ +/* cast to the correct argument type. This detail is system- and */ +/* compiler-dependent. The #define below assumes signal.h declares */ +/* type SIG_PF for the signal function's second argument. */ + +/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ + +#include + +#ifndef Sigret_t +#define Sigret_t void +#endif +#ifndef Sigarg_t +#ifdef KR_headers +#define Sigarg_t +#else +#define Sigarg_t int +#endif +#endif /*Sigarg_t*/ + +#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +#define sig_pf SIG_PF +#else +typedef Sigret_t (*sig_pf)(Sigarg_t); +#endif + +#define signal1(a,b) signal(a,(sig_pf)b) + +#ifdef __cplusplus +#define Sigarg ... +#define Use_Sigarg +#else +#define Sigarg Int n +#define Use_Sigarg n = n /* shut up compiler warning */ +#endif diff --git a/unix/f2c/libf2c/signal1.h0 b/unix/f2c/libf2c/signal1.h0 new file mode 100644 index 00000000..a383774b --- /dev/null +++ b/unix/f2c/libf2c/signal1.h0 @@ -0,0 +1,35 @@ +/* You may need to adjust the definition of signal1 to supply a */ +/* cast to the correct argument type. This detail is system- and */ +/* compiler-dependent. The #define below assumes signal.h declares */ +/* type SIG_PF for the signal function's second argument. */ + +/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ + +#include + +#ifndef Sigret_t +#define Sigret_t void +#endif +#ifndef Sigarg_t +#ifdef KR_headers +#define Sigarg_t +#else +#define Sigarg_t int +#endif +#endif /*Sigarg_t*/ + +#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +#define sig_pf SIG_PF +#else +typedef Sigret_t (*sig_pf)(Sigarg_t); +#endif + +#define signal1(a,b) signal(a,(sig_pf)b) + +#ifdef __cplusplus +#define Sigarg ... +#define Use_Sigarg +#else +#define Sigarg Int n +#define Use_Sigarg n = n /* shut up compiler warning */ +#endif diff --git a/unix/f2c/libf2c/signal_.c b/unix/f2c/libf2c/signal_.c new file mode 100644 index 00000000..3b0e6cfe --- /dev/null +++ b/unix/f2c/libf2c/signal_.c @@ -0,0 +1,21 @@ +#include "f2c.h" +#include "signal1.h" +#ifdef __cplusplus +extern "C" { +#endif + + ftnint +#ifdef KR_headers +signal_(sigp, proc) integer *sigp; sig_pf proc; +#else +signal_(integer *sigp, sig_pf proc) +#endif +{ + int sig; + sig = (int)*sigp; + + return (ftnint)signal(sig, proc); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/signbit.c b/unix/f2c/libf2c/signbit.c new file mode 100644 index 00000000..de95a3b7 --- /dev/null +++ b/unix/f2c/libf2c/signbit.c @@ -0,0 +1,24 @@ +#include "arith.h" + +#ifndef Long +#define Long long +#endif + + int +#ifdef KR_headers +signbit_f2c(x) double *x; +#else +signbit_f2c(double *x) +#endif +{ +#ifdef IEEE_MC68k + if (*(Long*)x & 0x80000000) + return 1; +#else +#ifdef IEEE_8087 + if (((Long*)x)[1] & 0x80000000) + return 1; +#endif /*IEEE_8087*/ +#endif /*IEEE_MC68k*/ + return 0; + } diff --git a/unix/f2c/libf2c/sue.c b/unix/f2c/libf2c/sue.c new file mode 100644 index 00000000..191e3262 --- /dev/null +++ b/unix/f2c/libf2c/sue.c @@ -0,0 +1,90 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +extern uiolen f__reclen; +OFF_T f__recloc; + + int +#ifdef KR_headers +c_sue(a) cilist *a; +#else +c_sue(cilist *a) +#endif +{ + f__external=f__sequential=1; + f__formatted=0; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit >= MXUNIT || a->ciunit < 0) + err(a->cierr,101,"startio"); + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) + err(a->cierr,114,"sue"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,103,"sue") + if(!f__curunit->useek) err(a->cierr,103,"sue") + return(0); +} +#ifdef KR_headers +integer s_rsue(a) cilist *a; +#else +integer s_rsue(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=1; + if(n=c_sue(a)) return(n); + f__recpos=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr, errno, "read start"); + if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) + != 1) + { if(feof(f__cf)) + { f__curunit->uend = 1; + err(a->ciend, EOF, "start"); + } + clearerr(f__cf); + err(a->cierr, errno, "start"); + } + return(0); +} +#ifdef KR_headers +integer s_wsue(a) cilist *a; +#else +integer s_wsue(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + if(n=c_sue(a)) return(n); + f__reading=0; + f__reclen=0; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "write start"); + f__recloc=FTELL(f__cf); + FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR); + return(0); +} +integer e_wsue(Void) +{ OFF_T loc; + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + loc=FTELL(f__cf); + FSEEK(f__cf,f__recloc,SEEK_SET); + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); + FSEEK(f__cf,loc,SEEK_SET); + return(0); +} +integer e_rsue(Void) +{ + FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/sysdep1.h b/unix/f2c/libf2c/sysdep1.h new file mode 100644 index 00000000..4c026a24 --- /dev/null +++ b/unix/f2c/libf2c/sysdep1.h @@ -0,0 +1,66 @@ +#ifndef SYSDEP_H_INCLUDED +#define SYSDEP_H_INCLUDED +#undef USE_LARGEFILE +#ifndef NO_LONG_LONG + +#ifdef __sun__ +#define USE_LARGEFILE +#define OFF_T off64_t +#endif + +#ifdef __linux__ +#define USE_LARGEFILE +#define OFF_T __off64_t +#endif + +#ifdef _AIX43 +#define _LARGE_FILES +#define _LARGE_FILE_API +#define USE_LARGEFILE +#endif /*_AIX43*/ + +#ifdef __hpux +#define _FILE64 +#define _LARGEFILE64_SOURCE +#define USE_LARGEFILE +#endif /*__hpux*/ + +#ifdef __sgi +#define USE_LARGEFILE +#endif /*__sgi*/ + +#ifdef __FreeBSD__ +#define OFF_T off_t +#define FSEEK fseeko +#define FTELL ftello +#endif + +#ifdef USE_LARGEFILE +#ifndef OFF_T +#define OFF_T off64_t +#endif +#define _LARGEFILE_SOURCE +#define _LARGEFILE64_SOURCE +#include +#include +#define FOPEN fopen64 +#define FREOPEN freopen64 +#define FSEEK fseeko64 +#define FSTAT fstat64 +#define FTELL ftello64 +#define FTRUNCATE ftruncate64 +#define STAT stat64 +#define STAT_ST stat64 +#endif /*USE_LARGEFILE*/ +#endif /*NO_LONG_LONG*/ + +#ifndef NON_UNIX_STDIO +#ifndef USE_LARGEFILE +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/stat.h" +#endif +#endif + +#endif /*SYSDEP_H_INCLUDED*/ diff --git a/unix/f2c/libf2c/sysdep1.h0 b/unix/f2c/libf2c/sysdep1.h0 new file mode 100644 index 00000000..4c026a24 --- /dev/null +++ b/unix/f2c/libf2c/sysdep1.h0 @@ -0,0 +1,66 @@ +#ifndef SYSDEP_H_INCLUDED +#define SYSDEP_H_INCLUDED +#undef USE_LARGEFILE +#ifndef NO_LONG_LONG + +#ifdef __sun__ +#define USE_LARGEFILE +#define OFF_T off64_t +#endif + +#ifdef __linux__ +#define USE_LARGEFILE +#define OFF_T __off64_t +#endif + +#ifdef _AIX43 +#define _LARGE_FILES +#define _LARGE_FILE_API +#define USE_LARGEFILE +#endif /*_AIX43*/ + +#ifdef __hpux +#define _FILE64 +#define _LARGEFILE64_SOURCE +#define USE_LARGEFILE +#endif /*__hpux*/ + +#ifdef __sgi +#define USE_LARGEFILE +#endif /*__sgi*/ + +#ifdef __FreeBSD__ +#define OFF_T off_t +#define FSEEK fseeko +#define FTELL ftello +#endif + +#ifdef USE_LARGEFILE +#ifndef OFF_T +#define OFF_T off64_t +#endif +#define _LARGEFILE_SOURCE +#define _LARGEFILE64_SOURCE +#include +#include +#define FOPEN fopen64 +#define FREOPEN freopen64 +#define FSEEK fseeko64 +#define FSTAT fstat64 +#define FTELL ftello64 +#define FTRUNCATE ftruncate64 +#define STAT stat64 +#define STAT_ST stat64 +#endif /*USE_LARGEFILE*/ +#endif /*NO_LONG_LONG*/ + +#ifndef NON_UNIX_STDIO +#ifndef USE_LARGEFILE +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/stat.h" +#endif +#endif + +#endif /*SYSDEP_H_INCLUDED*/ diff --git a/unix/f2c/libf2c/system_.c b/unix/f2c/libf2c/system_.c new file mode 100644 index 00000000..b18e8a67 --- /dev/null +++ b/unix/f2c/libf2c/system_.c @@ -0,0 +1,42 @@ +/* f77 interface to system routine */ + +#include "f2c.h" + +#ifdef KR_headers +extern char *F77_aloc(); + + integer +system_(s, n) register char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *F77_aloc(ftnlen, const char*); + + integer +system_(register char *s, ftnlen n) +#endif +{ + char buff0[256], *buff; + register char *bp, *blast; + integer rv; + + buff = bp = n < sizeof(buff0) + ? buff0 : F77_aloc(n+1, "system_"); + blast = bp + n; + + while(bp < blast && *s) + *bp++ = *s++; + *bp = 0; + rv = system(buff); + if (buff != buff0) + free(buff); + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/typesize.c b/unix/f2c/libf2c/typesize.c new file mode 100644 index 00000000..39097f46 --- /dev/null +++ b/unix/f2c/libf2c/typesize.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), + sizeof(real), sizeof(doublereal), + sizeof(complex), sizeof(doublecomplex), + sizeof(logical), sizeof(char), + 0, sizeof(integer1), + sizeof(logical1), sizeof(shortlogical), +#ifdef Allow_TYQUAD + sizeof(longint), +#endif + 0}; +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/uio.c b/unix/f2c/libf2c/uio.c new file mode 100644 index 00000000..44f768d9 --- /dev/null +++ b/unix/f2c/libf2c/uio.c @@ -0,0 +1,75 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +uiolen f__reclen; + + int +#ifdef KR_headers +do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +do_us(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__reading) + { + f__recpos += (int)(*number * len); + if(f__recpos>f__reclen) + err(f__elist->cierr, 110, "do_us"); + if (fread(ptr,(int)len,(int)(*number),f__cf) != *number) + err(f__elist->ciend, EOF, "do_us"); + return(0); + } + else + { + f__reclen += *number * len; + (void) fwrite(ptr,(int)len,(int)(*number),f__cf); + return(0); + } +} +#ifdef KR_headers +integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_ud(ftnint *number, char *ptr, ftnlen len) +#endif +{ + f__recpos += (int)(*number * len); + if(f__recpos > f__curunit->url && f__curunit->url!=1) + err(f__elist->cierr,110,"do_ud"); + if(f__reading) + { +#ifdef Pad_UDread +#ifdef KR_headers + int i; +#else + size_t i; +#endif + if (!(i = fread(ptr,(int)len,(int)(*number),f__cf)) + && !(f__recpos - *number*len)) + err(f__elist->cierr,EOF,"do_ud") + if (i < *number) + memset(ptr + i*len, 0, (*number - i)*len); + return 0; +#else + if(fread(ptr,(int)len,(int)(*number),f__cf) != *number) + err(f__elist->cierr,EOF,"do_ud") + else return(0); +#endif + } + (void) fwrite(ptr,(int)len,(int)(*number),f__cf); + return(0); +} +#ifdef KR_headers +integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_uio(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__sequential) + return(do_us(number,ptr,len)); + else return(do_ud(number,ptr,len)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/uninit.c b/unix/f2c/libf2c/uninit.c new file mode 100644 index 00000000..f15fe391 --- /dev/null +++ b/unix/f2c/libf2c/uninit.c @@ -0,0 +1,377 @@ +#include +#include +#include "arith.h" + +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYINT1 11 +#define TYQUAD 14 +#ifndef Long +#define Long long +#endif + +#ifdef __mips +#define RNAN 0xffc00000 +#define DNAN0 0xfff80000 +#define DNAN1 0 +#endif + +#ifdef _PA_RISC1_1 +#define RNAN 0xffc00000 +#define DNAN0 0xfff80000 +#define DNAN1 0 +#endif + +#ifndef RNAN +#define RNAN 0xff800001 +#ifdef IEEE_MC68k +#define DNAN0 0xfff00000 +#define DNAN1 1 +#else +#define DNAN0 1 +#define DNAN1 0xfff00000 +#endif +#endif /*RNAN*/ + +#ifdef KR_headers +#define Void /*void*/ +#define FA7UL (unsigned Long) 0xfa7a7a7aL +#else +#define Void void +#define FA7UL 0xfa7a7a7aUL +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +static void ieee0(Void); + +static unsigned Long rnan = RNAN, + dnan0 = DNAN0, + dnan1 = DNAN1; + +double _0 = 0.; + + void +#ifdef KR_headers +_uninit_f2c(x, type, len) void *x; int type; long len; +#else +_uninit_f2c(void *x, int type, long len) +#endif +{ + static int first = 1; + + unsigned Long *lx, *lxe; + + if (first) { + first = 0; + ieee0(); + } + if (len == 1) + switch(type) { + case TYINT1: + *(char*)x = 'Z'; + return; + case TYSHORT: + *(short*)x = 0xfa7a; + break; + case TYLONG: + *(unsigned Long*)x = FA7UL; + return; + case TYQUAD: + case TYCOMPLEX: + case TYDCOMPLEX: + break; + case TYREAL: + *(unsigned Long*)x = rnan; + return; + case TYDREAL: + lx = (unsigned Long*)x; + lx[0] = dnan0; + lx[1] = dnan1; + return; + default: + printf("Surprise type %d in _uninit_f2c\n", type); + } + switch(type) { + case TYINT1: + memset(x, 'Z', len); + break; + case TYSHORT: + *(short*)x = 0xfa7a; + break; + case TYQUAD: + len *= 2; + /* no break */ + case TYLONG: + lx = (unsigned Long*)x; + lxe = lx + len; + while(lx < lxe) + *lx++ = FA7UL; + break; + case TYCOMPLEX: + len *= 2; + /* no break */ + case TYREAL: + lx = (unsigned Long*)x; + lxe = lx + len; + while(lx < lxe) + *lx++ = rnan; + break; + case TYDCOMPLEX: + len *= 2; + /* no break */ + case TYDREAL: + lx = (unsigned Long*)x; + for(lxe = lx + 2*len; lx < lxe; lx += 2) { + lx[0] = dnan0; + lx[1] = dnan1; + } + } + } +#ifdef __cplusplus +} +#endif + +#ifndef MSpc +#ifdef MSDOS +#define MSpc +#else +#ifdef _WIN32 +#define MSpc +#endif +#endif +#endif + +#ifdef MSpc +#define IEEE0_done +#include "float.h" +#include "signal.h" + + static void +ieee0(Void) +{ +#ifndef __alpha +#ifndef EM_DENORMAL +#define EM_DENORMAL _EM_DENORMAL +#endif +#ifndef EM_UNDERFLOW +#define EM_UNDERFLOW _EM_UNDERFLOW +#endif +#ifndef EM_INEXACT +#define EM_INEXACT _EM_INEXACT +#endif +#ifndef MCW_EM +#define MCW_EM _MCW_EM +#endif + _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM); +#endif + /* With MS VC++, compiling and linking with -Zi will permit */ + /* clicking to invoke the MS C++ debugger, which will show */ + /* the point of error -- provided SIGFPE is SIG_DFL. */ + signal(SIGFPE, SIG_DFL); + } +#endif /* MSpc */ + +#ifdef __mips /* must link with -lfpe */ +#define IEEE0_done +/* code from Eric Grosse */ +#include +#include +#include "/usr/include/sigfpe.h" /* full pathname for lcc -N */ +#include "/usr/include/sys/fpu.h" + + static void +#ifdef KR_headers +ieeeuserhand(exception, val) unsigned exception[5]; int val[2]; +#else +ieeeuserhand(unsigned exception[5], int val[2]) +#endif +{ + fflush(stdout); + fprintf(stderr,"ieee0() aborting because of "); + if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n"); + else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n"); + else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n"); + else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n"); + else fprintf(stderr,"\tunknown reason\n"); + fflush(stderr); + abort(); +} + + static void +#ifdef KR_headers +ieeeuserhand2(j) unsigned int **j; +#else +ieeeuserhand2(unsigned int **j) +#endif +{ + fprintf(stderr,"ieee0() aborting because of confusion\n"); + abort(); +} + + static void +ieee0(Void) +{ + int i; + for(i=1; i<=4; i++){ + sigfpe_[i].count = 1000; + sigfpe_[i].trace = 1; + sigfpe_[i].repls = _USER_DETERMINED; + } + sigfpe_[1].repls = _ZERO; /* underflow */ + handle_sigfpes( _ON, + _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, + ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); + } +#endif /* mips */ + +#ifdef __linux__ +#define IEEE0_done +#include "fpu_control.h" + +#ifdef __alpha__ +#ifndef USE_setfpucw +#define __setfpucw(x) __fpu_control = (x) +#endif +#endif + +#ifndef _FPU_SETCW +#undef Can_use__setfpucw +#define Can_use__setfpucw +#endif + + static void +ieee0(Void) +{ +#if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) +/* Reported 20010705 by Alan Bain */ +/* Note that IEEE 754 IOP (illegal operation) */ +/* = Signaling NAN (SNAN) + operation error (OPERR). */ +#ifdef Can_use__setfpucw + __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); +#else + __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; + _FPU_SETCW(__fpu_control); +#endif + +#elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ +/* Reported 20011109 by Alan Bain */ + +#ifdef Can_use__setfpucw + +/* The following is NOT a mistake -- the author of the fpu_control.h +for the PPC has erroneously defined IEEE mode to turn on exceptions +other than Inexact! Start from default then and turn on only the ones +which we want*/ + + __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); + +#else /* PPC && !Can_use__setfpucw */ + + __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; + _FPU_SETCW(__fpu_control); + +#endif /*Can_use__setfpucw*/ + +#else /* !(mc68000||powerpc) */ + +#ifdef _FPU_IEEE +#ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ +#define _FPU_EXTENDED 0 +#endif +#ifndef _FPU_DOUBLE +#define _FPU_DOUBLE 0 +#endif +#ifdef Can_use__setfpucw /* pre-1997 (?) Linux */ + __setfpucw(_FPU_IEEE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); +#else +#ifdef UNINIT_F2C_PRECISION_53 /* 20051004 */ + /* unmask invalid, etc., and change rounding precision to double */ + __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; + _FPU_SETCW(__fpu_control); +#else + /* unmask invalid, etc., and keep current rounding precision */ + fpu_control_t cw; + _FPU_GETCW(cw); + cw &= ~(_FPU_MASK_IM | _FPU_MASK_ZM | _FPU_MASK_OM); + _FPU_SETCW(cw); +#endif +#endif + +#else /* !_FPU_IEEE */ + + fprintf(stderr, "\n%s\n%s\n%s\n%s\n", + "WARNING: _uninit_f2c in libf2c does not know how", + "to enable trapping on this system, so f2c's -trapuv", + "option will not detect uninitialized variables unless", + "you can enable trapping manually."); + fflush(stderr); + +#endif /* _FPU_IEEE */ +#endif /* __mc68k__ */ + } +#endif /* __linux__ */ + +#ifdef __alpha +#ifndef IEEE0_done +#define IEEE0_done +#include + static void +ieee0(Void) +{ + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); + } +#endif /*IEEE0_done*/ +#endif /*__alpha*/ + +#ifdef __hpux +#define IEEE0_done +#define _INCLUDE_HPUX_SOURCE +#include + +#ifndef FP_X_INV +#include +#define fpsetmask fesettrapenable +#define FP_X_INV FE_INVALID +#endif + + static void +ieee0(Void) +{ + fpsetmask(FP_X_INV); + } +#endif /*__hpux*/ + +#ifdef _AIX +#define IEEE0_done +#include + + static void +ieee0(Void) +{ + fp_enable(TRP_INVALID); + fp_trap(FP_TRAP_SYNC); + } +#endif /*_AIX*/ + +#ifdef __sun +#define IEEE0_done +#include + + static void +ieee0(Void) +{ + fpsetmask(FP_X_INV); + } +#endif /*__sparc*/ + +#ifndef IEEE0_done + static void +ieee0(Void) {} +#endif diff --git a/unix/f2c/libf2c/util.c b/unix/f2c/libf2c/util.c new file mode 100644 index 00000000..ad4bec5a --- /dev/null +++ b/unix/f2c/libf2c/util.c @@ -0,0 +1,57 @@ +#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +#define Const /*nothing*/ +g_char(a,alen,b) char *a,*b; ftnlen alen; +#else +#define Const const +g_char(const char *a, ftnlen alen, char *b) +#endif +{ + Const char *x = a + alen; + char *y = b + alen; + + for(;; y--) { + if (x <= a) { + *b = 0; + return; + } + if (*--x != ' ') + break; + } + *y-- = 0; + do *y-- = *x; + while(x-- > a); + } + + VOID +#ifdef KR_headers +b_char(a,b,blen) char *a,*b; ftnlen blen; +#else +b_char(const char *a, char *b, ftnlen blen) +#endif +{ int i; + for(i=0;i= d + 2 || f__scale <= -d) + goto nogood; + } + if(f__scale <= 0) + --d; + if (len == sizeof(real)) + dd = p->pf; + else + dd = p->pd; + if (dd < 0.) { + signspace = sign = 1; + dd = -dd; + } + else { + sign = 0; + signspace = (int)f__cplus; +#ifndef VAX + if (!dd) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&dd)) + signspace = sign = 1; +#endif + dd = 0.; /* avoid -0 */ + } +#endif + } + delta = w - (2 /* for the . and the d adjustment above */ + + 2 /* for the E+ */ + signspace + d + e); +#ifdef WANT_LEAD_0 + if (f__scale <= 0 && delta > 0) { + delta--; + insert0 = 1; + } + else +#endif + if (delta < 0) { +nogood: + while(--w >= 0) + PUT('*'); + return(0); + } + if (f__scale < 0) + d += f__scale; + if (d > FMAX) { + d1 = d - FMAX; + d = FMAX; + } + else + d1 = 0; + sprintf(buf,"%#.*E", d, dd); +#ifndef VAX + /* check for NaN, Infinity */ + if (!isdigit(buf[0])) { + switch(buf[0]) { + case 'n': + case 'N': + signspace = 0; /* no sign for NaNs */ + } + delta = w - strlen(buf) - signspace; + if (delta < 0) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + for(s = buf; *s; s++) + PUT(*s); + return 0; + } +#endif + se = buf + d + 3; +#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ + if (f__scale != 1 && dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +#else + if (dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); + else + strcpy(se, "+00"); +#endif + s = ++se; + if (e < 2) { + if (*s != '0') + goto nogood; + } +#ifndef VAX + /* accommodate 3 significant digits in exponent */ + if (s[2]) { +#ifdef Pedantic + if (!e0 && !s[3]) + for(s -= 2, e1 = 2; s[0] = s[1]; s++); + + /* Pedantic gives the behavior that Fortran 77 specifies, */ + /* i.e., requires that E be specified for exponent fields */ + /* of more than 3 digits. With Pedantic undefined, we get */ + /* the behavior that Cray displays -- you get a bigger */ + /* exponent field if it fits. */ +#else + if (!e0) { + for(s -= 2, e1 = 2; s[0] = s[1]; s++) +#ifdef CRAY + delta--; + if ((delta += 4) < 0) + goto nogood +#endif + ; + } +#endif + else if (e0 >= 0) + goto shift; + else + e1 = e; + } + else + shift: +#endif + for(s += 2, e1 = 2; *s; ++e1, ++s) + if (e1 >= e) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + s = buf; + i = f__scale; + if (f__scale <= 0) { +#ifdef WANT_LEAD_0 + if (insert0) + PUT('0'); +#endif + PUT('.'); + for(; i < 0; ++i) + PUT('0'); + PUT(*s); + s += 2; + } + else if (f__scale > 1) { + PUT(*s); + s += 2; + while(--i > 0) + PUT(*s++); + PUT('.'); + } + if (d1) { + se -= 2; + while(s < se) PUT(*s++); + se += 2; + do PUT('0'); while(--d1 > 0); + } + while(s < se) + PUT(*s++); + if (e < 2) + PUT(s[1]); + else { + while(++e1 <= e) + PUT('0'); + while(*s) + PUT(*s++); + } + return 0; + } + + int +#ifdef KR_headers +wrt_F(p,w,d,len) ufloat *p; ftnlen len; +#else +wrt_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + int d1, sign, n; + double x; + char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; + + x= (len==sizeof(real)?p->pf:p->pd); + if (d < MAXFRACDIGS) + d1 = 0; + else { + d1 = d - MAXFRACDIGS; + d = MAXFRACDIGS; + } + if (x < 0.) + { x = -x; sign = 1; } + else { + sign = 0; +#ifndef VAX + if (!x) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&x)) + sign = 2; +#endif + x = 0.; + } +#endif + } + + if (n = f__scale) + if (n > 0) + do x *= 10.; while(--n > 0); + else + do x *= 0.1; while(++n < 0); + +#ifdef USE_STRLEN + sprintf(b = buf, "%#.*f", d, x); + n = strlen(b) + d1; +#else + n = sprintf(b = buf, "%#.*f", d, x) + d1; +#endif + +#ifndef WANT_LEAD_0 + if (buf[0] == '0' && d) + { ++b; --n; } +#endif + if (sign == 1) { + /* check for all zeros */ + for(s = b;;) { + while(*s == '0') s++; + switch(*s) { + case '.': + s++; continue; + case 0: + sign = 0; + } + break; + } + } + if (sign || f__cplus) + ++n; + if (n > w) { +#ifdef WANT_LEAD_0 + if (buf[0] == '0' && --n == w) + ++b; + else +#endif + { + while(--w >= 0) + PUT('*'); + return 0; + } + } + for(w -= n; --w >= 0; ) + PUT(' '); + if (sign) + PUT('-'); + else if (f__cplus) + PUT('+'); + while(n = *b++) + PUT(n); + while(--d1 >= 0) + PUT('0'); + return 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wrtfmt.c b/unix/f2c/libf2c/wrtfmt.c new file mode 100644 index 00000000..a970db95 --- /dev/null +++ b/unix/f2c/libf2c/wrtfmt.c @@ -0,0 +1,377 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + +extern icilist *f__svic; +extern char *f__icptr; + + static int +mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ + /* instead we know too much about stdio */ +{ + int cursor = f__cursor; + f__cursor = 0; + if(f__external == 0) { + if(cursor < 0) { + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + f__icptr += cursor; + if(f__recpos < 0) + err(f__elist->cierr, 110, "left off"); + } + else if(cursor > 0) { + if(f__recpos + cursor >= f__svic->icirlen) + err(f__elist->cierr, 110, "recend"); + if(f__hiwater <= f__recpos) + for(; cursor > 0; cursor--) + (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { + cursor -= f__hiwater - f__recpos; + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { + f__icptr += cursor; + f__recpos += cursor; + } + } + return(0); + } + if (cursor > 0) { + if(f__hiwater <= f__recpos) + for(;cursor>0;cursor--) (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { + cursor -= f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { + f__recpos += cursor; + } + } + else if (cursor < 0) + { + if(cursor + f__recpos < 0) + err(f__elist->cierr,110,"left off"); + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + } + return(0); +} + + static int +#ifdef KR_headers +wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; +#else +wrt_Z(Uint *n, int w, int minlen, ftnlen len) +#endif +{ + register char *s, *se; + register int i, w1; + static int one = 1; + static char hex[] = "0123456789ABCDEF"; + s = (char *)n; + --len; + if (*(char *)&one) { + /* little endian */ + se = s; + s += len; + i = -1; + } + else { + se = s + len; + i = 1; + } + for(;; s += i) + if (s == se || *s) + break; + w1 = (i*(se-s) << 1) + 1; + if (*s & 0xf0) + w1++; + if (w1 > w) + for(i = 0; i < w; i++) + (*f__putn)('*'); + else { + if ((minlen -= w1) > 0) + w1 += minlen; + while(--w >= w1) + (*f__putn)(' '); + while(--minlen >= 0) + (*f__putn)('0'); + if (!(*s & 0xf0)) { + (*f__putn)(hex[*s & 0xf]); + if (s == se) + return 0; + s += i; + } + for(;; s += i) { + (*f__putn)(hex[*s >> 4 & 0xf]); + (*f__putn)(hex[*s & 0xf]); + if (s == se) + break; + } + } + return 0; + } + + static int +#ifdef KR_headers +wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; +#else +wrt_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ int ndigit,sign,spare,i; + longint x; + char *ans; + if(len==sizeof(integer)) x=n->il; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + spare=w-ndigit; + if(sign || f__cplus) spare--; + if(spare<0) + for(i=0;iil; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + if(sign || f__cplus) xsign=1; + else xsign=0; + if(ndigit+xsign>w || m+xsign>w) + { for(i=0;i=m) + spare=w-ndigit-xsign; + else + spare=w-m-xsign; + for(i=0;iil; + else if(sz == sizeof(char)) x = n->ic; + else x=n->is; + for(i=0;i 0) (*f__putn)(*p++); + return(0); +} + static int +#ifdef KR_headers +wrt_AW(p,w,len) char * p; ftnlen len; +#else +wrt_AW(char * p, int w, ftnlen len) +#endif +{ + while(w>len) + { w--; + (*f__putn)(' '); + } + while(w-- > 0) + (*f__putn)(*p++); + return(0); +} + + static int +#ifdef KR_headers +wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; +#else +wrt_G(ufloat *p, int w, int d, int e, ftnlen len) +#endif +{ double up = 1,x; + int i=0,oldscale,n,j; + x = len==sizeof(real)?p->pf:p->pd; + if(x < 0 ) x = -x; + if(x<.1) { + if (x != 0.) + return(wrt_E(p,w,d,e,len)); + i = 1; + goto have_i; + } + for(;i<=d;i++,up*=10) + { if(x>=up) continue; + have_i: + oldscale = f__scale; + f__scale = 0; + if(e==0) n=4; + else n=e+2; + i=wrt_F(p,w-n,d-i,len); + for(j=0;jop) + { + default: + fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); + case IM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); + case OM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); + case L: return(wrt_L((Uint *)ptr,p->p1, len)); + case A: return(wrt_A(ptr,len)); + case AW: + return(wrt_AW(ptr,p->p1,len)); + case D: + case E: + case EE: + return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); + case G: + case GE: + return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); + case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); + + /* Z and ZM assume 8-bit bytes. */ + + case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); + case ZM: + return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); + } +} + + int +#ifdef KR_headers +w_ned(p) struct syl *p; +#else +w_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case SLASH: + return((*f__donewrec)()); + case T: f__cursor = p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + case TR: + case X: + f__cursor += p->p1; + return(1); + case APOS: + return(wrt_AP(p->p2.s)); + case H: + return(wrt_H(p->p1,p->p2.s)); + } +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wsfe.c b/unix/f2c/libf2c/wsfe.c new file mode 100644 index 00000000..8709f3b3 --- /dev/null +++ b/unix/f2c/libf2c/wsfe.c @@ -0,0 +1,78 @@ +/*write sequential formatted external*/ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +x_wSL(Void) +{ + int n = f__putbuf('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return(n == 0); +} + + static int +xw_end(Void) +{ + int n; + + if(f__nonl) { + f__putbuf(n = 0); + fflush(f__cf); + } + else + n = f__putbuf('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return n; +} + + static int +xw_rev(Void) +{ + int n = 0; + if(f__workdone) { + n = f__putbuf('\n'); + f__workdone = 0; + } + f__hiwater = f__recpos = f__cursor = 0; + return n; +} + +#ifdef KR_headers +integer s_wsfe(a) cilist *a; /*start*/ +#else +integer s_wsfe(cilist *a) /*start*/ +#endif +{ int n; + if(!f__init) f_init(); + f__reading=0; + f__sequential=1; + f__formatted=1; + f__external=1; + if(n=c_sfe(a)) return(n); + f__elist=a; + f__hiwater = f__cursor=f__recpos=0; + f__nonl = 0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__putn= x_putc; + f__doed= w_ed; + f__doned= w_ned; + f__doend=xw_end; + f__dorevert=xw_rev; + f__donewrec=x_wSL; + fmt_bg(); + f__cplus=0; + f__cblank=f__curunit->ublnk; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wsle.c b/unix/f2c/libf2c/wsle.c new file mode 100644 index 00000000..3e602702 --- /dev/null +++ b/unix/f2c/libf2c/wsle.c @@ -0,0 +1,42 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer s_wsle(a) cilist *a; +#else +integer s_wsle(cilist *a) +#endif +{ + int n; + if(n=c_le(a)) return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = x_putc; + f__lioproc = l_write; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "list output start"); + return(0); + } + +integer e_wsle(Void) +{ + int n = f__putbuf('\n'); + f__recpos=0; +#ifdef ALWAYS_FLUSH + if (!n && fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + return(n); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wsne.c b/unix/f2c/libf2c/wsne.c new file mode 100644 index 00000000..e204a51a --- /dev/null +++ b/unix/f2c/libf2c/wsne.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif + + integer +#ifdef KR_headers +s_wsne(a) cilist *a; +#else +s_wsne(cilist *a) +#endif +{ + int n; + + if(n=c_le(a)) + return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = x_putc; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "namelist output start"); + x_wsne(a); + return e_wsle(); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/xsum0.out b/unix/f2c/libf2c/xsum0.out new file mode 100644 index 00000000..d6c6dc0b --- /dev/null +++ b/unix/f2c/libf2c/xsum0.out @@ -0,0 +1,182 @@ +Notice 76f23b4 1212 +README 19870416 16866 +abort_.c f51c808 304 +arithchk.c e460ec03 5299 +backspac.c 10ebf554 1328 +c_abs.c fec22c59 272 +c_cos.c 18fc0ea3 354 +c_div.c 1797c106 936 +c_exp.c 1b85b1fc 349 +c_log.c 28cdfed 384 +c_sin.c 1ccaedc8 350 +c_sqrt.c f1ee88d5 605 +cabs.c f3d3b5f2 494 +close.c 173f01de 1393 +comptry.bat f8a8a0d5 125 +ctype.c f553a125 40 +ctype.h 1e54977d 1139 +d_abs.c e58094ef 218 +d_acos.c e5ecf93d 245 +d_asin.c e12ceeff 245 +d_atan.c 53034db 245 +d_atn2.c ff8a1a78 271 +d_cnjg.c 1c27c728 255 +d_cos.c c0eb625 241 +d_cosh.c 11dc4adb 245 +d_dim.c e1ccb774 232 +d_exp.c 1879c41c 241 +d_imag.c fe9c703e 201 +d_int.c f5de3566 269 +d_lg10.c 1a1d7b77 291 +d_log.c 1b368adf 241 +d_mod.c f540cf24 688 +d_nint.c ff913b40 281 +d_prod.c ad4856b 207 +d_sign.c 9562fc5 266 +d_sin.c 6e3f542 241 +d_sinh.c 18b22950 245 +d_sqrt.c 17e1db09 245 +d_tan.c ec93ebdb 241 +d_tanh.c 1c55d15b 245 +derf_.c f85e74a3 239 +derfc_.c e96b7667 253 +dfe.c 1d658105 2624 +dolio.c 19c9fbd9 471 +dtime_.c c982be4 972 +due.c ee219f6d 1624 +ef1asc_.c e0576e63 521 +ef1cmc_.c ea5ad9e8 427 +endfile.c 6f7201d 2838 +erf_.c e82f7790 270 +erfc_.c ba65441 275 +err.c e59d1707 6442 +etime_.c 19d1fdad 839 +exit_.c ff4baa3a 543 +f2c.h0 e770b7d8 4688 +f2ch.add ef66bf17 6060 +f77_aloc.c f8daf96e 684 +f77vers.c ed1c96fa 4933 +fio.h e41d245e 2939 +fmt.c f9a1bb94 8566 +fmt.h ec84ce17 2006 +fmtlib.c eefc6a27 865 +fp.h 100fb355 665 +ftell_.c 78218d 900 +ftell64_.c e2c4b21e 917 +getarg_.c fd514f59 592 +getenv_.c f4b06e2 1223 +h_abs.c e4443109 218 +h_dim.c c6e48bc 230 +h_dnnt.c f6bb90e 294 +h_indx.c ef8461eb 442 +h_len.c e8c3633 205 +h_mod.c 7355bd0 207 +h_nint.c f0da3396 281 +h_sign.c f1370ffd 266 +hl_ge.c ed792501 346 +hl_gt.c feeacbd9 345 +hl_le.c f6fb5d6e 346 +hl_lt.c 18501419 345 +i77vers.c f57b8ef2 18128 +i_abs.c 12ab51ab 214 +i_dim.c f2a56785 225 +i_dnnt.c 11748482 291 +i_indx.c fb59026f 430 +i_len.c 17d17252 203 +i_mod.c bef73ae 211 +i_nint.c e494b804 278 +i_sign.c fa015b08 260 +iargc_.c 49abda3 196 +iio.c f958b627 2639 +ilnw.c fe0ab14b 1125 +inquire.c 1883d542 2732 +l_ge.c f4710e74 334 +l_gt.c e8db94a7 333 +l_le.c c9c0a99 334 +l_lt.c 767e79f 333 +lbitbits.c 33fe981 1097 +lbitshft.c e81981d2 258 +libf2c.lbc 10af591e 1594 +libf2c.sy fd5f568f 2051 +lio.h 805735d 1564 +lread.c f1e54a1f 14739 +lwrite.c f80da63f 4616 +main.c 371f60f 2230 +makefile.sy 174ccb83 2990 +makefile.u ed8e28fa 7379 +makefile.vc 18a3c2ce 2954 +makefile.wat 18b044ac 2936 +math.hvc 19bb2d07 50 +mkfile.plan9 e67e471e 5174 +open.c e7bcc295 5701 +pow_ci.c fa934cec 412 +pow_dd.c f004559b 276 +pow_di.c a4db539 448 +pow_hh.c d1a45a9 489 +pow_ii.c 1fcf2742 488 +pow_qq.c e6a32de6 516 +pow_ri.c e7d9fc2a 436 +pow_zi.c 1b894af7 851 +pow_zz.c f81a06b5 549 +qbitbits.c fdb9910e 1151 +qbitshft.c 873054d 258 +r_abs.c f471383c 206 +r_acos.c 1a6aca63 233 +r_asin.c e8555587 233 +r_atan.c eac25444 233 +r_atn2.c f611bea 253 +r_cnjg.c a8d7805 235 +r_cos.c fdef1ece 229 +r_cosh.c f05d1ae 233 +r_dim.c ee23e1a8 214 +r_exp.c 1da16cd7 229 +r_imag.c 166ad0f3 189 +r_int.c fc80b9a8 257 +r_lg10.c e876cfab 279 +r_log.c 2062254 229 +r_mod.c 187363fc 678 +r_nint.c 6edcbb2 269 +r_sign.c 1ae32441 248 +r_sin.c c3d968 229 +r_sinh.c 1090c850 233 +r_sqrt.c ffbb0625 233 +r_tan.c fe85179d 229 +r_tanh.c 10ffcc5b 233 +rawio.h 1ab49f7c 718 +rdfmt.c 7222fee 8925 +rewind.c e4c6236f 475 +rsfe.c eb9e882c 1492 +rsli.c 11f59b61 1785 +rsne.c fea7e5be 11585 +s_cat.c 164a6ff1 1458 +s_cmp.c e69e8b60 722 +s_copy.c 1e258852 1024 +s_paus.c e37cfe6 1617 +s_rnge.c e8cf83a3 759 +s_stop.c ffa80b24 762 +scomptry.bat ed740ad8 181 +sfe.c 1e10bda3 828 +sig_die.c 12eb0eac 689 +signal1.h0 1d43ee57 842 +signal_.c f3ef9cfc 299 +signbit.c e37eac06 330 +sue.c 9705ecf 1865 +sysdep1.h0 1812022d 1202 +system_.c ff72e46c 652 +typesize.c eee307ae 386 +uio.c e354a770 1619 +uninit.c fe760fb0 7584 +util.c 172fa76e 972 +wref.c 17bbfb7b 4747 +wrtfmt.c 113fc4f9 7506 +wsfe.c f2d1fe4d 1280 +wsle.c fe50b4c9 697 +wsne.c 428bfda 479 +xwsne.c 185c4bdc 1174 +z_abs.c 1fa0640d 268 +z_cos.c facccd9b 363 +z_div.c e6f03676 913 +z_exp.c 1a8506e8 357 +z_log.c 6bf3b22 2729 +z_sin.c 1aa35b59 359 +z_sqrt.c 1864d867 581 diff --git a/unix/f2c/libf2c/xwsne.c b/unix/f2c/libf2c/xwsne.c new file mode 100644 index 00000000..f810d3ed --- /dev/null +++ b/unix/f2c/libf2c/xwsne.c @@ -0,0 +1,77 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" + +extern int f__Aquote; + + static VOID +nl_donewrec(Void) +{ + (*f__donewrec)(); + PUT(' '); + } + +#ifdef KR_headers +x_wsne(a) cilist *a; +#else +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +x_wsne(cilist *a) +#endif +{ + Namelist *nl; + char *s; + Vardesc *v, **vd, **vde; + ftnint number, type; + ftnlen *dims; + ftnlen size; + extern ftnlen f__typesize[]; + + nl = (Namelist *)a->cifmt; + PUT('&'); + for(s = nl->name; *s; s++) + PUT(*s); + PUT(' '); + f__Aquote = 1; + vd = nl->vars; + vde = vd + nl->nvars; + while(vd < vde) { + v = *vd++; + s = v->name; +#ifdef No_Extra_Namelist_Newlines + if (f__recpos+strlen(s)+2 >= L_len) +#endif + nl_donewrec(); + while(*s) + PUT(*s++); + PUT(' '); + PUT('='); + number = (dims = v->dims) ? dims[1] : 1; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + l_write(&number, v->addr, size, type); + if (vd < vde) { + if (f__recpos+2 >= L_len) + nl_donewrec(); + PUT(','); + PUT(' '); + } + else if (f__recpos+1 >= L_len) + nl_donewrec(); + } + f__Aquote = 0; + PUT('/'); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_abs.c b/unix/f2c/libf2c/z_abs.c new file mode 100644 index 00000000..4d8a015d --- /dev/null +++ b/unix/f2c/libf2c/z_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double f__cabs(); +double z_abs(z) doublecomplex *z; +#else +double f__cabs(double, double); +double z_abs(doublecomplex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_cos.c b/unix/f2c/libf2c/z_cos.c new file mode 100644 index 00000000..4abe8bf8 --- /dev/null +++ b/unix/f2c/libf2c/z_cos.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_cos(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_cos(doublecomplex *r, doublecomplex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = cos(zr) * cosh(zi); + r->i = - sin(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_div.c b/unix/f2c/libf2c/z_div.c new file mode 100644 index 00000000..e45f3608 --- /dev/null +++ b/unix/f2c/libf2c/z_div.c @@ -0,0 +1,50 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); +VOID z_div(c, a, b) doublecomplex *a, *b, *c; +#else +extern void sig_die(const char*, int); +void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) +#endif +{ + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) + { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + if (a->i != 0 || a->r != 0) + abi = 1.; + c->i = c->r = abi / abr; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + + else + { + ratio = b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_exp.c b/unix/f2c/libf2c/z_exp.c new file mode 100644 index 00000000..7b8edfec --- /dev/null +++ b/unix/f2c/libf2c/z_exp.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(), cos(), sin(); +VOID z_exp(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_exp(doublecomplex *r, doublecomplex *z) +#endif +{ + double expx, zi = z->i; + + expx = exp(z->r); + r->r = expx * cos(zi); + r->i = expx * sin(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_log.c b/unix/f2c/libf2c/z_log.c new file mode 100644 index 00000000..4f11bbe0 --- /dev/null +++ b/unix/f2c/libf2c/z_log.c @@ -0,0 +1,121 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), f__cabs(), atan2(); +#define ANSI(x) () +#else +#define ANSI(x) x +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); +#endif + +#ifndef NO_DOUBLE_EXTENDED +#ifndef GCC_COMPARE_BUG_FIXED +#ifndef Pre20000310 +#ifdef Comment +Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3: +on IA32 (Intel 80x87) systems, they may do comparisons on values computed +in extended-precision registers. This can lead to the test "s > s0" that +was used below being carried out incorrectly. The fix below cannot be +spoiled by overzealous optimization, since the compiler cannot know +whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always +to be zero. The weird name is unlikely to collide with anything.) + +An example (provided by Ulrich Jakobus) where the bug fix matters is + + double complex a, b + a = (.1099557428756427618354862829619, .9857360542953131909982289471372) + b = log(a) + +An alternative to the fix below would be to use 53-bit rounding precision, +but the means of specifying this 80x87 feature are highly unportable. +#endif /*Comment*/ +#define BYPASS_GCC_COMPARE_BUG +double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*)); + static double +#ifdef KR_headers +diff1(a,b) double *a, *b; +#else +diff1(double *a, double *b) +#endif +{ return *a - *b; } +#endif /*Pre20000310*/ +#endif /*GCC_COMPARE_BUG_FIXED*/ +#endif /*NO_DOUBLE_EXTENDED*/ + +#ifdef KR_headers +VOID z_log(r, z) doublecomplex *r, *z; +#else +void z_log(doublecomplex *r, doublecomplex *z) +#endif +{ + double s, s0, t, t2, u, v; + double zi = z->i, zr = z->r; +#ifdef BYPASS_GCC_COMPARE_BUG + double (*diff) ANSI((double*,double*)); +#endif + + r->i = atan2(zi, zr); +#ifdef Pre20000310 + r->r = log( f__cabs( zr, zi ) ); +#else + if (zi < 0) + zi = -zi; + if (zr < 0) + zr = -zr; + if (zr < zi) { + t = zi; + zi = zr; + zr = t; + } + t = zi/zr; + s = zr * sqrt(1 + t*t); + /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */ + if ((t = s - 1) < 0) + t = -t; + if (t > .01) + r->r = log(s); + else { + +#ifdef Comment + + log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ... + + = x(1 - x/2 + x^2/3 -+...) + + [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so + + sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1] + +#endif /*Comment*/ + +#ifdef BYPASS_GCC_COMPARE_BUG + if (!(diff = gcc_bug_bypass_diff_F2C)) + diff = diff1; +#endif + t = ((zr*zr - 1.) + zi*zi) / (s + 1); + t2 = t*t; + s = 1. - 0.5*t; + u = v = 1; + do { + s0 = s; + u *= t2; + v += 2; + s += u/v - t*u/(v+1); + } +#ifdef BYPASS_GCC_COMPARE_BUG + while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.); +#else + while(s > s0); +#endif + r->r = s*t; + } +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_sin.c b/unix/f2c/libf2c/z_sin.c new file mode 100644 index 00000000..01225a94 --- /dev/null +++ b/unix/f2c/libf2c/z_sin.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_sin(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_sin(doublecomplex *r, doublecomplex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = sin(zr) * cosh(zi); + r->i = cos(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_sqrt.c b/unix/f2c/libf2c/z_sqrt.c new file mode 100644 index 00000000..35bd44c8 --- /dev/null +++ b/unix/f2c/libf2c/z_sqrt.c @@ -0,0 +1,35 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(), f__cabs(); +VOID z_sqrt(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); +void z_sqrt(doublecomplex *r, doublecomplex *z) +#endif +{ + double mag, zi = z->i, zr = z->r; + + if( (mag = f__cabs(zr, zi)) == 0.) + r->r = r->i = 0.; + else if(zr > 0) + { + r->r = sqrt(0.5 * (mag + zr) ); + r->i = zi / r->r / 2; + } + else + { + r->i = sqrt(0.5 * (mag - zr) ); + if(zi < 0) + r->i = - r->i; + r->r = zi / r->i / 2; + } + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf77 b/unix/f2c/libf77 new file mode 100644 index 00000000..ee82e9af --- /dev/null +++ b/unix/f2c/libf77 @@ -0,0 +1,5169 @@ +# to unbundle, sh this file (in an empty directory) +mkdir libF77 +echo libF77/uninit.c 1>&2 +sed >libF77/uninit.c <<'//GO.SYSIN DD libF77/uninit.c' 's/^-//' +-#include +-#include +-#include "arith.h" +- +-#define TYSHORT 2 +-#define TYLONG 3 +-#define TYREAL 4 +-#define TYDREAL 5 +-#define TYCOMPLEX 6 +-#define TYDCOMPLEX 7 +-#define TYINT1 11 +-#define TYQUAD 14 +-#ifndef Long +-#define Long long +-#endif +- +-#ifdef __mips +-#define RNAN 0xffc00000 +-#define DNAN0 0xfff80000 +-#define DNAN1 0 +-#endif +- +-#ifdef _PA_RISC1_1 +-#define RNAN 0xffc00000 +-#define DNAN0 0xfff80000 +-#define DNAN1 0 +-#endif +- +-#ifndef RNAN +-#define RNAN 0xff800001 +-#ifdef IEEE_MC68k +-#define DNAN0 0xfff00000 +-#define DNAN1 1 +-#else +-#define DNAN0 1 +-#define DNAN1 0xfff00000 +-#endif +-#endif /*RNAN*/ +- +-#ifdef KR_headers +-#define Void /*void*/ +-#define FA7UL (unsigned Long) 0xfa7a7a7aL +-#else +-#define Void void +-#define FA7UL 0xfa7a7a7aUL +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-static void ieee0(Void); +- +-static unsigned Long rnan = RNAN, +- dnan0 = DNAN0, +- dnan1 = DNAN1; +- +-double _0 = 0.; +- +- void +-#ifdef KR_headers +-_uninit_f2c(x, type, len) void *x; int type; long len; +-#else +-_uninit_f2c(void *x, int type, long len) +-#endif +-{ +- static int first = 1; +- +- unsigned Long *lx, *lxe; +- +- if (first) { +- first = 0; +- ieee0(); +- } +- if (len == 1) +- switch(type) { +- case TYINT1: +- *(char*)x = 'Z'; +- return; +- case TYSHORT: +- *(short*)x = 0xfa7a; +- break; +- case TYLONG: +- *(unsigned Long*)x = FA7UL; +- return; +- case TYQUAD: +- case TYCOMPLEX: +- case TYDCOMPLEX: +- break; +- case TYREAL: +- *(unsigned Long*)x = rnan; +- return; +- case TYDREAL: +- lx = (unsigned Long*)x; +- lx[0] = dnan0; +- lx[1] = dnan1; +- return; +- default: +- printf("Surprise type %d in _uninit_f2c\n", type); +- } +- switch(type) { +- case TYINT1: +- memset(x, 'Z', len); +- break; +- case TYSHORT: +- *(short*)x = 0xfa7a; +- break; +- case TYQUAD: +- len *= 2; +- /* no break */ +- case TYLONG: +- lx = (unsigned Long*)x; +- lxe = lx + len; +- while(lx < lxe) +- *lx++ = FA7UL; +- break; +- case TYCOMPLEX: +- len *= 2; +- /* no break */ +- case TYREAL: +- lx = (unsigned Long*)x; +- lxe = lx + len; +- while(lx < lxe) +- *lx++ = rnan; +- break; +- case TYDCOMPLEX: +- len *= 2; +- /* no break */ +- case TYDREAL: +- lx = (unsigned Long*)x; +- for(lxe = lx + 2*len; lx < lxe; lx += 2) { +- lx[0] = dnan0; +- lx[1] = dnan1; +- } +- } +- } +-#ifdef __cplusplus +-} +-#endif +- +-#ifndef MSpc +-#ifdef MSDOS +-#define MSpc +-#else +-#ifdef _WIN32 +-#define MSpc +-#endif +-#endif +-#endif +- +-#ifdef MSpc +-#define IEEE0_done +-#include "float.h" +-#include "signal.h" +- +- static void +-ieee0(Void) +-{ +-#ifndef __alpha +- _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM); +-#endif +- /* With MS VC++, compiling and linking with -Zi will permit */ +- /* clicking to invoke the MS C++ debugger, which will show */ +- /* the point of error -- provided SIGFPE is SIG_DFL. */ +- signal(SIGFPE, SIG_DFL); +- } +-#endif /* MSpc */ +- +-#ifdef __mips /* must link with -lfpe */ +-#define IEEE0_done +-/* code from Eric Grosse */ +-#include +-#include +-#include "/usr/include/sigfpe.h" /* full pathname for lcc -N */ +-#include "/usr/include/sys/fpu.h" +- +- static void +-#ifdef KR_headers +-ieeeuserhand(exception, val) unsigned exception[5]; int val[2]; +-#else +-ieeeuserhand(unsigned exception[5], int val[2]) +-#endif +-{ +- fflush(stdout); +- fprintf(stderr,"ieee0() aborting because of "); +- if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n"); +- else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n"); +- else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n"); +- else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n"); +- else fprintf(stderr,"\tunknown reason\n"); +- fflush(stderr); +- abort(); +-} +- +- static void +-#ifdef KR_headers +-ieeeuserhand2(j) unsigned int **j; +-#else +-ieeeuserhand2(unsigned int **j) +-#endif +-{ +- fprintf(stderr,"ieee0() aborting because of confusion\n"); +- abort(); +-} +- +- static void +-ieee0(Void) +-{ +- int i; +- for(i=1; i<=4; i++){ +- sigfpe_[i].count = 1000; +- sigfpe_[i].trace = 1; +- sigfpe_[i].repls = _USER_DETERMINED; +- } +- sigfpe_[1].repls = _ZERO; /* underflow */ +- handle_sigfpes( _ON, +- _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, +- ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); +- } +-#endif /* mips */ +- +-#ifdef __linux__ +-#define IEEE0_done +-#include "fpu_control.h" +- +-#ifdef __alpha__ +-#ifndef USE_setfpucw +-#define __setfpucw(x) __fpu_control = (x) +-#endif +-#endif +- +-#ifndef _FPU_SETCW +-#undef Can_use__setfpucw +-#define Can_use__setfpucw +-#endif +- +- static void +-ieee0(Void) +-{ +-#if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) +-/* Reported 20010705 by Alan Bain */ +-/* Note that IEEE 754 IOP (illegal operation) */ +-/* = Signaling NAN (SNAN) + operation error (OPERR). */ +-#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ +- __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); +-#else +- __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; +- _FPU_SETCW(__fpu_control); +-#endif +- +-#elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ +-/* Reported 20011109 by Alan Bain */ +- +-#ifdef Can_use__setfpucw +- +-/* The following is NOT a mistake -- the author of the fpu_control.h +-for the PPC has erroneously defined IEEE mode to turn on exceptions +-other than Inexact! Start from default then and turn on only the ones +-which we want*/ +- +- __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); +- +-#else /* PPC && !Can_use__setfpucw */ +- +- __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; +- _FPU_SETCW(__fpu_control); +- +-#endif /*Can_use__setfpucw*/ +- +-#else /* !(mc68000||powerpc) */ +- +-#ifdef _FPU_IEEE +-#ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ +-#define _FPU_EXTENDED 0 +-#endif +-#ifndef _FPU_DOUBLE +-#define _FPU_DOUBLE 0 +-#endif +-#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ +- __setfpucw(_FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); +-#else +- __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; +- _FPU_SETCW(__fpu_control); +-#endif +- +-#else /* !_FPU_IEEE */ +- +- fprintf(stderr, "\n%s\n%s\n%s\n%s\n", +- "WARNING: _uninit_f2c in libf2c does not know how", +- "to enable trapping on this system, so f2c's -trapuv", +- "option will not detect uninitialized variables unless", +- "you can enable trapping manually."); +- fflush(stderr); +- +-#endif /* _FPU_IEEE */ +-#endif /* __mc68k__ */ +- } +-#endif /* __linux__ */ +- +-#ifdef __alpha +-#ifndef IEEE0_done +-#define IEEE0_done +-#include +- static void +-ieee0(Void) +-{ +- ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); +- } +-#endif /*IEEE0_done*/ +-#endif /*__alpha*/ +- +-#ifdef __hpux +-#define IEEE0_done +-#define _INCLUDE_HPUX_SOURCE +-#include +- +-#ifndef FP_X_INV +-#include +-#define fpsetmask fesettrapenable +-#define FP_X_INV FE_INVALID +-#endif +- +- static void +-ieee0(Void) +-{ +- fpsetmask(FP_X_INV); +- } +-#endif /*__hpux*/ +- +-#ifdef _AIX +-#define IEEE0_done +-#include +- +- static void +-ieee0(Void) +-{ +- fp_enable(TRP_INVALID); +- fp_trap(FP_TRAP_SYNC); +- } +-#endif /*_AIX*/ +- +-#ifdef __sun +-#define IEEE0_done +-#include +- +- static void +-ieee0(Void) +-{ +- fpsetmask(FP_X_INV); +- } +-#endif /*__sparc*/ +- +-#ifndef IEEE0_done +- static void +-ieee0(Void) {} +-#endif +//GO.SYSIN DD libF77/uninit.c +echo libF77/arithchk.c 1>&2 +sed >libF77/arithchk.c <<'//GO.SYSIN DD libF77/arithchk.c' 's/^-//' +-/**************************************************************** +-Copyright (C) 1997, 1998, 2000 Lucent Technologies +-All Rights Reserved +- +-Permission to use, copy, modify, and distribute this software and +-its documentation for any purpose and without fee is hereby +-granted, provided that the above copyright notice appear in all +-copies and that both that the copyright notice and this +-permission notice and warranty disclaimer appear in supporting +-documentation, and that the name of Lucent or any of its entities +-not be used in advertising or publicity pertaining to +-distribution of the software without specific, written prior +-permission. +- +-LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, +-INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. +-IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY +-SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +-WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER +-IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +-ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +-THIS SOFTWARE. +-****************************************************************/ +- +-/* Try to deduce arith.h from arithmetic properties. */ +- +-#include +-#include +-#include +- +-#ifdef NO_FPINIT +-#define fpinit_ASL() +-#else +-#ifndef KR_headers +-extern +-#ifdef __cplusplus +- "C" +-#endif +- void fpinit_ASL(void); +-#endif /*KR_headers*/ +-#endif /*NO_FPINIT*/ +- +- static int dalign; +- typedef struct +-Akind { +- char *name; +- int kind; +- } Akind; +- +- static Akind +-IEEE_8087 = { "IEEE_8087", 1 }, +-IEEE_MC68k = { "IEEE_MC68k", 2 }, +-IBM = { "IBM", 3 }, +-VAX = { "VAX", 4 }, +-CRAY = { "CRAY", 5}; +- +- static double t_nan; +- +- static Akind * +-Lcheck() +-{ +- union { +- double d; +- long L[2]; +- } u; +- struct { +- double d; +- long L; +- } x[2]; +- +- if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) +- dalign = 1; +- u.L[0] = u.L[1] = 0; +- u.d = 1e13; +- if (u.L[0] == 1117925532 && u.L[1] == -448790528) +- return &IEEE_MC68k; +- if (u.L[1] == 1117925532 && u.L[0] == -448790528) +- return &IEEE_8087; +- if (u.L[0] == -2065213935 && u.L[1] == 10752) +- return &VAX; +- if (u.L[0] == 1267827943 && u.L[1] == 704643072) +- return &IBM; +- return 0; +- } +- +- static Akind * +-icheck() +-{ +- union { +- double d; +- int L[2]; +- } u; +- struct { +- double d; +- int L; +- } x[2]; +- +- if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) +- dalign = 1; +- u.L[0] = u.L[1] = 0; +- u.d = 1e13; +- if (u.L[0] == 1117925532 && u.L[1] == -448790528) +- return &IEEE_MC68k; +- if (u.L[1] == 1117925532 && u.L[0] == -448790528) +- return &IEEE_8087; +- if (u.L[0] == -2065213935 && u.L[1] == 10752) +- return &VAX; +- if (u.L[0] == 1267827943 && u.L[1] == 704643072) +- return &IBM; +- return 0; +- } +- +-char *emptyfmt = ""; /* avoid possible warning message with printf("") */ +- +- static Akind * +-ccheck() +-{ +- union { +- double d; +- long L; +- } u; +- long Cray1; +- +- /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ +- Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; +- if (printf(emptyfmt, Cray1) >= 0) +- Cray1 = 1000000*Cray1 + 693716; +- if (printf(emptyfmt, Cray1) >= 0) +- Cray1 = 1000000*Cray1 + 115456; +- u.d = 1e13; +- if (u.L == Cray1) +- return &CRAY; +- return 0; +- } +- +- static int +-fzcheck() +-{ +- double a, b; +- int i; +- +- a = 1.; +- b = .1; +- for(i = 155;; b *= b, i >>= 1) { +- if (i & 1) { +- a *= b; +- if (i == 1) +- break; +- } +- } +- b = a * a; +- return b == 0.; +- } +- +- static int +-need_nancheck() +-{ +- double t; +- +- errno = 0; +- t = log(t_nan); +- if (errno == 0) +- return 1; +- errno = 0; +- t = sqrt(t_nan); +- return errno == 0; +- } +- +-main() +-{ +- FILE *f; +- Akind *a = 0; +- int Ldef = 0; +- +- fpinit_ASL(); +-#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ +- f = fopen("arith.h", "w"); +- if (!f) { +- printf("Cannot open arith.h\n"); +- return 1; +- } +-#else +- f = stdout; +-#endif +- +- if (sizeof(double) == 2*sizeof(long)) +- a = Lcheck(); +- else if (sizeof(double) == 2*sizeof(int)) { +- Ldef = 1; +- a = icheck(); +- } +- else if (sizeof(double) == sizeof(long)) +- a = ccheck(); +- if (a) { +- fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", +- a->name, a->kind); +- if (Ldef) +- fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); +- if (dalign) +- fprintf(f, "#define Double_Align\n"); +- if (sizeof(char*) == 8) +- fprintf(f, "#define X64_bit_pointers\n"); +-#ifndef NO_LONG_LONG +- if (sizeof(long long) < 8) +-#endif +- fprintf(f, "#define NO_LONG_LONG\n"); +- if (a->kind <= 2) { +- if (fzcheck()) +- fprintf(f, "#define Sudden_Underflow\n"); +- t_nan = -a->kind; +- if (need_nancheck()) +- fprintf(f, "#define NANCHECK\n"); +- } +- return 0; +- } +- fprintf(f, "/* Unknown arithmetic */\n"); +- return 1; +- } +- +-#ifdef __sun +-#ifdef __i386 +-/* kludge for Intel Solaris */ +-void fpsetprec(int x) { } +-#endif +-#endif +//GO.SYSIN DD libF77/arithchk.c +echo libF77/f77vers.c 1>&2 +sed >libF77/f77vers.c <<'//GO.SYSIN DD libF77/f77vers.c' 's/^-//' +- char +-_libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20021004\n"; +- +-/* +-2.00 11 June 1980. File version.c added to library. +-2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed +- [ d]erf[c ] added +- 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c +- 29 Nov. 1989: s_cmp returns long (for f2c) +- 30 Nov. 1989: arg types from f2c.h +- 12 Dec. 1989: s_rnge allows long names +- 19 Dec. 1989: getenv_ allows unsorted environment +- 28 Mar. 1990: add exit(0) to end of main() +- 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main +- 17 Oct. 1990: abort() calls changed to sig_die(...,1) +- 22 Oct. 1990: separate sig_die from main +- 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die +- 31 May 1991: make system_ return status +- 18 Dec. 1991: change long to ftnlen (for -i2) many places +- 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) +- 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c +- and m**n in pow_hh.c and pow_ii.c; +- catch SIGTRAP in main() for error msg before abort +- 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined +- 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); +- change Cabs to f__cabs. +- 12 March 1993: various tweaks for C++ +- 2 June 1994: adjust so abnormal terminations invoke f_exit just once +- 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. +- 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS +- 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines +- that sign-extend right shifts when i is the most +- negative integer. +- 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side +- of character assignments to appear on the right-hand +- side (unless compiled with -DNO_OVERWRITE). +- 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever +- possible (for better cache behavior). +- 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. +- 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. +- 6 Sept. 1995: fix return type of system_ under -DKR_headers. +- 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. +- 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. +- 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). +- 19 June 1996: add casts to unsigned in [lq]bitshft.c. +- 26 Feb. 1997: adjust functions with a complex output argument +- to permit aliasing it with input arguments. +- (For now, at least, this is just for possible +- benefit of g77.) +- 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may +- affect systems using gratuitous extra precision). +- 19 Sept. 1997: [de]time_.c (Unix systems only): change return +- type to double. +- 2 May 1999: getenv_.c: omit environ in favor of getenv(). +- c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c, +- z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with +- overlapping arguments caused by equivalence. +- 3 May 1999: "invisible" tweaks to omit compiler warnings in +- abort_.c, ef1asc_.c, s_rnge.c, s_stop.c. +- +- 7 Sept. 1999: [cz]_div.c: arrange for compilation under +- -DIEEE_COMPLEX_DIVIDE to make these routines +- avoid calling sig_die when the denominator +- vanishes; instead, they return pairs of NaNs +- or Infinities, depending whether the numerator +- also vanishes or not. VERSION not changed. +- 15 Nov. 1999: s_rnge.c: add casts for the case of +- sizeof(ftnint) == sizeof(int) < sizeof(long). +- 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g., +- z near (+-1,eps) with |eps| small. For the old +- evaluation, compile with -DPre20000310 . +- 20 April 2000: s_cat.c: tweak argument types to accord with +- calls by f2c when ftnint and ftnlen are of +- different sizes (different numbers of bits). +- 4 July 2000: adjustments to permit compilation by C++ compilers; +- VERSION string remains unchanged. +- 29 Sept. 2000: dtime_.c, etime_.c: use floating-point divide. +- dtime_.d, erf_.c, erfc_.c, etime.c: for use with +- "f2c -R", compile with -DREAL=float. +- 23 June 2001: add uninit.c; [fi]77vers.c: make version strings +- visible as extern char _lib[fi]77_version_f2c[]. +- 5 July 2001: modify uninit.c for __mc68k__ under Linux. +- 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain. +- 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type, +- missing ~ on y in return value. +- 14 March 2002: z_log.c: add code to cope with buggy compilers +- (e.g., some versions of gcc under -O2 or -O3) +- that do floating-point comparisons against values +- computed into extended-precision registers on some +- systems (such as Intel IA32 systems). Compile with +- -DNO_DOUBLE_EXTENDED to omit the new logic. +- 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables. +-*/ +//GO.SYSIN DD libF77/f77vers.c +echo libF77/libF77.xsum 1>&2 +sed >libF77/libF77.xsum <<'//GO.SYSIN DD libF77/libF77.xsum' 's/^-//' +-F77_aloc.c f74c1f61 678 +-Notice 76f23b4 1212 +-README fbd01e7d 7210 +-abort_.c 1ef378f2 298 +-arithchk.c efc0d389 4669 +-c_abs.c fec22c59 272 +-c_cos.c 18fc0ea3 354 +-c_div.c f5424912 930 +-c_exp.c 1b85b1fc 349 +-c_log.c 28cdfed 384 +-c_sin.c 1ccaedc8 350 +-c_sqrt.c f1ee88d5 605 +-cabs.c f3d3b5f2 494 +-d_abs.c e58094ef 218 +-d_acos.c e5ecf93d 245 +-d_asin.c e12ceeff 245 +-d_atan.c 53034db 245 +-d_atn2.c ff8a1a78 271 +-d_cnjg.c 1c27c728 255 +-d_cos.c c0eb625 241 +-d_cosh.c 11dc4adb 245 +-d_dim.c e1ccb774 232 +-d_exp.c 1879c41c 241 +-d_imag.c fe9c703e 201 +-d_int.c f5de3566 269 +-d_lg10.c 1a1d7b77 291 +-d_log.c 1b368adf 241 +-d_mod.c f540cf24 688 +-d_nint.c ff913b40 281 +-d_prod.c ad4856b 207 +-d_sign.c 9562fc5 266 +-d_sin.c 6e3f542 241 +-d_sinh.c 18b22950 245 +-d_sqrt.c 17e1db09 245 +-d_tan.c ec93ebdb 241 +-d_tanh.c 1c55d15b 245 +-derf_.c f85e74a3 239 +-derfc_.c e96b7667 253 +-dtime_.c c982be4 972 +-ef1asc_.c e0576e63 521 +-ef1cmc_.c ea5ad9e8 427 +-erf_.c e82f7790 270 +-erfc_.c ba65441 275 +-etime_.c 19d1fdad 839 +-exit_.c ff4baa3a 543 +-f2ch.add ef66bf17 6060 +-f77vers.c 13362f51 4740 +-getarg_.c f182a268 562 +-getenv_.c ff3b797c 1217 +-h_abs.c e4443109 218 +-h_dim.c c6e48bc 230 +-h_dnnt.c f6bb90e 294 +-h_indx.c ef8461eb 442 +-h_len.c e8c3633 205 +-h_mod.c 7355bd0 207 +-h_nint.c f0da3396 281 +-h_sign.c f1370ffd 266 +-hl_ge.c ed792501 346 +-hl_gt.c feeacbd9 345 +-hl_le.c f6fb5d6e 346 +-hl_lt.c 18501419 345 +-i_abs.c 12ab51ab 214 +-i_dim.c f2a56785 225 +-i_dnnt.c 11748482 291 +-i_indx.c fb59026f 430 +-i_len.c 17d17252 203 +-i_mod.c bef73ae 211 +-i_nint.c e494b804 278 +-i_sign.c fa015b08 260 +-iargc_.c 49abda3 196 +-l_ge.c f4710e74 334 +-l_gt.c e8db94a7 333 +-l_le.c c9c0a99 334 +-l_lt.c 767e79f 333 +-lbitbits.c 33fe981 1097 +-lbitshft.c e81981d2 258 +-main.c dc8ce96 2219 +-makefile f4048935 4364 +-pow_ci.c fa934cec 412 +-pow_dd.c f004559b 276 +-pow_di.c a4db539 448 +-pow_hh.c d1a45a9 489 +-pow_ii.c 1fcf2742 488 +-pow_qq.c e6a32de6 516 +-pow_ri.c e7d9fc2a 436 +-pow_zi.c 1b894af7 851 +-pow_zz.c f81a06b5 549 +-qbitbits.c fdb9910e 1151 +-qbitshft.c 873054d 258 +-r_abs.c f471383c 206 +-r_acos.c 1a6aca63 233 +-r_asin.c e8555587 233 +-r_atan.c eac25444 233 +-r_atn2.c f611bea 253 +-r_cnjg.c a8d7805 235 +-r_cos.c fdef1ece 229 +-r_cosh.c f05d1ae 233 +-r_dim.c ee23e1a8 214 +-r_exp.c 1da16cd7 229 +-r_imag.c 166ad0f3 189 +-r_int.c fc80b9a8 257 +-r_lg10.c e876cfab 279 +-r_log.c 2062254 229 +-r_mod.c 187363fc 678 +-r_nint.c 6edcbb2 269 +-r_sign.c 1ae32441 248 +-r_sin.c c3d968 229 +-r_sinh.c 1090c850 233 +-r_sqrt.c ffbb0625 233 +-r_tan.c fe85179d 229 +-r_tanh.c 10ffcc5b 233 +-s_cat.c 3070507 1452 +-s_cmp.c e69e8b60 722 +-s_copy.c 1e258852 1024 +-s_paus.c 245d604 1596 +-s_rnge.c fd20c6b4 753 +-s_stop.c ffa80b24 762 +-sig_die.c fbcad8d6 701 +-signal1.h0 1d43ee57 842 +-signal_.c f3ef9cfc 299 +-system_.c eae6254c 646 +-uninit.c 183c9847 7170 +-z_abs.c 1fa0640d 268 +-z_cos.c facccd9b 363 +-z_div.c 1abdf45a 907 +-z_exp.c 1a8506e8 357 +-z_log.c 6bf3b22 2729 +-z_sin.c 1aa35b59 359 +-z_sqrt.c 1864d867 581 +//GO.SYSIN DD libF77/libF77.xsum +echo libF77/main.c 1>&2 +sed >libF77/main.c <<'//GO.SYSIN DD libF77/main.c' 's/^-//' +-/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ +- +-#include "stdio.h" +-#include "signal1.h" +- +-#ifndef SIGIOT +-#ifdef SIGABRT +-#define SIGIOT SIGABRT +-#endif +-#endif +- +-#ifndef KR_headers +-#undef VOID +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-#ifndef VOID +-#define VOID void +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef NO__STDC +-#define ONEXIT onexit +-extern VOID f_exit(); +-#else +-#ifndef KR_headers +-extern void f_exit(void); +-#ifndef NO_ONEXIT +-#define ONEXIT atexit +-extern int atexit(void (*)(void)); +-#endif +-#else +-#ifndef NO_ONEXIT +-#define ONEXIT onexit +-extern VOID f_exit(); +-#endif +-#endif +-#endif +- +-#ifdef KR_headers +-extern VOID f_init(), sig_die(); +-extern int MAIN__(); +-#define Int /* int */ +-#else +-extern void f_init(void), sig_die(char*, int); +-extern int MAIN__(void); +-#define Int int +-#endif +- +-static VOID sigfdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Floating Exception", 1); +-} +- +- +-static VOID sigidie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("IOT Trap", 1); +-} +- +-#ifdef SIGQUIT +-static VOID sigqdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Quit signal", 1); +-} +-#endif +- +- +-static VOID sigindie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Interrupt", 0); +-} +- +-static VOID sigtdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Killed", 0); +-} +- +-#ifdef SIGTRAP +-static VOID sigtrdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Trace trap", 1); +-} +-#endif +- +- +-int xargc; +-char **xargv; +- +-#ifdef __cplusplus +- } +-#endif +- +-#ifdef KR_headers +-main(argc, argv) int argc; char **argv; +-#else +-main(int argc, char **argv) +-#endif +-{ +-xargc = argc; +-xargv = argv; +-signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ +-#ifdef SIGIOT +-signal1(SIGIOT, sigidie); +-#endif +-#ifdef SIGTRAP +-signal1(SIGTRAP, sigtrdie); +-#endif +-#ifdef SIGQUIT +-if(signal1(SIGQUIT,sigqdie) == SIG_IGN) +- signal1(SIGQUIT, SIG_IGN); +-#endif +-if(signal1(SIGINT, sigindie) == SIG_IGN) +- signal1(SIGINT, SIG_IGN); +-signal1(SIGTERM,sigtdie); +- +-#ifdef pdp11 +- ldfps(01200); /* detect overflow as an exception */ +-#endif +- +-f_init(); +-#ifndef NO_ONEXIT +-ONEXIT(f_exit); +-#endif +-MAIN__(); +-#ifdef NO_ONEXIT +-f_exit(); +-#endif +-exit(0); /* exit(0) rather than return(0) to bypass Cray bug */ +-return 0; /* For compilers that complain of missing return values; */ +- /* others will complain that this is unreachable code. */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/main.c +echo libF77/makefile 1>&2 +sed >libF77/makefile <<'//GO.SYSIN DD libF77/makefile' 's/^-//' +-.SUFFIXES: .c .o +-CC = cc +-SHELL = /bin/sh +-CFLAGS = -O +- +-# If your system lacks onexit() and you are not using an +-# ANSI C compiler, then you should add -DNO_ONEXIT to CFLAGS, +-# e.g., by changing the above "CFLAGS =" line to +-# CFLAGS = -O -DNO_ONEXIT +- +-# On at least some Sun systems, it is more appropriate to change the +-# "CFLAGS =" line to +-# CFLAGS = -O -Donexit=on_exit +- +-# compile, then strip unnecessary symbols +-.c.o: +- $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c +- ld -r -x -o $*.xxx $*.o +- mv $*.xxx $*.o +-## Under Solaris (and other systems that do not understand ld -x), +-## omit -x in the ld line above. +-## If your system does not have the ld command, comment out +-## or remove both the ld and mv lines above. +- +-MISC = F77_aloc.o main.o s_rnge.o abort_.o f77vers.o getarg_.o iargc_.o \ +- getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\ +- derf_.o derfc_.o erf_.o erfc_.o sig_die.o exit_.o uninit.o +-POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o +-CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +-DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +-REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ +- r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ +- r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ +- r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +-DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ +- d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ +- d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ +- d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ +- d_sqrt.o d_tan.o d_tanh.o +-INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o +-HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +-CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +-EFL = ef1asc_.o ef1cmc_.o +-CHAR = F77_aloc.o s_cat.o s_cmp.o s_copy.o +-F90BIT = lbitbits.o lbitshft.o +-QINT = pow_qq.o qbitbits.o qbitshft.o +-TIME = dtime_.o etime_.o +- +-all: signal1.h libF77.a +- +-# You may need to adjust signal1.h suitably for your system... +-signal1.h: signal1.h0 +- cp signal1.h0 signal1.h +- +-# If you get an error compiling dtime_.c or etime_.c, try adding +-# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work, +-# omit $(TIME) from the dependency list for libF77.a below. +- +-# For INTEGER*8 support (which requires system-dependent adjustments to +-# f2c.h), add $(QINT) to the libf2c.a dependency list below... +- +-libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ +- $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT) $(TIME) +- ar r libF77.a $? +- ranlib libF77.a || true +- +-### If your system lacks ranlib, you don't need it; see README. +- +-# f77vers.c was "Version.c"; renamed on 20010623 to accord with libf2c.zip. +- +-f77vers.o: f77vers.c +- $(CC) -c f77vers.c +- +-uninit.o: arith.h +- +-arith.h: arithchk.c +- $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\ +- $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm +- ./a.out >arith.h +- rm -f a.out arithchk.o +- +-# To compile with C++, first "make f2c.h" +-f2c.h: f2ch.add +- cat /usr/include/f2c.h f2ch.add >f2c.h +- +-install: libF77.a +- mv libF77.a $(LIBDIR)/libF77.a +- ranlib $(LIBDIR)/libF77.a || true +- +-clean: +- rm -f libF77.a *.o arith.h +- +-check: +- xsum F77_aloc.c Notice README abort_.c arithchk.c c_abs.c \ +- c_cos.c c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c \ +- d_abs.c d_acos.c \ +- d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \ +- d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \ +- d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \ +- derf_.c derfc_.c dtime_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c \ +- etime_.c exit_.c f2ch.add f77vers.c \ +- getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ +- h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ +- i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c \ +- i_sign.c iargc_.c l_ge.c l_gt.c l_le.c l_lt.c lbitbits.c lbitshft.c \ +- main.c makefile pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c \ +- pow_qq.c pow_ri.c pow_zi.c pow_zz.c qbitbits.c qbitshft.c \ +- r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ +- r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ +- r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ +- r_tan.c r_tanh.c s_cat.c s_cmp.c s_copy.c \ +- s_paus.c s_rnge.c s_stop.c sig_die.c signal1.h0 signal_.c system_.c \ +- uninit.c z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >zap +- cmp zap libF77.xsum && rm zap || diff libF77.xsum zap +//GO.SYSIN DD libF77/makefile +echo libF77/pow_ci.c 1>&2 +sed >libF77/pow_ci.c <<'//GO.SYSIN DD libF77/pow_ci.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-VOID pow_ci(p, a, b) /* p = a**b */ +- complex *p, *a; integer *b; +-#else +-extern void pow_zi(doublecomplex*, doublecomplex*, integer*); +-void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */ +-#endif +-{ +-doublecomplex p1, a1; +- +-a1.r = a->r; +-a1.i = a->i; +- +-pow_zi(&p1, &a1, b); +- +-p->r = p1.r; +-p->i = p1.i; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_ci.c +echo libF77/pow_dd.c 1>&2 +sed >libF77/pow_dd.c <<'//GO.SYSIN DD libF77/pow_dd.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double pow(); +-double pow_dd(ap, bp) doublereal *ap, *bp; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double pow_dd(doublereal *ap, doublereal *bp) +-#endif +-{ +-return(pow(*ap, *bp) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_dd.c +echo libF77/pow_di.c 1>&2 +sed >libF77/pow_di.c <<'//GO.SYSIN DD libF77/pow_di.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double pow_di(ap, bp) doublereal *ap; integer *bp; +-#else +-double pow_di(doublereal *ap, integer *bp) +-#endif +-{ +-double pow, x; +-integer n; +-unsigned long u; +- +-pow = 1; +-x = *ap; +-n = *bp; +- +-if(n != 0) +- { +- if(n < 0) +- { +- n = -n; +- x = 1/x; +- } +- for(u = n; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- } +-return(pow); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_di.c +echo libF77/pow_hh.c 1>&2 +sed >libF77/pow_hh.c <<'//GO.SYSIN DD libF77/pow_hh.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint pow_hh(ap, bp) shortint *ap, *bp; +-#else +-shortint pow_hh(shortint *ap, shortint *bp) +-#endif +-{ +- shortint pow, x, n; +- unsigned u; +- +- x = *ap; +- n = *bp; +- +- if (n <= 0) { +- if (n == 0 || x == 1) +- return 1; +- if (x != -1) +- return x == 0 ? 1/x : 0; +- n = -n; +- } +- u = n; +- for(pow = 1; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- return(pow); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_hh.c +echo libF77/pow_ii.c 1>&2 +sed >libF77/pow_ii.c <<'//GO.SYSIN DD libF77/pow_ii.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer pow_ii(ap, bp) integer *ap, *bp; +-#else +-integer pow_ii(integer *ap, integer *bp) +-#endif +-{ +- integer pow, x, n; +- unsigned long u; +- +- x = *ap; +- n = *bp; +- +- if (n <= 0) { +- if (n == 0 || x == 1) +- return 1; +- if (x != -1) +- return x == 0 ? 1/x : 0; +- n = -n; +- } +- u = n; +- for(pow = 1; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- return(pow); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_ii.c +echo libF77/pow_qq.c 1>&2 +sed >libF77/pow_qq.c <<'//GO.SYSIN DD libF77/pow_qq.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-longint pow_qq(ap, bp) longint *ap, *bp; +-#else +-longint pow_qq(longint *ap, longint *bp) +-#endif +-{ +- longint pow, x, n; +- unsigned long long u; /* system-dependent */ +- +- x = *ap; +- n = *bp; +- +- if (n <= 0) { +- if (n == 0 || x == 1) +- return 1; +- if (x != -1) +- return x == 0 ? 1/x : 0; +- n = -n; +- } +- u = n; +- for(pow = 1; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- return(pow); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_qq.c +echo libF77/pow_ri.c 1>&2 +sed >libF77/pow_ri.c <<'//GO.SYSIN DD libF77/pow_ri.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double pow_ri(ap, bp) real *ap; integer *bp; +-#else +-double pow_ri(real *ap, integer *bp) +-#endif +-{ +-double pow, x; +-integer n; +-unsigned long u; +- +-pow = 1; +-x = *ap; +-n = *bp; +- +-if(n != 0) +- { +- if(n < 0) +- { +- n = -n; +- x = 1/x; +- } +- for(u = n; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- } +-return(pow); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_ri.c +echo libF77/pow_zi.c 1>&2 +sed >libF77/pow_zi.c <<'//GO.SYSIN DD libF77/pow_zi.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-VOID pow_zi(p, a, b) /* p = a**b */ +- doublecomplex *p, *a; integer *b; +-#else +-extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); +-void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ +-#endif +-{ +- integer n; +- unsigned long u; +- double t; +- doublecomplex q, x; +- static doublecomplex one = {1.0, 0.0}; +- +- n = *b; +- q.r = 1; +- q.i = 0; +- +- if(n == 0) +- goto done; +- if(n < 0) +- { +- n = -n; +- z_div(&x, &one, a); +- } +- else +- { +- x.r = a->r; +- x.i = a->i; +- } +- +- for(u = n; ; ) +- { +- if(u & 01) +- { +- t = q.r * x.r - q.i * x.i; +- q.i = q.r * x.i + q.i * x.r; +- q.r = t; +- } +- if(u >>= 1) +- { +- t = x.r * x.r - x.i * x.i; +- x.i = 2 * x.r * x.i; +- x.r = t; +- } +- else +- break; +- } +- done: +- p->i = q.i; +- p->r = q.r; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_zi.c +echo libF77/pow_zz.c 1>&2 +sed >libF77/pow_zz.c <<'//GO.SYSIN DD libF77/pow_zz.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(), exp(), cos(), sin(), atan2(), f__cabs(); +-VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double,double); +-void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b) +-#endif +-{ +-double logr, logi, x, y; +- +-logr = log( f__cabs(a->r, a->i) ); +-logi = atan2(a->i, a->r); +- +-x = exp( logr * b->r - logi * b->i ); +-y = logr * b->i + logi * b->r; +- +-r->r = x * cos(y); +-r->i = x * sin(y); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_zz.c +echo libF77/qbitbits.c 1>&2 +sed >libF77/qbitbits.c <<'//GO.SYSIN DD libF77/qbitbits.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef LONGBITS +-#define LONGBITS 32 +-#endif +- +-#ifndef LONG8BITS +-#define LONG8BITS (2*LONGBITS) +-#endif +- +- longint +-#ifdef KR_headers +-qbit_bits(a, b, len) longint a; integer b, len; +-#else +-qbit_bits(longint a, integer b, integer len) +-#endif +-{ +- /* Assume 2's complement arithmetic */ +- +- ulongint x, y; +- +- x = (ulongint) a; +- y = (ulongint)-1L; +- x >>= b; +- y <<= len; +- return (longint)(x & ~y); +- } +- +- longint +-#ifdef KR_headers +-qbit_cshift(a, b, len) longint a; integer b, len; +-#else +-qbit_cshift(longint a, integer b, integer len) +-#endif +-{ +- ulongint x, y, z; +- +- x = (ulongint)a; +- if (len <= 0) { +- if (len == 0) +- return 0; +- goto full_len; +- } +- if (len >= LONG8BITS) { +- full_len: +- if (b >= 0) { +- b %= LONG8BITS; +- return (longint)(x << b | x >> LONG8BITS - b ); +- } +- b = -b; +- b %= LONG8BITS; +- return (longint)(x << LONG8BITS - b | x >> b); +- } +- y = z = (unsigned long)-1; +- y <<= len; +- z &= ~y; +- y &= x; +- x &= z; +- if (b >= 0) { +- b %= len; +- return (longint)(y | z & (x << b | x >> len - b)); +- } +- b = -b; +- b %= len; +- return (longint)(y | z & (x >> b | x << len - b)); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/qbitbits.c +echo libF77/qbitshft.c 1>&2 +sed >libF77/qbitshft.c <<'//GO.SYSIN DD libF77/qbitshft.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- longint +-#ifdef KR_headers +-qbit_shift(a, b) longint a; integer b; +-#else +-qbit_shift(longint a, integer b) +-#endif +-{ +- return b >= 0 ? a << b : (longint)((ulongint)a >> -b); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/qbitshft.c +echo libF77/r_abs.c 1>&2 +sed >libF77/r_abs.c <<'//GO.SYSIN DD libF77/r_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_abs(x) real *x; +-#else +-double r_abs(real *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_abs.c +echo libF77/r_acos.c 1>&2 +sed >libF77/r_acos.c <<'//GO.SYSIN DD libF77/r_acos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double acos(); +-double r_acos(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_acos(real *x) +-#endif +-{ +-return( acos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_acos.c +echo libF77/r_asin.c 1>&2 +sed >libF77/r_asin.c <<'//GO.SYSIN DD libF77/r_asin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double asin(); +-double r_asin(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_asin(real *x) +-#endif +-{ +-return( asin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_asin.c +echo libF77/r_atan.c 1>&2 +sed >libF77/r_atan.c <<'//GO.SYSIN DD libF77/r_atan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan(); +-double r_atan(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_atan(real *x) +-#endif +-{ +-return( atan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_atan.c +echo libF77/r_atn2.c 1>&2 +sed >libF77/r_atn2.c <<'//GO.SYSIN DD libF77/r_atn2.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan2(); +-double r_atn2(x,y) real *x, *y; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_atn2(real *x, real *y) +-#endif +-{ +-return( atan2(*x,*y) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_atn2.c +echo libF77/z_sqrt.c 1>&2 +sed >libF77/z_sqrt.c <<'//GO.SYSIN DD libF77/z_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sqrt(), f__cabs(); +-VOID z_sqrt(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +-void z_sqrt(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double mag, zi = z->i, zr = z->r; +- +- if( (mag = f__cabs(zr, zi)) == 0.) +- r->r = r->i = 0.; +- else if(zr > 0) +- { +- r->r = sqrt(0.5 * (mag + zr) ); +- r->i = zi / r->r / 2; +- } +- else +- { +- r->i = sqrt(0.5 * (mag - zr) ); +- if(zi < 0) +- r->i = - r->i; +- r->r = zi / r->i / 2; +- } +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_sqrt.c +echo libF77/r_cnjg.c 1>&2 +sed >libF77/r_cnjg.c <<'//GO.SYSIN DD libF77/r_cnjg.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-VOID r_cnjg(r, z) complex *r, *z; +-#else +-VOID r_cnjg(complex *r, complex *z) +-#endif +-{ +- real zi = z->i; +- r->r = z->r; +- r->i = -zi; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_cnjg.c +echo libF77/r_cos.c 1>&2 +sed >libF77/r_cos.c <<'//GO.SYSIN DD libF77/r_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cos(); +-double r_cos(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_cos(real *x) +-#endif +-{ +-return( cos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_cos.c +echo libF77/r_cosh.c 1>&2 +sed >libF77/r_cosh.c <<'//GO.SYSIN DD libF77/r_cosh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cosh(); +-double r_cosh(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_cosh(real *x) +-#endif +-{ +-return( cosh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_cosh.c +echo libF77/r_dim.c 1>&2 +sed >libF77/r_dim.c <<'//GO.SYSIN DD libF77/r_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_dim(a,b) real *a, *b; +-#else +-double r_dim(real *a, real *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_dim.c +echo libF77/r_exp.c 1>&2 +sed >libF77/r_exp.c <<'//GO.SYSIN DD libF77/r_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double exp(); +-double r_exp(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_exp(real *x) +-#endif +-{ +-return( exp(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_exp.c +echo libF77/r_imag.c 1>&2 +sed >libF77/r_imag.c <<'//GO.SYSIN DD libF77/r_imag.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_imag(z) complex *z; +-#else +-double r_imag(complex *z) +-#endif +-{ +-return(z->i); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_imag.c +echo libF77/r_int.c 1>&2 +sed >libF77/r_int.c <<'//GO.SYSIN DD libF77/r_int.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double r_int(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_int(real *x) +-#endif +-{ +-return( (*x>0) ? floor(*x) : -floor(- *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_int.c +echo libF77/r_lg10.c 1>&2 +sed >libF77/r_lg10.c <<'//GO.SYSIN DD libF77/r_lg10.c' 's/^-//' +-#include "f2c.h" +- +-#define log10e 0.43429448190325182765 +- +-#ifdef KR_headers +-double log(); +-double r_lg10(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_lg10(real *x) +-#endif +-{ +-return( log10e * log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_lg10.c +echo libF77/r_log.c 1>&2 +sed >libF77/r_log.c <<'//GO.SYSIN DD libF77/r_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(); +-double r_log(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_log(real *x) +-#endif +-{ +-return( log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_log.c +echo libF77/r_mod.c 1>&2 +sed >libF77/r_mod.c <<'//GO.SYSIN DD libF77/r_mod.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-#ifdef IEEE_drem +-double drem(); +-#else +-double floor(); +-#endif +-double r_mod(x,y) real *x, *y; +-#else +-#ifdef IEEE_drem +-double drem(double, double); +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +-double r_mod(real *x, real *y) +-#endif +-{ +-#ifdef IEEE_drem +- double xa, ya, z; +- if ((ya = *y) < 0.) +- ya = -ya; +- z = drem(xa = *x, ya); +- if (xa > 0) { +- if (z < 0) +- z += ya; +- } +- else if (z > 0) +- z -= ya; +- return z; +-#else +- double quotient; +- if( (quotient = (double)*x / *y) >= 0) +- quotient = floor(quotient); +- else +- quotient = -floor(-quotient); +- return(*x - (*y) * quotient ); +-#endif +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_mod.c +echo libF77/r_nint.c 1>&2 +sed >libF77/r_nint.c <<'//GO.SYSIN DD libF77/r_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double r_nint(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_nint(real *x) +-#endif +-{ +-return( (*x)>=0 ? +- floor(*x + .5) : -floor(.5 - *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_nint.c +echo libF77/r_sign.c 1>&2 +sed >libF77/r_sign.c <<'//GO.SYSIN DD libF77/r_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_sign(a,b) real *a, *b; +-#else +-double r_sign(real *a, real *b) +-#endif +-{ +-double x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sign.c +echo libF77/r_sin.c 1>&2 +sed >libF77/r_sin.c <<'//GO.SYSIN DD libF77/r_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(); +-double r_sin(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_sin(real *x) +-#endif +-{ +-return( sin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sin.c +echo libF77/r_sinh.c 1>&2 +sed >libF77/r_sinh.c <<'//GO.SYSIN DD libF77/r_sinh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sinh(); +-double r_sinh(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_sinh(real *x) +-#endif +-{ +-return( sinh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sinh.c +echo libF77/r_sqrt.c 1>&2 +sed >libF77/r_sqrt.c <<'//GO.SYSIN DD libF77/r_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sqrt(); +-double r_sqrt(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_sqrt(real *x) +-#endif +-{ +-return( sqrt(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sqrt.c +echo libF77/r_tan.c 1>&2 +sed >libF77/r_tan.c <<'//GO.SYSIN DD libF77/r_tan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tan(); +-double r_tan(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_tan(real *x) +-#endif +-{ +-return( tan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_tan.c +echo libF77/r_tanh.c 1>&2 +sed >libF77/r_tanh.c <<'//GO.SYSIN DD libF77/r_tanh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tanh(); +-double r_tanh(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_tanh(real *x) +-#endif +-{ +-return( tanh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_tanh.c +echo libF77/s_cmp.c 1>&2 +sed >libF77/s_cmp.c <<'//GO.SYSIN DD libF77/s_cmp.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* compare two strings */ +- +-#ifdef KR_headers +-integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; +-#else +-integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +-#endif +-{ +-register unsigned char *a, *aend, *b, *bend; +-a = (unsigned char *)a0; +-b = (unsigned char *)b0; +-aend = a + la; +-bend = b + lb; +- +-if(la <= lb) +- { +- while(a < aend) +- if(*a != *b) +- return( *a - *b ); +- else +- { ++a; ++b; } +- +- while(b < bend) +- if(*b != ' ') +- return( ' ' - *b ); +- else ++b; +- } +- +-else +- { +- while(b < bend) +- if(*a == *b) +- { ++a; ++b; } +- else +- return( *a - *b ); +- while(a < aend) +- if(*a != ' ') +- return(*a - ' '); +- else ++a; +- } +-return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_cmp.c +echo libF77/s_copy.c 1>&2 +sed >libF77/s_copy.c <<'//GO.SYSIN DD libF77/s_copy.c' 's/^-//' +-/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the +- * target of an assignment to appear on its right-hand side (contrary +- * to the Fortran 77 Standard, but in accordance with Fortran 90), +- * as in a(2:5) = a(4:7) . +- */ +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* assign strings: a = b */ +- +-#ifdef KR_headers +-VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; +-#else +-void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +-#endif +-{ +- register char *aend, *bend; +- +- aend = a + la; +- +- if(la <= lb) +-#ifndef NO_OVERWRITE +- if (a <= b || a >= b + la) +-#endif +- while(a < aend) +- *a++ = *b++; +-#ifndef NO_OVERWRITE +- else +- for(b += la; a < aend; ) +- *--aend = *--b; +-#endif +- +- else { +- bend = b + lb; +-#ifndef NO_OVERWRITE +- if (a <= b || a >= bend) +-#endif +- while(b < bend) +- *a++ = *b++; +-#ifndef NO_OVERWRITE +- else { +- a += lb; +- while(b < bend) +- *--a = *--bend; +- a += lb; +- } +-#endif +- while(a < aend) +- *a++ = ' '; +- } +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_copy.c +echo libF77/s_paus.c 1>&2 +sed >libF77/s_paus.c <<'//GO.SYSIN DD libF77/s_paus.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +-#define PAUSESIG 15 +- +-#include "signal1.h" +-#ifdef KR_headers +-#define Void /* void */ +-#define Int /* int */ +-#else +-#define Void void +-#define Int int +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int getpid(void), isatty(int), pause(void); +-#endif +- +-extern VOID f_exit(Void); +- +- static VOID +-waitpause(Sigarg) +-{ Use_Sigarg; +- return; +- } +- +- static VOID +-#ifdef KR_headers +-s_1paus(fin) FILE *fin; +-#else +-s_1paus(FILE *fin) +-#endif +-{ +- fprintf(stderr, +- "To resume execution, type go. Other input will terminate the job.\n"); +- fflush(stderr); +- if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) { +- fprintf(stderr, "STOP\n"); +-#ifdef NO_ONEXIT +- f_exit(); +-#endif +- exit(0); +- } +- } +- +- int +-#ifdef KR_headers +-s_paus(s, n) char *s; ftnlen n; +-#else +-s_paus(char *s, ftnlen n) +-#endif +-{ +- fprintf(stderr, "PAUSE "); +- if(n > 0) +- fprintf(stderr, " %.*s", (int)n, s); +- fprintf(stderr, " statement executed\n"); +- if( isatty(fileno(stdin)) ) +- s_1paus(stdin); +- else { +-#ifdef MSDOS +- FILE *fin; +- fin = fopen("con", "r"); +- if (!fin) { +- fprintf(stderr, "s_paus: can't open con!\n"); +- fflush(stderr); +- exit(1); +- } +- s_1paus(fin); +- fclose(fin); +-#else +- fprintf(stderr, +- "To resume execution, execute a kill -%d %d command\n", +- PAUSESIG, getpid() ); +- signal1(PAUSESIG, waitpause); +- fflush(stderr); +- pause(); +-#endif +- } +- fprintf(stderr, "Execution resumes after PAUSE.\n"); +- fflush(stderr); +- return 0; /* NOT REACHED */ +-#ifdef __cplusplus +- } +-#endif +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_paus.c +echo libF77/s_rnge.c 1>&2 +sed >libF77/s_rnge.c <<'//GO.SYSIN DD libF77/s_rnge.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* called when a subscript is out of range */ +- +-#ifdef KR_headers +-extern VOID sig_die(); +-integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; +-#else +-extern VOID sig_die(char*,int); +-integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) +-#endif +-{ +-register int i; +- +-fprintf(stderr, "Subscript out of range on file line %ld, procedure ", +- (long)line); +-while((i = *procn) && i != '_' && i != ' ') +- putc(*procn++, stderr); +-fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", +- (long)offset+1); +-while((i = *varn) && i != ' ') +- putc(*varn++, stderr); +-sig_die(".", 1); +-return 0; /* not reached */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_rnge.c +echo libF77/s_stop.c 1>&2 +sed >libF77/s_stop.c <<'//GO.SYSIN DD libF77/s_stop.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +- +-#ifdef KR_headers +-extern void f_exit(); +-int s_stop(s, n) char *s; ftnlen n; +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-void f_exit(void); +- +-int s_stop(char *s, ftnlen n) +-#endif +-{ +-int i; +- +-if(n > 0) +- { +- fprintf(stderr, "STOP "); +- for(i = 0; i&2 +sed >libF77/signal1.h0 <<'//GO.SYSIN DD libF77/signal1.h0' 's/^-//' +-/* You may need to adjust the definition of signal1 to supply a */ +-/* cast to the correct argument type. This detail is system- and */ +-/* compiler-dependent. The #define below assumes signal.h declares */ +-/* type SIG_PF for the signal function's second argument. */ +- +-/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ +- +-#include +- +-#ifndef Sigret_t +-#define Sigret_t void +-#endif +-#ifndef Sigarg_t +-#ifdef KR_headers +-#define Sigarg_t +-#else +-#define Sigarg_t int +-#endif +-#endif /*Sigarg_t*/ +- +-#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +-#define sig_pf SIG_PF +-#else +-typedef Sigret_t (*sig_pf)(Sigarg_t); +-#endif +- +-#define signal1(a,b) signal(a,(sig_pf)b) +- +-#ifdef __cplusplus +-#define Sigarg ... +-#define Use_Sigarg +-#else +-#define Sigarg Int n +-#define Use_Sigarg n = n /* shut up compiler warning */ +-#endif +//GO.SYSIN DD libF77/signal1.h0 +echo libF77/signal_.c 1>&2 +sed >libF77/signal_.c <<'//GO.SYSIN DD libF77/signal_.c' 's/^-//' +-#include "f2c.h" +-#include "signal1.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- ftnint +-#ifdef KR_headers +-signal_(sigp, proc) integer *sigp; sig_pf proc; +-#else +-signal_(integer *sigp, sig_pf proc) +-#endif +-{ +- int sig; +- sig = (int)*sigp; +- +- return (ftnint)signal(sig, proc); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/signal_.c +echo libF77/system_.c 1>&2 +sed >libF77/system_.c <<'//GO.SYSIN DD libF77/system_.c' 's/^-//' +-/* f77 interface to system routine */ +- +-#include "f2c.h" +- +-#ifdef KR_headers +-extern char *F77_aloc(); +- +- integer +-system_(s, n) register char *s; ftnlen n; +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *F77_aloc(ftnlen, char*); +- +- integer +-system_(register char *s, ftnlen n) +-#endif +-{ +- char buff0[256], *buff; +- register char *bp, *blast; +- integer rv; +- +- buff = bp = n < sizeof(buff0) +- ? buff0 : F77_aloc(n+1, "system_"); +- blast = bp + n; +- +- while(bp < blast && *s) +- *bp++ = *s++; +- *bp = 0; +- rv = system(buff); +- if (buff != buff0) +- free(buff); +- return rv; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/system_.c +echo libF77/z_abs.c 1>&2 +sed >libF77/z_abs.c <<'//GO.SYSIN DD libF77/z_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double f__cabs(); +-double z_abs(z) doublecomplex *z; +-#else +-double f__cabs(double, double); +-double z_abs(doublecomplex *z) +-#endif +-{ +-return( f__cabs( z->r, z->i ) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_abs.c +echo libF77/z_cos.c 1>&2 +sed >libF77/z_cos.c <<'//GO.SYSIN DD libF77/z_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(), cos(), sinh(), cosh(); +-VOID z_cos(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-void z_cos(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = cos(zr) * cosh(zi); +- r->i = - sin(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_cos.c +echo libF77/z_div.c 1>&2 +sed >libF77/z_div.c <<'//GO.SYSIN DD libF77/z_div.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern VOID sig_die(); +-VOID z_div(c, a, b) doublecomplex *a, *b, *c; +-#else +-extern void sig_die(char*, int); +-void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) +-#endif +-{ +- double ratio, den; +- double abr, abi, cr; +- +- if( (abr = b->r) < 0.) +- abr = - abr; +- if( (abi = b->i) < 0.) +- abi = - abi; +- if( abr <= abi ) +- { +- if(abi == 0) { +-#ifdef IEEE_COMPLEX_DIVIDE +- if (a->i != 0 || a->r != 0) +- abi = 1.; +- c->i = c->r = abi / abr; +- return; +-#else +- sig_die("complex division by zero", 1); +-#endif +- } +- ratio = b->r / b->i ; +- den = b->i * (1 + ratio*ratio); +- cr = (a->r*ratio + a->i) / den; +- c->i = (a->i*ratio - a->r) / den; +- } +- +- else +- { +- ratio = b->i / b->r ; +- den = b->r * (1 + ratio*ratio); +- cr = (a->r + a->i*ratio) / den; +- c->i = (a->i - a->r*ratio) / den; +- } +- c->r = cr; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_div.c +echo libF77/z_exp.c 1>&2 +sed >libF77/z_exp.c <<'//GO.SYSIN DD libF77/z_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double exp(), cos(), sin(); +-VOID z_exp(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-void z_exp(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double expx, zi = z->i; +- +- expx = exp(z->r); +- r->r = expx * cos(zi); +- r->i = expx * sin(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_exp.c +echo libF77/z_log.c 1>&2 +sed >libF77/z_log.c <<'//GO.SYSIN DD libF77/z_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(), f__cabs(), atan2(); +-#define ANSI(x) () +-#else +-#define ANSI(x) x +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +-#endif +- +-#ifndef NO_DOUBLE_EXTENDED +-#ifndef GCC_COMPARE_BUG_FIXED +-#ifndef Pre20000310 +-#ifdef Comment +-Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3: +-on IA32 (Intel 80x87) systems, they may do comparisons on values computed +-in extended-precision registers. This can lead to the test "s > s0" that +-was used below being carried out incorrectly. The fix below cannot be +-spoiled by overzealous optimization, since the compiler cannot know +-whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always +-to be zero. The weird name is unlikely to collide with anything.) +- +-An example (provided by Ulrich Jakobus) where the bug fix matters is +- +- double complex a, b +- a = (.1099557428756427618354862829619, .9857360542953131909982289471372) +- b = log(a) +- +-An alternative to the fix below would be to use 53-bit rounding precision, +-but the means of specifying this 80x87 feature are highly unportable. +-#endif /*Comment*/ +-#define BYPASS_GCC_COMPARE_BUG +-double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*)); +- static double +-#ifdef KR_headers +-diff1(a,b) double *a, *b; +-#else +-diff1(double *a, double *b) +-#endif +-{ return *a - *b; } +-#endif /*Pre20000310*/ +-#endif /*GCC_COMPARE_BUG_FIXED*/ +-#endif /*NO_DOUBLE_EXTENDED*/ +- +-#ifdef KR_headers +-VOID z_log(r, z) doublecomplex *r, *z; +-#else +-void z_log(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double s, s0, t, t2, u, v; +- double zi = z->i, zr = z->r; +-#ifdef BYPASS_GCC_COMPARE_BUG +- double (*diff) ANSI((double*,double*)); +-#endif +- +- r->i = atan2(zi, zr); +-#ifdef Pre20000310 +- r->r = log( f__cabs( zr, zi ) ); +-#else +- if (zi < 0) +- zi = -zi; +- if (zr < 0) +- zr = -zr; +- if (zr < zi) { +- t = zi; +- zi = zr; +- zr = t; +- } +- t = zi/zr; +- s = zr * sqrt(1 + t*t); +- /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */ +- if ((t = s - 1) < 0) +- t = -t; +- if (t > .01) +- r->r = log(s); +- else { +- +-#ifdef Comment +- +- log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ... +- +- = x(1 - x/2 + x^2/3 -+...) +- +- [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so +- +- sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1] +- +-#endif /*Comment*/ +- +-#ifdef BYPASS_GCC_COMPARE_BUG +- if (!(diff = gcc_bug_bypass_diff_F2C)) +- diff = diff1; +-#endif +- t = ((zr*zr - 1.) + zi*zi) / (s + 1); +- t2 = t*t; +- s = 1. - 0.5*t; +- u = v = 1; +- do { +- s0 = s; +- u *= t2; +- v += 2; +- s += u/v - t*u/(v+1); +- } +-#ifdef BYPASS_GCC_COMPARE_BUG +- while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.); +-#else +- while(s > s0); +-#endif +- r->r = s*t; +- } +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_log.c +echo libF77/z_sin.c 1>&2 +sed >libF77/z_sin.c <<'//GO.SYSIN DD libF77/z_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(), cos(), sinh(), cosh(); +-VOID z_sin(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-void z_sin(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = sin(zr) * cosh(zi); +- r->i = cos(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_sin.c +echo libF77/i_mod.c 1>&2 +sed >libF77/i_mod.c <<'//GO.SYSIN DD libF77/i_mod.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_mod(a,b) integer *a, *b; +-#else +-integer i_mod(integer *a, integer *b) +-#endif +-{ +-return( *a % *b); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_mod.c +echo libF77/i_nint.c 1>&2 +sed >libF77/i_nint.c <<'//GO.SYSIN DD libF77/i_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-integer i_nint(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-integer i_nint(real *x) +-#endif +-{ +-return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_nint.c +echo libF77/i_sign.c 1>&2 +sed >libF77/i_sign.c <<'//GO.SYSIN DD libF77/i_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_sign(a,b) integer *a, *b; +-#else +-integer i_sign(integer *a, integer *b) +-#endif +-{ +-integer x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_sign.c +echo libF77/iargc_.c 1>&2 +sed >libF77/iargc_.c <<'//GO.SYSIN DD libF77/iargc_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-ftnint iargc_() +-#else +-ftnint iargc_(void) +-#endif +-{ +-extern int xargc; +-return ( xargc - 1 ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/iargc_.c +echo libF77/l_ge.c 1>&2 +sed >libF77/l_ge.c <<'//GO.SYSIN DD libF77/l_ge.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_ge(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) >= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_ge.c +echo libF77/l_gt.c 1>&2 +sed >libF77/l_gt.c <<'//GO.SYSIN DD libF77/l_gt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_gt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) > 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_gt.c +echo libF77/l_le.c 1>&2 +sed >libF77/l_le.c <<'//GO.SYSIN DD libF77/l_le.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_le(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) <= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_le.c +echo libF77/l_lt.c 1>&2 +sed >libF77/l_lt.c <<'//GO.SYSIN DD libF77/l_lt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_lt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) < 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_lt.c +echo libF77/lbitbits.c 1>&2 +sed >libF77/lbitbits.c <<'//GO.SYSIN DD libF77/lbitbits.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef LONGBITS +-#define LONGBITS 32 +-#endif +- +- integer +-#ifdef KR_headers +-lbit_bits(a, b, len) integer a, b, len; +-#else +-lbit_bits(integer a, integer b, integer len) +-#endif +-{ +- /* Assume 2's complement arithmetic */ +- +- unsigned long x, y; +- +- x = (unsigned long) a; +- y = (unsigned long)-1L; +- x >>= b; +- y <<= len; +- return (integer)(x & ~y); +- } +- +- integer +-#ifdef KR_headers +-lbit_cshift(a, b, len) integer a, b, len; +-#else +-lbit_cshift(integer a, integer b, integer len) +-#endif +-{ +- unsigned long x, y, z; +- +- x = (unsigned long)a; +- if (len <= 0) { +- if (len == 0) +- return 0; +- goto full_len; +- } +- if (len >= LONGBITS) { +- full_len: +- if (b >= 0) { +- b %= LONGBITS; +- return (integer)(x << b | x >> LONGBITS -b ); +- } +- b = -b; +- b %= LONGBITS; +- return (integer)(x << LONGBITS - b | x >> b); +- } +- y = z = (unsigned long)-1; +- y <<= len; +- z &= ~y; +- y &= x; +- x &= z; +- if (b >= 0) { +- b %= len; +- return (integer)(y | z & (x << b | x >> len - b)); +- } +- b = -b; +- b %= len; +- return (integer)(y | z & (x >> b | x << len - b)); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/lbitbits.c +echo libF77/lbitshft.c 1>&2 +sed >libF77/lbitshft.c <<'//GO.SYSIN DD libF77/lbitshft.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- integer +-#ifdef KR_headers +-lbit_shift(a, b) integer a; integer b; +-#else +-lbit_shift(integer a, integer b) +-#endif +-{ +- return b >= 0 ? a << b : (integer)((uinteger)a >> -b); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/lbitshft.c +echo libF77/sig_die.c 1>&2 +sed >libF77/sig_die.c <<'//GO.SYSIN DD libF77/sig_die.c' 's/^-//' +-#include "stdio.h" +-#include "signal.h" +- +-#ifndef SIGIOT +-#ifdef SIGABRT +-#define SIGIOT SIGABRT +-#endif +-#endif +- +-#ifdef KR_headers +-void sig_die(s, kill) register char *s; int kill; +-#else +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +- extern void f_exit(void); +- +-void sig_die(register char *s, int kill) +-#endif +-{ +- /* print error message, then clear buffers */ +- fprintf(stderr, "%s\n", s); +- +- if(kill) +- { +- fflush(stderr); +- f_exit(); +- fflush(stderr); +- /* now get a core */ +-#ifdef SIGIOT +- signal(SIGIOT, SIG_DFL); +-#endif +- abort(); +- } +- else { +-#ifdef NO_ONEXIT +- f_exit(); +-#endif +- exit(1); +- } +- } +-#ifdef __cplusplus +-} +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/sig_die.c +echo libF77/d_sinh.c 1>&2 +sed >libF77/d_sinh.c <<'//GO.SYSIN DD libF77/d_sinh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sinh(); +-double d_sinh(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_sinh(doublereal *x) +-#endif +-{ +-return( sinh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sinh.c +echo libF77/d_sqrt.c 1>&2 +sed >libF77/d_sqrt.c <<'//GO.SYSIN DD libF77/d_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sqrt(); +-double d_sqrt(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_sqrt(doublereal *x) +-#endif +-{ +-return( sqrt(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sqrt.c +echo libF77/d_tan.c 1>&2 +sed >libF77/d_tan.c <<'//GO.SYSIN DD libF77/d_tan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tan(); +-double d_tan(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_tan(doublereal *x) +-#endif +-{ +-return( tan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_tan.c +echo libF77/d_tanh.c 1>&2 +sed >libF77/d_tanh.c <<'//GO.SYSIN DD libF77/d_tanh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tanh(); +-double d_tanh(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_tanh(doublereal *x) +-#endif +-{ +-return( tanh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_tanh.c +echo libF77/derf_.c 1>&2 +sed >libF77/derf_.c <<'//GO.SYSIN DD libF77/derf_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double erf(); +-double derf_(x) doublereal *x; +-#else +-extern double erf(double); +-double derf_(doublereal *x) +-#endif +-{ +-return( erf(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/derf_.c +echo libF77/derfc_.c 1>&2 +sed >libF77/derfc_.c <<'//GO.SYSIN DD libF77/derfc_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern double erfc(); +- +-double derfc_(x) doublereal *x; +-#else +-extern double erfc(double); +- +-double derfc_(doublereal *x) +-#endif +-{ +-return( erfc(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/derfc_.c +echo libF77/dtime_.c 1>&2 +sed >libF77/dtime_.c <<'//GO.SYSIN DD libF77/dtime_.c' 's/^-//' +-#include "time.h" +- +-#ifdef MSDOS +-#undef USE_CLOCK +-#define USE_CLOCK +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifndef USE_CLOCK +-#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +-#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +-#include "sys/types.h" +-#include "sys/times.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-#undef Hz +-#ifdef CLK_TCK +-#define Hz CLK_TCK +-#else +-#ifdef HZ +-#define Hz HZ +-#else +-#define Hz 60 +-#endif +-#endif +- +- REAL +-#ifdef KR_headers +-dtime_(tarray) float *tarray; +-#else +-dtime_(float *tarray) +-#endif +-{ +-#ifdef USE_CLOCK +-#ifndef CLOCKS_PER_SECOND +-#define CLOCKS_PER_SECOND Hz +-#endif +- static double t0; +- double t = clock(); +- tarray[1] = 0; +- tarray[0] = (t - t0) / CLOCKS_PER_SECOND; +- t0 = t; +- return tarray[0]; +-#else +- struct tms t; +- static struct tms t0; +- +- times(&t); +- tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz; +- tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz; +- t0 = t; +- return tarray[0] + tarray[1]; +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/dtime_.c +echo libF77/ef1asc_.c 1>&2 +sed >libF77/ef1asc_.c <<'//GO.SYSIN DD libF77/ef1asc_.c' 's/^-//' +-/* EFL support routine to copy string b to string a */ +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- +-#define M ( (long) (sizeof(long) - 1) ) +-#define EVEN(x) ( ( (x)+ M) & (~M) ) +- +-#ifdef KR_headers +-extern VOID s_copy(); +-ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +-#else +-extern void s_copy(char*,char*,ftnlen,ftnlen); +-int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +-#endif +-{ +-s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +-return 0; /* ignored return value */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/ef1asc_.c +echo libF77/ef1cmc_.c 1>&2 +sed >libF77/ef1cmc_.c <<'//GO.SYSIN DD libF77/ef1cmc_.c' 's/^-//' +-/* EFL support routine to compare two character strings */ +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +-#else +-extern integer s_cmp(char*,char*,ftnlen,ftnlen); +-integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +-#endif +-{ +-return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/ef1cmc_.c +echo libF77/erf_.c 1>&2 +sed >libF77/erf_.c <<'//GO.SYSIN DD libF77/erf_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifdef KR_headers +-double erf(); +-REAL erf_(x) real *x; +-#else +-extern double erf(double); +-REAL erf_(real *x) +-#endif +-{ +-return( erf((double)*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/erf_.c +echo libF77/erfc_.c 1>&2 +sed >libF77/erfc_.c <<'//GO.SYSIN DD libF77/erfc_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifdef KR_headers +-double erfc(); +-REAL erfc_(x) real *x; +-#else +-extern double erfc(double); +-REAL erfc_(real *x) +-#endif +-{ +-return( erfc((double)*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/erfc_.c +echo libF77/etime_.c 1>&2 +sed >libF77/etime_.c <<'//GO.SYSIN DD libF77/etime_.c' 's/^-//' +-#include "time.h" +- +-#ifdef MSDOS +-#undef USE_CLOCK +-#define USE_CLOCK +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifndef USE_CLOCK +-#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +-#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +-#include "sys/types.h" +-#include "sys/times.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-#undef Hz +-#ifdef CLK_TCK +-#define Hz CLK_TCK +-#else +-#ifdef HZ +-#define Hz HZ +-#else +-#define Hz 60 +-#endif +-#endif +- +- REAL +-#ifdef KR_headers +-etime_(tarray) float *tarray; +-#else +-etime_(float *tarray) +-#endif +-{ +-#ifdef USE_CLOCK +-#ifndef CLOCKS_PER_SECOND +-#define CLOCKS_PER_SECOND Hz +-#endif +- double t = clock(); +- tarray[1] = 0; +- return tarray[0] = t / CLOCKS_PER_SECOND; +-#else +- struct tms t; +- +- times(&t); +- return (tarray[0] = (double)t.tms_utime/Hz) +- + (tarray[1] = (double)t.tms_stime/Hz); +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/etime_.c +echo libF77/exit_.c 1>&2 +sed >libF77/exit_.c <<'//GO.SYSIN DD libF77/exit_.c' 's/^-//' +-/* This gives the effect of +- +- subroutine exit(rc) +- integer*4 rc +- stop +- end +- +- * with the added side effect of supplying rc as the program's exit code. +- */ +- +-#include "f2c.h" +-#undef abs +-#undef min +-#undef max +-#ifndef KR_headers +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern void f_exit(void); +-#endif +- +- void +-#ifdef KR_headers +-exit_(rc) integer *rc; +-#else +-exit_(integer *rc) +-#endif +-{ +-#ifdef NO_ONEXIT +- f_exit(); +-#endif +- exit(*rc); +- } +-#ifdef __cplusplus +-} +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/exit_.c +echo libF77/getarg_.c 1>&2 +sed >libF77/getarg_.c <<'//GO.SYSIN DD libF77/getarg_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* +- * subroutine getarg(k, c) +- * returns the kth unix command argument in fortran character +- * variable argument c +-*/ +- +-#ifdef KR_headers +-VOID getarg_(n, s, ls) ftnint *n; register char *s; ftnlen ls; +-#else +-void getarg_(ftnint *n, register char *s, ftnlen ls) +-#endif +-{ +-extern int xargc; +-extern char **xargv; +-register char *t; +-register int i; +- +-if(*n>=0 && *n&2 +sed >libF77/getenv_.c <<'//GO.SYSIN DD libF77/getenv_.c' 's/^-//' +-#include "f2c.h" +-#undef abs +-#ifdef KR_headers +-extern char *F77_aloc(), *getenv(); +-#else +-#include +-#include +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *F77_aloc(ftnlen, char*); +-#endif +- +-/* +- * getenv - f77 subroutine to return environment variables +- * +- * called by: +- * call getenv (ENV_NAME, char_var) +- * where: +- * ENV_NAME is the name of an environment variable +- * char_var is a character variable which will receive +- * the current value of ENV_NAME, or all blanks +- * if ENV_NAME is not defined +- */ +- +-#ifdef KR_headers +- VOID +-getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen; +-#else +- void +-getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen) +-#endif +-{ +- char buf[256], *ep, *fp; +- integer i; +- +- if (flen <= 0) +- goto add_blanks; +- for(i = 0; i < sizeof(buf); i++) { +- if (i == flen || (buf[i] = fname[i]) == ' ') { +- buf[i] = 0; +- ep = getenv(buf); +- goto have_ep; +- } +- } +- while(i < flen && fname[i] != ' ') +- i++; +- strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i); +- fp[i] = 0; +- ep = getenv(fp); +- free(fp); +- have_ep: +- if (ep) +- while(*ep && vlen-- > 0) +- *value++ = *ep++; +- add_blanks: +- while(vlen-- > 0) +- *value++ = ' '; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/getenv_.c +echo libF77/h_abs.c 1>&2 +sed >libF77/h_abs.c <<'//GO.SYSIN DD libF77/h_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_abs(x) shortint *x; +-#else +-shortint h_abs(shortint *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_abs.c +echo libF77/h_dim.c 1>&2 +sed >libF77/h_dim.c <<'//GO.SYSIN DD libF77/h_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_dim(a,b) shortint *a, *b; +-#else +-shortint h_dim(shortint *a, shortint *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_dim.c +echo libF77/h_dnnt.c 1>&2 +sed >libF77/h_dnnt.c <<'//GO.SYSIN DD libF77/h_dnnt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-shortint h_dnnt(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-shortint h_dnnt(doublereal *x) +-#endif +-{ +-return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_dnnt.c +echo libF77/h_indx.c 1>&2 +sed >libF77/h_indx.c <<'//GO.SYSIN DD libF77/h_indx.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +-#else +-shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-ftnlen i, n; +-char *s, *t, *bend; +- +-n = la - lb + 1; +-bend = b + lb; +- +-for(i = 0 ; i < n ; ++i) +- { +- s = a + i; +- t = b; +- while(t < bend) +- if(*s++ != *t++) +- goto no; +- return((shortint)i+1); +- no: ; +- } +-return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_indx.c +echo libF77/h_len.c 1>&2 +sed >libF77/h_len.c <<'//GO.SYSIN DD libF77/h_len.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_len(s, n) char *s; ftnlen n; +-#else +-shortint h_len(char *s, ftnlen n) +-#endif +-{ +-return(n); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_len.c +echo libF77/h_mod.c 1>&2 +sed >libF77/h_mod.c <<'//GO.SYSIN DD libF77/h_mod.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_mod(a,b) short *a, *b; +-#else +-shortint h_mod(short *a, short *b) +-#endif +-{ +-return( *a % *b); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_mod.c +echo libF77/h_nint.c 1>&2 +sed >libF77/h_nint.c <<'//GO.SYSIN DD libF77/h_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-shortint h_nint(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-shortint h_nint(real *x) +-#endif +-{ +-return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_nint.c +echo libF77/h_sign.c 1>&2 +sed >libF77/h_sign.c <<'//GO.SYSIN DD libF77/h_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_sign(a,b) shortint *a, *b; +-#else +-shortint h_sign(shortint *a, shortint *b) +-#endif +-{ +-shortint x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_sign.c +echo libF77/hl_ge.c 1>&2 +sed >libF77/hl_ge.c <<'//GO.SYSIN DD libF77/hl_ge.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) >= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_ge.c +echo libF77/hl_gt.c 1>&2 +sed >libF77/hl_gt.c <<'//GO.SYSIN DD libF77/hl_gt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) > 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_gt.c +echo libF77/hl_le.c 1>&2 +sed >libF77/hl_le.c <<'//GO.SYSIN DD libF77/hl_le.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) <= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_le.c +echo libF77/hl_lt.c 1>&2 +sed >libF77/hl_lt.c <<'//GO.SYSIN DD libF77/hl_lt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) < 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_lt.c +echo libF77/i_abs.c 1>&2 +sed >libF77/i_abs.c <<'//GO.SYSIN DD libF77/i_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_abs(x) integer *x; +-#else +-integer i_abs(integer *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_abs.c +echo libF77/i_dim.c 1>&2 +sed >libF77/i_dim.c <<'//GO.SYSIN DD libF77/i_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_dim(a,b) integer *a, *b; +-#else +-integer i_dim(integer *a, integer *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_dim.c +echo libF77/i_dnnt.c 1>&2 +sed >libF77/i_dnnt.c <<'//GO.SYSIN DD libF77/i_dnnt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-integer i_dnnt(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-integer i_dnnt(doublereal *x) +-#endif +-{ +-return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_dnnt.c +echo libF77/i_indx.c 1>&2 +sed >libF77/i_indx.c <<'//GO.SYSIN DD libF77/i_indx.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +-#else +-integer i_indx(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-ftnlen i, n; +-char *s, *t, *bend; +- +-n = la - lb + 1; +-bend = b + lb; +- +-for(i = 0 ; i < n ; ++i) +- { +- s = a + i; +- t = b; +- while(t < bend) +- if(*s++ != *t++) +- goto no; +- return(i+1); +- no: ; +- } +-return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_indx.c +echo libF77/i_len.c 1>&2 +sed >libF77/i_len.c <<'//GO.SYSIN DD libF77/i_len.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_len(s, n) char *s; ftnlen n; +-#else +-integer i_len(char *s, ftnlen n) +-#endif +-{ +-return(n); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_len.c +echo libF77/F77_aloc.c 1>&2 +sed >libF77/F77_aloc.c <<'//GO.SYSIN DD libF77/F77_aloc.c' 's/^-//' +-#include "f2c.h" +-#undef abs +-#undef min +-#undef max +-#include "stdio.h" +- +-static integer memfailure = 3; +- +-#ifdef KR_headers +-extern char *malloc(); +-extern void exit_(); +- +- char * +-F77_aloc(Len, whence) integer Len; char *whence; +-#else +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern void exit_(integer*); +-#ifdef __cplusplus +- } +-#endif +- +- char * +-F77_aloc(integer Len, char *whence) +-#endif +-{ +- char *rv; +- unsigned int uLen = (unsigned int) Len; /* for K&R C */ +- +- if (!(rv = (char*)malloc(uLen))) { +- fprintf(stderr, "malloc(%u) failure in %s\n", +- uLen, whence); +- exit_(&memfailure); +- } +- return rv; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/F77_aloc.c +echo libF77/README 1>&2 +sed >libF77/README <<'//GO.SYSIN DD libF77/README' 's/^-//' +-If your compiler does not recognize ANSI C headers, +-compile with KR_headers defined: either add -DKR_headers +-to the definition of CFLAGS in the makefile, or insert +- +-#define KR_headers +- +-at the top of f2c.h , cabs.c , main.c , and sig_die.c . +- +-Under MS-DOS, compile s_paus.c with -DMSDOS. +- +-If you have a really ancient K&R C compiler that does not understand +-void, add -Dvoid=int to the definition of CFLAGS in the makefile. +- +-If you use a C++ compiler, first create a local f2c.h by appending +-f2ch.add to the usual f2c.h, e.g., by issuing the command +- make f2c.h +-which assumes f2c.h is installed in /usr/include . +- +-If your system lacks onexit() and you are not using an ANSI C +-compiler, then you should compile main.c, s_paus.c, s_stop.c, and +-sig_die.c with NO_ONEXIT defined. See the comments about onexit in +-the makefile. +- +-If your system has a double drem() function such that drem(a,b) +-is the IEEE remainder function (with double a, b), then you may +-wish to compile r_mod.c and d_mod.c with IEEE_drem defined. +-On some systems, you may also need to compile with -Ddrem=remainder . +- +-To check for transmission errors, issue the command +- make check +-This assumes you have the xsum program whose source, xsum.c, +-is distributed as part of "all from f2c/src". If you do not +-have xsum, you can obtain xsum.c by sending the following E-mail +-message to netlib@netlib.bell-labs.com +- send xsum.c from f2c/src +- +-The makefile assumes you have installed f2c.h in a standard +-place (and does not cause recompilation when f2c.h is changed); +-f2c.h comes with "all from f2c" (the source for f2c) and is +-available separately ("f2c.h from f2c"). +- +-Most of the routines in libF77 are support routines for Fortran +-intrinsic functions or for operations that f2c chooses not +-to do "in line". There are a few exceptions, summarized below -- +-functions and subroutines that appear to your program as ordinary +-external Fortran routines. +- +-If you use the REAL valued functions listed below (ERF, ERFC, +-DTIME, and ETIME) with "f2c -R", then you need to compile the +-corresponding source files with -DREAL=float. To do this, it is +-perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile. +- +-1. CALL ABORT prints a message and causes a core dump. +- +-2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION +- error functions (with x REAL and d DOUBLE PRECISION); +- DERF must be declared DOUBLE PRECISION in your program. +- Both ERF and DERF assume your C library provides the +- underlying erf() function (which not all systems do). +- +-3. ERFC(r) and DERFC(d) are the complementary error functions: +- ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d) +- (except that their results may be more accurate than +- explicitly evaluating the above formulae would give). +- Again, ERFC and r are REAL, and DERFC and d are DOUBLE +- PRECISION (and must be declared as such in your program), +- and ERFC and DERFC rely on your system's erfc(). +- +-4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER +- variable, sets s to the n-th command-line argument (or to +- all blanks if there are fewer than n command-line arguments); +- CALL GETARG(0,s) sets s to the name of the program (on systems +- that support this feature). See IARGC below. +- +-5. CALL GETENV(name, value), where name and value are of type +- CHARACTER, sets value to the environment value, $name, of +- name (or to blanks if $name has not been set). +- +-6. NARGS = IARGC() sets NARGS to the number of command-line +- arguments (an INTEGER value). +- +-7. CALL SIGNAL(n,func), where n is an INTEGER and func is an +- EXTERNAL procedure, arranges for func to be invoked when +- signal n occurs (on systems where this makes sense). +- +-8. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes +- cmd to the system's command processor (on systems where +- this can be done). +- +-If your compiler complains about the signal calls in main.c, s_paus.c, +-and signal_.c, you may need to adjust signal1.h suitably. See the +-comments in signal1.h. +- +-8. ETIME(ARR) and DTIME(ARR) are REAL functions that return +- execution times. ARR is declared REAL ARR(2). The elapsed +- user and system CPU times are stored in ARR(1) and ARR(2), +- respectively. ETIME returns the total elapsed CPU time, +- i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU +- time since the previous call on DTIME. +- +-9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes +- cmd to the system's command processor (on systems where +- this can be done). +- +-The makefile does not attempt to compile pow_qq.c, qbitbits.c, +-and qbitshft.c, which are meant for use with INTEGER*8. To use +-INTEGER*8, you must modify f2c.h to declare longint and ulongint +-appropriately; then add pow_qq.o to the POW = line in the makefile, +-and add " qbitbits.o qbitshft.o" to the makefile's F90BIT = line. +- +-Following Fortran 90, s_cat.c and s_copy.c allow the target of a +-(character string) assignment to be appear on its right-hand, at +-the cost of some extra overhead for all run-time concatenations. +-If you prefer the extra efficiency that comes with the Fortran 77 +-requirement that the left-hand side of a character assignment not +-be involved in the right-hand side, compile s_cat.c and s_copy.c +-with -DNO_OVERWRITE . +- +-If your system lacks a ranlib command, you don't need it. +-Either comment out the makefile's ranlib invocation, or install +-a harmless "ranlib" command somewhere in your PATH, such as the +-one-line shell script +- +- exit 0 +- +-or (on some systems) +- +- exec /usr/bin/ar lts $1 >/dev/null +- +-If your compiler complains about the signal calls in main.c, s_paus.c, +-and signal_.c, you may need to adjust signal1.h suitably. See the +-comments in signal1.h. +- +-By default, the routines that implement complex and double complex +-division, c_div.c and z_div.c, call sig_die to print an error message +-and exit if they see a divisor of 0, as this is sometimes helpful for +-debugging. On systems with IEEE arithmetic, compiling c_div.c and +-z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both +-the real and imaginary parts of the result to +INFINITY if the +-numerator is nonzero, or to NaN if it vanishes. +- +-The initializations for "f2c -trapuv" are done by _uninit_f2c(), +-whose source is uninit.c, introduced June 2001. On IEEE-arithmetic +-systems, _uninit_f2c should initialize floating-point variables to +-signaling NaNs and, at its first invocation, should enable the +-invalid operation exception. Alas, the rules for distinguishing +-signaling from quiet NaNs were not specified in the IEEE P754 standard, +-nor were the precise means of enabling and disabling IEEE-arithmetic +-exceptions, and these details are thus system dependent. There are +-#ifdef's in uninit.c that specify them for some popular systems. If +-yours is not one of these systems, it may take some detective work to +-discover the appropriate details for your system. Sometimes it helps +-to look in the standard include directories for header files with +-relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and +-it may be simplest to run experiments to see what distinguishes a +-signaling from a quiet NaN. (If x is initialized to a signaling +-NaN and the invalid operation exception is masked off, as it should +-be by default on IEEE-arithmetic systems, then computing, say, +-y = x + 1 will yield a quiet NaN.) +//GO.SYSIN DD libF77/README +echo libF77/abort_.c 1>&2 +sed >libF77/abort_.c <<'//GO.SYSIN DD libF77/abort_.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern VOID sig_die(); +- +-int abort_() +-#else +-extern void sig_die(char*,int); +- +-int abort_(void) +-#endif +-{ +-sig_die("Fortran abort routine called", 1); +-return 0; /* not reached */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/abort_.c +echo libF77/c_abs.c 1>&2 +sed >libF77/c_abs.c <<'//GO.SYSIN DD libF77/c_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern double f__cabs(); +- +-double c_abs(z) complex *z; +-#else +-extern double f__cabs(double, double); +- +-double c_abs(complex *z) +-#endif +-{ +-return( f__cabs( z->r, z->i ) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_abs.c +echo libF77/c_cos.c 1>&2 +sed >libF77/c_cos.c <<'//GO.SYSIN DD libF77/c_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double sin(), cos(), sinh(), cosh(); +- +-VOID c_cos(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-void c_cos(complex *r, complex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = cos(zr) * cosh(zi); +- r->i = - sin(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_cos.c +echo libF77/c_div.c 1>&2 +sed >libF77/c_div.c <<'//GO.SYSIN DD libF77/c_div.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern VOID sig_die(); +-VOID c_div(c, a, b) +-complex *a, *b, *c; +-#else +-extern void sig_die(char*,int); +-void c_div(complex *c, complex *a, complex *b) +-#endif +-{ +- double ratio, den; +- double abr, abi, cr; +- +- if( (abr = b->r) < 0.) +- abr = - abr; +- if( (abi = b->i) < 0.) +- abi = - abi; +- if( abr <= abi ) +- { +- if(abi == 0) { +-#ifdef IEEE_COMPLEX_DIVIDE +- float af, bf; +- af = bf = abr; +- if (a->i != 0 || a->r != 0) +- af = 1.; +- c->i = c->r = af / bf; +- return; +-#else +- sig_die("complex division by zero", 1); +-#endif +- } +- ratio = (double)b->r / b->i ; +- den = b->i * (1 + ratio*ratio); +- cr = (a->r*ratio + a->i) / den; +- c->i = (a->i*ratio - a->r) / den; +- } +- +- else +- { +- ratio = (double)b->i / b->r ; +- den = b->r * (1 + ratio*ratio); +- cr = (a->r + a->i*ratio) / den; +- c->i = (a->i - a->r*ratio) / den; +- } +- c->r = cr; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_div.c +echo libF77/c_exp.c 1>&2 +sed >libF77/c_exp.c <<'//GO.SYSIN DD libF77/c_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double exp(), cos(), sin(); +- +- VOID c_exp(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-void c_exp(complex *r, complex *z) +-#endif +-{ +- double expx, zi = z->i; +- +- expx = exp(z->r); +- r->r = expx * cos(zi); +- r->i = expx * sin(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_exp.c +echo libF77/c_log.c 1>&2 +sed >libF77/c_log.c <<'//GO.SYSIN DD libF77/c_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double log(), f__cabs(), atan2(); +-VOID c_log(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +- +-void c_log(complex *r, complex *z) +-#endif +-{ +- double zi, zr; +- r->i = atan2(zi = z->i, zr = z->r); +- r->r = log( f__cabs(zr, zi) ); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_log.c +echo libF77/c_sin.c 1>&2 +sed >libF77/c_sin.c <<'//GO.SYSIN DD libF77/c_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double sin(), cos(), sinh(), cosh(); +- +-VOID c_sin(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-void c_sin(complex *r, complex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = sin(zr) * cosh(zi); +- r->i = cos(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_sin.c +echo libF77/c_sqrt.c 1>&2 +sed >libF77/c_sqrt.c <<'//GO.SYSIN DD libF77/c_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double sqrt(), f__cabs(); +- +-VOID c_sqrt(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +- +-void c_sqrt(complex *r, complex *z) +-#endif +-{ +- double mag, t; +- double zi = z->i, zr = z->r; +- +- if( (mag = f__cabs(zr, zi)) == 0.) +- r->r = r->i = 0.; +- else if(zr > 0) +- { +- r->r = t = sqrt(0.5 * (mag + zr) ); +- t = zi / t; +- r->i = 0.5 * t; +- } +- else +- { +- t = sqrt(0.5 * (mag - zr) ); +- if(zi < 0) +- t = -t; +- r->i = t; +- t = zi / t; +- r->r = 0.5 * t; +- } +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_sqrt.c +echo libF77/cabs.c 1>&2 +sed >libF77/cabs.c <<'//GO.SYSIN DD libF77/cabs.c' 's/^-//' +-#ifdef KR_headers +-extern double sqrt(); +-double f__cabs(real, imag) double real, imag; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double f__cabs(double real, double imag) +-#endif +-{ +-double temp; +- +-if(real < 0) +- real = -real; +-if(imag < 0) +- imag = -imag; +-if(imag > real){ +- temp = real; +- real = imag; +- imag = temp; +-} +-if((real+imag) == real) +- return(real); +- +-temp = imag/real; +-temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ +-return(temp); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/cabs.c +echo libF77/d_abs.c 1>&2 +sed >libF77/d_abs.c <<'//GO.SYSIN DD libF77/d_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_abs(x) doublereal *x; +-#else +-double d_abs(doublereal *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_abs.c +echo libF77/d_acos.c 1>&2 +sed >libF77/d_acos.c <<'//GO.SYSIN DD libF77/d_acos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double acos(); +-double d_acos(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_acos(doublereal *x) +-#endif +-{ +-return( acos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_acos.c +echo libF77/d_asin.c 1>&2 +sed >libF77/d_asin.c <<'//GO.SYSIN DD libF77/d_asin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double asin(); +-double d_asin(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_asin(doublereal *x) +-#endif +-{ +-return( asin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_asin.c +echo libF77/d_atan.c 1>&2 +sed >libF77/d_atan.c <<'//GO.SYSIN DD libF77/d_atan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan(); +-double d_atan(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_atan(doublereal *x) +-#endif +-{ +-return( atan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_atan.c +echo libF77/d_atn2.c 1>&2 +sed >libF77/d_atn2.c <<'//GO.SYSIN DD libF77/d_atn2.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan2(); +-double d_atn2(x,y) doublereal *x, *y; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_atn2(doublereal *x, doublereal *y) +-#endif +-{ +-return( atan2(*x,*y) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_atn2.c +echo libF77/d_cnjg.c 1>&2 +sed >libF77/d_cnjg.c <<'//GO.SYSIN DD libF77/d_cnjg.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-#ifdef KR_headers +-d_cnjg(r, z) doublecomplex *r, *z; +-#else +-d_cnjg(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- doublereal zi = z->i; +- r->r = z->r; +- r->i = -zi; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_cnjg.c +echo libF77/d_cos.c 1>&2 +sed >libF77/d_cos.c <<'//GO.SYSIN DD libF77/d_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cos(); +-double d_cos(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_cos(doublereal *x) +-#endif +-{ +-return( cos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_cos.c +echo libF77/d_cosh.c 1>&2 +sed >libF77/d_cosh.c <<'//GO.SYSIN DD libF77/d_cosh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cosh(); +-double d_cosh(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_cosh(doublereal *x) +-#endif +-{ +-return( cosh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_cosh.c +echo libF77/d_dim.c 1>&2 +sed >libF77/d_dim.c <<'//GO.SYSIN DD libF77/d_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_dim(a,b) doublereal *a, *b; +-#else +-double d_dim(doublereal *a, doublereal *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_dim.c +echo libF77/d_exp.c 1>&2 +sed >libF77/d_exp.c <<'//GO.SYSIN DD libF77/d_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double exp(); +-double d_exp(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_exp(doublereal *x) +-#endif +-{ +-return( exp(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_exp.c +echo libF77/d_imag.c 1>&2 +sed >libF77/d_imag.c <<'//GO.SYSIN DD libF77/d_imag.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_imag(z) doublecomplex *z; +-#else +-double d_imag(doublecomplex *z) +-#endif +-{ +-return(z->i); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_imag.c +echo libF77/d_int.c 1>&2 +sed >libF77/d_int.c <<'//GO.SYSIN DD libF77/d_int.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double d_int(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_int(doublereal *x) +-#endif +-{ +-return( (*x>0) ? floor(*x) : -floor(- *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_int.c +echo libF77/d_lg10.c 1>&2 +sed >libF77/d_lg10.c <<'//GO.SYSIN DD libF77/d_lg10.c' 's/^-//' +-#include "f2c.h" +- +-#define log10e 0.43429448190325182765 +- +-#ifdef KR_headers +-double log(); +-double d_lg10(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_lg10(doublereal *x) +-#endif +-{ +-return( log10e * log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_lg10.c +echo libF77/d_log.c 1>&2 +sed >libF77/d_log.c <<'//GO.SYSIN DD libF77/d_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(); +-double d_log(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_log(doublereal *x) +-#endif +-{ +-return( log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_log.c +echo libF77/d_mod.c 1>&2 +sed >libF77/d_mod.c <<'//GO.SYSIN DD libF77/d_mod.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-#ifdef IEEE_drem +-double drem(); +-#else +-double floor(); +-#endif +-double d_mod(x,y) doublereal *x, *y; +-#else +-#ifdef IEEE_drem +-double drem(double, double); +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +-double d_mod(doublereal *x, doublereal *y) +-#endif +-{ +-#ifdef IEEE_drem +- double xa, ya, z; +- if ((ya = *y) < 0.) +- ya = -ya; +- z = drem(xa = *x, ya); +- if (xa > 0) { +- if (z < 0) +- z += ya; +- } +- else if (z > 0) +- z -= ya; +- return z; +-#else +- double quotient; +- if( (quotient = *x / *y) >= 0) +- quotient = floor(quotient); +- else +- quotient = -floor(-quotient); +- return(*x - (*y) * quotient ); +-#endif +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_mod.c +echo libF77/d_nint.c 1>&2 +sed >libF77/d_nint.c <<'//GO.SYSIN DD libF77/d_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double d_nint(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_nint(doublereal *x) +-#endif +-{ +-return( (*x)>=0 ? +- floor(*x + .5) : -floor(.5 - *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_nint.c +echo libF77/d_prod.c 1>&2 +sed >libF77/d_prod.c <<'//GO.SYSIN DD libF77/d_prod.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_prod(x,y) real *x, *y; +-#else +-double d_prod(real *x, real *y) +-#endif +-{ +-return( (*x) * (*y) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_prod.c +echo libF77/d_sign.c 1>&2 +sed >libF77/d_sign.c <<'//GO.SYSIN DD libF77/d_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_sign(a,b) doublereal *a, *b; +-#else +-double d_sign(doublereal *a, doublereal *b) +-#endif +-{ +-double x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sign.c +echo libF77/d_sin.c 1>&2 +sed >libF77/d_sin.c <<'//GO.SYSIN DD libF77/d_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(); +-double d_sin(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_sin(doublereal *x) +-#endif +-{ +-return( sin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sin.c +echo libF77/s_cat.c 1>&2 +sed >libF77/s_cat.c <<'//GO.SYSIN DD libF77/s_cat.c' 's/^-//' +-/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the +- * target of a concatenation to appear on its right-hand side (contrary +- * to the Fortran 77 Standard, but in accordance with Fortran 90). +- */ +- +-#include "f2c.h" +-#ifndef NO_OVERWRITE +-#include "stdio.h" +-#undef abs +-#ifdef KR_headers +- extern char *F77_aloc(); +- extern void free(); +- extern void exit_(); +-#else +-#undef min +-#undef max +-#include "stdlib.h" +-extern +-#ifdef __cplusplus +- "C" +-#endif +- char *F77_aloc(ftnlen, char*); +-#endif +-#include "string.h" +-#endif /* NO_OVERWRITE */ +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-#ifdef KR_headers +-s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll; +-#else +-s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) +-#endif +-{ +- ftnlen i, nc; +- char *rp; +- ftnlen n = *np; +-#ifndef NO_OVERWRITE +- ftnlen L, m; +- char *lp0, *lp1; +- +- lp0 = 0; +- lp1 = lp; +- L = ll; +- i = 0; +- while(i < n) { +- rp = rpp[i]; +- m = rnp[i++]; +- if (rp >= lp1 || rp + m <= lp) { +- if ((L -= m) <= 0) { +- n = i; +- break; +- } +- lp1 += m; +- continue; +- } +- lp0 = lp; +- lp = lp1 = F77_aloc(L = ll, "s_cat"); +- break; +- } +- lp1 = lp; +-#endif /* NO_OVERWRITE */ +- for(i = 0 ; i < n ; ++i) { +- nc = ll; +- if(rnp[i] < nc) +- nc = rnp[i]; +- ll -= nc; +- rp = rpp[i]; +- while(--nc >= 0) +- *lp++ = *rp++; +- } +- while(--ll >= 0) +- *lp++ = ' '; +-#ifndef NO_OVERWRITE +- if (lp0) { +- memcpy(lp0, lp1, L); +- free(lp1); +- } +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_cat.c +echo libF77/Notice 1>&2 +sed >libF77/Notice <<'//GO.SYSIN DD libF77/Notice' 's/^-//' +-/**************************************************************** +-Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. +- +-Permission to use, copy, modify, and distribute this software +-and its documentation for any purpose and without fee is hereby +-granted, provided that the above copyright notice appear in all +-copies and that both that the copyright notice and this +-permission notice and warranty disclaimer appear in supporting +-documentation, and that the names of AT&T, Bell Laboratories, +-Lucent or Bellcore or any of their entities not be used in +-advertising or publicity pertaining to distribution of the +-software without specific, written prior permission. +- +-AT&T, Lucent and Bellcore disclaim all warranties with regard to +-this software, including all implied warranties of +-merchantability and fitness. In no event shall AT&T, Lucent or +-Bellcore be liable for any special, indirect or consequential +-damages or any damages whatsoever resulting from loss of use, +-data or profits, whether in an action of contract, negligence or +-other tortious action, arising out of or in connection with the +-use or performance of this software. +-****************************************************************/ +- +//GO.SYSIN DD libF77/Notice +echo libF77/f2ch.add 1>&2 +sed >libF77/f2ch.add <<'//GO.SYSIN DD libF77/f2ch.add' 's/^-//' +-/* If you are using a C++ compiler, append the following to f2c.h +- for compiling libF77 and libI77. */ +- +-#ifdef __cplusplus +-extern "C" { +-extern int abort_(void); +-extern double c_abs(complex *); +-extern void c_cos(complex *, complex *); +-extern void c_div(complex *, complex *, complex *); +-extern void c_exp(complex *, complex *); +-extern void c_log(complex *, complex *); +-extern void c_sin(complex *, complex *); +-extern void c_sqrt(complex *, complex *); +-extern double d_abs(double *); +-extern double d_acos(double *); +-extern double d_asin(double *); +-extern double d_atan(double *); +-extern double d_atn2(double *, double *); +-extern void d_cnjg(doublecomplex *, doublecomplex *); +-extern double d_cos(double *); +-extern double d_cosh(double *); +-extern double d_dim(double *, double *); +-extern double d_exp(double *); +-extern double d_imag(doublecomplex *); +-extern double d_int(double *); +-extern double d_lg10(double *); +-extern double d_log(double *); +-extern double d_mod(double *, double *); +-extern double d_nint(double *); +-extern double d_prod(float *, float *); +-extern double d_sign(double *, double *); +-extern double d_sin(double *); +-extern double d_sinh(double *); +-extern double d_sqrt(double *); +-extern double d_tan(double *); +-extern double d_tanh(double *); +-extern double derf_(double *); +-extern double derfc_(double *); +-extern integer do_fio(ftnint *, char *, ftnlen); +-extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +-extern integer do_uio(ftnint *, char *, ftnlen); +-extern integer e_rdfe(void); +-extern integer e_rdue(void); +-extern integer e_rsfe(void); +-extern integer e_rsfi(void); +-extern integer e_rsle(void); +-extern integer e_rsli(void); +-extern integer e_rsue(void); +-extern integer e_wdfe(void); +-extern integer e_wdue(void); +-extern integer e_wsfe(void); +-extern integer e_wsfi(void); +-extern integer e_wsle(void); +-extern integer e_wsli(void); +-extern integer e_wsue(void); +-extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern double erf(double); +-extern double erf_(float *); +-extern double erfc(double); +-extern double erfc_(float *); +-extern integer f_back(alist *); +-extern integer f_clos(cllist *); +-extern integer f_end(alist *); +-extern void f_exit(void); +-extern integer f_inqu(inlist *); +-extern integer f_open(olist *); +-extern integer f_rew(alist *); +-extern int flush_(void); +-extern void getarg_(integer *, char *, ftnlen); +-extern void getenv_(char *, char *, ftnlen, ftnlen); +-extern short h_abs(short *); +-extern short h_dim(short *, short *); +-extern short h_dnnt(double *); +-extern short h_indx(char *, char *, ftnlen, ftnlen); +-extern short h_len(char *, ftnlen); +-extern short h_mod(short *, short *); +-extern short h_nint(float *); +-extern short h_sign(short *, short *); +-extern short hl_ge(char *, char *, ftnlen, ftnlen); +-extern short hl_gt(char *, char *, ftnlen, ftnlen); +-extern short hl_le(char *, char *, ftnlen, ftnlen); +-extern short hl_lt(char *, char *, ftnlen, ftnlen); +-extern integer i_abs(integer *); +-extern integer i_dim(integer *, integer *); +-extern integer i_dnnt(double *); +-extern integer i_indx(char *, char *, ftnlen, ftnlen); +-extern integer i_len(char *, ftnlen); +-extern integer i_mod(integer *, integer *); +-extern integer i_nint(float *); +-extern integer i_sign(integer *, integer *); +-extern integer iargc_(void); +-extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +-extern void pow_ci(complex *, complex *, integer *); +-extern double pow_dd(double *, double *); +-extern double pow_di(double *, integer *); +-extern short pow_hh(short *, shortint *); +-extern integer pow_ii(integer *, integer *); +-extern double pow_ri(float *, integer *); +-extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +-extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +-extern double r_abs(float *); +-extern double r_acos(float *); +-extern double r_asin(float *); +-extern double r_atan(float *); +-extern double r_atn2(float *, float *); +-extern void r_cnjg(complex *, complex *); +-extern double r_cos(float *); +-extern double r_cosh(float *); +-extern double r_dim(float *, float *); +-extern double r_exp(float *); +-extern double r_imag(complex *); +-extern double r_int(float *); +-extern double r_lg10(float *); +-extern double r_log(float *); +-extern double r_mod(float *, float *); +-extern double r_nint(float *); +-extern double r_sign(float *, float *); +-extern double r_sin(float *); +-extern double r_sinh(float *); +-extern double r_sqrt(float *); +-extern double r_tan(float *); +-extern double r_tanh(float *); +-extern void s_cat(char *, char **, integer *, integer *, ftnlen); +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-extern void s_copy(char *, char *, ftnlen, ftnlen); +-extern int s_paus(char *, ftnlen); +-extern integer s_rdfe(cilist *); +-extern integer s_rdue(cilist *); +-extern integer s_rnge(char *, integer, char *, integer); +-extern integer s_rsfe(cilist *); +-extern integer s_rsfi(icilist *); +-extern integer s_rsle(cilist *); +-extern integer s_rsli(icilist *); +-extern integer s_rsne(cilist *); +-extern integer s_rsni(icilist *); +-extern integer s_rsue(cilist *); +-extern int s_stop(char *, ftnlen); +-extern integer s_wdfe(cilist *); +-extern integer s_wdue(cilist *); +-extern integer s_wsfe(cilist *); +-extern integer s_wsfi(icilist *); +-extern integer s_wsle(cilist *); +-extern integer s_wsli(icilist *); +-extern integer s_wsne(cilist *); +-extern integer s_wsni(icilist *); +-extern integer s_wsue(cilist *); +-extern void sig_die(char *, int); +-extern integer signal_(integer *, void (*)(int)); +-extern integer system_(char *, ftnlen); +-extern double z_abs(doublecomplex *); +-extern void z_cos(doublecomplex *, doublecomplex *); +-extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +-extern void z_exp(doublecomplex *, doublecomplex *); +-extern void z_log(doublecomplex *, doublecomplex *); +-extern void z_sin(doublecomplex *, doublecomplex *); +-extern void z_sqrt(doublecomplex *, doublecomplex *); +- } +-#endif +//GO.SYSIN DD libF77/f2ch.add diff --git a/unix/f2c/libi77 b/unix/f2c/libi77 new file mode 100644 index 00000000..750ee952 --- /dev/null +++ b/unix/f2c/libi77 @@ -0,0 +1,7453 @@ +# to unbundle, sh this file (in an empty directory) +mkdir libI77 +echo libI77/lio.h 1>&2 +sed >libI77/lio.h <<'//GO.SYSIN DD libI77/lio.h' 's/^-//' +-/* copy of ftypes from the compiler */ +-/* variable types +- * numeric assumptions: +- * int < reals < complexes +- * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX +- */ +- +-/* 0-10 retain their old (pre LOGICAL*1, etc.) */ +-/* values to allow mixing old and new objects. */ +- +-#define TYUNKNOWN 0 +-#define TYADDR 1 +-#define TYSHORT 2 +-#define TYLONG 3 +-#define TYREAL 4 +-#define TYDREAL 5 +-#define TYCOMPLEX 6 +-#define TYDCOMPLEX 7 +-#define TYLOGICAL 8 +-#define TYCHAR 9 +-#define TYSUBR 10 +-#define TYINT1 11 +-#define TYLOGICAL1 12 +-#define TYLOGICAL2 13 +-#ifdef Allow_TYQUAD +-#undef TYQUAD +-#define TYQUAD 14 +-#endif +- +-#define LINTW 24 +-#define LINE 80 +-#define LLOGW 2 +-#ifdef Old_list_output +-#define LLOW 1.0 +-#define LHIGH 1.e9 +-#define LEFMT " %# .8E" +-#define LFFMT " %# .9g" +-#else +-#define LGFMT "%.9G" +-#endif +-/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ +-#define LEFBL 24 +- +-typedef union +-{ +- char flchar; +- short flshort; +- ftnint flint; +-#ifdef Allow_TYQUAD +- longint fllongint; +-#endif +- real flreal; +- doublereal fldouble; +-} flex; +-extern int f__scale; +-#ifdef KR_headers +-extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +-extern int l_read(), l_write(); +-#else +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +-extern int l_write(ftnint*, char*, ftnlen, ftnint); +-extern void x_wsne(cilist*); +-extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); +-extern int l_read(ftnint*,char*,ftnlen,ftnint); +-extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); +-extern int z_rnew(void); +-#ifdef __cplusplus +- } +-#endif +-#endif +-extern ftnint L_len; +//GO.SYSIN DD libI77/lio.h +echo libI77/lread.c 1>&2 +sed >libI77/lread.c <<'//GO.SYSIN DD libI77/lread.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ +-/* marks in namelist input a la the Fortran 8X Draft published in */ +-/* the May 1989 issue of Fortran Forum. */ +- +- +-extern char *f__fmtbuf; +- +-#ifdef Allow_TYQUAD +-static longint f__llx; +-#endif +- +-#ifdef KR_headers +-extern double atof(); +-extern char *malloc(), *realloc(); +-int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#endif +- +-#include "fmt.h" +-#include "lio.h" +-#include "ctype.h" +-#include "fp.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef KR_headers +-int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), +- (*l_ungetc)(int,FILE*); +-#endif +- +-int l_eof; +- +-#define isblnk(x) (f__ltab[x+1]&B) +-#define issep(x) (f__ltab[x+1]&SX) +-#define isapos(x) (f__ltab[x+1]&AX) +-#define isexp(x) (f__ltab[x+1]&EX) +-#define issign(x) (f__ltab[x+1]&SG) +-#define iswhit(x) (f__ltab[x+1]&WH) +-#define SX 1 +-#define B 2 +-#define AX 4 +-#define EX 8 +-#define SG 16 +-#define WH 32 +-char f__ltab[128+1] = { /* offset one for EOF */ +- 0, +- 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, +- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +- SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, +- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +- 0,0,0,0,EX,EX,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, +- AX,0,0,0,EX,EX,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 +-}; +- +-#ifdef ungetc +- static int +-#ifdef KR_headers +-un_getc(x,f__cf) int x; FILE *f__cf; +-#else +-un_getc(int x, FILE *f__cf) +-#endif +-{ return ungetc(x,f__cf); } +-#else +-#define un_getc ungetc +-#ifdef KR_headers +- extern int ungetc(); +-#else +-extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +-#endif +-#endif +- +- int +-t_getc(Void) +-{ int ch; +- if(f__curunit->uend) return(EOF); +- if((ch=getc(f__cf))!=EOF) return(ch); +- if(feof(f__cf)) +- f__curunit->uend = l_eof = 1; +- return(EOF); +-} +-integer e_rsle(Void) +-{ +- int ch; +- if(f__curunit->uend) return(0); +- while((ch=t_getc())!='\n') +- if (ch == EOF) { +- if(feof(f__cf)) +- f__curunit->uend = l_eof = 1; +- return EOF; +- } +- return(0); +-} +- +-flag f__lquit; +-int f__lcount,f__ltype,nml_read; +-char *f__lchar; +-double f__lx,f__ly; +-#define ERR(x) if(n=(x)) return(n) +-#define GETC(x) (x=(*l_getc)()) +-#define Ungetc(x,y) (*l_ungetc)(x,y) +- +- static int +-#ifdef KR_headers +-l_R(poststar, reqint) int poststar, reqint; +-#else +-l_R(int poststar, int reqint) +-#endif +-{ +- char s[FMAX+EXPMAXDIGS+4]; +- register int ch; +- register char *sp, *spe, *sp1; +- long e, exp; +- int havenum, havestar, se; +- +- if (!poststar) { +- if (f__lcount > 0) +- return(0); +- f__lcount = 1; +- } +-#ifdef Allow_TYQUAD +- f__llx = 0; +-#endif +- f__ltype = 0; +- exp = 0; +- havestar = 0; +-retry: +- sp1 = sp = s; +- spe = sp + FMAX; +- havenum = 0; +- +- switch(GETC(ch)) { +- case '-': *sp++ = ch; sp1++; spe++; +- case '+': +- GETC(ch); +- } +- while(ch == '0') { +- ++havenum; +- GETC(ch); +- } +- while(isdigit(ch)) { +- if (sp < spe) *sp++ = ch; +- else ++exp; +- GETC(ch); +- } +- if (ch == '*' && !poststar) { +- if (sp == sp1 || exp || *s == '-') { +- errfl(f__elist->cierr,112,"bad repetition count"); +- } +- poststar = havestar = 1; +- *sp = 0; +- f__lcount = atoi(s); +- goto retry; +- } +- if (ch == '.') { +-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT +- if (reqint) +- errfl(f__elist->cierr,115,"invalid integer"); +-#endif +- GETC(ch); +- if (sp == sp1) +- while(ch == '0') { +- ++havenum; +- --exp; +- GETC(ch); +- } +- while(isdigit(ch)) { +- if (sp < spe) +- { *sp++ = ch; --exp; } +- GETC(ch); +- } +- } +- havenum += sp - sp1; +- se = 0; +- if (issign(ch)) +- goto signonly; +- if (havenum && isexp(ch)) { +-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT +- if (reqint) +- errfl(f__elist->cierr,115,"invalid integer"); +-#endif +- GETC(ch); +- if (issign(ch)) { +-signonly: +- if (ch == '-') se = 1; +- GETC(ch); +- } +- if (!isdigit(ch)) { +-bad: +- errfl(f__elist->cierr,112,"exponent field"); +- } +- +- e = ch - '0'; +- while(isdigit(GETC(ch))) { +- e = 10*e + ch - '0'; +- if (e > EXPMAX) +- goto bad; +- } +- if (se) +- exp -= e; +- else +- exp += e; +- } +- (void) Ungetc(ch, f__cf); +- if (sp > sp1) { +- ++havenum; +- while(*--sp == '0') +- ++exp; +- if (exp) +- sprintf(sp+1, "e%ld", exp); +- else +- sp[1] = 0; +- f__lx = atof(s); +-#ifdef Allow_TYQUAD +- if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { +- /* Assuming 64-bit longint and 32-bit long. */ +- if (exp < 0) +- sp += exp; +- if (sp1 <= sp) { +- f__llx = *sp1 - '0'; +- while(++sp1 <= sp) +- f__llx = 10*f__llx + (*sp1 - '0'); +- } +- while(--exp >= 0) +- f__llx *= 10; +- if (*s == '-') +- f__llx = -f__llx; +- } +-#endif +- } +- else +- f__lx = 0.; +- if (havenum) +- f__ltype = TYLONG; +- else +- switch(ch) { +- case ',': +- case '/': +- break; +- default: +- if (havestar && ( ch == ' ' +- ||ch == '\t' +- ||ch == '\n')) +- break; +- if (nml_read > 1) { +- f__lquit = 2; +- return 0; +- } +- errfl(f__elist->cierr,112,"invalid number"); +- } +- return 0; +- } +- +- static int +-#ifdef KR_headers +-rd_count(ch) register int ch; +-#else +-rd_count(register int ch) +-#endif +-{ +- if (ch < '0' || ch > '9') +- return 1; +- f__lcount = ch - '0'; +- while(GETC(ch) >= '0' && ch <= '9') +- f__lcount = 10*f__lcount + ch - '0'; +- Ungetc(ch,f__cf); +- return f__lcount <= 0; +- } +- +- static int +-l_C(Void) +-{ int ch, nml_save; +- double lz; +- if(f__lcount>0) return(0); +- f__ltype=0; +- GETC(ch); +- if(ch!='(') +- { +- if (nml_read > 1 && (ch < '0' || ch > '9')) { +- Ungetc(ch,f__cf); +- f__lquit = 2; +- return 0; +- } +- if (rd_count(ch)) +- if(!f__cf || !feof(f__cf)) +- errfl(f__elist->cierr,112,"complex format"); +- else +- err(f__elist->cierr,(EOF),"lread"); +- if(GETC(ch)!='*') +- { +- if(!f__cf || !feof(f__cf)) +- errfl(f__elist->cierr,112,"no star"); +- else +- err(f__elist->cierr,(EOF),"lread"); +- } +- if(GETC(ch)!='(') +- { Ungetc(ch,f__cf); +- return(0); +- } +- } +- else +- f__lcount = 1; +- while(iswhit(GETC(ch))); +- Ungetc(ch,f__cf); +- nml_save = nml_read; +- nml_read = 0; +- if (ch = l_R(1,0)) +- return ch; +- if (!f__ltype) +- errfl(f__elist->cierr,112,"no real part"); +- lz = f__lx; +- while(iswhit(GETC(ch))); +- if(ch!=',') +- { (void) Ungetc(ch,f__cf); +- errfl(f__elist->cierr,112,"no comma"); +- } +- while(iswhit(GETC(ch))); +- (void) Ungetc(ch,f__cf); +- if (ch = l_R(1,0)) +- return ch; +- if (!f__ltype) +- errfl(f__elist->cierr,112,"no imaginary part"); +- while(iswhit(GETC(ch))); +- if(ch!=')') errfl(f__elist->cierr,112,"no )"); +- f__ly = f__lx; +- f__lx = lz; +-#ifdef Allow_TYQUAD +- f__llx = 0; +-#endif +- nml_read = nml_save; +- return(0); +-} +- +- static char nmLbuf[256], *nmL_next; +- static int (*nmL_getc_save)(Void); +-#ifdef KR_headers +- static int (*nmL_ungetc_save)(/* int, FILE* */); +-#else +- static int (*nmL_ungetc_save)(int, FILE*); +-#endif +- +- static int +-nmL_getc(Void) +-{ +- int rv; +- if (rv = *nmL_next++) +- return rv; +- l_getc = nmL_getc_save; +- l_ungetc = nmL_ungetc_save; +- return (*l_getc)(); +- } +- +- static int +-#ifdef KR_headers +-nmL_ungetc(x, f) int x; FILE *f; +-#else +-nmL_ungetc(int x, FILE *f) +-#endif +-{ +- f = f; /* banish non-use warning */ +- return *--nmL_next = x; +- } +- +- static int +-#ifdef KR_headers +-Lfinish(ch, dot, rvp) int ch, dot, *rvp; +-#else +-Lfinish(int ch, int dot, int *rvp) +-#endif +-{ +- char *s, *se; +- static char what[] = "namelist input"; +- +- s = nmLbuf + 2; +- se = nmLbuf + sizeof(nmLbuf) - 1; +- *s++ = ch; +- while(!issep(GETC(ch)) && ch!=EOF) { +- if (s >= se) { +- nmLbuf_ovfl: +- return *rvp = err__fl(f__elist->cierr,131,what); +- } +- *s++ = ch; +- if (ch != '=') +- continue; +- if (dot) +- return *rvp = err__fl(f__elist->cierr,112,what); +- got_eq: +- *s = 0; +- nmL_getc_save = l_getc; +- l_getc = nmL_getc; +- nmL_ungetc_save = l_ungetc; +- l_ungetc = nmL_ungetc; +- nmLbuf[1] = *(nmL_next = nmLbuf) = ','; +- *rvp = f__lcount = 0; +- return 1; +- } +- if (dot) +- goto done; +- for(;;) { +- if (s >= se) +- goto nmLbuf_ovfl; +- *s++ = ch; +- if (!isblnk(ch)) +- break; +- if (GETC(ch) == EOF) +- goto done; +- } +- if (ch == '=') +- goto got_eq; +- done: +- Ungetc(ch, f__cf); +- return 0; +- } +- +- static int +-l_L(Void) +-{ +- int ch, rv, sawdot; +- +- if(f__lcount>0) +- return(0); +- f__lcount = 1; +- f__ltype=0; +- GETC(ch); +- if(isdigit(ch)) +- { +- rd_count(ch); +- if(GETC(ch)!='*') +- if(!f__cf || !feof(f__cf)) +- errfl(f__elist->cierr,112,"no star"); +- else +- err(f__elist->cierr,(EOF),"lread"); +- GETC(ch); +- } +- sawdot = 0; +- if(ch == '.') { +- sawdot = 1; +- GETC(ch); +- } +- switch(ch) +- { +- case 't': +- case 'T': +- if (nml_read && Lfinish(ch, sawdot, &rv)) +- return rv; +- f__lx=1; +- break; +- case 'f': +- case 'F': +- if (nml_read && Lfinish(ch, sawdot, &rv)) +- return rv; +- f__lx=0; +- break; +- default: +- if(isblnk(ch) || issep(ch) || ch==EOF) +- { (void) Ungetc(ch,f__cf); +- return(0); +- } +- if (nml_read > 1) { +- Ungetc(ch,f__cf); +- f__lquit = 2; +- return 0; +- } +- errfl(f__elist->cierr,112,"logical"); +- } +- f__ltype=TYLONG; +- while(!issep(GETC(ch)) && ch!=EOF); +- Ungetc(ch, f__cf); +- return(0); +-} +- +-#define BUFSIZE 128 +- +- static int +-l_CHAR(Void) +-{ int ch,size,i; +- static char rafail[] = "realloc failure"; +- char quote,*p; +- if(f__lcount>0) return(0); +- f__ltype=0; +- if(f__lchar!=NULL) free(f__lchar); +- size=BUFSIZE; +- p=f__lchar = (char *)malloc((unsigned int)size); +- if(f__lchar == NULL) +- errfl(f__elist->cierr,113,"no space"); +- +- GETC(ch); +- if(isdigit(ch)) { +- /* allow Fortran 8x-style unquoted string... */ +- /* either find a repetition count or the string */ +- f__lcount = ch - '0'; +- *p++ = ch; +- for(i = 1;;) { +- switch(GETC(ch)) { +- case '*': +- if (f__lcount == 0) { +- f__lcount = 1; +-#ifndef F8X_NML_ELIDE_QUOTES +- if (nml_read) +- goto no_quote; +-#endif +- goto noquote; +- } +- p = f__lchar; +- goto have_lcount; +- case ',': +- case ' ': +- case '\t': +- case '\n': +- case '/': +- Ungetc(ch,f__cf); +- /* no break */ +- case EOF: +- f__lcount = 1; +- f__ltype = TYCHAR; +- return *p = 0; +- } +- if (!isdigit(ch)) { +- f__lcount = 1; +-#ifndef F8X_NML_ELIDE_QUOTES +- if (nml_read) { +- no_quote: +- errfl(f__elist->cierr,112, +- "undelimited character string"); +- } +-#endif +- goto noquote; +- } +- *p++ = ch; +- f__lcount = 10*f__lcount + ch - '0'; +- if (++i == size) { +- f__lchar = (char *)realloc(f__lchar, +- (unsigned int)(size += BUFSIZE)); +- if(f__lchar == NULL) +- errfl(f__elist->cierr,113,rafail); +- p = f__lchar + i; +- } +- } +- } +- else (void) Ungetc(ch,f__cf); +- have_lcount: +- if(GETC(ch)=='\'' || ch=='"') quote=ch; +- else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { +- Ungetc(ch,f__cf); +- return 0; +- } +-#ifndef F8X_NML_ELIDE_QUOTES +- else if (nml_read > 1) { +- Ungetc(ch,f__cf); +- f__lquit = 2; +- return 0; +- } +-#endif +- else { +- /* Fortran 8x-style unquoted string */ +- *p++ = ch; +- for(i = 1;;) { +- switch(GETC(ch)) { +- case ',': +- case ' ': +- case '\t': +- case '\n': +- case '/': +- Ungetc(ch,f__cf); +- /* no break */ +- case EOF: +- f__ltype = TYCHAR; +- return *p = 0; +- } +- noquote: +- *p++ = ch; +- if (++i == size) { +- f__lchar = (char *)realloc(f__lchar, +- (unsigned int)(size += BUFSIZE)); +- if(f__lchar == NULL) +- errfl(f__elist->cierr,113,rafail); +- p = f__lchar + i; +- } +- } +- } +- f__ltype=TYCHAR; +- for(i=0;;) +- { while(GETC(ch)!=quote && ch!='\n' +- && ch!=EOF && ++icierr,113,rafail); +- p=f__lchar+i-1; +- *p++ = ch; +- } +- else if(ch==EOF) return(EOF); +- else if(ch=='\n') +- { if(*(p-1) != '\\') continue; +- i--; +- p--; +- if(++iciunit]; +- if(a->ciunit>=MXUNIT || a->ciunit<0) +- err(a->cierr,101,"stler"); +- f__scale=f__recpos=0; +- f__elist=a; +- if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) +- err(a->cierr,102,"lio"); +- f__cf=f__curunit->ufd; +- if(!f__curunit->ufmt) err(a->cierr,103,"lio") +- return(0); +-} +- +- int +-#ifdef KR_headers +-l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +-#else +-l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) +-#endif +-{ +-#define Ptr ((flex *)ptr) +- int i,n,ch; +- doublereal *yy; +- real *xx; +- for(i=0;i<*number;i++) +- { +- if(f__lquit) return(0); +- if(l_eof) +- err(f__elist->ciend, EOF, "list in") +- if(f__lcount == 0) { +- f__ltype = 0; +- for(;;) { +- GETC(ch); +- switch(ch) { +- case EOF: +- err(f__elist->ciend,(EOF),"list in") +- case ' ': +- case '\t': +- case '\n': +- continue; +- case '/': +- f__lquit = 1; +- goto loopend; +- case ',': +- f__lcount = 1; +- goto loopend; +- default: +- (void) Ungetc(ch, f__cf); +- goto rddata; +- } +- } +- } +- rddata: +- switch((int)type) +- { +- case TYINT1: +- case TYSHORT: +- case TYLONG: +-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT +- ERR(l_R(0,1)); +- break; +-#endif +- case TYREAL: +- case TYDREAL: +- ERR(l_R(0,0)); +- break; +-#ifdef TYQUAD +- case TYQUAD: +- n = l_R(0,2); +- if (n) +- return n; +- break; +-#endif +- case TYCOMPLEX: +- case TYDCOMPLEX: +- ERR(l_C()); +- break; +- case TYLOGICAL1: +- case TYLOGICAL2: +- case TYLOGICAL: +- ERR(l_L()); +- break; +- case TYCHAR: +- ERR(l_CHAR()); +- break; +- } +- while (GETC(ch) == ' ' || ch == '\t'); +- if (ch != ',' || f__lcount > 1) +- Ungetc(ch,f__cf); +- loopend: +- if(f__lquit) return(0); +- if(f__cf && ferror(f__cf)) { +- clearerr(f__cf); +- errfl(f__elist->cierr,errno,"list in"); +- } +- if(f__ltype==0) goto bump; +- switch((int)type) +- { +- case TYINT1: +- case TYLOGICAL1: +- Ptr->flchar = (char)f__lx; +- break; +- case TYLOGICAL2: +- case TYSHORT: +- Ptr->flshort = (short)f__lx; +- break; +- case TYLOGICAL: +- case TYLONG: +- Ptr->flint = (ftnint)f__lx; +- break; +-#ifdef Allow_TYQUAD +- case TYQUAD: +- if (!(Ptr->fllongint = f__llx)) +- Ptr->fllongint = f__lx; +- break; +-#endif +- case TYREAL: +- Ptr->flreal=f__lx; +- break; +- case TYDREAL: +- Ptr->fldouble=f__lx; +- break; +- case TYCOMPLEX: +- xx=(real *)ptr; +- *xx++ = f__lx; +- *xx = f__ly; +- break; +- case TYDCOMPLEX: +- yy=(doublereal *)ptr; +- *yy++ = f__lx; +- *yy = f__ly; +- break; +- case TYCHAR: +- b_char(f__lchar,ptr,len); +- break; +- } +- bump: +- if(f__lcount>0) f__lcount--; +- ptr += len; +- if (nml_read) +- nml_read++; +- } +- return(0); +-#undef Ptr +-} +-#ifdef KR_headers +-integer s_rsle(a) cilist *a; +-#else +-integer s_rsle(cilist *a) +-#endif +-{ +- int n; +- +- f__reading=1; +- f__external=1; +- f__formatted=1; +- if(n=c_le(a)) return(n); +- f__lioproc = l_read; +- f__lquit = 0; +- f__lcount = 0; +- l_eof = 0; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- if(f__curunit->uend) +- err(f__elist->ciend,(EOF),"read start"); +- l_getc = t_getc; +- l_ungetc = un_getc; +- f__doend = xrd_SL; +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/lread.c +echo libI77/lwrite.c 1>&2 +sed >libI77/lwrite.c <<'//GO.SYSIN DD libI77/lwrite.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#include "lio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-ftnint L_len; +-int f__Aquote; +- +- static VOID +-donewrec(Void) +-{ +- if (f__recpos) +- (*f__donewrec)(); +- } +- +- static VOID +-#ifdef KR_headers +-lwrt_I(n) longint n; +-#else +-lwrt_I(longint n) +-#endif +-{ +- char *p; +- int ndigit, sign; +- +- p = f__icvt(n, &ndigit, &sign, 10); +- if(f__recpos + ndigit >= L_len) +- donewrec(); +- PUT(' '); +- if (sign) +- PUT('-'); +- while(*p) +- PUT(*p++); +-} +- static VOID +-#ifdef KR_headers +-lwrt_L(n, len) ftnint n; ftnlen len; +-#else +-lwrt_L(ftnint n, ftnlen len) +-#endif +-{ +- if(f__recpos+LLOGW>=L_len) +- donewrec(); +- wrt_L((Uint *)&n,LLOGW, len); +-} +- static VOID +-#ifdef KR_headers +-lwrt_A(p,len) char *p; ftnlen len; +-#else +-lwrt_A(char *p, ftnlen len) +-#endif +-{ +- int a; +- char *p1, *pe; +- +- a = 0; +- pe = p + len; +- if (f__Aquote) { +- a = 3; +- if (len > 1 && p[len-1] == ' ') { +- while(--len > 1 && p[len-1] == ' '); +- pe = p + len; +- } +- p1 = p; +- while(p1 < pe) +- if (*p1++ == '\'') +- a++; +- } +- if(f__recpos+len+a >= L_len) +- donewrec(); +- if (a +-#ifndef OMIT_BLANK_CC +- || !f__recpos +-#endif +- ) +- PUT(' '); +- if (a) { +- PUT('\''); +- while(p < pe) { +- if (*p == '\'') +- PUT('\''); +- PUT(*p++); +- } +- PUT('\''); +- } +- else +- while(p < pe) +- PUT(*p++); +-} +- +- static int +-#ifdef KR_headers +-l_g(buf, n) char *buf; double n; +-#else +-l_g(char *buf, double n) +-#endif +-{ +-#ifdef Old_list_output +- doublereal absn; +- char *fmt; +- +- absn = n; +- if (absn < 0) +- absn = -absn; +- fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; +-#ifdef USE_STRLEN +- sprintf(buf, fmt, n); +- return strlen(buf); +-#else +- return sprintf(buf, fmt, n); +-#endif +- +-#else +- register char *b, c, c1; +- +- b = buf; +- *b++ = ' '; +- if (n < 0) { +- *b++ = '-'; +- n = -n; +- } +- else +- *b++ = ' '; +- if (n == 0) { +-#ifdef SIGNED_ZEROS +- if (signbit_f2c(&n)) +- *b++ = '-'; +-#endif +- *b++ = '0'; +- *b++ = '.'; +- *b = 0; +- goto f__ret; +- } +- sprintf(b, LGFMT, n); +- switch(*b) { +-#ifndef WANT_LEAD_0 +- case '0': +- while(b[0] = b[1]) +- b++; +- break; +-#endif +- case 'i': +- case 'I': +- /* Infinity */ +- case 'n': +- case 'N': +- /* NaN */ +- while(*++b); +- break; +- +- default: +- /* Fortran 77 insists on having a decimal point... */ +- for(;; b++) +- switch(*b) { +- case 0: +- *b++ = '.'; +- *b = 0; +- goto f__ret; +- case '.': +- while(*++b); +- goto f__ret; +- case 'E': +- for(c1 = '.', c = 'E'; *b = c1; +- c1 = c, c = *++b); +- goto f__ret; +- } +- } +- f__ret: +- return b - buf; +-#endif +- } +- +- static VOID +-#ifdef KR_headers +-l_put(s) register char *s; +-#else +-l_put(register char *s) +-#endif +-{ +-#ifdef KR_headers +- register void (*pn)() = f__putn; +-#else +- register void (*pn)(int) = f__putn; +-#endif +- register int c; +- +- while(c = *s++) +- (*pn)(c); +- } +- +- static VOID +-#ifdef KR_headers +-lwrt_F(n) double n; +-#else +-lwrt_F(double n) +-#endif +-{ +- char buf[LEFBL]; +- +- if(f__recpos + l_g(buf,n) >= L_len) +- donewrec(); +- l_put(buf); +-} +- static VOID +-#ifdef KR_headers +-lwrt_C(a,b) double a,b; +-#else +-lwrt_C(double a, double b) +-#endif +-{ +- char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; +- int al, bl; +- +- al = l_g(bufa, a); +- for(ba = bufa; *ba == ' '; ba++) +- --al; +- bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ +- for(bb = bufb; *bb == ' '; bb++) +- --bl; +- if(f__recpos + al + bl + 3 >= L_len) +- donewrec(); +-#ifdef OMIT_BLANK_CC +- else +-#endif +- PUT(' '); +- PUT('('); +- l_put(ba); +- PUT(','); +- if (f__recpos + bl >= L_len) { +- (*f__donewrec)(); +-#ifndef OMIT_BLANK_CC +- PUT(' '); +-#endif +- } +- l_put(bb); +- PUT(')'); +-} +- +- int +-#ifdef KR_headers +-l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +-#else +-l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) +-#endif +-{ +-#define Ptr ((flex *)ptr) +- int i; +- longint x; +- double y,z; +- real *xx; +- doublereal *yy; +- for(i=0;i< *number; i++) +- { +- switch((int)type) +- { +- default: f__fatal(117,"unknown type in lio"); +- case TYINT1: +- x = Ptr->flchar; +- goto xint; +- case TYSHORT: +- x=Ptr->flshort; +- goto xint; +-#ifdef Allow_TYQUAD +- case TYQUAD: +- x = Ptr->fllongint; +- goto xint; +-#endif +- case TYLONG: +- x=Ptr->flint; +- xint: lwrt_I(x); +- break; +- case TYREAL: +- y=Ptr->flreal; +- goto xfloat; +- case TYDREAL: +- y=Ptr->fldouble; +- xfloat: lwrt_F(y); +- break; +- case TYCOMPLEX: +- xx= &Ptr->flreal; +- y = *xx++; +- z = *xx; +- goto xcomplex; +- case TYDCOMPLEX: +- yy = &Ptr->fldouble; +- y= *yy++; +- z = *yy; +- xcomplex: +- lwrt_C(y,z); +- break; +- case TYLOGICAL1: +- x = Ptr->flchar; +- goto xlog; +- case TYLOGICAL2: +- x = Ptr->flshort; +- goto xlog; +- case TYLOGICAL: +- x = Ptr->flint; +- xlog: lwrt_L(Ptr->flint, len); +- break; +- case TYCHAR: +- lwrt_A(ptr,len); +- break; +- } +- ptr += len; +- } +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/lwrite.c +echo libI77/makefile 1>&2 +sed >libI77/makefile <<'//GO.SYSIN DD libI77/makefile' 's/^-//' +-.SUFFIXES: .c .o +-CC = cc +-CFLAGS = -O +-SHELL = /bin/sh +- +-# compile, then strip unnecessary symbols +-.c.o: +- $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c +- ld -r -x -o $*.xxx $*.o +- mv $*.xxx $*.o +-## Under Solaris (and other systems that do not understand ld -x), +-## omit -x in the ld line above. +-## If your system does not have the ld command, comment out +-## or remove both the ld and mv lines above. +- +-# To get signed zeros in write statements on IEEE-arithmetic systems, +-# add -DSIGNED_ZEROS to the CFLAGS assignment above and add signbit.o +-# to the end of the "OBJ =" assignment below. Also copy or link +-# libF77/arith.h to this directory (after "make arith.h" if necessary +-# in the libF77 directory). It's simpler to do things all at once +-# with libf2c.zip and its makefile.u. +- +-OBJ = backspace.o close.o dfe.o dolio.o due.o endfile.o err.o fmt.o \ +- fmtlib.o ftell_.o i77vers.o iio.o ilnw.o inquire.o lread.o lwrite.o \ +- open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o \ +- uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o +- +-all: sysdep1.h libI77.a +- +-libI77.a: $(OBJ) +- ar r libI77.a $? +- ranlib libI77.a || true +- +-### If your system lacks ranlib, you don't need it; see README. +- +-install: libI77.a +- cp libI77.a $(LIBDIR)/libI77.a +- ranlib $(LIBDIR)/libI77.a || true +- +-# i77vers.c was "Version.c"; renamed on 20010623 to accord with libf2c.zip. +- +-i77vers.o: i77vers.c +- $(CC) -c i77vers.c +- +-# To compile with C++, first "make f2c.h" +-f2c.h: f2ch.add +- cat /usr/include/f2c.h f2ch.add >f2c.h +- +- +-clean: +- rm -f $(OBJ) libI77.a +- +-clobber: clean +- rm -f libI77.a +- +-backspace.o: fio.h +-close.o: fio.h +-dfe.o: fio.h +-dfe.o: fmt.h +-due.o: fio.h +-endfile.o: fio.h rawio.h +-err.o: fio.h rawio.h +-fmt.o: fio.h +-fmt.o: fmt.h +-ftell_.o: fio.h +-ftell64_.o: fio.h +-iio.o: fio.h +-iio.o: fmt.h +-ilnw.o: fio.h +-ilnw.o: lio.h +-inquire.o: fio.h +-lread.o: fio.h +-lread.o: fmt.h +-lread.o: lio.h +-lread.o: fp.h +-lwrite.o: fio.h +-lwrite.o: fmt.h +-lwrite.o: lio.h +-open.o: fio.h rawio.h +-rdfmt.o: fio.h +-rdfmt.o: fmt.h +-rdfmt.o: fp.h +-rewind.o: fio.h +-rsfe.o: fio.h +-rsfe.o: fmt.h +-rsli.o: fio.h +-rsli.o: lio.h +-rsne.o: fio.h +-rsne.o: lio.h +-sfe.o: fio.h +-sue.o: fio.h +-uio.o: fio.h +-util.o: fio.h +-wref.o: fio.h +-wref.o: fmt.h +-wref.o: fp.h +-wrtfmt.o: fio.h +-wrtfmt.o: fmt.h +-wsfe.o: fio.h +-wsfe.o: fmt.h +-wsle.o: fio.h +-wsle.o: fmt.h +-wsle.o: lio.h +-wsne.o: fio.h +-wsne.o: lio.h +-xwsne.o: fio.h +-xwsne.o: lio.h +-xwsne.o: fmt.h +- +-sysdep1.h: sysdep1.h0 +- cp sysdep1.h0 sysdep1.h +- +-check: +- xsum Notice README backspace.c close.c dfe.c dolio.c due.c \ +- endfile.c err.c f2ch.add fio.h fmt.c fmt.h fmtlib.c fp.h ftell_.c \ +- ftell64_.c i77vers.c iio.c ilnw.c inquire.c lio.h lread.c lwrite.c \ +- makefile open.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c \ +- sue.c typesize.c uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c \ +- xwsne.c >zap +- cmp zap libI77.xsum && rm zap || diff libI77.xsum zap +//GO.SYSIN DD libI77/makefile +echo libI77/open.c 1>&2 +sed >libI77/open.c <<'//GO.SYSIN DD libI77/open.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "string.h" +-#ifndef NON_POSIX_STDIO +-#ifdef MSDOS +-#include "io.h" +-#else +-#include "unistd.h" /* for access */ +-#endif +-#endif +- +-#ifdef KR_headers +-extern char *malloc(); +-#ifdef NON_ANSI_STDIO +-extern char *mktemp(); +-#endif +-extern integer f_clos(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int f__canseek(FILE*); +-extern integer f_clos(cllist*); +-#endif +- +-#ifdef NON_ANSI_RW_MODES +-char *f__r_mode[2] = {"r", "r"}; +-char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; +-#else +-char *f__r_mode[2] = {"rb", "r"}; +-char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; +-#endif +- +- static char f__buf0[400], *f__buf = f__buf0; +- int f__buflen = (int)sizeof(f__buf0); +- +- static void +-#ifdef KR_headers +-f__bufadj(n, c) int n, c; +-#else +-f__bufadj(int n, int c) +-#endif +-{ +- unsigned int len; +- char *nbuf, *s, *t, *te; +- +- if (f__buf == f__buf0) +- f__buflen = 1024; +- while(f__buflen <= n) +- f__buflen <<= 1; +- len = (unsigned int)f__buflen; +- if (len != f__buflen || !(nbuf = (char*)malloc(len))) +- f__fatal(113, "malloc failure"); +- s = nbuf; +- t = f__buf; +- te = t + c; +- while(t < te) +- *s++ = *t++; +- if (f__buf != f__buf0) +- free(f__buf); +- f__buf = nbuf; +- } +- +- int +-#ifdef KR_headers +-f__putbuf(c) int c; +-#else +-f__putbuf(int c) +-#endif +-{ +- char *s, *se; +- int n; +- +- if (f__hiwater > f__recpos) +- f__recpos = f__hiwater; +- n = f__recpos + 1; +- if (n >= f__buflen) +- f__bufadj(n, f__recpos); +- s = f__buf; +- se = s + f__recpos; +- if (c) +- *se++ = c; +- *se = 0; +- for(;;) { +- fputs(s, f__cf); +- s += strlen(s); +- if (s >= se) +- break; /* normally happens the first time */ +- putc(*s++, f__cf); +- } +- return 0; +- } +- +- void +-#ifdef KR_headers +-x_putc(c) +-#else +-x_putc(int c) +-#endif +-{ +- if (f__recpos >= f__buflen) +- f__bufadj(f__recpos, f__buflen); +- f__buf[f__recpos++] = c; +- } +- +-#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);} +- +- static void +-#ifdef KR_headers +-opn_err(m, s, a) int m; char *s; olist *a; +-#else +-opn_err(int m, char *s, olist *a) +-#endif +-{ +- if (a->ofnm) { +- /* supply file name to error message */ +- if (a->ofnmlen >= f__buflen) +- f__bufadj((int)a->ofnmlen, 0); +- g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); +- } +- f__fatal(m, s); +- } +- +-#ifdef KR_headers +-integer f_open(a) olist *a; +-#else +-integer f_open(olist *a) +-#endif +-{ unit *b; +- integer rv; +- char buf[256], *s; +- cllist x; +- int ufmt; +- FILE *tf; +-#ifndef NON_UNIX_STDIO +- int n; +-#endif +- f__external = 1; +- if(a->ounit>=MXUNIT || a->ounit<0) +- err(a->oerr,101,"open") +- if (!f__init) +- f_init(); +- f__curunit = b = &f__units[a->ounit]; +- if(b->ufd) { +- if(a->ofnm==0) +- { +- same: if (a->oblnk) +- b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; +- return(0); +- } +-#ifdef NON_UNIX_STDIO +- if (b->ufnm +- && strlen(b->ufnm) == a->ofnmlen +- && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) +- goto same; +-#else +- g_char(a->ofnm,a->ofnmlen,buf); +- if (f__inode(buf,&n) == b->uinode && n == b->udev) +- goto same; +-#endif +- x.cunit=a->ounit; +- x.csta=0; +- x.cerr=a->oerr; +- if ((rv = f_clos(&x)) != 0) +- return rv; +- } +- b->url = (int)a->orl; +- b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); +- if(a->ofm==0) +- { if(b->url>0) b->ufmt=0; +- else b->ufmt=1; +- } +- else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; +- else b->ufmt=0; +- ufmt = b->ufmt; +-#ifdef url_Adjust +- if (b->url && !ufmt) +- url_Adjust(b->url); +-#endif +- if (a->ofnm) { +- g_char(a->ofnm,a->ofnmlen,buf); +- if (!buf[0]) +- opnerr(a->oerr,107,"open") +- } +- else +- sprintf(buf, "fort.%ld", (long)a->ounit); +- b->uscrtch = 0; +- b->uend=0; +- b->uwrt = 0; +- b->ufd = 0; +- b->urw = 3; +- switch(a->osta ? *a->osta : 'u') +- { +- case 'o': +- case 'O': +-#ifdef NON_POSIX_STDIO +- if (!(tf = FOPEN(buf,"r"))) +- opnerr(a->oerr,errno,"open") +- fclose(tf); +-#else +- if (access(buf,0)) +- opnerr(a->oerr,errno,"open") +-#endif +- break; +- case 's': +- case 'S': +- b->uscrtch=1; +-#ifdef NON_ANSI_STDIO +- (void) strcpy(buf,"tmp.FXXXXXX"); +- (void) mktemp(buf); +- goto replace; +-#else +- if (!(b->ufd = tmpfile())) +- opnerr(a->oerr,errno,"open") +- b->ufnm = 0; +-#ifndef NON_UNIX_STDIO +- b->uinode = b->udev = -1; +-#endif +- b->useek = 1; +- return 0; +-#endif +- +- case 'n': +- case 'N': +-#ifdef NON_POSIX_STDIO +- if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) { +- fclose(tf); +- opnerr(a->oerr,128,"open") +- } +-#else +- if (!access(buf,0)) +- opnerr(a->oerr,128,"open") +-#endif +- /* no break */ +- case 'r': /* Fortran 90 replace option */ +- case 'R': +-#ifdef NON_ANSI_STDIO +- replace: +-#endif +- if (tf = FOPEN(buf,f__w_mode[0])) +- fclose(tf); +- } +- +- b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); +- if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); +- (void) strcpy(b->ufnm,buf); +- if ((s = a->oacc) && b->url) +- ufmt = 0; +- if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) { +- if (tf = FOPEN(buf, f__r_mode[ufmt])) +- b->urw = 1; +- else if (tf = FOPEN(buf, f__w_mode[ufmt])) { +- b->uwrt = 1; +- b->urw = 2; +- } +- else +- err(a->oerr, errno, "open"); +- } +- b->useek = f__canseek(b->ufd = tf); +-#ifndef NON_UNIX_STDIO +- if((b->uinode = f__inode(buf,&b->udev)) == -1) +- opnerr(a->oerr,108,"open") +-#endif +- if(b->useek) +- if (a->orl) +- rewind(b->ufd); +- else if ((s = a->oacc) && (*s == 'a' || *s == 'A') +- && FSEEK(b->ufd, 0L, SEEK_END)) +- opnerr(a->oerr,129,"open"); +- return(0); +-} +- +- int +-#ifdef KR_headers +-fk_open(seq,fmt,n) ftnint n; +-#else +-fk_open(int seq, int fmt, ftnint n) +-#endif +-{ char nbuf[10]; +- olist a; +- (void) sprintf(nbuf,"fort.%ld",(long)n); +- a.oerr=1; +- a.ounit=n; +- a.ofnm=nbuf; +- a.ofnmlen=strlen(nbuf); +- a.osta=NULL; +- a.oacc= (char*)(seq==SEQ?"s":"d"); +- a.ofm = (char*)(fmt==FMT?"f":"u"); +- a.orl = seq==DIR?1:0; +- a.oblnk=NULL; +- return(f_open(&a)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/open.c +echo libI77/rawio.h 1>&2 +sed >libI77/rawio.h <<'//GO.SYSIN DD libI77/rawio.h' 's/^-//' +-#ifndef KR_headers +-#ifdef MSDOS +-#include "io.h" +-#ifndef WATCOM +-#define close _close +-#define creat _creat +-#define open _open +-#define read _read +-#define write _write +-#endif /*WATCOM*/ +-#endif /*MSDOS*/ +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifndef MSDOS +-#ifdef OPEN_DECL +-extern int creat(const char*,int), open(const char*,int); +-#endif +-extern int close(int); +-extern int read(int,void*,size_t), write(int,void*,size_t); +-extern int unlink(const char*); +-#ifndef _POSIX_SOURCE +-#ifndef NON_UNIX_STDIO +-extern FILE *fdopen(int, const char*); +-#endif +-#endif +-#endif /*KR_HEADERS*/ +- +-extern char *mktemp(char*); +- +-#ifdef __cplusplus +- } +-#endif +-#endif +- +-#include "fcntl.h" +- +-#ifndef O_WRONLY +-#define O_RDONLY 0 +-#define O_WRONLY 1 +-#endif +//GO.SYSIN DD libI77/rawio.h +echo libI77/rdfmt.c 1>&2 +sed >libI77/rdfmt.c <<'//GO.SYSIN DD libI77/rdfmt.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-#ifdef KR_headers +-extern double atof(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#endif +- +-#include "fmt.h" +-#include "fp.h" +-#include "ctype.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- static int +-#ifdef KR_headers +-rd_Z(n,w,len) Uint *n; ftnlen len; +-#else +-rd_Z(Uint *n, int w, ftnlen len) +-#endif +-{ +- long x[9]; +- char *s, *s0, *s1, *se, *t; +- int ch, i, w1, w2; +- static char hex[256]; +- static int one = 1; +- int bad = 0; +- +- if (!hex['0']) { +- s = "0123456789"; +- while(ch = *s++) +- hex[ch] = ch - '0' + 1; +- s = "ABCDEF"; +- while(ch = *s++) +- hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; +- } +- s = s0 = (char *)x; +- s1 = (char *)&x[4]; +- se = (char *)&x[8]; +- if (len > 4*sizeof(long)) +- return errno = 117; +- while (w) { +- GET(ch); +- if (ch==',' || ch=='\n') +- break; +- w--; +- if (ch > ' ') { +- if (!hex[ch & 0xff]) +- bad++; +- *s++ = ch; +- if (s == se) { +- /* discard excess characters */ +- for(t = s0, s = s1; t < s1;) +- *t++ = *s++; +- s = s1; +- } +- } +- } +- if (bad) +- return errno = 115; +- w = (int)len; +- w1 = s - s0; +- w2 = w1+1 >> 1; +- t = (char *)n; +- if (*(char *)&one) { +- /* little endian */ +- t += w - 1; +- i = -1; +- } +- else +- i = 1; +- for(; w > w2; t += i, --w) +- *t = 0; +- if (!w) +- return 0; +- if (w < w2) +- s0 = s - (w << 1); +- else if (w1 & 1) { +- *t = hex[*s0++ & 0xff] - 1; +- if (!--w) +- return 0; +- t += i; +- } +- do { +- *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; +- t += i; +- s0 += 2; +- } +- while(--w); +- return 0; +- } +- +- static int +-#ifdef KR_headers +-rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; +-#else +-rd_I(Uint *n, int w, ftnlen len, register int base) +-#endif +-{ +- int ch, sign; +- longint x = 0; +- +- if (w <= 0) +- goto have_x; +- for(;;) { +- GET(ch); +- if (ch != ' ') +- break; +- if (!--w) +- goto have_x; +- } +- sign = 0; +- switch(ch) { +- case ',': +- case '\n': +- w = 0; +- goto have_x; +- case '-': +- sign = 1; +- case '+': +- break; +- default: +- if (ch >= '0' && ch <= '9') { +- x = ch - '0'; +- break; +- } +- goto have_x; +- } +- while(--w) { +- GET(ch); +- if (ch >= '0' && ch <= '9') { +- x = x*base + ch - '0'; +- continue; +- } +- if (ch != ' ') { +- if (ch == '\n' || ch == ',') +- w = 0; +- break; +- } +- if (f__cblank) +- x *= base; +- } +- if (sign) +- x = -x; +- have_x: +- if(len == sizeof(integer)) +- n->il=x; +- else if(len == sizeof(char)) +- n->ic = (char)x; +-#ifdef Allow_TYQUAD +- else if (len == sizeof(longint)) +- n->ili = x; +-#endif +- else +- n->is = (short)x; +- if (w) { +- while(--w) +- GET(ch); +- return errno = 115; +- } +- return 0; +-} +- +- static int +-#ifdef KR_headers +-rd_L(n,w,len) ftnint *n; ftnlen len; +-#else +-rd_L(ftnint *n, int w, ftnlen len) +-#endif +-{ int ch, dot, lv; +- +- if (w <= 0) +- goto bad; +- for(;;) { +- GET(ch); +- --w; +- if (ch != ' ') +- break; +- if (!w) +- goto bad; +- } +- dot = 0; +- retry: +- switch(ch) { +- case '.': +- if (dot++ || !w) +- goto bad; +- GET(ch); +- --w; +- goto retry; +- case 't': +- case 'T': +- lv = 1; +- break; +- case 'f': +- case 'F': +- lv = 0; +- break; +- default: +- bad: +- for(; w > 0; --w) +- GET(ch); +- /* no break */ +- case ',': +- case '\n': +- return errno = 116; +- } +- switch(len) { +- case sizeof(char): *(char *)n = (char)lv; break; +- case sizeof(short): *(short *)n = (short)lv; break; +- default: *n = lv; +- } +- while(w-- > 0) { +- GET(ch); +- if (ch == ',' || ch == '\n') +- break; +- } +- return 0; +-} +- +- static int +-#ifdef KR_headers +-rd_F(p, w, d, len) ufloat *p; ftnlen len; +-#else +-rd_F(ufloat *p, int w, int d, ftnlen len) +-#endif +-{ +- char s[FMAX+EXPMAXDIGS+4]; +- register int ch; +- register char *sp, *spe, *sp1; +- double x; +- int scale1, se; +- long e, exp; +- +- sp1 = sp = s; +- spe = sp + FMAX; +- exp = -d; +- x = 0.; +- +- do { +- GET(ch); +- w--; +- } while (ch == ' ' && w); +- switch(ch) { +- case '-': *sp++ = ch; sp1++; spe++; +- case '+': +- if (!w) goto zero; +- --w; +- GET(ch); +- } +- while(ch == ' ') { +-blankdrop: +- if (!w--) goto zero; GET(ch); } +- while(ch == '0') +- { if (!w--) goto zero; GET(ch); } +- if (ch == ' ' && f__cblank) +- goto blankdrop; +- scale1 = f__scale; +- while(isdigit(ch)) { +-digloop1: +- if (sp < spe) *sp++ = ch; +- else ++exp; +-digloop1e: +- if (!w--) goto done; +- GET(ch); +- } +- if (ch == ' ') { +- if (f__cblank) +- { ch = '0'; goto digloop1; } +- goto digloop1e; +- } +- if (ch == '.') { +- exp += d; +- if (!w--) goto done; +- GET(ch); +- if (sp == sp1) { /* no digits yet */ +- while(ch == '0') { +-skip01: +- --exp; +-skip0: +- if (!w--) goto done; +- GET(ch); +- } +- if (ch == ' ') { +- if (f__cblank) goto skip01; +- goto skip0; +- } +- } +- while(isdigit(ch)) { +-digloop2: +- if (sp < spe) +- { *sp++ = ch; --exp; } +-digloop2e: +- if (!w--) goto done; +- GET(ch); +- } +- if (ch == ' ') { +- if (f__cblank) +- { ch = '0'; goto digloop2; } +- goto digloop2e; +- } +- } +- switch(ch) { +- default: +- break; +- case '-': se = 1; goto signonly; +- case '+': se = 0; goto signonly; +- case 'e': +- case 'E': +- case 'd': +- case 'D': +- if (!w--) +- goto bad; +- GET(ch); +- while(ch == ' ') { +- if (!w--) +- goto bad; +- GET(ch); +- } +- se = 0; +- switch(ch) { +- case '-': se = 1; +- case '+': +-signonly: +- if (!w--) +- goto bad; +- GET(ch); +- } +- while(ch == ' ') { +- if (!w--) +- goto bad; +- GET(ch); +- } +- if (!isdigit(ch)) +- goto bad; +- +- e = ch - '0'; +- for(;;) { +- if (!w--) +- { ch = '\n'; break; } +- GET(ch); +- if (!isdigit(ch)) { +- if (ch == ' ') { +- if (f__cblank) +- ch = '0'; +- else continue; +- } +- else +- break; +- } +- e = 10*e + ch - '0'; +- if (e > EXPMAX && sp > sp1) +- goto bad; +- } +- if (se) +- exp -= e; +- else +- exp += e; +- scale1 = 0; +- } +- switch(ch) { +- case '\n': +- case ',': +- break; +- default: +-bad: +- return (errno = 115); +- } +-done: +- if (sp > sp1) { +- while(*--sp == '0') +- ++exp; +- if (exp -= scale1) +- sprintf(sp+1, "e%ld", exp); +- else +- sp[1] = 0; +- x = atof(s); +- } +-zero: +- if (len == sizeof(real)) +- p->pf = x; +- else +- p->pd = x; +- return(0); +- } +- +- +- static int +-#ifdef KR_headers +-rd_A(p,len) char *p; ftnlen len; +-#else +-rd_A(char *p, ftnlen len) +-#endif +-{ int i,ch; +- for(i=0;i=len) +- { for(i=0;i0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); +- if(f__cursor<0) +- { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ +- f__cursor = -f__recpos; /* is this in the standard? */ +- if(f__external == 0) { +- extern char *f__icptr; +- f__icptr += f__cursor; +- } +- else if(f__curunit && f__curunit->useek) +- (void) FSEEK(f__cf, f__cursor,SEEK_CUR); +- else +- err(f__elist->cierr,106,"fmt"); +- f__recpos += f__cursor; +- f__cursor=0; +- } +- switch(p->op) +- { +- default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case IM: +- case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); +- break; +- +- /* O and OM don't work right for character, double, complex, */ +- /* or doublecomplex, and they differ from Fortran 90 in */ +- /* showing a minus sign for negative values. */ +- +- case OM: +- case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); +- break; +- case L: ch = rd_L((ftnint *)ptr,p->p1,len); +- break; +- case A: ch = rd_A(ptr,len); +- break; +- case AW: +- ch = rd_AW(ptr,p->p1,len); +- break; +- case E: case EE: +- case D: +- case G: +- case GE: +- case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); +- break; +- +- /* Z and ZM assume 8-bit bytes. */ +- +- case ZM: +- case Z: +- ch = rd_Z((Uint *)ptr, p->p1, len); +- break; +- } +- if(ch == 0) return(ch); +- else if(ch == EOF) return(EOF); +- if (f__cf) +- clearerr(f__cf); +- return(errno); +-} +- +- int +-#ifdef KR_headers +-rd_ned(p) struct syl *p; +-#else +-rd_ned(struct syl *p) +-#endif +-{ +- switch(p->op) +- { +- default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case APOS: +- return(rd_POS(p->p2.s)); +- case H: return(rd_H(p->p1,p->p2.s)); +- case SLASH: return((*f__donewrec)()); +- case TR: +- case X: f__cursor += p->p1; +- return(1); +- case T: f__cursor=p->p1-f__recpos - 1; +- return(1); +- case TL: f__cursor -= p->p1; +- if(f__cursor < -f__recpos) /* TL1000, 1X */ +- f__cursor = -f__recpos; +- return(1); +- } +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rdfmt.c +echo libI77/rewind.c 1>&2 +sed >libI77/rewind.c <<'//GO.SYSIN DD libI77/rewind.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef KR_headers +-integer f_rew(a) alist *a; +-#else +-integer f_rew(alist *a) +-#endif +-{ +- unit *b; +- if(a->aunit>=MXUNIT || a->aunit<0) +- err(a->aerr,101,"rewind"); +- b = &f__units[a->aunit]; +- if(b->ufd == NULL || b->uwrt == 3) +- return(0); +- if(!b->useek) +- err(a->aerr,106,"rewind") +- if(b->uwrt) { +- (void) t_runc(a); +- b->uwrt = 3; +- } +- rewind(b->ufd); +- b->uend=0; +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rewind.c +echo libI77/rsfe.c 1>&2 +sed >libI77/rsfe.c <<'//GO.SYSIN DD libI77/rsfe.c' 's/^-//' +-/* read sequential formatted external */ +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-xrd_SL(Void) +-{ int ch; +- if(!f__curunit->uend) +- while((ch=getc(f__cf))!='\n') +- if (ch == EOF) { +- f__curunit->uend = 1; +- break; +- } +- f__cursor=f__recpos=0; +- return(1); +-} +- +- int +-x_getc(Void) +-{ int ch; +- if(f__curunit->uend) return(EOF); +- ch = getc(f__cf); +- if(ch!=EOF && ch!='\n') +- { f__recpos++; +- return(ch); +- } +- if(ch=='\n') +- { (void) ungetc(ch,f__cf); +- return(ch); +- } +- if(f__curunit->uend || feof(f__cf)) +- { errno=0; +- f__curunit->uend=1; +- return(-1); +- } +- return(-1); +-} +- +- int +-x_endp(Void) +-{ +- xrd_SL(); +- return f__curunit->uend == 1 ? EOF : 0; +-} +- +- int +-x_rev(Void) +-{ +- (void) xrd_SL(); +- return(0); +-} +-#ifdef KR_headers +-integer s_rsfe(a) cilist *a; /* start */ +-#else +-integer s_rsfe(cilist *a) /* start */ +-#endif +-{ int n; +- if(!f__init) f_init(); +- f__reading=1; +- f__sequential=1; +- f__formatted=1; +- f__external=1; +- if(n=c_sfe(a)) return(n); +- f__elist=a; +- f__cursor=f__recpos=0; +- f__scale=0; +- f__fmtbuf=a->cifmt; +- f__cf=f__curunit->ufd; +- if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); +- f__getn= x_getc; +- f__doed= rd_ed; +- f__doned= rd_ned; +- fmt_bg(); +- f__doend=x_endp; +- f__donewrec=xrd_SL; +- f__dorevert=x_rev; +- f__cblank=f__curunit->ublnk; +- f__cplus=0; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- if(f__curunit->uend) +- err(f__elist->ciend,(EOF),"read start"); +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rsfe.c +echo libI77/rsli.c 1>&2 +sed >libI77/rsli.c <<'//GO.SYSIN DD libI77/rsli.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#include "fmt.h" /* for f__doend */ +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-extern flag f__lquit; +-extern int f__lcount; +-extern char *f__icptr; +-extern char *f__icend; +-extern icilist *f__svic; +-extern int f__icnum, f__recpos; +- +-static int i_getc(Void) +-{ +- if(f__recpos >= f__svic->icirlen) { +- if (f__recpos++ == f__svic->icirlen) +- return '\n'; +- z_rnew(); +- } +- f__recpos++; +- if(f__icptr >= f__icend) +- return EOF; +- return(*f__icptr++); +- } +- +- static +-#ifdef KR_headers +-int i_ungetc(ch, f) int ch; FILE *f; +-#else +-int i_ungetc(int ch, FILE *f) +-#endif +-{ +- if (--f__recpos == f__svic->icirlen) +- return '\n'; +- if (f__recpos < -1) +- err(f__svic->icierr,110,"recend"); +- /* *--icptr == ch, and icptr may point to read-only memory */ +- return *--f__icptr /* = ch */; +- } +- +- static void +-#ifdef KR_headers +-c_lir(a) icilist *a; +-#else +-c_lir(icilist *a) +-#endif +-{ +- extern int l_eof; +- f__reading = 1; +- f__external = 0; +- f__formatted = 1; +- f__svic = a; +- L_len = a->icirlen; +- f__recpos = -1; +- f__icnum = f__recpos = 0; +- f__cursor = 0; +- l_getc = i_getc; +- l_ungetc = i_ungetc; +- l_eof = 0; +- f__icptr = a->iciunit; +- f__icend = f__icptr + a->icirlen*a->icirnum; +- f__cf = 0; +- f__curunit = 0; +- f__elist = (cilist *)a; +- } +- +- +-#ifdef KR_headers +-integer s_rsli(a) icilist *a; +-#else +-integer s_rsli(icilist *a) +-#endif +-{ +- f__lioproc = l_read; +- f__lquit = 0; +- f__lcount = 0; +- c_lir(a); +- f__doend = 0; +- return(0); +- } +- +-integer e_rsli(Void) +-{ return 0; } +- +-#ifdef KR_headers +-integer s_rsni(a) icilist *a; +-#else +-extern int x_rsne(cilist*); +- +-integer s_rsni(icilist *a) +-#endif +-{ +- extern int nml_read; +- integer rv; +- cilist ca; +- ca.ciend = a->iciend; +- ca.cierr = a->icierr; +- ca.cifmt = a->icifmt; +- c_lir(a); +- rv = x_rsne(&ca); +- nml_read = 0; +- return rv; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rsli.c +echo libI77/rsne.c 1>&2 +sed >libI77/rsne.c <<'//GO.SYSIN DD libI77/rsne.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +- +-#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ +-#define MAXDIM 20 /* maximum number of subscripts */ +- +- struct dimen { +- ftnlen extent; +- ftnlen curval; +- ftnlen delta; +- ftnlen stride; +- }; +- typedef struct dimen dimen; +- +- struct hashentry { +- struct hashentry *next; +- char *name; +- Vardesc *vd; +- }; +- typedef struct hashentry hashentry; +- +- struct hashtab { +- struct hashtab *next; +- Namelist *nl; +- int htsize; +- hashentry *tab[1]; +- }; +- typedef struct hashtab hashtab; +- +- static hashtab *nl_cache; +- static int n_nlcache; +- static hashentry **zot; +- static int colonseen; +- extern ftnlen f__typesize[]; +- +- extern flag f__lquit; +- extern int f__lcount, nml_read; +- extern int t_getc(Void); +- +-#ifdef KR_headers +- extern char *malloc(), *memset(); +- +-#ifdef ungetc +- static int +-un_getc(x,f__cf) int x; FILE *f__cf; +-{ return ungetc(x,f__cf); } +-#else +-#define un_getc ungetc +- extern int ungetc(); +-#endif +- +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef ungetc +- static int +-un_getc(int x, FILE *f__cf) +-{ return ungetc(x,f__cf); } +-#else +-#define un_getc ungetc +-extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +-#endif +-#endif +- +- static Vardesc * +-#ifdef KR_headers +-hash(ht, s) hashtab *ht; register char *s; +-#else +-hash(hashtab *ht, register char *s) +-#endif +-{ +- register int c, x; +- register hashentry *h; +- char *s0 = s; +- +- for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) +- x += c; +- for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) +- if (!strcmp(s0, h->name)) +- return h->vd; +- return 0; +- } +- +- hashtab * +-#ifdef KR_headers +-mk_hashtab(nl) Namelist *nl; +-#else +-mk_hashtab(Namelist *nl) +-#endif +-{ +- int nht, nv; +- hashtab *ht; +- Vardesc *v, **vd, **vde; +- hashentry *he; +- +- hashtab **x, **x0, *y; +- for(x = &nl_cache; y = *x; x0 = x, x = &y->next) +- if (nl == y->nl) +- return y; +- if (n_nlcache >= MAX_NL_CACHE) { +- /* discard least recently used namelist hash table */ +- y = *x0; +- free((char *)y->next); +- y->next = 0; +- } +- else +- n_nlcache++; +- nv = nl->nvars; +- if (nv >= 0x4000) +- nht = 0x7fff; +- else { +- for(nht = 1; nht < nv; nht <<= 1); +- nht += nht - 1; +- } +- ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) +- + nv*sizeof(hashentry)); +- if (!ht) +- return 0; +- he = (hashentry *)&ht->tab[nht]; +- ht->nl = nl; +- ht->htsize = nht; +- ht->next = nl_cache; +- nl_cache = ht; +- memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); +- vd = nl->vars; +- vde = vd + nv; +- while(vd < vde) { +- v = *vd++; +- if (!hash(ht, v->name)) { +- he->next = *zot; +- *zot = he; +- he->name = v->name; +- he->vd = v; +- he++; +- } +- } +- return ht; +- } +- +-static char Alpha[256], Alphanum[256]; +- +- static VOID +-nl_init(Void) { +- register char *s; +- register int c; +- +- if(!f__init) +- f_init(); +- for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) +- Alpha[c] +- = Alphanum[c] +- = Alpha[c + 'a' - 'A'] +- = Alphanum[c + 'a' - 'A'] +- = c; +- for(s = "0123456789_"; c = *s++; ) +- Alphanum[c] = c; +- } +- +-#define GETC(x) (x=(*l_getc)()) +-#define Ungetc(x,y) (*l_ungetc)(x,y) +- +- static int +-#ifdef KR_headers +-getname(s, slen) register char *s; int slen; +-#else +-getname(register char *s, int slen) +-#endif +-{ +- register char *se = s + slen - 1; +- register int ch; +- +- GETC(ch); +- if (!(*s++ = Alpha[ch & 0xff])) { +- if (ch != EOF) +- ch = 115; +- errfl(f__elist->cierr, ch, "namelist read"); +- } +- while(*s = Alphanum[GETC(ch) & 0xff]) +- if (s < se) +- s++; +- if (ch == EOF) +- err(f__elist->cierr, EOF, "namelist read"); +- if (ch > ' ') +- Ungetc(ch,f__cf); +- return *s = 0; +- } +- +- static int +-#ifdef KR_headers +-getnum(chp, val) int *chp; ftnlen *val; +-#else +-getnum(int *chp, ftnlen *val) +-#endif +-{ +- register int ch, sign; +- register ftnlen x; +- +- while(GETC(ch) <= ' ' && ch >= 0); +- if (ch == '-') { +- sign = 1; +- GETC(ch); +- } +- else { +- sign = 0; +- if (ch == '+') +- GETC(ch); +- } +- x = ch - '0'; +- if (x < 0 || x > 9) +- return 115; +- while(GETC(ch) >= '0' && ch <= '9') +- x = 10*x + ch - '0'; +- while(ch <= ' ' && ch >= 0) +- GETC(ch); +- if (ch == EOF) +- return EOF; +- *val = sign ? -x : x; +- *chp = ch; +- return 0; +- } +- +- static int +-#ifdef KR_headers +-getdimen(chp, d, delta, extent, x1) +- int *chp; dimen *d; ftnlen delta, extent, *x1; +-#else +-getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) +-#endif +-{ +- register int k; +- ftnlen x2, x3; +- +- if (k = getnum(chp, x1)) +- return k; +- x3 = 1; +- if (*chp == ':') { +- if (k = getnum(chp, &x2)) +- return k; +- x2 -= *x1; +- if (*chp == ':') { +- if (k = getnum(chp, &x3)) +- return k; +- if (!x3) +- return 123; +- x2 /= x3; +- colonseen = 1; +- } +- if (x2 < 0 || x2 >= extent) +- return 123; +- d->extent = x2 + 1; +- } +- else +- d->extent = 1; +- d->curval = 0; +- d->delta = delta; +- d->stride = x3; +- return 0; +- } +- +-#ifndef No_Namelist_Questions +- static Void +-#ifdef KR_headers +-print_ne(a) cilist *a; +-#else +-print_ne(cilist *a) +-#endif +-{ +- flag intext = f__external; +- int rpsave = f__recpos; +- FILE *cfsave = f__cf; +- unit *usave = f__curunit; +- cilist t; +- t = *a; +- t.ciunit = 6; +- s_wsne(&t); +- fflush(f__cf); +- f__external = intext; +- f__reading = 1; +- f__recpos = rpsave; +- f__cf = cfsave; +- f__curunit = usave; +- f__elist = a; +- } +-#endif +- +- static char where0[] = "namelist read start "; +- +- int +-#ifdef KR_headers +-x_rsne(a) cilist *a; +-#else +-x_rsne(cilist *a) +-#endif +-{ +- int ch, got1, k, n, nd, quote, readall; +- Namelist *nl; +- static char where[] = "namelist read"; +- char buf[64]; +- hashtab *ht; +- Vardesc *v; +- dimen *dn, *dn0, *dn1; +- ftnlen *dims, *dims1; +- ftnlen b, b0, b1, ex, no, nomax, size, span; +- ftnint no1, no2, type; +- char *vaddr; +- long iva, ivae; +- dimen dimens[MAXDIM], substr; +- +- if (!Alpha['a']) +- nl_init(); +- f__reading=1; +- f__formatted=1; +- got1 = 0; +- top: +- for(;;) switch(GETC(ch)) { +- case EOF: +- eof: +- err(a->ciend,(EOF),where0); +- case '&': +- case '$': +- goto have_amp; +-#ifndef No_Namelist_Questions +- case '?': +- print_ne(a); +- continue; +-#endif +- default: +- if (ch <= ' ' && ch >= 0) +- continue; +-#ifndef No_Namelist_Comments +- while(GETC(ch) != '\n') +- if (ch == EOF) +- goto eof; +-#else +- errfl(a->cierr, 115, where0); +-#endif +- } +- have_amp: +- if (ch = getname(buf,sizeof(buf))) +- return ch; +- nl = (Namelist *)a->cifmt; +- if (strcmp(buf, nl->name)) +-#ifdef No_Bad_Namelist_Skip +- errfl(a->cierr, 118, where0); +-#else +- { +- fprintf(stderr, +- "Skipping namelist \"%s\": seeking namelist \"%s\".\n", +- buf, nl->name); +- fflush(stderr); +- for(;;) switch(GETC(ch)) { +- case EOF: +- err(a->ciend, EOF, where0); +- case '/': +- case '&': +- case '$': +- if (f__external) +- e_rsle(); +- else +- z_rnew(); +- goto top; +- case '"': +- case '\'': +- quote = ch; +- more_quoted: +- while(GETC(ch) != quote) +- if (ch == EOF) +- err(a->ciend, EOF, where0); +- if (GETC(ch) == quote) +- goto more_quoted; +- Ungetc(ch,f__cf); +- default: +- continue; +- } +- } +-#endif +- ht = mk_hashtab(nl); +- if (!ht) +- errfl(f__elist->cierr, 113, where0); +- for(;;) { +- for(;;) switch(GETC(ch)) { +- case EOF: +- if (got1) +- return 0; +- err(a->ciend, EOF, where0); +- case '/': +- case '$': +- case '&': +- return 0; +- default: +- if (ch <= ' ' && ch >= 0 || ch == ',') +- continue; +- Ungetc(ch,f__cf); +- if (ch = getname(buf,sizeof(buf))) +- return ch; +- goto havename; +- } +- havename: +- v = hash(ht,buf); +- if (!v) +- errfl(a->cierr, 119, where); +- while(GETC(ch) <= ' ' && ch >= 0); +- vaddr = v->addr; +- type = v->type; +- if (type < 0) { +- size = -type; +- type = TYCHAR; +- } +- else +- size = f__typesize[type]; +- ivae = size; +- iva = readall = 0; +- if (ch == '(' /*)*/ ) { +- dn = dimens; +- if (!(dims = v->dims)) { +- if (type != TYCHAR) +- errfl(a->cierr, 122, where); +- if (k = getdimen(&ch, dn, (ftnlen)size, +- (ftnlen)size, &b)) +- errfl(a->cierr, k, where); +- if (ch != ')') +- errfl(a->cierr, 115, where); +- b1 = dn->extent; +- if (--b < 0 || b + b1 > size) +- return 124; +- iva += b; +- size = b1; +- while(GETC(ch) <= ' ' && ch >= 0); +- goto scalar; +- } +- nd = (int)dims[0]; +- nomax = span = dims[1]; +- ivae = iva + size*nomax; +- colonseen = 0; +- if (k = getdimen(&ch, dn, size, nomax, &b)) +- errfl(a->cierr, k, where); +- no = dn->extent; +- b0 = dims[2]; +- dims1 = dims += 3; +- ex = 1; +- for(n = 1; n++ < nd; dims++) { +- if (ch != ',') +- errfl(a->cierr, 115, where); +- dn1 = dn + 1; +- span /= *dims; +- if (k = getdimen(&ch, dn1, dn->delta**dims, +- span, &b1)) +- errfl(a->cierr, k, where); +- ex *= *dims; +- b += b1*ex; +- no *= dn1->extent; +- dn = dn1; +- } +- if (ch != ')') +- errfl(a->cierr, 115, where); +- readall = 1 - colonseen; +- b -= b0; +- if (b < 0 || b >= nomax) +- errfl(a->cierr, 125, where); +- iva += size * b; +- dims = dims1; +- while(GETC(ch) <= ' ' && ch >= 0); +- no1 = 1; +- dn0 = dimens; +- if (type == TYCHAR && ch == '(' /*)*/) { +- if (k = getdimen(&ch, &substr, size, size, &b)) +- errfl(a->cierr, k, where); +- if (ch != ')') +- errfl(a->cierr, 115, where); +- b1 = substr.extent; +- if (--b < 0 || b + b1 > size) +- return 124; +- iva += b; +- b0 = size; +- size = b1; +- while(GETC(ch) <= ' ' && ch >= 0); +- if (b1 < b0) +- goto delta_adj; +- } +- if (readall) +- goto delta_adj; +- for(; dn0 < dn; dn0++) { +- if (dn0->extent != *dims++ || dn0->stride != 1) +- break; +- no1 *= dn0->extent; +- } +- if (dn0 == dimens && dimens[0].stride == 1) { +- no1 = dimens[0].extent; +- dn0++; +- } +- delta_adj: +- ex = 0; +- for(dn1 = dn0; dn1 <= dn; dn1++) +- ex += (dn1->extent-1) +- * (dn1->delta *= dn1->stride); +- for(dn1 = dn; dn1 > dn0; dn1--) { +- ex -= (dn1->extent - 1) * dn1->delta; +- dn1->delta -= ex; +- } +- } +- else if (dims = v->dims) { +- no = no1 = dims[1]; +- ivae = iva + no*size; +- } +- else +- scalar: +- no = no1 = 1; +- if (ch != '=') +- errfl(a->cierr, 115, where); +- got1 = nml_read = 1; +- f__lcount = 0; +- readloop: +- for(;;) { +- if (iva >= ivae || iva < 0) { +- f__lquit = 1; +- goto mustend; +- } +- else if (iva + no1*size > ivae) +- no1 = (ivae - iva)/size; +- f__lquit = 0; +- if (k = l_read(&no1, vaddr + iva, size, type)) +- return k; +- if (f__lquit == 1) +- return 0; +- if (readall) { +- iva += dn0->delta; +- if (f__lcount > 0) { +- no2 = (ivae - iva)/size; +- if (no2 > f__lcount) +- no2 = f__lcount; +- if (k = l_read(&no2, vaddr + iva, +- size, type)) +- return k; +- iva += no2 * dn0->delta; +- } +- } +- mustend: +- GETC(ch); +- if (readall) +- if (iva >= ivae) +- readall = 0; +- else for(;;) { +- switch(ch) { +- case ' ': +- case '\t': +- case '\n': +- GETC(ch); +- continue; +- } +- break; +- } +- if (ch == '/' || ch == '$' || ch == '&') { +- f__lquit = 1; +- return 0; +- } +- else if (f__lquit) { +- while(ch <= ' ' && ch >= 0) +- GETC(ch); +- Ungetc(ch,f__cf); +- if (!Alpha[ch & 0xff] && ch >= 0) +- errfl(a->cierr, 125, where); +- break; +- } +- Ungetc(ch,f__cf); +- if (readall && !Alpha[ch & 0xff]) +- goto readloop; +- if ((no -= no1) <= 0) +- break; +- for(dn1 = dn0; dn1 <= dn; dn1++) { +- if (++dn1->curval < dn1->extent) { +- iva += dn1->delta; +- goto readloop; +- } +- dn1->curval = 0; +- } +- break; +- } +- } +- } +- +- integer +-#ifdef KR_headers +-s_rsne(a) cilist *a; +-#else +-s_rsne(cilist *a) +-#endif +-{ +- extern int l_eof; +- int n; +- +- f__external=1; +- l_eof = 0; +- if(n = c_le(a)) +- return n; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,where0); +- l_getc = t_getc; +- l_ungetc = un_getc; +- f__doend = xrd_SL; +- n = x_rsne(a); +- nml_read = 0; +- if (n) +- return n; +- return e_rsle(); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rsne.c +echo libI77/sfe.c 1>&2 +sed >libI77/sfe.c <<'//GO.SYSIN DD libI77/sfe.c' 's/^-//' +-/* sequential formatted external common routines*/ +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-extern char *f__fmtbuf; +- +-integer e_rsfe(Void) +-{ int n; +- n=en_fio(); +- f__fmtbuf=NULL; +- return(n); +-} +- +- int +-#ifdef KR_headers +-c_sfe(a) cilist *a; /* check */ +-#else +-c_sfe(cilist *a) /* check */ +-#endif +-{ unit *p; +- f__curunit = p = &f__units[a->ciunit]; +- if(a->ciunit >= MXUNIT || a->ciunit<0) +- err(a->cierr,101,"startio"); +- if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") +- if(!p->ufmt) err(a->cierr,102,"sfe") +- return(0); +-} +-integer e_wsfe(Void) +-{ +- int n = en_fio(); +- f__fmtbuf = NULL; +-#ifdef ALWAYS_FLUSH +- if (!n && fflush(f__cf)) +- err(f__elist->cierr, errno, "write end"); +-#endif +- return n; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/sfe.c +echo libI77/sue.c 1>&2 +sed >libI77/sue.c <<'//GO.SYSIN DD libI77/sue.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern uiolen f__reclen; +-OFF_T f__recloc; +- +- int +-#ifdef KR_headers +-c_sue(a) cilist *a; +-#else +-c_sue(cilist *a) +-#endif +-{ +- f__external=f__sequential=1; +- f__formatted=0; +- f__curunit = &f__units[a->ciunit]; +- if(a->ciunit >= MXUNIT || a->ciunit < 0) +- err(a->cierr,101,"startio"); +- f__elist=a; +- if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) +- err(a->cierr,114,"sue"); +- f__cf=f__curunit->ufd; +- if(f__curunit->ufmt) err(a->cierr,103,"sue") +- if(!f__curunit->useek) err(a->cierr,103,"sue") +- return(0); +-} +-#ifdef KR_headers +-integer s_rsue(a) cilist *a; +-#else +-integer s_rsue(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- f__reading=1; +- if(n=c_sue(a)) return(n); +- f__recpos=0; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr, errno, "read start"); +- if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) +- != 1) +- { if(feof(f__cf)) +- { f__curunit->uend = 1; +- err(a->ciend, EOF, "start"); +- } +- clearerr(f__cf); +- err(a->cierr, errno, "start"); +- } +- return(0); +-} +-#ifdef KR_headers +-integer s_wsue(a) cilist *a; +-#else +-integer s_wsue(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- if(n=c_sue(a)) return(n); +- f__reading=0; +- f__reclen=0; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr, errno, "write start"); +- f__recloc=FTELL(f__cf); +- FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR); +- return(0); +-} +-integer e_wsue(Void) +-{ OFF_T loc; +- fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +-#ifdef ALWAYS_FLUSH +- if (fflush(f__cf)) +- err(f__elist->cierr, errno, "write end"); +-#endif +- loc=FTELL(f__cf); +- FSEEK(f__cf,f__recloc,SEEK_SET); +- fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +- FSEEK(f__cf,loc,SEEK_SET); +- return(0); +-} +-integer e_rsue(Void) +-{ +- FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/sue.c +echo libI77/typesize.c 1>&2 +sed >libI77/typesize.c <<'//GO.SYSIN DD libI77/typesize.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), +- sizeof(real), sizeof(doublereal), +- sizeof(complex), sizeof(doublecomplex), +- sizeof(logical), sizeof(char), +- 0, sizeof(integer1), +- sizeof(logical1), sizeof(shortlogical), +-#ifdef Allow_TYQUAD +- sizeof(longint), +-#endif +- 0}; +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/typesize.c +echo libI77/uio.c 1>&2 +sed >libI77/uio.c <<'//GO.SYSIN DD libI77/uio.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-uiolen f__reclen; +- +- int +-#ifdef KR_headers +-do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +-#else +-do_us(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- if(f__reading) +- { +- f__recpos += (int)(*number * len); +- if(f__recpos>f__reclen) +- err(f__elist->cierr, 110, "do_us"); +- if (fread(ptr,(int)len,(int)(*number),f__cf) != *number) +- err(f__elist->ciend, EOF, "do_us"); +- return(0); +- } +- else +- { +- f__reclen += *number * len; +- (void) fwrite(ptr,(int)len,(int)(*number),f__cf); +- return(0); +- } +-} +-#ifdef KR_headers +-integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +-#else +-integer do_ud(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- f__recpos += (int)(*number * len); +- if(f__recpos > f__curunit->url && f__curunit->url!=1) +- err(f__elist->cierr,110,"do_ud"); +- if(f__reading) +- { +-#ifdef Pad_UDread +-#ifdef KR_headers +- int i; +-#else +- size_t i; +-#endif +- if (!(i = fread(ptr,(int)len,(int)(*number),f__cf)) +- && !(f__recpos - *number*len)) +- err(f__elist->cierr,EOF,"do_ud") +- if (i < *number) +- memset(ptr + i*len, 0, (*number - i)*len); +- return 0; +-#else +- if(fread(ptr,(int)len,(int)(*number),f__cf) != *number) +- err(f__elist->cierr,EOF,"do_ud") +- else return(0); +-#endif +- } +- (void) fwrite(ptr,(int)len,(int)(*number),f__cf); +- return(0); +-} +-#ifdef KR_headers +-integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +-#else +-integer do_uio(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- if(f__sequential) +- return(do_us(number,ptr,len)); +- else return(do_ud(number,ptr,len)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/uio.c +echo libI77/util.c 1>&2 +sed >libI77/util.c <<'//GO.SYSIN DD libI77/util.c' 's/^-//' +-#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-#ifdef KR_headers +-g_char(a,alen,b) char *a,*b; ftnlen alen; +-#else +-g_char(char *a, ftnlen alen, char *b) +-#endif +-{ +- char *x = a + alen, *y = b + alen; +- +- for(;; y--) { +- if (x <= a) { +- *b = 0; +- return; +- } +- if (*--x != ' ') +- break; +- } +- *y-- = 0; +- do *y-- = *x; +- while(x-- > a); +- } +- +- VOID +-#ifdef KR_headers +-b_char(a,b,blen) char *a,*b; ftnlen blen; +-#else +-b_char(char *a, char *b, ftnlen blen) +-#endif +-{ int i; +- for(i=0;i&2 +sed >libI77/wref.c <<'//GO.SYSIN DD libI77/wref.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-#ifndef KR_headers +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#include "string.h" +-#endif +- +-#include "fmt.h" +-#include "fp.h" +-#ifndef VAX +-#include "ctype.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +- int +-#ifdef KR_headers +-wrt_E(p,w,d,e,len) ufloat *p; ftnlen len; +-#else +-wrt_E(ufloat *p, int w, int d, int e, ftnlen len) +-#endif +-{ +- char buf[FMAX+EXPMAXDIGS+4], *s, *se; +- int d1, delta, e1, i, sign, signspace; +- double dd; +-#ifdef WANT_LEAD_0 +- int insert0 = 0; +-#endif +-#ifndef VAX +- int e0 = e; +-#endif +- +- if(e <= 0) +- e = 2; +- if(f__scale) { +- if(f__scale >= d + 2 || f__scale <= -d) +- goto nogood; +- } +- if(f__scale <= 0) +- --d; +- if (len == sizeof(real)) +- dd = p->pf; +- else +- dd = p->pd; +- if (dd < 0.) { +- signspace = sign = 1; +- dd = -dd; +- } +- else { +- sign = 0; +- signspace = (int)f__cplus; +-#ifndef VAX +- if (!dd) { +-#ifdef SIGNED_ZEROS +- if (signbit_f2c(&dd)) +- signspace = sign = 1; +-#endif +- dd = 0.; /* avoid -0 */ +- } +-#endif +- } +- delta = w - (2 /* for the . and the d adjustment above */ +- + 2 /* for the E+ */ + signspace + d + e); +-#ifdef WANT_LEAD_0 +- if (f__scale <= 0 && delta > 0) { +- delta--; +- insert0 = 1; +- } +- else +-#endif +- if (delta < 0) { +-nogood: +- while(--w >= 0) +- PUT('*'); +- return(0); +- } +- if (f__scale < 0) +- d += f__scale; +- if (d > FMAX) { +- d1 = d - FMAX; +- d = FMAX; +- } +- else +- d1 = 0; +- sprintf(buf,"%#.*E", d, dd); +-#ifndef VAX +- /* check for NaN, Infinity */ +- if (!isdigit(buf[0])) { +- switch(buf[0]) { +- case 'n': +- case 'N': +- signspace = 0; /* no sign for NaNs */ +- } +- delta = w - strlen(buf) - signspace; +- if (delta < 0) +- goto nogood; +- while(--delta >= 0) +- PUT(' '); +- if (signspace) +- PUT(sign ? '-' : '+'); +- for(s = buf; *s; s++) +- PUT(*s); +- return 0; +- } +-#endif +- se = buf + d + 3; +-#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ +- if (f__scale != 1 && dd) +- sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +-#else +- if (dd) +- sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +- else +- strcpy(se, "+00"); +-#endif +- s = ++se; +- if (e < 2) { +- if (*s != '0') +- goto nogood; +- } +-#ifndef VAX +- /* accommodate 3 significant digits in exponent */ +- if (s[2]) { +-#ifdef Pedantic +- if (!e0 && !s[3]) +- for(s -= 2, e1 = 2; s[0] = s[1]; s++); +- +- /* Pedantic gives the behavior that Fortran 77 specifies, */ +- /* i.e., requires that E be specified for exponent fields */ +- /* of more than 3 digits. With Pedantic undefined, we get */ +- /* the behavior that Cray displays -- you get a bigger */ +- /* exponent field if it fits. */ +-#else +- if (!e0) { +- for(s -= 2, e1 = 2; s[0] = s[1]; s++) +-#ifdef CRAY +- delta--; +- if ((delta += 4) < 0) +- goto nogood +-#endif +- ; +- } +-#endif +- else if (e0 >= 0) +- goto shift; +- else +- e1 = e; +- } +- else +- shift: +-#endif +- for(s += 2, e1 = 2; *s; ++e1, ++s) +- if (e1 >= e) +- goto nogood; +- while(--delta >= 0) +- PUT(' '); +- if (signspace) +- PUT(sign ? '-' : '+'); +- s = buf; +- i = f__scale; +- if (f__scale <= 0) { +-#ifdef WANT_LEAD_0 +- if (insert0) +- PUT('0'); +-#endif +- PUT('.'); +- for(; i < 0; ++i) +- PUT('0'); +- PUT(*s); +- s += 2; +- } +- else if (f__scale > 1) { +- PUT(*s); +- s += 2; +- while(--i > 0) +- PUT(*s++); +- PUT('.'); +- } +- if (d1) { +- se -= 2; +- while(s < se) PUT(*s++); +- se += 2; +- do PUT('0'); while(--d1 > 0); +- } +- while(s < se) +- PUT(*s++); +- if (e < 2) +- PUT(s[1]); +- else { +- while(++e1 <= e) +- PUT('0'); +- while(*s) +- PUT(*s++); +- } +- return 0; +- } +- +- int +-#ifdef KR_headers +-wrt_F(p,w,d,len) ufloat *p; ftnlen len; +-#else +-wrt_F(ufloat *p, int w, int d, ftnlen len) +-#endif +-{ +- int d1, sign, n; +- double x; +- char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; +- +- x= (len==sizeof(real)?p->pf:p->pd); +- if (d < MAXFRACDIGS) +- d1 = 0; +- else { +- d1 = d - MAXFRACDIGS; +- d = MAXFRACDIGS; +- } +- if (x < 0.) +- { x = -x; sign = 1; } +- else { +- sign = 0; +-#ifndef VAX +- if (!x) { +-#ifdef SIGNED_ZEROS +- if (signbit_f2c(&x)) +- sign = 2; +-#endif +- x = 0.; +- } +-#endif +- } +- +- if (n = f__scale) +- if (n > 0) +- do x *= 10.; while(--n > 0); +- else +- do x *= 0.1; while(++n < 0); +- +-#ifdef USE_STRLEN +- sprintf(b = buf, "%#.*f", d, x); +- n = strlen(b) + d1; +-#else +- n = sprintf(b = buf, "%#.*f", d, x) + d1; +-#endif +- +-#ifndef WANT_LEAD_0 +- if (buf[0] == '0' && d) +- { ++b; --n; } +-#endif +- if (sign == 1) { +- /* check for all zeros */ +- for(s = b;;) { +- while(*s == '0') s++; +- switch(*s) { +- case '.': +- s++; continue; +- case 0: +- sign = 0; +- } +- break; +- } +- } +- if (sign || f__cplus) +- ++n; +- if (n > w) { +-#ifdef WANT_LEAD_0 +- if (buf[0] == '0' && --n == w) +- ++b; +- else +-#endif +- { +- while(--w >= 0) +- PUT('*'); +- return 0; +- } +- } +- for(w -= n; --w >= 0; ) +- PUT(' '); +- if (sign) +- PUT('-'); +- else if (f__cplus) +- PUT('+'); +- while(n = *b++) +- PUT(n); +- while(--d1 >= 0) +- PUT('0'); +- return 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wref.c +echo libI77/wrtfmt.c 1>&2 +sed >libI77/wrtfmt.c <<'//GO.SYSIN DD libI77/wrtfmt.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-extern icilist *f__svic; +-extern char *f__icptr; +- +- static int +-mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ +- /* instead we know too much about stdio */ +-{ +- int cursor = f__cursor; +- f__cursor = 0; +- if(f__external == 0) { +- if(cursor < 0) { +- if(f__hiwater < f__recpos) +- f__hiwater = f__recpos; +- f__recpos += cursor; +- f__icptr += cursor; +- if(f__recpos < 0) +- err(f__elist->cierr, 110, "left off"); +- } +- else if(cursor > 0) { +- if(f__recpos + cursor >= f__svic->icirlen) +- err(f__elist->cierr, 110, "recend"); +- if(f__hiwater <= f__recpos) +- for(; cursor > 0; cursor--) +- (*f__putn)(' '); +- else if(f__hiwater <= f__recpos + cursor) { +- cursor -= f__hiwater - f__recpos; +- f__icptr += f__hiwater - f__recpos; +- f__recpos = f__hiwater; +- for(; cursor > 0; cursor--) +- (*f__putn)(' '); +- } +- else { +- f__icptr += cursor; +- f__recpos += cursor; +- } +- } +- return(0); +- } +- if (cursor > 0) { +- if(f__hiwater <= f__recpos) +- for(;cursor>0;cursor--) (*f__putn)(' '); +- else if(f__hiwater <= f__recpos + cursor) { +- cursor -= f__hiwater - f__recpos; +- f__recpos = f__hiwater; +- for(; cursor > 0; cursor--) +- (*f__putn)(' '); +- } +- else { +- f__recpos += cursor; +- } +- } +- else if (cursor < 0) +- { +- if(cursor + f__recpos < 0) +- err(f__elist->cierr,110,"left off"); +- if(f__hiwater < f__recpos) +- f__hiwater = f__recpos; +- f__recpos += cursor; +- } +- return(0); +-} +- +- static int +-#ifdef KR_headers +-wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; +-#else +-wrt_Z(Uint *n, int w, int minlen, ftnlen len) +-#endif +-{ +- register char *s, *se; +- register int i, w1; +- static int one = 1; +- static char hex[] = "0123456789ABCDEF"; +- s = (char *)n; +- --len; +- if (*(char *)&one) { +- /* little endian */ +- se = s; +- s += len; +- i = -1; +- } +- else { +- se = s + len; +- i = 1; +- } +- for(;; s += i) +- if (s == se || *s) +- break; +- w1 = (i*(se-s) << 1) + 1; +- if (*s & 0xf0) +- w1++; +- if (w1 > w) +- for(i = 0; i < w; i++) +- (*f__putn)('*'); +- else { +- if ((minlen -= w1) > 0) +- w1 += minlen; +- while(--w >= w1) +- (*f__putn)(' '); +- while(--minlen >= 0) +- (*f__putn)('0'); +- if (!(*s & 0xf0)) { +- (*f__putn)(hex[*s & 0xf]); +- if (s == se) +- return 0; +- s += i; +- } +- for(;; s += i) { +- (*f__putn)(hex[*s >> 4 & 0xf]); +- (*f__putn)(hex[*s & 0xf]); +- if (s == se) +- break; +- } +- } +- return 0; +- } +- +- static int +-#ifdef KR_headers +-wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; +-#else +-wrt_I(Uint *n, int w, ftnlen len, register int base) +-#endif +-{ int ndigit,sign,spare,i; +- longint x; +- char *ans; +- if(len==sizeof(integer)) x=n->il; +- else if(len == sizeof(char)) x = n->ic; +-#ifdef Allow_TYQUAD +- else if (len == sizeof(longint)) x = n->ili; +-#endif +- else x=n->is; +- ans=f__icvt(x,&ndigit,&sign, base); +- spare=w-ndigit; +- if(sign || f__cplus) spare--; +- if(spare<0) +- for(i=0;iil; +- else if(len == sizeof(char)) x = n->ic; +-#ifdef Allow_TYQUAD +- else if (len == sizeof(longint)) x = n->ili; +-#endif +- else x=n->is; +- ans=f__icvt(x,&ndigit,&sign, base); +- if(sign || f__cplus) xsign=1; +- else xsign=0; +- if(ndigit+xsign>w || m+xsign>w) +- { for(i=0;i=m) +- spare=w-ndigit-xsign; +- else +- spare=w-m-xsign; +- for(i=0;iil; +- else if(sz == sizeof(char)) x = n->ic; +- else x=n->is; +- for(i=0;i 0) (*f__putn)(*p++); +- return(0); +-} +- static int +-#ifdef KR_headers +-wrt_AW(p,w,len) char * p; ftnlen len; +-#else +-wrt_AW(char * p, int w, ftnlen len) +-#endif +-{ +- while(w>len) +- { w--; +- (*f__putn)(' '); +- } +- while(w-- > 0) +- (*f__putn)(*p++); +- return(0); +-} +- +- static int +-#ifdef KR_headers +-wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; +-#else +-wrt_G(ufloat *p, int w, int d, int e, ftnlen len) +-#endif +-{ double up = 1,x; +- int i=0,oldscale,n,j; +- x = len==sizeof(real)?p->pf:p->pd; +- if(x < 0 ) x = -x; +- if(x<.1) { +- if (x != 0.) +- return(wrt_E(p,w,d,e,len)); +- i = 1; +- goto have_i; +- } +- for(;i<=d;i++,up*=10) +- { if(x>=up) continue; +- have_i: +- oldscale = f__scale; +- f__scale = 0; +- if(e==0) n=4; +- else n=e+2; +- i=wrt_F(p,w-n,d-i,len); +- for(j=0;jop) +- { +- default: +- fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); +- case IM: +- return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); +- +- /* O and OM don't work right for character, double, complex, */ +- /* or doublecomplex, and they differ from Fortran 90 in */ +- /* showing a minus sign for negative values. */ +- +- case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); +- case OM: +- return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); +- case L: return(wrt_L((Uint *)ptr,p->p1, len)); +- case A: return(wrt_A(ptr,len)); +- case AW: +- return(wrt_AW(ptr,p->p1,len)); +- case D: +- case E: +- case EE: +- return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); +- case G: +- case GE: +- return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); +- case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); +- +- /* Z and ZM assume 8-bit bytes. */ +- +- case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); +- case ZM: +- return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); +- } +-} +- +- int +-#ifdef KR_headers +-w_ned(p) struct syl *p; +-#else +-w_ned(struct syl *p) +-#endif +-{ +- switch(p->op) +- { +- default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case SLASH: +- return((*f__donewrec)()); +- case T: f__cursor = p->p1-f__recpos - 1; +- return(1); +- case TL: f__cursor -= p->p1; +- if(f__cursor < -f__recpos) /* TL1000, 1X */ +- f__cursor = -f__recpos; +- return(1); +- case TR: +- case X: +- f__cursor += p->p1; +- return(1); +- case APOS: +- return(wrt_AP(p->p2.s)); +- case H: +- return(wrt_H(p->p1,p->p2.s)); +- } +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wrtfmt.c +echo libI77/wsfe.c 1>&2 +sed >libI77/wsfe.c <<'//GO.SYSIN DD libI77/wsfe.c' 's/^-//' +-/*write sequential formatted external*/ +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-x_wSL(Void) +-{ +- int n = f__putbuf('\n'); +- f__hiwater = f__recpos = f__cursor = 0; +- return(n == 0); +-} +- +- static int +-xw_end(Void) +-{ +- int n; +- +- if(f__nonl) { +- f__putbuf(n = 0); +- fflush(f__cf); +- } +- else +- n = f__putbuf('\n'); +- f__hiwater = f__recpos = f__cursor = 0; +- return n; +-} +- +- static int +-xw_rev(Void) +-{ +- int n = 0; +- if(f__workdone) { +- n = f__putbuf('\n'); +- f__workdone = 0; +- } +- f__hiwater = f__recpos = f__cursor = 0; +- return n; +-} +- +-#ifdef KR_headers +-integer s_wsfe(a) cilist *a; /*start*/ +-#else +-integer s_wsfe(cilist *a) /*start*/ +-#endif +-{ int n; +- if(!f__init) f_init(); +- f__reading=0; +- f__sequential=1; +- f__formatted=1; +- f__external=1; +- if(n=c_sfe(a)) return(n); +- f__elist=a; +- f__hiwater = f__cursor=f__recpos=0; +- f__nonl = 0; +- f__scale=0; +- f__fmtbuf=a->cifmt; +- f__cf=f__curunit->ufd; +- if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); +- f__putn= x_putc; +- f__doed= w_ed; +- f__doned= w_ned; +- f__doend=xw_end; +- f__dorevert=xw_rev; +- f__donewrec=x_wSL; +- fmt_bg(); +- f__cplus=0; +- f__cblank=f__curunit->ublnk; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr,errno,"write start"); +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wsfe.c +echo libI77/wsle.c 1>&2 +sed >libI77/wsle.c <<'//GO.SYSIN DD libI77/wsle.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#include "lio.h" +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer s_wsle(a) cilist *a; +-#else +-integer s_wsle(cilist *a) +-#endif +-{ +- int n; +- if(n=c_le(a)) return(n); +- f__reading=0; +- f__external=1; +- f__formatted=1; +- f__putn = x_putc; +- f__lioproc = l_write; +- L_len = LINE; +- f__donewrec = x_wSL; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr, errno, "list output start"); +- return(0); +- } +- +-integer e_wsle(Void) +-{ +- int n = f__putbuf('\n'); +- f__recpos=0; +-#ifdef ALWAYS_FLUSH +- if (!n && fflush(f__cf)) +- err(f__elist->cierr, errno, "write end"); +-#endif +- return(n); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wsle.c +echo libI77/wsne.c 1>&2 +sed >libI77/wsne.c <<'//GO.SYSIN DD libI77/wsne.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- integer +-#ifdef KR_headers +-s_wsne(a) cilist *a; +-#else +-s_wsne(cilist *a) +-#endif +-{ +- int n; +- +- if(n=c_le(a)) +- return(n); +- f__reading=0; +- f__external=1; +- f__formatted=1; +- f__putn = x_putc; +- L_len = LINE; +- f__donewrec = x_wSL; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr, errno, "namelist output start"); +- x_wsne(a); +- return e_wsle(); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wsne.c +echo libI77/xwsne.c 1>&2 +sed >libI77/xwsne.c <<'//GO.SYSIN DD libI77/xwsne.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#include "fmt.h" +- +-extern int f__Aquote; +- +- static VOID +-nl_donewrec(Void) +-{ +- (*f__donewrec)(); +- PUT(' '); +- } +- +-#ifdef KR_headers +-x_wsne(a) cilist *a; +-#else +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-x_wsne(cilist *a) +-#endif +-{ +- Namelist *nl; +- char *s; +- Vardesc *v, **vd, **vde; +- ftnint number, type; +- ftnlen *dims; +- ftnlen size; +- extern ftnlen f__typesize[]; +- +- nl = (Namelist *)a->cifmt; +- PUT('&'); +- for(s = nl->name; *s; s++) +- PUT(*s); +- PUT(' '); +- f__Aquote = 1; +- vd = nl->vars; +- vde = vd + nl->nvars; +- while(vd < vde) { +- v = *vd++; +- s = v->name; +-#ifdef No_Extra_Namelist_Newlines +- if (f__recpos+strlen(s)+2 >= L_len) +-#endif +- nl_donewrec(); +- while(*s) +- PUT(*s++); +- PUT(' '); +- PUT('='); +- number = (dims = v->dims) ? dims[1] : 1; +- type = v->type; +- if (type < 0) { +- size = -type; +- type = TYCHAR; +- } +- else +- size = f__typesize[type]; +- l_write(&number, v->addr, size, type); +- if (vd < vde) { +- if (f__recpos+2 >= L_len) +- nl_donewrec(); +- PUT(','); +- PUT(' '); +- } +- else if (f__recpos+1 >= L_len) +- nl_donewrec(); +- } +- f__Aquote = 0; +- PUT('/'); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/xwsne.c +echo libI77/Notice 1>&2 +sed >libI77/Notice <<'//GO.SYSIN DD libI77/Notice' 's/^-//' +-/**************************************************************** +-Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. +- +-Permission to use, copy, modify, and distribute this software +-and its documentation for any purpose and without fee is hereby +-granted, provided that the above copyright notice appear in all +-copies and that both that the copyright notice and this +-permission notice and warranty disclaimer appear in supporting +-documentation, and that the names of AT&T, Bell Laboratories, +-Lucent or Bellcore or any of their entities not be used in +-advertising or publicity pertaining to distribution of the +-software without specific, written prior permission. +- +-AT&T, Lucent and Bellcore disclaim all warranties with regard to +-this software, including all implied warranties of +-merchantability and fitness. In no event shall AT&T, Lucent or +-Bellcore be liable for any special, indirect or consequential +-damages or any damages whatsoever resulting from loss of use, +-data or profits, whether in an action of contract, negligence or +-other tortious action, arising out of or in connection with the +-use or performance of this software. +-****************************************************************/ +- +//GO.SYSIN DD libI77/Notice +echo libI77/README 1>&2 +sed >libI77/README <<'//GO.SYSIN DD libI77/README' 's/^-//' +-If your compiler does not recognize ANSI C headers, +-compile with KR_headers defined: either add -DKR_headers +-to the definition of CFLAGS in the makefile, or insert +- +-#define KR_headers +- +-at the top of f2c.h and fmtlib.c . +- +- +-If you have a really ancient K&R C compiler that does not understand +-void, add -Dvoid=int to the definition of CFLAGS in the makefile. +- +-If you use a C++ compiler, first create a local f2c.h by appending +-f2ch.add to the usual f2c.h, e.g., by issuing the command +- make f2c.h +-which assumes f2c.h is installed in /usr/include . +- +-If your system lacks /usr/include/fcntl.h , then you +-should simply create an empty fcntl.h in this directory. +-If your compiler then complains about creat and open not +-having a prototype, compile with OPEN_DECL defined. +-On many systems, open and creat are declared in fcntl.h . +- +-If your system has /usr/include/fcntl.h, you may need to add +--D_POSIX_SOURCE to the makefile's definition of CFLAGS. +- +-If your system's sprintf does not work the way ANSI C +-specifies -- specifically, if it does not return the +-number of characters transmitted -- then insert the line +- +-#define USE_STRLEN +- +-at the end of fmt.h . This is necessary with +-at least some versions of Sun and DEC software. +-In particular, if you get a warning about an improper +-pointer/integer combination in compiling wref.c, then +-you need to compile with -DUSE_STRLEN . +- +-If your system's fopen does not like the ANSI binary +-reading and writing modes "rb" and "wb", then you should +-compile open.c with NON_ANSI_RW_MODES #defined. +- +-If you get error messages about references to cf->_ptr +-and cf->_base when compiling wrtfmt.c and wsfe.c or to +-stderr->_flag when compiling err.c, then insert the line +- +-#define NON_UNIX_STDIO +- +-at the beginning of fio.h, and recompile everything (or +-at least those modules that contain NON_UNIX_STDIO). +- +-Unformatted sequential records consist of a length of record +-contents, the record contents themselves, and the length of +-record contents again (for backspace). Prior to 17 Oct. 1991, +-the length was of type int; now it is of type long, but you +-can change it back to int by inserting +- +-#define UIOLEN_int +- +-at the beginning of fio.h. This affects only sue.c and uio.c . +- +-On VAX, Cray, or Research Tenth-Edition Unix systems, you may +-need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS +-to make fp.h work correctly. Alternatively, you may need to +-edit fp.h to suit your machine. +- +-You may need to supply the following non-ANSI routines: +- +- fstat(int fileds, struct stat *buf) is similar +-to stat(char *name, struct stat *buf), except that +-the first argument, fileds, is the file descriptor +-returned by open rather than the name of the file. +-fstat is used in the system-dependent routine +-canseek (in the libI77 source file err.c), which +-is supposed to return 1 if it's possible to issue +-seeks on the file in question, 0 if it's not; you may +-need to suitably modify err.c . On non-UNIX systems, +-you can avoid references to fstat and stat by compiling +-with NON_UNIX_STDIO defined; in that case, you may need +-to supply access(char *Name,0), which is supposed to +-return 0 if file Name exists, nonzero otherwise. +- +- char * mktemp(char *buf) is supposed to replace the +-6 trailing X's in buf with a unique number and then +-return buf. The idea is to get a unique name for +-a temporary file. +- +-On non-UNIX systems, you may need to change a few other, +-e.g.: the form of name computed by mktemp() in endfile.c and +-open.c; the use of the open(), close(), and creat() system +-calls in endfile.c, err.c, open.c; and the modes in calls on +-fopen() and fdopen() (and perhaps the use of fdopen() itself +--- it's supposed to return a FILE* corresponding to a given +-an integer file descriptor) in err.c and open.c (component ufmt +-of struct unit is 1 for formatted I/O -- text mode on some systems +--- and 0 for unformatted I/O -- binary mode on some systems). +-Compiling with -DNON_UNIX_STDIO omits all references to creat() +-and almost all references to open() and close(), the exception +-being in the function f__isdev() (in open.c). +- +-For MS-DOS, compile all of libI77 with -DMSDOS (which implies +--DNON_UNIX_STDIO). You may need to make other compiler-dependent +-adjustments; for example, for Turbo C++ you need to adjust the mktemp +-invocations and to #undef ungetc in lread.c and rsne.c . +- +-If you want to be able to load against libI77 but not libF77, +-then you will need to add sig_die.o (from libF77) to libI77. +- +-If you wish to use translated Fortran that has funny notions +-of record length for direct unformatted I/O (i.e., that assumes +-RECL= values in OPEN statements are not bytes but rather counts +-of some other units -- e.g., 4-character words for VMS), then you +-should insert an appropriate #define for url_Adjust at the +-beginning of open.c . For VMS Fortran, for example, +-#define url_Adjust(x) x *= 4 +-would suffice. +- +-To check for transmission errors, issue the command +- make check +-This assumes you have the xsum program whose source, xsum.c, +-is distributed as part of "all from f2c/src". If you do not +-have xsum, you can obtain xsum.c by sending the following E-mail +-message to netlib@netlib.bell-labs.com +- send xsum.c from f2c/src +- +-The makefile assumes you have installed f2c.h in a standard +-place (and does not cause recompilation when f2c.h is changed); +-f2c.h comes with "all from f2c" (the source for f2c) and is +-available separately ("f2c.h from f2c"). +- +-By default, Fortran I/O units 5, 6, and 0 are pre-connected to +-stdin, stdout, and stderr, respectively. You can change this +-behavior by changing f_init() in err.c to suit your needs. +-Note that f2c assumes READ(*... means READ(5... and WRITE(*... +-means WRITE(6... . Moreover, an OPEN(n,... statement that does +-not specify a file name (and does not specify STATUS='SCRATCH') +-assumes FILE='fort.n' . You can change this by editing open.c +-and endfile.c suitably. +- +-Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units +-0, 1, ..., 99 are available, i.e., the highest allowed unit number +-is MXUNIT - 1. +- +-Lines protected from compilation by #ifdef Allow_TYQUAD +-are for a possible extension to 64-bit integers in which +-integer = int = 32 bits and longint = long = 64 bits. +- +-Extensions (Feb. 1993) to NAMELIST processing: +- 1. Reading a ? instead of &name (the start of a namelist) causes +-the namelist being sought to be written to stdout (unit 6); +-to omit this feature, compile rsne.c with -DNo_Namelist_Questions. +- 2. Reading the wrong namelist name now leads to an error message +-and an attempt to skip input until the right namelist name is found; +-to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. +- 3. Namelist writes now insert newlines before each variable; to omit +-this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. +- 4. (Sept. 1995) When looking for the &name that starts namelist +-input, lines whose first non-blank character is something other +-than &, $, or ? are treated as comment lines and ignored, unless +-rsne.c is compiled with -DNo_Namelist_Comments. +- +-Nonstandard extension (Feb. 1993) to open: for sequential files, +-ACCESS='APPEND' (or access='anything else starting with "A" or "a"') +-causes the file to be positioned at end-of-file, so a write will +-append to the file. +- +-Some buggy Fortran programs use unformatted direct I/O to write +-an incomplete record and later read more from that record than +-they have written. For records other than the last, the unwritten +-portion of the record reads as binary zeros. The last record is +-a special case: attempting to read more from it than was written +-gives end-of-file -- which may help one find a bug. Some other +-Fortran I/O libraries treat the last record no differently than +-others and thus give no help in finding the bug of reading more +-than was written. If you wish to have this behavior, compile +-uio.c with -DPad_UDread . +- +-If you want to be able to catch write failures (e.g., due to a +-disk being full) with an ERR= specifier, compile dfe.c, due.c, +-sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to +-slower execution and more I/O, but should make ERR= work as +-expected, provided fflush returns an error return when its +-physical write fails. +- +-Carriage controls are meant to be interpreted by the UNIX col +-program (or a similar program). Sometimes it's convenient to use +-only ' ' as the carriage control character (normal single spacing). +-If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted +-external output lines will have an initial ' ' quietly omitted, +-making use of the col program unnecessary with output that only +-has ' ' for carriage control. +- +-The Fortran 77 Standard leaves it up to the implementation whether +-formatted writes of floating-point numbers of absolute value < 1 have +-a zero before the decimal point. By default, libI77 omits such +-superfluous zeros, but you can cause them to appear by compiling +-lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . +- +-If your system lacks a ranlib command, you don't need it. +-Either comment out the makefile's ranlib invocation, or install +-a harmless "ranlib" command somewhere in your PATH, such as the +-one-line shell script +- +- exit 0 +- +-or (on some systems) +- +- exec /usr/bin/ar lts $1 >/dev/null +- +-Most of the routines in libI77 are support routines for Fortran +-I/O. There are a few exceptions, summarized below -- I/O related +-functions and subroutines that appear to your program as ordinary +-external Fortran routines. +- +-1. CALL FLUSH flushes all buffers. +- +-2. FTELL(i) is an INTEGER function that returns the current +- offset of Fortran unit i (or -1 if unit i is not open). +- +-3. CALL FSEEK(i, offset, whence, *errlab) attemps to move +- Fortran unit i to the specified offset: absolute offset +- if whence = 0; relative to the current offset if whence = 1; +- relative to the end of the file if whence = 2. It branches +- to label errlab if unit i is not open or if the call +- otherwise fails. +- +-Nowadays most Unix and Linux systems have function +- int ftruncate(int fildes, off_t len); +-defined in system header file unistd.h that adjusts the length of file +-descriptor fildes to length len. Unless endfile.c is compiled with +--DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if +-necessary to shorten files. If your system lacks ftruncate(), compile +-endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more +-portable scheme of shortening a file by copying to a temporary file +-and back again. +//GO.SYSIN DD libI77/README +echo libI77/backspace.c 1>&2 +sed >libI77/backspace.c <<'//GO.SYSIN DD libI77/backspace.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef KR_headers +-integer f_back(a) alist *a; +-#else +-integer f_back(alist *a) +-#endif +-{ unit *b; +- OFF_T v, w, x, y, z; +- uiolen n; +- FILE *f; +- +- f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ +- if(a->aunit >= MXUNIT || a->aunit < 0) +- err(a->aerr,101,"backspace") +- if(b->useek==0) err(a->aerr,106,"backspace") +- if(b->ufd == NULL) { +- fk_open(1, 1, a->aunit); +- return(0); +- } +- if(b->uend==1) +- { b->uend=0; +- return(0); +- } +- if(b->uwrt) { +- t_runc(a); +- if (f__nowreading(b)) +- err(a->aerr,errno,"backspace") +- } +- f = b->ufd; /* may have changed in t_runc() */ +- if(b->url>0) +- { +- x=FTELL(f); +- y = x % b->url; +- if(y == 0) x--; +- x /= b->url; +- x *= b->url; +- (void) FSEEK(f,x,SEEK_SET); +- return(0); +- } +- +- if(b->ufmt==0) +- { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); +- fread((char *)&n,sizeof(uiolen),1,f); +- FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); +- return(0); +- } +- w = x = FTELL(f); +- z = 0; +- loop: +- while(x) { +- x -= x < 64 ? x : 64; +- FSEEK(f,x,SEEK_SET); +- for(y = x; y < w; y++) { +- if (getc(f) != '\n') +- continue; +- v = FTELL(f); +- if (v == w) { +- if (z) +- goto break2; +- goto loop; +- } +- z = v; +- } +- err(a->aerr,(EOF),"backspace") +- } +- break2: +- FSEEK(f, z, SEEK_SET); +- return 0; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/backspace.c +echo libI77/close.c 1>&2 +sed >libI77/close.c <<'//GO.SYSIN DD libI77/close.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef KR_headers +-integer f_clos(a) cllist *a; +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef NON_UNIX_STDIO +-#ifndef unlink +-#define unlink remove +-#endif +-#else +-#ifdef MSDOS +-#include "io.h" +-#else +-#ifdef __cplusplus +-extern "C" int unlink(const char*); +-#else +-extern int unlink(const char*); +-#endif +-#endif +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-integer f_clos(cllist *a) +-#endif +-{ unit *b; +- +- if(a->cunit >= MXUNIT) return(0); +- b= &f__units[a->cunit]; +- if(b->ufd==NULL) +- goto done; +- if (b->uscrtch == 1) +- goto Delete; +- if (!a->csta) +- goto Keep; +- switch(*a->csta) { +- default: +- Keep: +- case 'k': +- case 'K': +- if(b->uwrt == 1) +- t_runc((alist *)a); +- if(b->ufnm) { +- fclose(b->ufd); +- free(b->ufnm); +- } +- break; +- case 'd': +- case 'D': +- Delete: +- fclose(b->ufd); +- if(b->ufnm) { +- unlink(b->ufnm); /*SYSDEP*/ +- free(b->ufnm); +- } +- } +- b->ufd=NULL; +- done: +- b->uend=0; +- b->ufnm=NULL; +- return(0); +- } +- void +-#ifdef KR_headers +-f_exit() +-#else +-f_exit(void) +-#endif +-{ int i; +- static cllist xx; +- if (!xx.cerr) { +- xx.cerr=1; +- xx.csta=NULL; +- for(i=0;i&2 +sed >libI77/dfe.c <<'//GO.SYSIN DD libI77/dfe.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-y_rsk(Void) +-{ +- if(f__curunit->uend || f__curunit->url <= f__recpos +- || f__curunit->url == 1) return 0; +- do { +- getc(f__cf); +- } while(++f__recpos < f__curunit->url); +- return 0; +-} +- +- int +-y_getc(Void) +-{ +- int ch; +- if(f__curunit->uend) return(-1); +- if((ch=getc(f__cf))!=EOF) +- { +- f__recpos++; +- if(f__curunit->url>=f__recpos || +- f__curunit->url==1) +- return(ch); +- else return(' '); +- } +- if(feof(f__cf)) +- { +- f__curunit->uend=1; +- errno=0; +- return(-1); +- } +- err(f__elist->cierr,errno,"readingd"); +-} +- +- static int +-y_rev(Void) +-{ +- if (f__recpos < f__hiwater) +- f__recpos = f__hiwater; +- if (f__curunit->url > 1) +- while(f__recpos < f__curunit->url) +- (*f__putn)(' '); +- if (f__recpos) +- f__putbuf(0); +- f__recpos = 0; +- return(0); +-} +- +- static int +-y_err(Void) +-{ +- err(f__elist->cierr, 110, "dfe"); +-} +- +- static int +-y_newrec(Void) +-{ +- y_rev(); +- f__hiwater = f__cursor = 0; +- return(1); +-} +- +- int +-#ifdef KR_headers +-c_dfe(a) cilist *a; +-#else +-c_dfe(cilist *a) +-#endif +-{ +- f__sequential=0; +- f__formatted=f__external=1; +- f__elist=a; +- f__cursor=f__scale=f__recpos=0; +- f__curunit = &f__units[a->ciunit]; +- if(a->ciunit>MXUNIT || a->ciunit<0) +- err(a->cierr,101,"startchk"); +- if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) +- err(a->cierr,104,"dfe"); +- f__cf=f__curunit->ufd; +- if(!f__curunit->ufmt) err(a->cierr,102,"dfe") +- if(!f__curunit->useek) err(a->cierr,104,"dfe") +- f__fmtbuf=a->cifmt; +- if(a->cirec <= 0) +- err(a->cierr,130,"dfe") +- FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET); +- f__curunit->uend = 0; +- return(0); +-} +-#ifdef KR_headers +-integer s_rdfe(a) cilist *a; +-#else +-integer s_rdfe(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- f__reading=1; +- if(n=c_dfe(a))return(n); +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- f__getn = y_getc; +- f__doed = rd_ed; +- f__doned = rd_ned; +- f__dorevert = f__donewrec = y_err; +- f__doend = y_rsk; +- if(pars_f(f__fmtbuf)<0) +- err(a->cierr,100,"read start"); +- fmt_bg(); +- return(0); +-} +-#ifdef KR_headers +-integer s_wdfe(a) cilist *a; +-#else +-integer s_wdfe(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- f__reading=0; +- if(n=c_dfe(a)) return(n); +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr,errno,"startwrt"); +- f__putn = x_putc; +- f__doed = w_ed; +- f__doned= w_ned; +- f__dorevert = y_err; +- f__donewrec = y_newrec; +- f__doend = y_rev; +- if(pars_f(f__fmtbuf)<0) +- err(a->cierr,100,"startwrt"); +- fmt_bg(); +- return(0); +-} +-integer e_rdfe(Void) +-{ +- en_fio(); +- return 0; +-} +-integer e_wdfe(Void) +-{ +- return en_fio(); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/dfe.c +echo libI77/dolio.c 1>&2 +sed >libI77/dolio.c <<'//GO.SYSIN DD libI77/dolio.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef KR_headers +-extern int (*f__lioproc)(); +- +-integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; +-#else +-extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +- +-integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- return((*f__lioproc)(number,ptr,len,*type)); +-} +-#ifdef __cplusplus +- } +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/dolio.c +echo libI77/due.c 1>&2 +sed >libI77/due.c <<'//GO.SYSIN DD libI77/due.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-#ifdef KR_headers +-c_due(a) cilist *a; +-#else +-c_due(cilist *a) +-#endif +-{ +- if(!f__init) f_init(); +- f__sequential=f__formatted=f__recpos=0; +- f__external=1; +- f__curunit = &f__units[a->ciunit]; +- if(a->ciunit>=MXUNIT || a->ciunit<0) +- err(a->cierr,101,"startio"); +- f__elist=a; +- if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); +- f__cf=f__curunit->ufd; +- if(f__curunit->ufmt) err(a->cierr,102,"cdue") +- if(!f__curunit->useek) err(a->cierr,104,"cdue") +- if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue") +- if(a->cirec <= 0) +- err(a->cierr,130,"due") +- FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET); +- f__curunit->uend = 0; +- return(0); +-} +-#ifdef KR_headers +-integer s_rdue(a) cilist *a; +-#else +-integer s_rdue(cilist *a) +-#endif +-{ +- int n; +- f__reading=1; +- if(n=c_due(a)) return(n); +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- return(0); +-} +-#ifdef KR_headers +-integer s_wdue(a) cilist *a; +-#else +-integer s_wdue(cilist *a) +-#endif +-{ +- int n; +- f__reading=0; +- if(n=c_due(a)) return(n); +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr,errno,"write start"); +- return(0); +-} +-integer e_rdue(Void) +-{ +- if(f__curunit->url==1 || f__recpos==f__curunit->url) +- return(0); +- FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR); +- if(FTELL(f__cf)%f__curunit->url) +- err(f__elist->cierr,200,"syserr"); +- return(0); +-} +-integer e_wdue(Void) +-{ +-#ifdef ALWAYS_FLUSH +- if (fflush(f__cf)) +- err(f__elist->cierr,errno,"write end"); +-#endif +- return(e_rdue()); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/due.c +echo libI77/endfile.c 1>&2 +sed >libI77/endfile.c <<'//GO.SYSIN DD libI77/endfile.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-/* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */ +-/* if it does not define int truncate(const char *name, off_t). */ +- +-#ifdef MSDOS +-#undef NO_TRUNCATE +-#define NO_TRUNCATE +-#endif +- +-#ifndef NO_TRUNCATE +-#include "unistd.h" +-#endif +- +-#ifdef KR_headers +-extern char *strcpy(); +-extern FILE *tmpfile(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-extern char *f__r_mode[], *f__w_mode[]; +- +-#ifdef KR_headers +-integer f_end(a) alist *a; +-#else +-integer f_end(alist *a) +-#endif +-{ +- unit *b; +- FILE *tf; +- +- if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); +- b = &f__units[a->aunit]; +- if(b->ufd==NULL) { +- char nbuf[10]; +- sprintf(nbuf,"fort.%ld",(long)a->aunit); +- if (tf = FOPEN(nbuf, f__w_mode[0])) +- fclose(tf); +- return(0); +- } +- b->uend=1; +- return(b->useek ? t_runc(a) : 0); +-} +- +-#ifdef NO_TRUNCATE +- static int +-#ifdef KR_headers +-copy(from, len, to) FILE *from, *to; register long len; +-#else +-copy(FILE *from, register long len, FILE *to) +-#endif +-{ +- int len1; +- char buf[BUFSIZ]; +- +- while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { +- if (!fwrite(buf, len1, 1, to)) +- return 1; +- if ((len -= len1) <= 0) +- break; +- } +- return 0; +- } +-#endif /* NO_TRUNCATE */ +- +- int +-#ifdef KR_headers +-t_runc(a) alist *a; +-#else +-t_runc(alist *a) +-#endif +-{ +- OFF_T loc, len; +- unit *b; +- int rc; +- FILE *bf; +-#ifdef NO_TRUNCATE +- FILE *tf; +-#endif +- +- b = &f__units[a->aunit]; +- if(b->url) +- return(0); /*don't truncate direct files*/ +- loc=FTELL(bf = b->ufd); +- FSEEK(bf,(OFF_T)0,SEEK_END); +- len=FTELL(bf); +- if (loc >= len || b->useek == 0) +- return(0); +-#ifdef NO_TRUNCATE +- if (b->ufnm == NULL) +- return 0; +- rc = 0; +- fclose(b->ufd); +- if (!loc) { +- if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt]))) +- rc = 1; +- if (b->uwrt) +- b->uwrt = 1; +- goto done; +- } +- if (!(bf = FOPEN(b->ufnm, f__r_mode[0])) +- || !(tf = tmpfile())) { +-#ifdef NON_UNIX_STDIO +- bad: +-#endif +- rc = 1; +- goto done; +- } +- if (copy(bf, (long)loc, tf)) { +- bad1: +- rc = 1; +- goto done1; +- } +- if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf))) +- goto bad1; +- rewind(tf); +- if (copy(tf, (long)loc, bf)) +- goto bad1; +- b->uwrt = 1; +- b->urw = 2; +-#ifdef NON_UNIX_STDIO +- if (b->ufmt) { +- fclose(bf); +- if (!(bf = FOPEN(b->ufnm, f__w_mode[3]))) +- goto bad; +- FSEEK(bf,(OFF_T)0,SEEK_END); +- b->urw = 3; +- } +-#endif +-done1: +- fclose(tf); +-done: +- f__cf = b->ufd = bf; +-#else /* NO_TRUNCATE */ +- if (b->urw & 2) +- fflush(b->ufd); /* necessary on some Linux systems */ +-#ifndef FTRUNCATE +-#define FTRUNCATE ftruncate +-#endif +- rc = FTRUNCATE(fileno(b->ufd), loc); +- /* The following FSEEK is unnecessary on some systems, */ +- /* but should be harmless. */ +- FSEEK(b->ufd, (OFF_T)0, SEEK_END); +-#endif /* NO_TRUNCATE */ +- if (rc) +- err(a->aerr,111,"endfile"); +- return 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/endfile.c +echo libI77/err.c 1>&2 +sed >libI77/err.c <<'//GO.SYSIN DD libI77/err.c' 's/^-//' +-#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +-#include "f2c.h" +-#ifdef KR_headers +-extern char *malloc(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#endif +-#include "fio.h" +-#include "fmt.h" /* for struct syl */ +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/*global definitions*/ +-unit f__units[MXUNIT]; /*unit table*/ +-flag f__init; /*0 on entry, 1 after initializations*/ +-cilist *f__elist; /*active external io list*/ +-icilist *f__svic; /*active internal io list*/ +-flag f__reading; /*1 if reading, 0 if writing*/ +-flag f__cplus,f__cblank; +-char *f__fmtbuf; +-flag f__external; /*1 if external io, 0 if internal */ +-#ifdef KR_headers +-int (*f__doed)(),(*f__doned)(); +-int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); +-int (*f__getn)(); /* for formatted input */ +-void (*f__putn)(); /* for formatted output */ +-#else +-int (*f__getn)(void); /* for formatted input */ +-void (*f__putn)(int); /* for formatted output */ +-int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +-int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); +-#endif +-flag f__sequential; /*1 if sequential io, 0 if direct*/ +-flag f__formatted; /*1 if formatted io, 0 if unformatted*/ +-FILE *f__cf; /*current file*/ +-unit *f__curunit; /*current unit*/ +-int f__recpos; /*place in current record*/ +-OFF_T f__cursor, f__hiwater; +-int f__scale; +-char *f__icptr; +- +-/*error messages*/ +-char *F_err[] = +-{ +- "error in format", /* 100 */ +- "illegal unit number", /* 101 */ +- "formatted io not allowed", /* 102 */ +- "unformatted io not allowed", /* 103 */ +- "direct io not allowed", /* 104 */ +- "sequential io not allowed", /* 105 */ +- "can't backspace file", /* 106 */ +- "null file name", /* 107 */ +- "can't stat file", /* 108 */ +- "unit not connected", /* 109 */ +- "off end of record", /* 110 */ +- "truncation failed in endfile", /* 111 */ +- "incomprehensible list input", /* 112 */ +- "out of free space", /* 113 */ +- "unit not connected", /* 114 */ +- "read unexpected character", /* 115 */ +- "bad logical input field", /* 116 */ +- "bad variable type", /* 117 */ +- "bad namelist name", /* 118 */ +- "variable not in namelist", /* 119 */ +- "no end record", /* 120 */ +- "variable count incorrect", /* 121 */ +- "subscript for scalar variable", /* 122 */ +- "invalid array section", /* 123 */ +- "substring out of bounds", /* 124 */ +- "subscript out of bounds", /* 125 */ +- "can't read file", /* 126 */ +- "can't write file", /* 127 */ +- "'new' file exists", /* 128 */ +- "can't append to file", /* 129 */ +- "non-positive record number", /* 130 */ +- "nmLbuf overflow" /* 131 */ +-}; +-#define MAXERR (sizeof(F_err)/sizeof(char *)+100) +- +- int +-#ifdef KR_headers +-f__canseek(f) FILE *f; /*SYSDEP*/ +-#else +-f__canseek(FILE *f) /*SYSDEP*/ +-#endif +-{ +-#ifdef NON_UNIX_STDIO +- return !isatty(fileno(f)); +-#else +- struct STAT_ST x; +- +- if (FSTAT(fileno(f),&x) < 0) +- return(0); +-#ifdef S_IFMT +- switch(x.st_mode & S_IFMT) { +- case S_IFDIR: +- case S_IFREG: +- if(x.st_nlink > 0) /* !pipe */ +- return(1); +- else +- return(0); +- case S_IFCHR: +- if(isatty(fileno(f))) +- return(0); +- return(1); +-#ifdef S_IFBLK +- case S_IFBLK: +- return(1); +-#endif +- } +-#else +-#ifdef S_ISDIR +- /* POSIX version */ +- if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { +- if(x.st_nlink > 0) /* !pipe */ +- return(1); +- else +- return(0); +- } +- if (S_ISCHR(x.st_mode)) { +- if(isatty(fileno(f))) +- return(0); +- return(1); +- } +- if (S_ISBLK(x.st_mode)) +- return(1); +-#else +- Help! How does fstat work on this system? +-#endif +-#endif +- return(0); /* who knows what it is? */ +-#endif +-} +- +- void +-#ifdef KR_headers +-f__fatal(n,s) char *s; +-#else +-f__fatal(int n, char *s) +-#endif +-{ +- if(n<100 && n>=0) perror(s); /*SYSDEP*/ +- else if(n >= (int)MAXERR || n < -1) +- { fprintf(stderr,"%s: illegal error number %d\n",s,n); +- } +- else if(n == -1) fprintf(stderr,"%s: end of file\n",s); +- else +- fprintf(stderr,"%s: %s\n",s,F_err[n-100]); +- if (f__curunit) { +- fprintf(stderr,"apparent state: unit %d ", +- (int)(f__curunit-f__units)); +- fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", +- f__curunit->ufnm); +- } +- else +- fprintf(stderr,"apparent state: internal I/O\n"); +- if (f__fmtbuf) +- fprintf(stderr,"last format: %s\n",f__fmtbuf); +- fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", +- f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", +- f__external?"external":"internal"); +- sig_die(" IO", 1); +-} +-/*initialization routine*/ +- VOID +-f_init(Void) +-{ unit *p; +- +- f__init=1; +- p= &f__units[0]; +- p->ufd=stderr; +- p->useek=f__canseek(stderr); +- p->ufmt=1; +- p->uwrt=1; +- p = &f__units[5]; +- p->ufd=stdin; +- p->useek=f__canseek(stdin); +- p->ufmt=1; +- p->uwrt=0; +- p= &f__units[6]; +- p->ufd=stdout; +- p->useek=f__canseek(stdout); +- p->ufmt=1; +- p->uwrt=1; +-} +- +- int +-#ifdef KR_headers +-f__nowreading(x) unit *x; +-#else +-f__nowreading(unit *x) +-#endif +-{ +- OFF_T loc; +- int ufmt, urw; +- extern char *f__r_mode[], *f__w_mode[]; +- +- if (x->urw & 1) +- goto done; +- if (!x->ufnm) +- goto cantread; +- ufmt = x->url ? 0 : x->ufmt; +- loc = FTELL(x->ufd); +- urw = 3; +- if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { +- urw = 1; +- if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) { +- cantread: +- errno = 126; +- return 1; +- } +- } +- FSEEK(x->ufd,loc,SEEK_SET); +- x->urw = urw; +- done: +- x->uwrt = 0; +- return 0; +-} +- +- int +-#ifdef KR_headers +-f__nowwriting(x) unit *x; +-#else +-f__nowwriting(unit *x) +-#endif +-{ +- OFF_T loc; +- int ufmt; +- extern char *f__w_mode[]; +- +- if (x->urw & 2) { +- if (x->urw & 1) +- FSEEK(x->ufd, (OFF_T)0, SEEK_CUR); +- goto done; +- } +- if (!x->ufnm) +- goto cantwrite; +- ufmt = x->url ? 0 : x->ufmt; +- if (x->uwrt == 3) { /* just did write, rewind */ +- if (!(f__cf = x->ufd = +- FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd))) +- goto cantwrite; +- x->urw = 2; +- } +- else { +- loc=FTELL(x->ufd); +- if (!(f__cf = x->ufd = +- FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) +- { +- x->ufd = NULL; +- cantwrite: +- errno = 127; +- return(1); +- } +- x->urw = 3; +- FSEEK(x->ufd,loc,SEEK_SET); +- } +- done: +- x->uwrt = 1; +- return 0; +-} +- +- int +-#ifdef KR_headers +-err__fl(f, m, s) int f, m; char *s; +-#else +-err__fl(int f, int m, char *s) +-#endif +-{ +- if (!f) +- f__fatal(m, s); +- if (f__doend) +- (*f__doend)(); +- return errno = m; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/err.c +echo libI77/f2ch.add 1>&2 +sed >libI77/f2ch.add <<'//GO.SYSIN DD libI77/f2ch.add' 's/^-//' +-/* If you are using a C++ compiler, append the following to f2c.h +- for compiling libF77 and libI77. */ +- +-#ifdef __cplusplus +-extern "C" { +-extern int abort_(void); +-extern double c_abs(complex *); +-extern void c_cos(complex *, complex *); +-extern void c_div(complex *, complex *, complex *); +-extern void c_exp(complex *, complex *); +-extern void c_log(complex *, complex *); +-extern void c_sin(complex *, complex *); +-extern void c_sqrt(complex *, complex *); +-extern double d_abs(double *); +-extern double d_acos(double *); +-extern double d_asin(double *); +-extern double d_atan(double *); +-extern double d_atn2(double *, double *); +-extern void d_cnjg(doublecomplex *, doublecomplex *); +-extern double d_cos(double *); +-extern double d_cosh(double *); +-extern double d_dim(double *, double *); +-extern double d_exp(double *); +-extern double d_imag(doublecomplex *); +-extern double d_int(double *); +-extern double d_lg10(double *); +-extern double d_log(double *); +-extern double d_mod(double *, double *); +-extern double d_nint(double *); +-extern double d_prod(float *, float *); +-extern double d_sign(double *, double *); +-extern double d_sin(double *); +-extern double d_sinh(double *); +-extern double d_sqrt(double *); +-extern double d_tan(double *); +-extern double d_tanh(double *); +-extern double derf_(double *); +-extern double derfc_(double *); +-extern integer do_fio(ftnint *, char *, ftnlen); +-extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +-extern integer do_uio(ftnint *, char *, ftnlen); +-extern integer e_rdfe(void); +-extern integer e_rdue(void); +-extern integer e_rsfe(void); +-extern integer e_rsfi(void); +-extern integer e_rsle(void); +-extern integer e_rsli(void); +-extern integer e_rsue(void); +-extern integer e_wdfe(void); +-extern integer e_wdue(void); +-extern integer e_wsfe(void); +-extern integer e_wsfi(void); +-extern integer e_wsle(void); +-extern integer e_wsli(void); +-extern integer e_wsue(void); +-extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern double erf(double); +-extern double erf_(float *); +-extern double erfc(double); +-extern double erfc_(float *); +-extern integer f_back(alist *); +-extern integer f_clos(cllist *); +-extern integer f_end(alist *); +-extern void f_exit(void); +-extern integer f_inqu(inlist *); +-extern integer f_open(olist *); +-extern integer f_rew(alist *); +-extern int flush_(void); +-extern void getarg_(integer *, char *, ftnlen); +-extern void getenv_(char *, char *, ftnlen, ftnlen); +-extern short h_abs(short *); +-extern short h_dim(short *, short *); +-extern short h_dnnt(double *); +-extern short h_indx(char *, char *, ftnlen, ftnlen); +-extern short h_len(char *, ftnlen); +-extern short h_mod(short *, short *); +-extern short h_nint(float *); +-extern short h_sign(short *, short *); +-extern short hl_ge(char *, char *, ftnlen, ftnlen); +-extern short hl_gt(char *, char *, ftnlen, ftnlen); +-extern short hl_le(char *, char *, ftnlen, ftnlen); +-extern short hl_lt(char *, char *, ftnlen, ftnlen); +-extern integer i_abs(integer *); +-extern integer i_dim(integer *, integer *); +-extern integer i_dnnt(double *); +-extern integer i_indx(char *, char *, ftnlen, ftnlen); +-extern integer i_len(char *, ftnlen); +-extern integer i_mod(integer *, integer *); +-extern integer i_nint(float *); +-extern integer i_sign(integer *, integer *); +-extern integer iargc_(void); +-extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +-extern void pow_ci(complex *, complex *, integer *); +-extern double pow_dd(double *, double *); +-extern double pow_di(double *, integer *); +-extern short pow_hh(short *, shortint *); +-extern integer pow_ii(integer *, integer *); +-extern double pow_ri(float *, integer *); +-extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +-extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +-extern double r_abs(float *); +-extern double r_acos(float *); +-extern double r_asin(float *); +-extern double r_atan(float *); +-extern double r_atn2(float *, float *); +-extern void r_cnjg(complex *, complex *); +-extern double r_cos(float *); +-extern double r_cosh(float *); +-extern double r_dim(float *, float *); +-extern double r_exp(float *); +-extern double r_imag(complex *); +-extern double r_int(float *); +-extern double r_lg10(float *); +-extern double r_log(float *); +-extern double r_mod(float *, float *); +-extern double r_nint(float *); +-extern double r_sign(float *, float *); +-extern double r_sin(float *); +-extern double r_sinh(float *); +-extern double r_sqrt(float *); +-extern double r_tan(float *); +-extern double r_tanh(float *); +-extern void s_cat(char *, char **, integer *, integer *, ftnlen); +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-extern void s_copy(char *, char *, ftnlen, ftnlen); +-extern int s_paus(char *, ftnlen); +-extern integer s_rdfe(cilist *); +-extern integer s_rdue(cilist *); +-extern integer s_rnge(char *, integer, char *, integer); +-extern integer s_rsfe(cilist *); +-extern integer s_rsfi(icilist *); +-extern integer s_rsle(cilist *); +-extern integer s_rsli(icilist *); +-extern integer s_rsne(cilist *); +-extern integer s_rsni(icilist *); +-extern integer s_rsue(cilist *); +-extern int s_stop(char *, ftnlen); +-extern integer s_wdfe(cilist *); +-extern integer s_wdue(cilist *); +-extern integer s_wsfe(cilist *); +-extern integer s_wsfi(icilist *); +-extern integer s_wsle(cilist *); +-extern integer s_wsli(icilist *); +-extern integer s_wsne(cilist *); +-extern integer s_wsni(icilist *); +-extern integer s_wsue(cilist *); +-extern void sig_die(char *, int); +-extern integer signal_(integer *, void (*)(int)); +-extern integer system_(char *, ftnlen); +-extern double z_abs(doublecomplex *); +-extern void z_cos(doublecomplex *, doublecomplex *); +-extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +-extern void z_exp(doublecomplex *, doublecomplex *); +-extern void z_log(doublecomplex *, doublecomplex *); +-extern void z_sin(doublecomplex *, doublecomplex *); +-extern void z_sqrt(doublecomplex *, doublecomplex *); +- } +-#endif +//GO.SYSIN DD libI77/f2ch.add +echo libI77/fio.h 1>&2 +sed >libI77/fio.h <<'//GO.SYSIN DD libI77/fio.h' 's/^-//' +-#ifndef SYSDEP_H_INCLUDED +-#include "sysdep1.h" +-#endif +-#include "stdio.h" +-#include "errno.h" +-#ifndef NULL +-/* ANSI C */ +-#include "stddef.h" +-#endif +- +-#ifndef SEEK_SET +-#define SEEK_SET 0 +-#define SEEK_CUR 1 +-#define SEEK_END 2 +-#endif +- +-#ifndef FOPEN +-#define FOPEN fopen +-#endif +- +-#ifndef FREOPEN +-#define FREOPEN freopen +-#endif +- +-#ifndef FSEEK +-#define FSEEK fseek +-#endif +- +-#ifndef FSTAT +-#define FSTAT fstat +-#endif +- +-#ifndef FTELL +-#define FTELL ftell +-#endif +- +-#ifndef OFF_T +-#define OFF_T long +-#endif +- +-#ifndef STAT_ST +-#define STAT_ST stat +-#endif +- +-#ifndef STAT +-#define STAT stat +-#endif +- +-#ifdef MSDOS +-#ifndef NON_UNIX_STDIO +-#define NON_UNIX_STDIO +-#endif +-#endif +- +-#ifdef UIOLEN_int +-typedef int uiolen; +-#else +-typedef long uiolen; +-#endif +- +-/*units*/ +-typedef struct +-{ FILE *ufd; /*0=unconnected*/ +- char *ufnm; +-#ifndef MSDOS +- long uinode; +- int udev; +-#endif +- int url; /*0=sequential*/ +- flag useek; /*true=can backspace, use dir, ...*/ +- flag ufmt; +- flag urw; /* (1 for can read) | (2 for can write) */ +- flag ublnk; +- flag uend; +- flag uwrt; /*last io was write*/ +- flag uscrtch; +-} unit; +- +-extern flag f__init; +-extern cilist *f__elist; /*active external io list*/ +-extern flag f__reading,f__external,f__sequential,f__formatted; +-#undef Void +-#ifdef KR_headers +-#define Void /*void*/ +-extern int (*f__getn)(); /* for formatted input */ +-extern void (*f__putn)(); /* for formatted output */ +-extern void x_putc(); +-extern long f__inode(); +-extern VOID sig_die(); +-extern int (*f__donewrec)(), t_putc(), x_wSL(); +-extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); +-#else +-#define Void void +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int (*f__getn)(void); /* for formatted input */ +-extern void (*f__putn)(int); /* for formatted output */ +-extern void x_putc(int); +-extern long f__inode(char*,int*); +-extern void sig_die(char*,int); +-extern void f__fatal(int,char*); +-extern int t_runc(alist*); +-extern int f__nowreading(unit*), f__nowwriting(unit*); +-extern int fk_open(int,int,ftnint); +-extern int en_fio(void); +-extern void f_init(void); +-extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); +-extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*); +-extern int c_sfe(cilist*), z_rnew(void); +-extern int isatty(int); +-extern int err__fl(int,int,char*); +-extern int xrd_SL(void); +-extern int f__putbuf(int); +-#ifdef __cplusplus +- } +-#endif +-#endif +-extern int (*f__doend)(Void); +-extern FILE *f__cf; /*current file*/ +-extern unit *f__curunit; /*current unit*/ +-extern unit f__units[]; +-#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);} +-#define errfl(f,m,s) return err__fl((int)f,m,s) +- +-/*Table sizes*/ +-#define MXUNIT 100 +- +-extern int f__recpos; /*position in current record*/ +-extern OFF_T f__cursor; /* offset to move to */ +-extern OFF_T f__hiwater; /* so TL doesn't confuse us */ +- +-#define WRITE 1 +-#define READ 2 +-#define SEQ 3 +-#define DIR 4 +-#define FMT 5 +-#define UNF 6 +-#define EXT 7 +-#define INT 8 +- +-#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) +//GO.SYSIN DD libI77/fio.h +echo libI77/fmt.c 1>&2 +sed >libI77/fmt.c <<'//GO.SYSIN DD libI77/fmt.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#define skip(s) while(*s==' ') s++ +-#ifdef interdata +-#define SYLMX 300 +-#endif +-#ifdef pdp11 +-#define SYLMX 300 +-#endif +-#ifdef vax +-#define SYLMX 300 +-#endif +-#ifndef SYLMX +-#define SYLMX 300 +-#endif +-#define GLITCH '\2' +- /* special quote character for stu */ +-extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ +-static struct syl f__syl[SYLMX]; +-int f__parenlvl,f__pc,f__revloc; +- +- static +-#ifdef KR_headers +-char *ap_end(s) char *s; +-#else +-char *ap_end(char *s) +-#endif +-{ char quote; +- quote= *s++; +- for(;*s;s++) +- { if(*s!=quote) continue; +- if(*++s!=quote) return(s); +- } +- if(f__elist->cierr) { +- errno = 100; +- return(NULL); +- } +- f__fatal(100, "bad string"); +- /*NOTREACHED*/ return 0; +-} +- static int +-#ifdef KR_headers +-op_gen(a,b,c,d) +-#else +-op_gen(int a, int b, int c, int d) +-#endif +-{ struct syl *p= &f__syl[f__pc]; +- if(f__pc>=SYLMX) +- { fprintf(stderr,"format too complicated:\n"); +- sig_die(f__fmtbuf, 1); +- } +- p->op=a; +- p->p1=b; +- p->p2.i[0]=c; +- p->p2.i[1]=d; +- return(f__pc++); +-} +-#ifdef KR_headers +-static char *f_list(); +-static char *gt_num(s,n,n1) char *s; int *n, n1; +-#else +-static char *f_list(char*); +-static char *gt_num(char *s, int *n, int n1) +-#endif +-{ int m=0,f__cnt=0; +- char c; +- for(c= *s;;c = *s) +- { if(c==' ') +- { s++; +- continue; +- } +- if(c>'9' || c<'0') break; +- m=10*m+c-'0'; +- f__cnt++; +- s++; +- } +- if(f__cnt==0) { +- if (!n1) +- s = 0; +- *n=n1; +- } +- else *n=m; +- return(s); +-} +- +- static +-#ifdef KR_headers +-char *f_s(s,curloc) char *s; +-#else +-char *f_s(char *s, int curloc) +-#endif +-{ +- skip(s); +- if(*s++!='(') +- { +- return(NULL); +- } +- if(f__parenlvl++ ==1) f__revloc=curloc; +- if(op_gen(RET1,curloc,0,0)<0 || +- (s=f_list(s))==NULL) +- { +- return(NULL); +- } +- skip(s); +- return(s); +-} +- +- static int +-#ifdef KR_headers +-ne_d(s,p) char *s,**p; +-#else +-ne_d(char *s, char **p) +-#endif +-{ int n,x,sign=0; +- struct syl *sp; +- switch(*s) +- { +- default: +- return(0); +- case ':': (void) op_gen(COLON,0,0,0); break; +- case '$': +- (void) op_gen(NONL, 0, 0, 0); break; +- case 'B': +- case 'b': +- if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); +- else (void) op_gen(BN,0,0,0); +- break; +- case 'S': +- case 's': +- if(*(s+1)=='s' || *(s+1) == 'S') +- { x=SS; +- s++; +- } +- else if(*(s+1)=='p' || *(s+1) == 'P') +- { x=SP; +- s++; +- } +- else x=S; +- (void) op_gen(x,0,0,0); +- break; +- case '/': (void) op_gen(SLASH,0,0,0); break; +- case '-': sign=1; +- case '+': s++; /*OUTRAGEOUS CODING TRICK*/ +- case '0': case '1': case '2': case '3': case '4': +- case '5': case '6': case '7': case '8': case '9': +- if (!(s=gt_num(s,&n,0))) { +- bad: *p = 0; +- return 1; +- } +- switch(*s) +- { +- default: +- return(0); +- case 'P': +- case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; +- case 'X': +- case 'x': (void) op_gen(X,n,0,0); break; +- case 'H': +- case 'h': +- sp = &f__syl[op_gen(H,n,0,0)]; +- sp->p2.s = s + 1; +- s+=n; +- break; +- } +- break; +- case GLITCH: +- case '"': +- case '\'': +- sp = &f__syl[op_gen(APOS,0,0,0)]; +- sp->p2.s = s; +- if((*p = ap_end(s)) == NULL) +- return(0); +- return(1); +- case 'T': +- case 't': +- if(*(s+1)=='l' || *(s+1) == 'L') +- { x=TL; +- s++; +- } +- else if(*(s+1)=='r'|| *(s+1) == 'R') +- { x=TR; +- s++; +- } +- else x=T; +- if (!(s=gt_num(s+1,&n,0))) +- goto bad; +- s--; +- (void) op_gen(x,n,0,0); +- break; +- case 'X': +- case 'x': (void) op_gen(X,1,0,0); break; +- case 'P': +- case 'p': (void) op_gen(P,1,0,0); break; +- } +- s++; +- *p=s; +- return(1); +-} +- +- static int +-#ifdef KR_headers +-e_d(s,p) char *s,**p; +-#else +-e_d(char *s, char **p) +-#endif +-{ int i,im,n,w,d,e,found=0,x=0; +- char *sv=s; +- s=gt_num(s,&n,1); +- (void) op_gen(STACK,n,0,0); +- switch(*s++) +- { +- default: break; +- case 'E': +- case 'e': x=1; +- case 'G': +- case 'g': +- found=1; +- if (!(s=gt_num(s,&w,0))) { +- bad: +- *p = 0; +- return 1; +- } +- if(w==0) break; +- if(*s=='.') { +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- } +- else d=0; +- if(*s!='E' && *s != 'e') +- (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ +- else { +- if (!(s=gt_num(s+1,&e,0))) +- goto bad; +- (void) op_gen(x==1?EE:GE,w,d,e); +- } +- break; +- case 'O': +- case 'o': +- i = O; +- im = OM; +- goto finish_I; +- case 'Z': +- case 'z': +- i = Z; +- im = ZM; +- goto finish_I; +- case 'L': +- case 'l': +- found=1; +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- if(w==0) break; +- (void) op_gen(L,w,0,0); +- break; +- case 'A': +- case 'a': +- found=1; +- skip(s); +- if(*s>='0' && *s<='9') +- { s=gt_num(s,&w,1); +- if(w==0) break; +- (void) op_gen(AW,w,0,0); +- break; +- } +- (void) op_gen(A,0,0,0); +- break; +- case 'F': +- case 'f': +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- found=1; +- if(w==0) break; +- if(*s=='.') { +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- } +- else d=0; +- (void) op_gen(F,w,d,0); +- break; +- case 'D': +- case 'd': +- found=1; +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- if(w==0) break; +- if(*s=='.') { +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- } +- else d=0; +- (void) op_gen(D,w,d,0); +- break; +- case 'I': +- case 'i': +- i = I; +- im = IM; +- finish_I: +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- found=1; +- if(w==0) break; +- if(*s!='.') +- { (void) op_gen(i,w,0,0); +- break; +- } +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- (void) op_gen(im,w,d,0); +- break; +- } +- if(found==0) +- { f__pc--; /*unSTACK*/ +- *p=sv; +- return(0); +- } +- *p=s; +- return(1); +-} +- static +-#ifdef KR_headers +-char *i_tem(s) char *s; +-#else +-char *i_tem(char *s) +-#endif +-{ char *t; +- int n,curloc; +- if(*s==')') return(s); +- if(ne_d(s,&t)) return(t); +- if(e_d(s,&t)) return(t); +- s=gt_num(s,&n,1); +- if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); +- return(f_s(s,curloc)); +-} +- +- static +-#ifdef KR_headers +-char *f_list(s) char *s; +-#else +-char *f_list(char *s) +-#endif +-{ +- for(;*s!=0;) +- { skip(s); +- if((s=i_tem(s))==NULL) return(NULL); +- skip(s); +- if(*s==',') s++; +- else if(*s==')') +- { if(--f__parenlvl==0) +- { +- (void) op_gen(REVERT,f__revloc,0,0); +- return(++s); +- } +- (void) op_gen(GOTO,0,0,0); +- return(++s); +- } +- } +- return(NULL); +-} +- +- int +-#ifdef KR_headers +-pars_f(s) char *s; +-#else +-pars_f(char *s) +-#endif +-{ +- f__parenlvl=f__revloc=f__pc=0; +- if(f_s(s,0) == NULL) +- { +- return(-1); +- } +- return(0); +-} +-#define STKSZ 10 +-int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; +-flag f__workdone, f__nonl; +- +- static int +-#ifdef KR_headers +-type_f(n) +-#else +-type_f(int n) +-#endif +-{ +- switch(n) +- { +- default: +- return(n); +- case RET1: +- return(RET1); +- case REVERT: return(REVERT); +- case GOTO: return(GOTO); +- case STACK: return(STACK); +- case X: +- case SLASH: +- case APOS: case H: +- case T: case TL: case TR: +- return(NED); +- case F: +- case I: +- case IM: +- case A: case AW: +- case O: case OM: +- case L: +- case E: case EE: case D: +- case G: case GE: +- case Z: case ZM: +- return(ED); +- } +-} +-#ifdef KR_headers +-integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +-#else +-integer do_fio(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ struct syl *p; +- int n,i; +- for(i=0;i<*number;i++,ptr+=len) +- { +-loop: switch(type_f((p= &f__syl[f__pc])->op)) +- { +- default: +- fprintf(stderr,"unknown code in do_fio: %d\n%s\n", +- p->op,f__fmtbuf); +- err(f__elist->cierr,100,"do_fio"); +- case NED: +- if((*f__doned)(p)) +- { f__pc++; +- goto loop; +- } +- f__pc++; +- continue; +- case ED: +- if(f__cnt[f__cp]<=0) +- { f__cp--; +- f__pc++; +- goto loop; +- } +- if(ptr==NULL) +- return((*f__doend)()); +- f__cnt[f__cp]--; +- f__workdone=1; +- if((n=(*f__doed)(p,ptr,len))>0) +- errfl(f__elist->cierr,errno,"fmt"); +- if(n<0) +- err(f__elist->ciend,(EOF),"fmt"); +- continue; +- case STACK: +- f__cnt[++f__cp]=p->p1; +- f__pc++; +- goto loop; +- case RET1: +- f__ret[++f__rp]=p->p1; +- f__pc++; +- goto loop; +- case GOTO: +- if(--f__cnt[f__cp]<=0) +- { f__cp--; +- f__rp--; +- f__pc++; +- goto loop; +- } +- f__pc=1+f__ret[f__rp--]; +- goto loop; +- case REVERT: +- f__rp=f__cp=0; +- f__pc = p->p1; +- if(ptr==NULL) +- return((*f__doend)()); +- if(!f__workdone) return(0); +- if((n=(*f__dorevert)()) != 0) return(n); +- goto loop; +- case COLON: +- if(ptr==NULL) +- return((*f__doend)()); +- f__pc++; +- goto loop; +- case NONL: +- f__nonl = 1; +- f__pc++; +- goto loop; +- case S: +- case SS: +- f__cplus=0; +- f__pc++; +- goto loop; +- case SP: +- f__cplus = 1; +- f__pc++; +- goto loop; +- case P: f__scale=p->p1; +- f__pc++; +- goto loop; +- case BN: +- f__cblank=0; +- f__pc++; +- goto loop; +- case BZ: +- f__cblank=1; +- f__pc++; +- goto loop; +- } +- } +- return(0); +-} +- +- int +-en_fio(Void) +-{ ftnint one=1; +- return(do_fio(&one,(char *)NULL,(ftnint)0)); +-} +- +- VOID +-fmt_bg(Void) +-{ +- f__workdone=f__cp=f__rp=f__pc=f__cursor=0; +- f__cnt[0]=f__ret[0]=0; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/fmt.c +echo libI77/fmt.h 1>&2 +sed >libI77/fmt.h <<'//GO.SYSIN DD libI77/fmt.h' 's/^-//' +-struct syl +-{ int op; +- int p1; +- union { int i[2]; char *s;} p2; +- }; +-#define RET1 1 +-#define REVERT 2 +-#define GOTO 3 +-#define X 4 +-#define SLASH 5 +-#define STACK 6 +-#define I 7 +-#define ED 8 +-#define NED 9 +-#define IM 10 +-#define APOS 11 +-#define H 12 +-#define TL 13 +-#define TR 14 +-#define T 15 +-#define COLON 16 +-#define S 17 +-#define SP 18 +-#define SS 19 +-#define P 20 +-#define BN 21 +-#define BZ 22 +-#define F 23 +-#define E 24 +-#define EE 25 +-#define D 26 +-#define G 27 +-#define GE 28 +-#define L 29 +-#define A 30 +-#define AW 31 +-#define O 32 +-#define NONL 33 +-#define OM 34 +-#define Z 35 +-#define ZM 36 +-extern int f__pc,f__parenlvl,f__revloc; +-typedef union +-{ real pf; +- doublereal pd; +-} ufloat; +-typedef union +-{ short is; +-#ifndef KR_headers +- signed +-#endif +- char ic; +- integer il; +-#ifdef Allow_TYQUAD +- longint ili; +-#endif +-} Uint; +-#ifdef KR_headers +-extern int (*f__doed)(),(*f__doned)(); +-extern int (*f__dorevert)(); +-extern int rd_ed(),rd_ned(); +-extern int w_ed(),w_ned(); +-extern int signbit_f2c(); +-#else +-#ifdef __cplusplus +-extern "C" { +-#define Cextern extern "C" +-#else +-#define Cextern extern +-#endif +-extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +-extern int (*f__dorevert)(void); +-extern void fmt_bg(void); +-extern int pars_f(char*); +-extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); +-extern int signbit_f2c(double*); +-extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); +-extern int wrt_E(ufloat*, int, int, int, ftnlen); +-extern int wrt_F(ufloat*, int, int, ftnlen); +-extern int wrt_L(Uint*, int, ftnlen); +-#ifdef __cplusplus +- } +-#endif +-#endif +-extern flag f__cblank,f__cplus,f__workdone, f__nonl; +-extern char *f__fmtbuf; +-extern int f__scale; +-#define GET(x) if((x=(*f__getn)())<0) return(x) +-#define VAL(x) (x!='\n'?x:' ') +-#define PUT(x) (*f__putn)(x) +- +-#undef TYQUAD +-#ifndef Allow_TYQUAD +-#undef longint +-#define longint long +-#else +-#define TYQUAD 14 +-#endif +- +-#ifdef KR_headers +-extern char *f__icvt(); +-#else +-Cextern char *f__icvt(longint, int*, int*, int); +-#endif +//GO.SYSIN DD libI77/fmt.h +echo libI77/fmtlib.c 1>&2 +sed >libI77/fmtlib.c <<'//GO.SYSIN DD libI77/fmtlib.c' 's/^-//' +-/* @(#)fmtlib.c 1.2 */ +-#define MAXINTLENGTH 23 +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifndef Allow_TYQUAD +-#undef longint +-#define longint long +-#undef ulongint +-#define ulongint unsigned long +-#endif +- +-#ifdef KR_headers +-char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; +- register int base; +-#else +-char *f__icvt(longint value, int *ndigit, int *sign, int base) +-#endif +-{ +- static char buf[MAXINTLENGTH+1]; +- register int i; +- ulongint uvalue; +- +- if(value > 0) { +- uvalue = value; +- *sign = 0; +- } +- else if (value < 0) { +- uvalue = -value; +- *sign = 1; +- } +- else { +- *sign = 0; +- *ndigit = 1; +- buf[MAXINTLENGTH-1] = '0'; +- return &buf[MAXINTLENGTH-1]; +- } +- i = MAXINTLENGTH; +- do { +- buf[--i] = (uvalue%base) + '0'; +- uvalue /= base; +- } +- while(uvalue > 0); +- *ndigit = MAXINTLENGTH - i; +- return &buf[i]; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/fmtlib.c +echo libI77/fp.h 1>&2 +sed >libI77/fp.h <<'//GO.SYSIN DD libI77/fp.h' 's/^-//' +-#define FMAX 40 +-#define EXPMAXDIGS 8 +-#define EXPMAX 99999999 +-/* FMAX = max number of nonzero digits passed to atof() */ +-/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ +- +-#ifdef V10 /* Research Tenth-Edition Unix */ +-#include "local.h" +-#endif +- +-/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily +- tight) on the maximum number of digits to the right and left of +- * the decimal point. +- */ +- +-#ifdef VAX +-#define MAXFRACDIGS 56 +-#define MAXINTDIGS 38 +-#else +-#ifdef CRAY +-#define MAXFRACDIGS 9880 +-#define MAXINTDIGS 9864 +-#else +-/* values that suffice for IEEE double */ +-#define MAXFRACDIGS 344 +-#define MAXINTDIGS 308 +-#endif +-#endif +//GO.SYSIN DD libI77/fp.h +echo libI77/ftell_.c 1>&2 +sed >libI77/ftell_.c <<'//GO.SYSIN DD libI77/ftell_.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- static FILE * +-#ifdef KR_headers +-unit_chk(Unit, who) integer Unit; char *who; +-#else +-unit_chk(integer Unit, char *who) +-#endif +-{ +- if (Unit >= MXUNIT || Unit < 0) +- f__fatal(101, who); +- return f__units[Unit].ufd; +- } +- +- integer +-#ifdef KR_headers +-ftell_(Unit) integer *Unit; +-#else +-ftell_(integer *Unit) +-#endif +-{ +- FILE *f; +- return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; +- } +- +- int +-#ifdef KR_headers +-fseek_(Unit, offset, whence) integer *Unit, *offset, *whence; +-#else +-fseek_(integer *Unit, integer *offset, integer *whence) +-#endif +-{ +- FILE *f; +- int w = (int)*whence; +-#ifdef SEEK_SET +- static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +-#endif +- if (w < 0 || w > 2) +- w = 0; +-#ifdef SEEK_SET +- w = wohin[w]; +-#endif +- return !(f = unit_chk(*Unit, "fseek")) +- || fseek(f, *offset, w) ? 1 : 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/ftell_.c +echo libI77/iio.c 1>&2 +sed >libI77/iio.c <<'//GO.SYSIN DD libI77/iio.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *f__icptr; +-char *f__icend; +-extern icilist *f__svic; +-int f__icnum; +- +- int +-z_getc(Void) +-{ +- if(f__recpos++ < f__svic->icirlen) { +- if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); +- return(*(unsigned char *)f__icptr++); +- } +- return '\n'; +-} +- +- void +-#ifdef KR_headers +-z_putc(c) +-#else +-z_putc(int c) +-#endif +-{ +- if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen) +- *f__icptr++ = c; +-} +- +- int +-z_rnew(Void) +-{ +- f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; +- f__recpos = 0; +- f__cursor = 0; +- f__hiwater = 0; +- return 1; +-} +- +- static int +-z_endp(Void) +-{ +- (*f__donewrec)(); +- return 0; +- } +- +- int +-#ifdef KR_headers +-c_si(a) icilist *a; +-#else +-c_si(icilist *a) +-#endif +-{ +- f__elist = (cilist *)a; +- f__fmtbuf=a->icifmt; +- f__curunit = 0; +- f__sequential=f__formatted=1; +- f__external=0; +- if(pars_f(f__fmtbuf)<0) +- err(a->icierr,100,"startint"); +- fmt_bg(); +- f__cblank=f__cplus=f__scale=0; +- f__svic=a; +- f__icnum=f__recpos=0; +- f__cursor = 0; +- f__hiwater = 0; +- f__icptr = a->iciunit; +- f__icend = f__icptr + a->icirlen*a->icirnum; +- f__cf = 0; +- return(0); +-} +- +- int +-iw_rev(Void) +-{ +- if(f__workdone) +- z_endp(); +- f__hiwater = f__recpos = f__cursor = 0; +- return(f__workdone=0); +- } +- +-#ifdef KR_headers +-integer s_rsfi(a) icilist *a; +-#else +-integer s_rsfi(icilist *a) +-#endif +-{ int n; +- if(n=c_si(a)) return(n); +- f__reading=1; +- f__doed=rd_ed; +- f__doned=rd_ned; +- f__getn=z_getc; +- f__dorevert = z_endp; +- f__donewrec = z_rnew; +- f__doend = z_endp; +- return(0); +-} +- +- int +-z_wnew(Void) +-{ +- if (f__recpos < f__hiwater) { +- f__icptr += f__hiwater - f__recpos; +- f__recpos = f__hiwater; +- } +- while(f__recpos++ < f__svic->icirlen) +- *f__icptr++ = ' '; +- f__recpos = 0; +- f__cursor = 0; +- f__hiwater = 0; +- f__icnum++; +- return 1; +-} +-#ifdef KR_headers +-integer s_wsfi(a) icilist *a; +-#else +-integer s_wsfi(icilist *a) +-#endif +-{ int n; +- if(n=c_si(a)) return(n); +- f__reading=0; +- f__doed=w_ed; +- f__doned=w_ned; +- f__putn=z_putc; +- f__dorevert = iw_rev; +- f__donewrec = z_wnew; +- f__doend = z_endp; +- return(0); +-} +-integer e_rsfi(Void) +-{ int n = en_fio(); +- f__fmtbuf = NULL; +- return(n); +-} +-integer e_wsfi(Void) +-{ +- int n; +- n = en_fio(); +- f__fmtbuf = NULL; +- if(f__svic->icirnum != 1 +- && (f__icnum > f__svic->icirnum +- || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) +- err(f__svic->icierr,110,"inwrite"); +- if (f__recpos < f__hiwater) +- f__recpos = f__hiwater; +- if (f__recpos >= f__svic->icirlen) +- err(f__svic->icierr,110,"recend"); +- if (!f__recpos && f__icnum) +- return n; +- while(f__recpos++ < f__svic->icirlen) +- *f__icptr++ = ' '; +- return n; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/iio.c +echo libI77/ilnw.c 1>&2 +sed >libI77/ilnw.c <<'//GO.SYSIN DD libI77/ilnw.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *f__icptr; +-extern char *f__icend; +-extern icilist *f__svic; +-extern int f__icnum; +-#ifdef KR_headers +-extern void z_putc(); +-#else +-extern void z_putc(int); +-#endif +- +- static int +-z_wSL(Void) +-{ +- while(f__recpos < f__svic->icirlen) +- z_putc(' '); +- return z_rnew(); +- } +- +- static void +-#ifdef KR_headers +-c_liw(a) icilist *a; +-#else +-c_liw(icilist *a) +-#endif +-{ +- f__reading = 0; +- f__external = 0; +- f__formatted = 1; +- f__putn = z_putc; +- L_len = a->icirlen; +- f__donewrec = z_wSL; +- f__svic = a; +- f__icnum = f__recpos = 0; +- f__cursor = 0; +- f__cf = 0; +- f__curunit = 0; +- f__icptr = a->iciunit; +- f__icend = f__icptr + a->icirlen*a->icirnum; +- f__elist = (cilist *)a; +- } +- +- integer +-#ifdef KR_headers +-s_wsni(a) icilist *a; +-#else +-s_wsni(icilist *a) +-#endif +-{ +- cilist ca; +- +- c_liw(a); +- ca.cifmt = a->icifmt; +- x_wsne(&ca); +- z_wSL(); +- return 0; +- } +- +- integer +-#ifdef KR_headers +-s_wsli(a) icilist *a; +-#else +-s_wsli(icilist *a) +-#endif +-{ +- f__lioproc = l_write; +- c_liw(a); +- return(0); +- } +- +-integer e_wsli(Void) +-{ +- z_wSL(); +- return(0); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/ilnw.c +echo libI77/inquire.c 1>&2 +sed >libI77/inquire.c <<'//GO.SYSIN DD libI77/inquire.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "string.h" +-#ifdef NON_UNIX_STDIO +-#ifndef MSDOS +-#include "unistd.h" /* for access() */ +-#endif +-#endif +-#ifdef KR_headers +-integer f_inqu(a) inlist *a; +-#else +-#ifdef __cplusplus +-extern "C" integer f_inqu(inlist*); +-#endif +-#ifdef MSDOS +-#undef abs +-#undef min +-#undef max +-#include "io.h" +-#endif +-integer f_inqu(inlist *a) +-#endif +-{ flag byfile; +- int i; +-#ifndef NON_UNIX_STDIO +- int n; +-#endif +- unit *p; +- char buf[256]; +- long x; +- if(a->infile!=NULL) +- { byfile=1; +- g_char(a->infile,a->infilen,buf); +-#ifdef NON_UNIX_STDIO +- x = access(buf,0) ? -1 : 0; +- for(i=0,p=NULL;iinunitinunit>=0) +- { +- p= &f__units[a->inunit]; +- } +- else +- { +- p=NULL; +- } +- } +- if(a->inex!=NULL) +- if(byfile && x != -1 || !byfile && p!=NULL) +- *a->inex=1; +- else *a->inex=0; +- if(a->inopen!=NULL) +- if(byfile) *a->inopen=(p!=NULL); +- else *a->inopen=(p!=NULL && p->ufd!=NULL); +- if(a->innum!=NULL) *a->innum= p-f__units; +- if(a->innamed!=NULL) +- if(byfile || p!=NULL && p->ufnm!=NULL) +- *a->innamed=1; +- else *a->innamed=0; +- if(a->inname!=NULL) +- if(byfile) +- b_char(buf,a->inname,a->innamlen); +- else if(p!=NULL && p->ufnm!=NULL) +- b_char(p->ufnm,a->inname,a->innamlen); +- if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) +- if(p->url) +- b_char("DIRECT",a->inacc,a->inacclen); +- else b_char("SEQUENTIAL",a->inacc,a->inacclen); +- if(a->inseq!=NULL) +- if(p!=NULL && p->url) +- b_char("NO",a->inseq,a->inseqlen); +- else b_char("YES",a->inseq,a->inseqlen); +- if(a->indir!=NULL) +- if(p==NULL || p->url) +- b_char("YES",a->indir,a->indirlen); +- else b_char("NO",a->indir,a->indirlen); +- if(a->infmt!=NULL) +- if(p!=NULL && p->ufmt==0) +- b_char("UNFORMATTED",a->infmt,a->infmtlen); +- else b_char("FORMATTED",a->infmt,a->infmtlen); +- if(a->inform!=NULL) +- if(p!=NULL && p->ufmt==0) +- b_char("NO",a->inform,a->informlen); +- else b_char("YES",a->inform,a->informlen); +- if(a->inunf) +- if(p!=NULL && p->ufmt==0) +- b_char("YES",a->inunf,a->inunflen); +- else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); +- else b_char("UNKNOWN",a->inunf,a->inunflen); +- if(a->inrecl!=NULL && p!=NULL) +- *a->inrecl=p->url; +- if(a->innrec!=NULL && p!=NULL && p->url>0) +- *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1); +- if(a->inblank && p!=NULL && p->ufmt) +- if(p->ublnk) +- b_char("ZERO",a->inblank,a->inblanklen); +- else b_char("NULL",a->inblank,a->inblanklen); +- return(0); +-} +//GO.SYSIN DD libI77/inquire.c +echo libI77/i77vers.c 1>&2 +sed >libI77/i77vers.c <<'//GO.SYSIN DD libI77/i77vers.c' 's/^-//' +- char +-_libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n"; +- +-/* +-2.01 $ format added +-2.02 Coding bug in open.c repaired +-2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c +- and lio.h (e-format conforming to spec) +-2.04 changed open.c and err.c (fopen and freopen respectively) to +- update to new c-library (append mode) +-2.05 added namelist capability +-2.06 allow internal list and namelist I/O +-*/ +- +-/* +-close.c: +- allow upper-case STATUS= values +-endfile.c +- create fort.nnn if unit nnn not open; +- else if (file length == 0) use creat() rather than copy; +- use local copy() rather than forking /bin/cp; +- rewind, fseek to clear buffer (for no reading past EOF) +-err.c +- use neither setbuf nor setvbuf; make stderr buffered +-fio.h +- #define _bufend +-inquire.c +- upper case responses; +- omit byfile test from SEQUENTIAL= +- answer "YES" to DIRECT= for unopened file (open to debate) +-lio.c +- flush stderr, stdout at end of each stmt +- space before character strings in list output only at line start +-lio.h +- adjust LEW, LED consistent with old libI77 +-lread.c +- use atof() +- allow "nnn*," when reading complex constants +-open.c +- try opening for writing when open for read fails, with +- special uwrt value (2) delaying creat() to first write; +- set curunit so error messages don't drop core; +- no file name ==> fort.nnn except for STATUS='SCRATCH' +-rdfmt.c +- use atof(); trust EOF == end-of-file (so don't read past +- end-of-file after endfile stmt) +-sfe.c +- flush stderr, stdout at end of each stmt +-wrtfmt.c: +- use upper case +- put wrt_E and wrt_F into wref.c, use sprintf() +- rather than ecvt() and fcvt() [more accurate on VAX] +-*/ +- +-/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ +- +-/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ +- +-/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ +-/* 29 Nov. 1989: change various int return types to long for f2c */ +-/* 30 Nov. 1989: various types from f2c.h */ +-/* 6 Dec. 1989: types corrected various places */ +-/* 19 Dec. 1989: make iostat= work right for internal I/O */ +-/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ +-/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white +- space as blank */ +-/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads +- of logical values reject letters other than fFtT; +- have nowwriting reset cf */ +-/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ +-/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as +- blank='z...' when reopening an open file */ +-/* 30 Aug. 1990: prevent embedded blanks in list output of complex values; +- omit exponent field in list output of values of +- magnitude between 10 and 1e8; prevent writing stdin +- and reading stdout or stderr; don't close stdin, stdout, +- or stderr when reopening units 5, 6, 0. */ +-/* 18 Sep. 1990: add component udev to unit and consider old == new file +- iff uinode and udev values agree; use stat rather than +- access to check existence of file (when STATUS='OLD')*/ +-/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write +- don't clobber the file. */ +-/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; +- adjust g_char in util.c for segmented memories. */ +-/* 17 Oct. 1990: replace abort() and _cleanup() with calls on +- sig_die(...,1) (defined in main.c). */ +-/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the +- file already exists; allow file= to be omitted in open stmts +- and allow status='replace' (Fortran 90 extensions). */ +-/* 11 Dec. 1990: adjustments for POSIX. */ +-/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from +- strings in read-only memory. */ +-/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ +-/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ +-/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ +-/* 17 Oct. 1991: change type of length field in sequential unformatted +- records from int to long (for systems where sizeof(int) +- can vary, depending on the compiler or compiler options). */ +-/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ +-/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to +- sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ +-/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); +- adjust an error return from EOF to off end of record */ +-/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused +- the last character of each record to be ignored. +- iio.c: adjust error message in internal formatted +- input from "end-of-file" to "off end of record" if +- the format specifies more characters than the +- record contains. */ +-/* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input, +- treat "r* ," and "r*," alike (where r is a +- positive integer constant), and fix a bug in +- handling null values following items with repeat +- counts (e.g., 2*1,,3); for namelist reading +- of a numeric array, allow a new name-value subsequence +- to terminate the current one (as though the current +- one ended with the right number of null values). +- lio.h, lwrite.c: omit insignificant zeros in +- list and namelist output. To get the old +- behavior, compile with -DOld_list_output . */ +-/* 18 Jan. 1992: make list output consistent with F format by +- printing .1 rather than 0.1 (introduced yesterday). */ +-/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the +- character following a comma to be ignored. */ +-/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= +- work with internal list and formatted I/O. */ +-/* 18 July 1992: adjust rsne.c to allow namelist input to stop at +- an & (e.g. &end). */ +-/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; +- recognize Z format (assuming 8-bit bytes). */ +-/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ +-/* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c +- (so end-of-file on other files won't confuse namelist +- reads of external files). Prepend f__ to external +- names that are only of internal interest to lib[FI]77. */ +-/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd +- buffer == '\n'. +- endfile.c: guard against tiny L_tmpnam; close and reopen +- files in t_runc(). +- lio.h: lengthen LINTW (buffer size in lwrite.c). +- err.c, open.c: more prepending of f__ (to [rw]_mode). */ +-/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being +- sought; namelists of the wrong name are skipped (after +- an error message; xwsne.c: namelist writes have a +- newline before each new variable. +- open.c: ACCESS='APPEND' positions sequential files +- at EOF (nonstandard extension -- that doesn't require +- changing data structures). */ +-/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. +- err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) +- when the unit has another file descriptor for name. */ +-/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; +- open.c: always give f__w_mode[] 4 elements for use +- in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ +-/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential +- unformatted reads to respond to err= rather than end=. */ +-/* 12 March 1993: various tweaks for C++ */ +-/* 6 April 1993: adjust error returns for formatted inputs to flush +- the current input line when err=label is specified. +- To restore the old behavior (input left mid-line), +- either adjust the #definition of errfl in fio.h or +- omit the invocation of f__doend in err__fl (in err.c). */ +-/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ +-/* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for +- logical data (during list or namelist input). +- Change struct f__syl to struct syl (for buggy compilers). */ +-/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete +- logical arrays. */ +-/* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete +- array of numeric data followed by another namelist +- item whose name starts with 'd', 'D', 'e', or 'E'. */ +-/* 8 Sept. 1993: open.c: protect #include "sys/..." with +- #ifndef NON_UNIX_STDIO; Version date not changed. */ +-/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ +-/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat +- short records as though padded with blanks +- (rather than causing an "off end of record" error). */ +-/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ +-/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct +- formatted files (avoiding any confusion regarding \n). */ +-/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files +- under NON_UNIX_STDIO. */ +-/* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an +- optimization that requires exponents to have 2 digits +- when 2 digits suffice. +- lwrite.c wsfe.c (list and formatted external output): +- omit ' ' carriage-control when compiled with +- -DOMIT_BLANK_CC . Off-by-one bug fixed in character +- count for list output of character strings. +- Omit '.' in list-directed printing of Nan, Infinity. */ +-/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather +- than " .0000E+00". */ +-/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an +- oversize item to an empty line. */ +-/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept +- ERR= (in list- or format-directed input) from working +- after a NAMELIST READ. */ +-/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, +- INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 +- in NAMELISTs. */ +-/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ +-/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ +-/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when +- GOOD_SPRINTF_EXPONENT is not #defined. */ +-/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow +- internal reading of characters with high-bit set +- (on machines that sign-extend characters). */ +-/* 14 March 1995:lread.c and rsfe.c: adjust s_rsle and s_rsfe to +- check for end-of-file (to prevent infinite loops +- with empty read statements). */ +-/* 26 May 1995: iio.c: z_wnew: fix bug in handling T format items +- in internal writes whose last item is written to +- an earlier position than some previous item. */ +-/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ +-/* 6 Sept. 1995: Adjust namelist input to treat a subscripted name +- whose subscripts do not involve colons similarly +- to the name without a subscript: accept several +- values, stored in successive elements starting at +- the indicated subscript. Adjust namelist output +- to quote character strings (avoiding confusion with +- arrays of character strings). Adjust f_init calls +- for people who don't use libF77's main(); now open and +- namelist read statements invoke f_init if needed. */ +-/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). +- Add -DNo_Namelist_Comments lines to rsne.c. */ +-/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not +- always zeroed in mv_cur). */ +-/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c +- to err.c */ +-/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ +- +-/* 13 May 1996: add ftell_.c and fseek_.c */ +-/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with +- too few items in the input string will honor end= . */ +-/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ +-/* 25 Sept. 1995:fmt.h: for formatted writes of negative integer*1 values, +- make ic signed on ANSI systems. If formatted writes of +- integer*1 values trouble you when using a K&R C compiler, +- switch to an ANSI compiler or use a compiler flag that +- makes characters signed. */ +-/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= +- in direct read and write statements. +- ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ +-/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use +- SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ +-/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats +- (but still treat missing ".nnn" as ".0"). */ +-/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather +- than fully buffered. (Buffering is needed for format +- items T and TR.) */ +-/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be +- treated as 2 on some systems). */ +-/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X +- draft (in 1990 or 1991) that rescinded permission to elide +- quote marks in namelist input of character data; compile +- with -DF8X_NML_ELIDE_QUOTES to get the old behavior. +- wrtfmt.o: wrt_G: tweak to print the right number of 0's +- for zero under G format. */ +-/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character +- strings that sometimes caused one more array element than +- required by the format to be blank-filled. Example: +- format(1x). */ +-/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines +- with 64-bit pointers and 32-bit ints that did not 64-bit +- align struct syl (e.g., Linux on the DEC Alpha). */ +-/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to +- sizeof(uiolen). On machines where this would make a +- difference, it is best for portability to compile libI77 with +- -DUIOLEN_int (which will render the change invisible). */ +-/* 4 March 1998: open.c: fix glitch in comparing file names under +- -DNON_UNIX_STDIO */ +-/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(), +- unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). +- New buffering scheme independent of NON_UNIX_STDIO for +- handling T format items. Now -DNON_UNIX_STDIO is no +- longer be necessary for Linux, and libf2c no longer +- causes stderr to be buffered -- the former setbuf or +- setvbuf call for stderr was to make T format items work. +- open.c: use the Posix access() function to check existence +- or nonexistence of files, except under -DNON_POSIX_STDIO, +- where trial fopen calls are used. */ +-/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the +- changes of 17 March 1998. */ +-/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: +- set f__curunit sooner so various error messages will +- correctly identify the I/O unit involved. */ +-/* 17 June 1998: lread.c: unless compiled with +- ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat +- floating-point numbers (containing either a decimal point +- or an exponent field) as errors when they appear as list +- input for integer data. */ +-/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally. +- Why did it ever move to sfe.c? */ +-/* 2 May 1999: open.c: set f__external (to get "external" versus "internal" +- right in the error message if we cannot open the file). +- err.c: cast a pointer difference to (int) for %d. +- rdfmt.c: omit fixed-length buffer that could be overwritten +- by formats Inn or Lnn with nn > 83. */ +-/* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */ +-/* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */ +-/* 27 June 1999: rsne.c: fix bug in namelist input: a misplaced increment */ +-/* could cause wrong array elements to be assigned; e.g., */ +-/* "&input k(5)=10*1 &end" assigned k(5) and k(15..23) */ +-/* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */ +-/* endfile statement requires copying the file. */ +-/* (Otherwise an immediately following rewind statement */ +-/* could make the file appear empty.) Also, supply a */ +-/* missing (long) cast in the sprintf call. */ +-/* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */ +-/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */ +-/* any data in buffers should the program fault. It also */ +-/* makes the program run more slowly. */ +-/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */ +-/* ftnlen are of different fundamental types (different numbers */ +-/* of bits). Since these files will not compile when this */ +-/* change matters, the above VERSION string remains unchanged. */ +-/* 4 July 2000: adjustments to permit compilation by C++ compilers; */ +-/* VERSION string remains unchanged. */ +-/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */ +-/* treat Tstuff= and Fstuff= as new assignments rather than as */ +-/* logical constants. */ +-/* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */ +-/* -DNO_TRUNCATE (or with -DMSDOS). */ +-/* 1 March 2001: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), */ +-/* thus permitting truncation of scratch files on true Unix */ +-/* systems, where scratch files have no name. Add an fflush() */ +-/* (surprisingly) needed on some Linux systems. */ +-/* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */ +-/* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */ +-/* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */ +-/* respectively, in fio.h unless otherwise #defined), and use */ +-/* type OFF_T (#defined to be long unless otherwise #defined) */ +-/* to permit handling files over 2GB long where possible, */ +-/* with suitable -D options, provided for some systems in new */ +-/* header file sysdep1.h (copied from sysdep1.h0 by default). */ +-/* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */ +-/* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */ +-/* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */ +-/* comments in makefile or (better) libf2c/makefile.* . */ +-/* 6 Sept. 2002: rsne.c: fix bug with multiple repeat counts in reading */ +-/* namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / */ +-/* 21 March 2003: err.c: before writing to a file after reading from it, */ +-/* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */ +//GO.SYSIN DD libI77/i77vers.c +echo libI77/sysdep1.h0 1>&2 +sed >libI77/sysdep1.h0 <<'//GO.SYSIN DD libI77/sysdep1.h0' 's/^-//' +-#ifndef SYSDEP_H_INCLUDED +-#define SYSDEP_H_INCLUDED +-#undef USE_LARGEFILE +-#ifndef NO_LONG_LONG +- +-#ifdef __sun__ +-#define USE_LARGEFILE +-#define OFF_T off64_t +-#endif +- +-#ifdef __linux__ +-#define USE_LARGEFILE +-#define OFF_T __off64_t +-#endif +- +-#ifdef _AIX43 +-#define _LARGE_FILES +-#define _LARGE_FILE_API +-#define USE_LARGEFILE +-#endif /*_AIX43*/ +- +-#ifdef __hpux +-#define _FILE64 +-#define _LARGEFILE64_SOURCE +-#define USE_LARGEFILE +-#endif /*__hpux*/ +- +-#ifdef __sgi +-#define USE_LARGEFILE +-#endif /*__sgi*/ +- +-#ifdef __FreeBSD__ +-#define OFF_T off_t +-#define FSEEK fseeko +-#define FTELL ftello +-#endif +- +-#ifdef USE_LARGEFILE +-#ifndef OFF_T +-#define OFF_T off64_t +-#endif +-#define _LARGEFILE_SOURCE +-#define _LARGEFILE64_SOURCE +-#include +-#include +-#define FOPEN fopen64 +-#define FREOPEN freopen64 +-#define FSEEK fseeko64 +-#define FSTAT fstat64 +-#define FTELL ftello64 +-#define FTRUNCATE ftruncate64 +-#define STAT stat64 +-#define STAT_ST stat64 +-#endif /*USE_LARGEFILE*/ +-#endif /*NO_LONG_LONG*/ +- +-#ifndef NON_UNIX_STDIO +-#ifndef USE_LARGEFILE +-#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +-#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +-#include "sys/types.h" +-#include "sys/stat.h" +-#endif +-#endif +- +-#endif /*SYSDEP_H_INCLUDED*/ +//GO.SYSIN DD libI77/sysdep1.h0 +echo libI77/ftell64_.c 1>&2 +sed >libI77/ftell64_.c <<'//GO.SYSIN DD libI77/ftell64_.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- static FILE * +-#ifdef KR_headers +-unit_chk(Unit, who) integer Unit; char *who; +-#else +-unit_chk(integer Unit, char *who) +-#endif +-{ +- if (Unit >= MXUNIT || Unit < 0) +- f__fatal(101, who); +- return f__units[Unit].ufd; +- } +- +- longint +-#ifdef KR_headers +-ftell64_(Unit) integer *Unit; +-#else +-ftell64_(integer *Unit) +-#endif +-{ +- FILE *f; +- return (f = unit_chk(*Unit, "ftell")) ? FTELL(f) : -1L; +- } +- +- int +-#ifdef KR_headers +-fseek64_(Unit, offset, whence) integer *Unit, *whence; longint *offset; +-#else +-fseek64_(integer *Unit, longint *offset, integer *whence) +-#endif +-{ +- FILE *f; +- int w = (int)*whence; +-#ifdef SEEK_SET +- static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +-#endif +- if (w < 0 || w > 2) +- w = 0; +-#ifdef SEEK_SET +- w = wohin[w]; +-#endif +- return !(f = unit_chk(*Unit, "fseek")) +- || FSEEK(f, (OFF_T)*offset, w) ? 1 : 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/ftell64_.c +echo libI77/signbit.c 1>&2 +sed >libI77/signbit.c <<'//GO.SYSIN DD libI77/signbit.c' 's/^-//' +-#include "arith.h" +- +-#ifndef Long +-#define Long long +-#endif +- +- int +-#ifdef KR_headers +-signbit_f2c(x) double *x; +-#else +-signbit_f2c(double *x) +-#endif +-{ +-#ifdef IEEE_MC68k +- if (*(Long*)x & 0x80000000) +- return 1; +-#else +-#ifdef IEEE_8087 +- if (((Long*)x)[1] & 0x80000000) +- return 1; +-#endif /*IEEE_8087*/ +-#endif /*IEEE_MC68k*/ +- return 0; +- } +//GO.SYSIN DD libI77/signbit.c +echo libI77/libI77.xsum 1>&2 +sed >libI77/libI77.xsum <<'//GO.SYSIN DD libI77/libI77.xsum' 's/^-//' +-Notice 76f23b4 1212 +-README f35cf24 10373 +-backspace.c 10ebf554 1328 +-close.c 173f01de 1393 +-dfe.c 1d658105 2624 +-dolio.c 19c9fbd9 471 +-due.c ee219f6d 1624 +-endfile.c 6f7201d 2838 +-err.c fea5c2a7 6189 +-f2ch.add ef66bf17 6060 +-fio.h f9389f5f 2932 +-fmt.c cdfb2a1 8361 +-fmt.h f5dd2afb 1970 +-fmtlib.c eefc6a27 865 +-fp.h 100fb355 665 +-ftell64_.c e2c4b21e 917 +-ftell_.c e845eedb 894 +-i77vers.c f57b8ef2 18128 +-iio.c f958b627 2639 +-ilnw.c fe0ab14b 1125 +-inquire.c 1883d542 2732 +-lio.h a087b39 1564 +-lread.c eb3c2be3 14705 +-lwrite.c f80da63f 4616 +-makefile e31c232c 2856 +-open.c a2fe776 5625 +-rawio.h 1ab49f7c 718 +-rdfmt.c ffbd74b2 8858 +-rewind.c e4c6236f 475 +-rsfe.c eb9e882c 1492 +-rsli.c 11f59b61 1785 +-rsne.c 1b1e1814 11551 +-sfe.c d24f06 767 +-signbit.c e37eac06 330 +-sue.c 9705ecf 1865 +-sysdep1.h0 1812022d 1202 +-typesize.c eee307ae 386 +-uio.c e354a770 1619 +-util.c e526349d 902 +-wref.c 17bbfb7b 4747 +-wrtfmt.c 113fc4f9 7506 +-wsfe.c f2d1fe4d 1280 +-wsle.c fe50b4c9 697 +-wsne.c 428bfda 479 +-xwsne.c 185c4bdc 1174 +//GO.SYSIN DD libI77/libI77.xsum diff --git a/unix/f2c/mkpkg.sh b/unix/f2c/mkpkg.sh new file mode 100644 index 00000000..ccb92bb8 --- /dev/null +++ b/unix/f2c/mkpkg.sh @@ -0,0 +1,6 @@ +# Bootstrap the F2C compiler and libraries. + +echo "----------------------- F2C ---------------------------" +(cd src; sh -x mkpkg.sh) +echo "----------------------- LIBF2C ------------------------" +(cd libf2c; sh -x mkpkg.sh) diff --git a/unix/f2c/msdos/README b/unix/f2c/msdos/README new file mode 100644 index 00000000..2e0f921b --- /dev/null +++ b/unix/f2c/msdos/README @@ -0,0 +1,48 @@ +f2c.exe.gz is a compressed MSDOS version of f2c that should run on just +about any MSDOS machine. It was compiled by Microsoft Visual C++ 1.51 +with ccm.bat in March 1999; we do not intend to recompile it again. +It is superceded by the Win32 f2c.exe in directory ../mswin. + +f2cx.exe.gz is a compressed MSDOS version of f2c that requires an 80386 +or 80486, as it uses extended memory. It was compiled by the Symantec +C/C++ compiler (version 6.11, with ccs.bat), and it generally can +translate larger Fortran files without running out of memory than can +f2c.exe. + +etime.exe.gz is a compressed MSDOS timing program that is of interest +because it can redirect stderr (file descriptor 2). For example, +invoking + + etime -2foo.err f2c foo.f +or + etime -2+foo.err f2c foo.f + +will cause the output that f2c writes on file descriptor 2 (such as +the names of the subprograms translated and any warning or error +messages) while it processes the Fortran in file foo.f to be written +to file foo.err rather than to the screen. The first invocation +overwrites foo.err, while the second one appends to it. (You can +replace "foo.f" with any f2c command-line options and input file name +of your choice, and can similarly change "foo.err" to any file name +you like. Sensible shells allow redirection of stderr, but etime.exe +is useful with MSDOS's command.com.) Etime also can run f2cx.exe, or +any other MSDOS program whose arguments fit on its command line. +Execute "etime" or "etime -?" for usage summary. + +Compression is by gzip, source for which is available by ftp +in prep.ai.mit.edu:/pub/gnu. As a convenience, gzip binaries for +several systems (with names of the form system.executable) and +source for the gzip used to compress the *.gz files are available +for ftp from netlib directory gnu/gzip. In particular, if you +copy gnu/gzip/dos.executable to an MSDOS machine (in binary mode), +rename it gzip.exe, and rename f2c.exe.gz f2c.exz and f2cx.exe f2cx.exz, +then on the MSDOS machine you can recover f2c.exe and f2cx.exe by +executing "gzip -dN f2c.exz f2cx.exz". + +"xsum f2c.exe f2c.exe.gz f2cx.exe f2cx.exe.gz" should give you: +f2c.exe 1c458998 285402 +f2c.exe.gz e93d0ab 141545 +f2cx.exe f721d8b8 262097 +f2cx.exe.gz 13ba4d83 140359 + +Last (and final) update of f2cx.exe: 17 December 2002 diff --git a/unix/f2c/msdos/ccb.bat b/unix/f2c/msdos/ccb.bat new file mode 100644 index 00000000..1caf5723 --- /dev/null +++ b/unix/f2c/msdos/ccb.bat @@ -0,0 +1,64 @@ +rem script for compiling f2c with Borland C++ 4.02 +del *.obj +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe cds.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe data.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe equiv.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe error.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe exec.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe expr.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe format.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe formatda.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe gram.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe init.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe intr.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe io.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe lex.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe main.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe mem.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe misc.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe names.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe niceprin.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe output.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe p1output.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe parse_ar.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe pread.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe proc.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe put.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe putpcc.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe sysdep.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe vax.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe version.c >zot +if errorlevel 1 goto +echo extern unsigned _stklen = 0x4000; >stklen.c +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe stklen.c >zot +if errorlevel 1 goto +bcc -ml -N -ef2c *.obj +if errorlevel 1 goto +del *.obj diff --git a/unix/f2c/msdos/ccm.bat b/unix/f2c/msdos/ccm.bat new file mode 100644 index 00000000..b116a34b --- /dev/null +++ b/unix/f2c/msdos/ccm.bat @@ -0,0 +1,90 @@ +rem script for compiling conventional-memory f2c with Microsoft C compilers +del *.obj +cl -c -AL -Gt28 -Ox -Ge -nologo CDS.C +if errorlevel 1 goto +del CDS.C +cl -c -AL -Gt28 -Ox -Ge -nologo DATA.C +if errorlevel 1 goto +del DATA.C +cl -c -AL -Gt28 -Ox -Ge -nologo EQUIV.C +if errorlevel 1 goto +del EQUIV.C +cl -c -AL -Gt28 -Ox -Ge -nologo ERROR.C +if errorlevel 1 goto +del ERROR.C +cl -c -AL -Gt28 -Ox -Ge -nologo EXEC.C +if errorlevel 1 goto +del EXEC.C +cl -c -AL -Gt28 -Ox -Ge -nologo EXPR.C +if errorlevel 1 goto +del EXPR.C +cl -c -AL -Gt28 -Ox -Ge -nologo FORMAT.C +if errorlevel 1 goto +del FORMAT.C +cl -c -AL -Gt28 -Ox -Ge -nologo FORMATDA.C +if errorlevel 1 goto +del FORMATDA.C +cl -c -AL -Gt28 -Ox -Ge -nologo GRAM.C +if errorlevel 1 goto +del GRAM.C +cl -c -AL -Gt28 -Ox -Ge -nologo INIT.C +if errorlevel 1 goto +del INIT.C +cl -c -AL -Gt28 -Ox -Ge -nologo INTR.C +if errorlevel 1 goto +del INTR.C +cl -c -AL -Gt28 -Ox -Ge -nologo IO.C +if errorlevel 1 goto +del IO.C +cl -c -AL -Gt28 -Ox -Ge -nologo LEX.C +if errorlevel 1 goto +del LEX.C +cl -c -AL -Gt28 -Ox -Ge -nologo MAIN.C +if errorlevel 1 goto +del MAIN.C +cl -c -AL -Gt28 -Ox -Ge -nologo MEM.C +if errorlevel 1 goto +del MEM.C +cl -c -AL -Gt28 -Ox -Ge -nologo MISC.C +if errorlevel 1 goto +del MISC.C +cl -c -AL -Gt28 -Ox -Ge -nologo NAMES.C +if errorlevel 1 goto +del NAMES.C +cl -c -AL -Gt28 -Ox -Ge -nologo NICEPRIN.C +if errorlevel 1 goto +del NICEPRIN.C +cl -c -AL -Gt28 -Ox -Ge -nologo OUTPUT.C +if errorlevel 1 goto +del OUTPUT.C +cl -c -AL -Gt28 -Ox -Ge -nologo P1OUTPUT.C +if errorlevel 1 goto +del P1OUTPUT.C +cl -c -AL -Gt28 -Ox -Ge -nologo PARSE_AR.C +if errorlevel 1 goto +del PARSE_AR.C +cl -c -AL -Gt28 -Ox -Ge -nologo PREAD.C +if errorlevel 1 goto +del PREAD.C +cl -c -AL -Gt28 -Ox -Ge -nologo PROC.C +if errorlevel 1 goto +del PROC.C +cl -c -AL -Gt28 -Ox -Ge -nologo PUT.C +if errorlevel 1 goto +del PUT.C +cl -c -AL -Gt28 -Ox -Ge -nologo PUTPCC.C +if errorlevel 1 goto +del PUTPCC.C +cl -c -AL -Gt28 -Ox -Ge -nologo SYSDEP.C +if errorlevel 1 goto +del SYSDEP.C +cl -c -AL -Gt28 -Ox -Ge -nologo VAX.C +if errorlevel 1 goto +del VAX.C +cl -c -AL -Gt28 -Ox -Ge -nologo VERSION.C +if errorlevel 1 goto +del VERSION.C +cl -AL *.obj -link /ST:0x6000 +if errorlevel 1 goto +ren cds.exe f2c.exe +if errorlevel 1 goto diff --git a/unix/f2c/msdos/ccs.bat b/unix/f2c/msdos/ccs.bat new file mode 100644 index 00000000..1d385903 --- /dev/null +++ b/unix/f2c/msdos/ccs.bat @@ -0,0 +1,71 @@ +rem script for compiling f2cx (extended-memory f2c) with Symantec C version 6 +del *.obj +sc -c -s -mx -o -w2 -w7 -DMSDOS cds.c >zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS data.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS equiv.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS error.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS exec.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS expr.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS format.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS formatda.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS gram.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS init.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS intr.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS io.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS lex.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS main.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS mem.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS misc.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS names.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS niceprin.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS -DUSE_DTOA output.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS p1output.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS parse_ar.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS pread.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS proc.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS put.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS putpcc.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS sysdep.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS vax.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS version.c >>zot +if errorlevel 1 goto +rem The following echo and ren create stklen.c if it does not exist +rem and avoid overwriting an existing stklen.c . +echo extern unsigned _stklen = 0x4000; >zap +ren zap stklen.c +sc -c -s -mx -o -w2 -w7 -DMSDOS stklen.c >>zot +if errorlevel 1 goto +rem README tells about dtoa.c and g_fmt.c . +sc -c -s -mx -o -w2 -w7 -DMSDOS -DMALLOC=ckalloc -DIEEE_8087 dtoa.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS -DIEEE_8087 g_fmt.c >>zot +if errorlevel 1 goto +sc -mx -s -o f2cx.exe *.obj +del *.obj diff --git a/unix/f2c/msdos/etime.exe.gz b/unix/f2c/msdos/etime.exe.gz new file mode 100644 index 00000000..5c4ff2d1 Binary files /dev/null and b/unix/f2c/msdos/etime.exe.gz differ diff --git a/unix/f2c/msdos/f2c.exe.gz b/unix/f2c/msdos/f2c.exe.gz new file mode 100644 index 00000000..91bcecb4 Binary files /dev/null and b/unix/f2c/msdos/f2c.exe.gz differ diff --git a/unix/f2c/msdos/f2cx.exe.gz b/unix/f2c/msdos/f2cx.exe.gz new file mode 100644 index 00000000..d614650b Binary files /dev/null and b/unix/f2c/msdos/f2cx.exe.gz differ diff --git a/unix/f2c/msdos/index.html b/unix/f2c/msdos/index.html new file mode 100644 index 00000000..2229f846 --- /dev/null +++ b/unix/f2c/msdos/index.html @@ -0,0 +1,32 @@ + +f2c/msdos + + +

f2c/msdos

+

+Click here to see the number of accesses to this library. +

+
+file	README
+
+file	f2c.exe.gz
+for	conventional-memory MSDOS version of f2c (compiled by Borland C++ 4.02)
+
+file	f2cx.exe.gz
+for	extended-memory MSDOS version of f2c (compiled by Symantec C/C++)
+
+file	ccb.bat
+for	compilation of f2c.exe (for people curious about how it was done)
+
+file	ccs.bat
+for	compilation of f2cx.exe (for people curious about how it was done)
+
+file	ccm.bat
+
+file	etime.exe.gz
+
+file	xsum.executable (uncompressed MSDOS version of xsum)
+
+
+ + diff --git a/unix/f2c/mswin/README b/unix/f2c/mswin/README new file mode 100644 index 00000000..26f05313 --- /dev/null +++ b/unix/f2c/mswin/README @@ -0,0 +1,19 @@ +f2c.exe.gz is a compressed Win32 console binary for f2c that runs +under Microsoft Windows 9x and NT. It was compiled by Microsoft +Visual C++ 6.0 by makefile.vc. + +Compression is by gzip, source for which is available by ftp +in prep.ai.mit.edu:/pub/gnu. As a convenience, gzip binaries for +several systems (with names of the form system.executable) and +source for the gzip used to compress the *.gz files are available +for ftp from netlib directory gnu/gzip. In particular, if you +copy gnu/gzip/dos.executable to an MSDOS machine (in binary mode), +rename it gzip.exe, and rename f2c.exe.gz f2c.exz and f2cx.exe f2cx.exz, +then on the MSDOS machine you can recover f2c.exe and f2cx.exe by +executing "gzip -dN f2c.exz f2cx.exz". + +"xsum f2c.exe f2c.exe.gz" should give you: +f2c.exe b39b23e 245760 +f2c.exe.gz efe20e82 133264 + +Last update: 6 May 2006 diff --git a/unix/f2c/mswin/f2c.exe.gz b/unix/f2c/mswin/f2c.exe.gz new file mode 100644 index 00000000..a2d679c9 Binary files /dev/null and b/unix/f2c/mswin/f2c.exe.gz differ diff --git a/unix/f2c/mswin/index.html b/unix/f2c/mswin/index.html new file mode 100644 index 00000000..0fc5eb99 --- /dev/null +++ b/unix/f2c/mswin/index.html @@ -0,0 +1,16 @@ + + +f2c/mswin + + +
+file	README
+
+file	f2c.exe.gz
+for	Win32 console version of f2c (compiled by MSVC++ 6.0)
+
+file	makefile.vc
+for	compiling f2c.exe by MSVC++
+
+ + diff --git a/unix/f2c/mswin/makefile.vc b/unix/f2c/mswin/makefile.vc new file mode 100644 index 00000000..e79a6ca8 --- /dev/null +++ b/unix/f2c/mswin/makefile.vc @@ -0,0 +1,76 @@ +# Microsoft Visual C++ Makefile for f2c, a Fortran 77 to C converter +# Invoke with "nmake -f makefile.vc", or execute the commands +# copy makefile.vc makefile +# nmake . + +CC = cl +CFLAGS = -Ot1 -nologo -DNO_LONG_LONG + +.c.obj: + $(CC) -c $(CFLAGS) $*.c + +OBJECTS = main.obj init.obj gram.obj lex.obj proc.obj equiv.obj data.obj format.obj \ + expr.obj exec.obj intr.obj io.obj misc.obj error.obj mem.obj names.obj \ + output.obj p1output.obj pread.obj put.obj putpcc.obj vax.obj formatdata.obj \ + parse_args.obj niceprintf.obj cds.obj sysdep.obj version.obj + +checkfirst: xsum.out + +f2c.exe: $(OBJECTS) + $(CC) -Fef2c.exe $(OBJECTS) setargv.obj + +$(OBJECTS): defs.h ftypes.h defines.h machdefs.h sysdep.h + +cds.obj: sysdep.h +exec.obj: p1defs.h names.h +expr.obj: output.h niceprintf.h names.h +format.obj: p1defs.h format.h output.h niceprintf.h names.h iob.h +formatdata.obj: format.h output.h niceprintf.h names.h +gram.obj: p1defs.h +init.obj: output.h niceprintf.h iob.h +intr.obj: names.h +io.obj: names.h iob.h +lex.obj : tokdefs.h p1defs.h +main.obj: parse.h usignal.h +mem.obj: iob.h +names.obj: iob.h names.h output.h niceprintf.h +niceprintf.obj: defs.h names.h output.h niceprintf.h +output.obj: output.h niceprintf.h names.h +p1output.obj: p1defs.h output.h niceprintf.h names.h +parse_args.obj: parse.h +proc.obj: tokdefs.h names.h niceprintf.h output.h p1defs.h +put.obj: names.h pccdefs.h p1defs.h +putpcc.obj: names.h +vax.obj: defs.h output.h pccdefs.h +output.h: niceprintf.h + +put.obj putpcc.obj: pccdefs.h + +clean: + deltree /Y *.obj f2c.exe + +veryclean: clean + deltree /Y xsum.exe + +b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ + exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ + ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ + init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile.u makefile.vc \ + malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \ + niceprintf.h output.c output.h p1defs.h p1output.c \ + parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \ + sysdep.c sysdep.h sysdeptest.c tokens usignal.h vax.c version.c xsum.c + +xsum.exe: xsum.c + $(CC) $(CFLAGS) -DMSDOS xsum.c + +#Check validity of transmitted source... +# Unfortunately, conditional execution is hard here, since fc does not set a +# nonzero exit code when files differ. + +xsum.out: xsum.exe $b + xsum $b >xsum1.out + fc xsum0.out xsum1.out + @echo If fc showed no differences, manually rename xsum1.out xsum.out: + @echo if xsum.out exists, first "del xsum.out"; then "ren xsum1.out xsum.out". + @echo Once you are happy that your source is OK, "nmake -f makefile.vc f2c.exe". diff --git a/unix/f2c/src/README b/unix/f2c/src/README new file mode 100644 index 00000000..1416f521 --- /dev/null +++ b/unix/f2c/src/README @@ -0,0 +1,186 @@ +To compile f2c on Linux or Unix systems, copy makefile.u to makefile, +edit makefile if necessary (see the comments in it and below) and +type "make" (or maybe "nmake", depending on your system). + +To compile f2c.exe on MS Windows systems with Microsoft Visual C++, + + copy makefile.vc makefile + nmake + +With other PC compilers, you may need to compile xsum.c with -DMSDOS +(i.e., with MSDOS #defined). + +If your compiler does not understand ANSI/ISO C syntax (i.e., if +you have a K&R C compiler), compile with -DKR_headers . + +On non-Unix systems where files have separate binary and text modes, +you may need to "make xsumr.out" rather than "make xsum.out". + +If (in accordance with what follows) you need to any of the source +files (excluding the makefile), first issue a "make xsum.out" (or, if +appropriate, "make xsumr.out") to check the validity of the f2c source, +then make your changes, then type "make f2c". + +The file usignal.h is for the benefit of strictly ANSI include files +on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. +You may need to modify usignal.h if you are not running f2c on a UNIX +system. + +Should you get the message "xsum0.out xsum1.out differ", see what lines +are different (`diff xsum0.out xsum1.out`) and ask netlib +(e.g., netlib@netlib.org) to send you the files in question, +plus the current xsum0.out (which may have changed) "from f2c/src". +For example, if exec.c and expr.c have incorrect check sums, you would +send netlib the message + send exec.c expr.c xsum0.out from f2c/src +You can also ftp these files from netlib.bell-labs.com; for more +details, ask netlib@netlib.org to "send readme from f2c". + +On some systems, the malloc and free in malloc.c let f2c run faster +than do the standard malloc and free. Other systems may not tolerate +redefinition of malloc and free (though changes of 8 Nov. 1994 may +render this less of a problem than hitherto). If your system permits +use of a user-supplied malloc, you may wish to change the MALLOC = +line in the makefile to "MALLOC = malloc.o", or to type + make MALLOC=malloc.o +instead of + make +Still other systems have a -lmalloc that provides performance +competitive with that from malloc.c; you may wish to compare the two +on your system. If your system does not permit user-supplied malloc +routines, then f2c may fault with "MALLOC=malloc.o", or may display +other untoward behavior. + +On some BSD systems, you may need to create a file named "string.h" +whose single line is +#include +you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment +in the makefile, and you may need to add " memset.o" to the "OBJECTS =" +assignment in the makefile -- see the comments in memset.c . + +For non-UNIX systems, you may need to change some things in sysdep.c, +such as the choice of intermediate file names. + +On some systems, you may need to modify parts of sysdep.h (which is +included by defs.h). In particular, for Sun 4.1 systems and perhaps +some others, you need to comment out the typedef of size_t. For some +systems (e.g., IRIX 4.0.1 and AIX) it is better to add +#define ANSI_Libraries +to the beginning of sysdep.h (or to supply -DANSI_Libraries in the +makefile). + +Alas, some systems #define __STDC__ but do not provide a true standard +(ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours +is such a system, then (a) you should complain loudly to your vendor +about __STDC__ being erroneously defined, and (b) you should insert +#undef __STDC__ +at the beginning of sysdep.h . You may need to make other adjustments. + +For some non-ANSI versions of stdio, you must change the values given +to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". +You may need to make this change if you run f2c and get an error +message of the form + Compiler error ... cannot open intermediate file ... + +In the days of yore, two libraries, libF77 and libI77, were used with +f77 (the Fortran compiler on which f2c is based). Separate source for +these libraries is still available from netlib, but it is more +convenient to combine them into a single library, libf2c. Source for +this combined library is also available from netlib in f2c/libf2c.zip, +e.g., + http://netlib.bell-labs.com/netlib/f2c/libf2c.zip +or + http://www.netlib.org/f2c/libf2c.zip + +(and similarly for other netlib mirrors). After unzipping libf2c.zip, +copy the relevant makefile.* to makefile, edit makefile if necessary +(see the comments in it and in libf2c/README) and invoke "make" or +"nmake". The resulting library is called *f2c.lib on MS Windows +systems and libf2c.a or libf2c.so on Linux and Unix systems; +makefile.u just shows how to make libf2c.a. Details on creating the +shared-library variant, libf2c.so, are system-dependent; some that +have worked under Linux appear below. For some other systems, you can +glean the details from the system-dependent makefile variants in +directory http://www.netlib.org/ampl/solvers/funclink or +http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. + +In general, under Linux it is necessary to compile libf2c (or libI77) +with -DNON_UNIX_STDIO . Under at least one variant of Linux, you can +make and install a shared-library version of libf2c by compiling +libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then +executing + + mkdir t + ln lib?77/*.o t + cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o + cd .. + rm -r t + rm /usr/lib/libf2c* + mv libf2c.a libf2c.so /usr/lib + cd /usr/lib + ln libf2c.so libf2c.so.1 + ln libf2c.so libf2c.so.1.0.0 + +On some other systems, /usr/local/lib is the appropriate installation +directory. + + +Some older C compilers object to + typedef void (*foo)(); +or to + typedef void zap; + zap (*foo)(); +If yours is such a compiler, change the definition of VOID in +f2c.h from void to int. + +For convenience with systems that use control-Z to denote end-of-file, +f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the +beginning of a line as an end-of-file indicator. You can disable this +test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can +change control-Z to some other character by #defining EOF_CHAR to +be the desired value. + + +If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your +printf is inaccurate (e.g., with Symantec C++ version 6.0, +printf("%.17g",12.) prints 12.000000000000001), you can make f2c print +correctly rounded numbers by compiling with -DUSE_DTOA and adding +dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes + + OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o + +Also add the rule + + dtoa.o: dtoa.c + $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c + +(without the initial tab) to the makefile, where IEEE... is one of +IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's +arithmetic. See the comments near the start of dtoa.c. + +The relevant source files, dtoa.c and g_fmt.c, are available +separately from netlib's fp directory. For example, you could +send the E-mail message + + send dtoa.c g_fmt.c from fp + +to netlib@netlib.netlib.org (or use anonymous ftp from +ftp.netlib.org and look in directory /netlib/fp). + +The makefile has a rule for creating tokdefs.h. If you cannot use the +makefile, an alternative is to extract tokdefs.h from the beginning of +gram.c: it's the first 100 lines. + +File mem.c has #ifdef CRAY lines that are appropriate for machines +with the conventional CRAY architecture, but not for "Cray" machines +based on DEC Alpha chips, such as the T3E; on such machines, you may +need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. + + +Please send bug reports to dmg at acm.org (with " at " changed to "@"). +The old index file (now called "readme" due to unfortunate changes in +netlib conventions: "send readme from f2c") will report recent +changes in the recent-change log at its end; all changes will be shown +in the "changes" file ("send changes from f2c"). To keep current +source, you will need to request xsum0.out and version.c, in addition +to the changed source files. diff --git a/unix/f2c/src/cds.c b/unix/f2c/src/cds.c new file mode 100644 index 00000000..05f3d501 --- /dev/null +++ b/unix/f2c/src/cds.c @@ -0,0 +1,195 @@ +/**************************************************************** +Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* Put strings representing decimal floating-point numbers + * into canonical form: always have a decimal point or + * exponent field; if using an exponent field, have the + * number before it start with a digit and decimal point + * (if the number has more than one digit); only have an + * exponent field if it saves space. + * + * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' . + */ + +#include "defs.h" + + char * +#ifdef KR_headers +cds(s, z0) + char *s; + char *z0; +#else +cds(char *s, char *z0) +#endif +{ + int ea, esign, et, i, k, nd = 0, sign = 0, tz; + char c, *z; + char ebuf[24]; + long ex = 0; + static char etype[Table_size], *db; + static int dblen = 64; + + if (!db) { + etype['E'] = 1; + etype['e'] = 1; + etype['D'] = 1; + etype['d'] = 1; + etype['+'] = 2; + etype['-'] = 3; + db = Alloc(dblen); + } + + while((c = *s++) == '0'); + if (c == '-') + { sign = 1; c = *s++; } + else if (c == '+') + c = *s++; + k = strlen(s) + 2; + if (k >= dblen) { + do dblen <<= 1; + while(k >= dblen); + free(db); + db = Alloc(dblen); + } + if (etype[(unsigned char)c] >= 2) + while(c == '0') c = *s++; + tz = 0; + while(c >= '0' && c <= '9') { + if (c == '0') + tz++; + else { + if (nd) + for(; tz; --tz) + db[nd++] = '0'; + else + tz = 0; + db[nd++] = c; + } + c = *s++; + } + ea = -tz; + if (c == '.') { + while((c = *s++) >= '0' && c <= '9') { + if (c == '0') + tz++; + else { + if (tz) { + ea += tz; + if (nd) + for(; tz; --tz) + db[nd++] = '0'; + else + tz = 0; + } + db[nd++] = c; + ea++; + } + } + } + if (et = etype[(unsigned char)c]) { + esign = et == 3; + c = *s++; + if (et == 1) { + if(etype[(unsigned char)c] > 1) { + if (c == '-') + esign = 1; + c = *s++; + } + } + while(c >= '0' && c <= '9') { + ex = 10*ex + (c - '0'); + c = *s++; + } + if (esign) + ex = -ex; + } + switch(c) { + case 0: + break; +#ifndef VAX + case 'i': + case 'I': + Fatal("Overflow evaluating constant expression."); + case 'n': + case 'N': + Fatal("Constant expression yields NaN."); +#endif + default: + Fatal("unexpected character in cds."); + } + ex -= ea; + if (!nd) { + if (!z0) + z0 = mem(4,0); + strcpy(z0, "-0."); + /* sign = 0; */ /* 20010820: preserve sign of 0. */ + } + else if (ex > 2 || ex + nd < -2) { + sprintf(ebuf, "%ld", ex + nd - 1); + k = strlen(ebuf) + nd + 3; + if (nd > 1) + k++; + if (!z0) + z0 = mem(k,0); + z = z0; + *z++ = '-'; + *z++ = *db; + if (nd > 1) { + *z++ = '.'; + for(k = 1; k < nd; k++) + *z++ = db[k]; + } + *z++ = 'e'; + strcpy(z, ebuf); + } + else { + k = (int)(ex + nd); + i = nd + 3; + if (k < 0) + i -= k; + else if (ex > 0) + i += (int)ex; + if (!z0) + z0 = mem(i,0); + z = z0; + *z++ = '-'; + if (ex >= 0) { + for(k = 0; k < nd; k++) + *z++ = db[k]; + while(--ex >= 0) + *z++ = '0'; + *z++ = '.'; + } + else { + for(i = 0; i < k;) + *z++ = db[i++]; + *z++ = '.'; + while(++k <= 0) + *z++ = '0'; + while(i < nd) + *z++ = db[i++]; + } + *z = 0; + } + return sign ? z0 : z0+1; + } diff --git a/unix/f2c/src/data.c b/unix/f2c/src/data.c new file mode 100644 index 00000000..7da3ecb0 --- /dev/null +++ b/unix/f2c/src/data.c @@ -0,0 +1,502 @@ +/**************************************************************** +Copyright 1990, 1993-1996, 1999, 2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" + +/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */ + +static char datafmt[] = "%s\t%09ld\t%d"; +static char *cur_varname; + +/* another initializer, called from parser */ + void +#ifdef KR_headers +dataval(repp, valp) + register expptr repp; + register expptr valp; +#else +dataval(register expptr repp, register expptr valp) +#endif +{ + ftnint elen, i, nrep; + register Addrp p; + + if (parstate < INDATA) { + frexpr(repp); + goto ret; + } + if(repp == NULL) + nrep = 1; + else if (ISICON(repp) && repp->constblock.Const.ci >= 0) + nrep = repp->constblock.Const.ci; + else + { + err("invalid repetition count in DATA statement"); + frexpr(repp); + goto ret; + } + frexpr(repp); + + if( ! ISCONST(valp) ) { + if (valp->tag == TADDR + && valp->addrblock.uname_tag == UNAM_CONST) { + /* kludge */ + frexpr(valp->addrblock.memoffset); + valp->tag = TCONST; + } + else { + err("non-constant initializer"); + goto ret; + } + } + + if(toomanyinit) goto ret; + for(i = 0 ; i < nrep ; ++i) + { + p = nextdata(&elen); + if(p == NULL) + { + if (lineno != err_lineno) + err("too many initializers"); + toomanyinit = YES; + goto ret; + } + setdata((Addrp)p, (Constp)valp, elen); + frexpr((expptr)p); + } + +ret: + frexpr(valp); +} + + + Addrp +#ifdef KR_headers +nextdata(elenp) + ftnint *elenp; +#else +nextdata(ftnint *elenp) +#endif +{ + register struct Impldoblock *ip; + struct Primblock *pp; + register Namep np; + register struct Rplblock *rp; + tagptr p; + expptr neltp; + register expptr q; + int skip; + ftnint off, vlen; + + while(curdtp) + { + p = (tagptr)curdtp->datap; + if(p->tag == TIMPLDO) + { + ip = &(p->impldoblock); + if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) { + char buf[100]; + sprintf(buf, "bad impldoblock #%lx", + (unsigned long)ip); + Fatal(buf); + } + if(ip->isactive) + ip->varvp->Const.ci += ip->impdiff; + else + { + q = fixtype(cpexpr(ip->implb)); + if( ! ISICON(q) ) + goto doerr; + ip->varvp = (Constp) q; + + if(ip->impstep) + { + q = fixtype(cpexpr(ip->impstep)); + if( ! ISICON(q) ) + goto doerr; + ip->impdiff = q->constblock.Const.ci; + frexpr(q); + } + else + ip->impdiff = 1; + + q = fixtype(cpexpr(ip->impub)); + if(! ISICON(q)) + goto doerr; + ip->implim = q->constblock.Const.ci; + frexpr(q); + + ip->isactive = YES; + rp = ALLOC(Rplblock); + rp->rplnextp = rpllist; + rpllist = rp; + rp->rplnp = ip->varnp; + rp->rplvp = (expptr) (ip->varvp); + rp->rpltag = TCONST; + } + + if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim)) + || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) ) + { /* start new loop */ + curdtp = ip->datalist; + goto next; + } + + /* clean up loop */ + + if(rpllist) + { + rp = rpllist; + rpllist = rpllist->rplnextp; + free( (charptr) rp); + } + else + Fatal("rpllist empty"); + + frexpr((expptr)ip->varvp); + ip->isactive = NO; + curdtp = curdtp->nextp; + goto next; + } + + pp = (struct Primblock *) p; + np = pp->namep; + cur_varname = np->fvarname; + skip = YES; + + if(p->primblock.argsp==NULL && np->vdim!=NULL) + { /* array initialization */ + q = (expptr) mkaddr(np); + off = typesize[np->vtype] * curdtelt; + if(np->vtype == TYCHAR) + off *= np->vleng->constblock.Const.ci; + q->addrblock.memoffset = + mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); + if( (neltp = np->vdim->nelt) && ISCONST(neltp)) + { + if(++curdtelt < neltp->constblock.Const.ci) + skip = NO; + } + else + err("attempt to initialize adjustable array"); + } + else + q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0); + if(skip) + { + curdtp = curdtp->nextp; + curdtelt = 0; + } + if(q->headblock.vtype == TYCHAR) + if(ISICON(q->headblock.vleng)) + *elenp = q->headblock.vleng->constblock.Const.ci; + else { + err("initialization of string of nonconstant length"); + continue; + } + else *elenp = typesize[q->headblock.vtype]; + + if (np->vstg == STGBSS) { + vlen = np->vtype==TYCHAR + ? np->vleng->constblock.Const.ci + : typesize[np->vtype]; + if(vlen > 0) + np->vstg = STGINIT; + } + return( (Addrp) q ); + +doerr: + err("nonconstant implied DO parameter"); + frexpr(q); + curdtp = curdtp->nextp; + +next: + curdtelt = 0; + } + + return(NULL); +} + + + +LOCAL FILEP dfile; + + void +#ifdef KR_headers +setdata(varp, valp, elen) + register Addrp varp; + register Constp valp; + ftnint elen; +#else +setdata(register Addrp varp, register Constp valp, ftnint elen) +#endif +{ + struct Constblock con; + register int type; + int j, valtype; + ftnint i, k, offset; + char *varname; + static Addrp badvar; + register unsigned char *s; + static long last_lineno; + static char *last_varname; + + if (varp->vstg == STGCOMMON) { + if (!(dfile = blkdfile)) + dfile = blkdfile = opf(blkdfname, textwrite); + } + else { + if (procclass == CLBLOCK) { + if (varp != badvar) { + badvar = varp; + warn1("%s is not in a COMMON block", + varp->uname_tag == UNAM_NAME + ? varp->user.name->fvarname + : "???"); + } + return; + } + if (!(dfile = initfile)) + dfile = initfile = opf(initfname, textwrite); + } + varname = dataname(varp->vstg, varp->memno); + offset = varp->memoffset->constblock.Const.ci; + type = varp->vtype; + valtype = valp->vtype; + if(type!=TYCHAR && valtype==TYCHAR) + { + if(! ftn66flag + && (last_varname != cur_varname || last_lineno != lineno)) { + /* prevent multiple warnings */ + last_lineno = lineno; + warn1( + "non-character datum %.42s initialized with character string", + last_varname = cur_varname); + } + varp->vleng = ICON(typesize[type]); + varp->vtype = type = TYCHAR; + } + else if( (type==TYCHAR && valtype!=TYCHAR) || + (cktype(OPASSIGN,type,valtype) == TYERROR) ) + { + err("incompatible types in initialization"); + return; + } + if(type == TYADDR) + con.Const.ci = valp->Const.ci; + else if(type != TYCHAR) + { + if(valtype == TYUNKNOWN) + con.Const.ci = valp->Const.ci; + else consconv(type, &con, valp); + } + + j = 1; + + switch(type) + { + case TYLOGICAL: + case TYINT1: + case TYLOGICAL1: + case TYLOGICAL2: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + dataline(varname, offset, type); + prconi(dfile, con.Const.ci); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + dataline(varname, offset, type); + prconq(dfile, con.Const.cq); + break; +#endif + + case TYADDR: + dataline(varname, offset, type); + prcona(dfile, con.Const.ci); + break; + + case TYCOMPLEX: + case TYDCOMPLEX: + j = 2; + case TYREAL: + case TYDREAL: + dataline(varname, offset, type); + prconr(dfile, &con, j); + break; + + case TYCHAR: + k = valp -> vleng -> constblock.Const.ci; + if (elen < k) + k = elen; + s = (unsigned char *)valp->Const.ccp; + for(i = 0 ; i < k ; ++i) { + dataline(varname, offset++, TYCHAR); + fprintf(dfile, "\t%d\n", *s++); + } + k = elen - valp->vleng->constblock.Const.ci; + if(k > 0) { + dataline(varname, offset, TYBLANK); + fprintf(dfile, "\t%d\n", (int)k); + } + break; + + default: + badtype("setdata", type); + } + +} + + + +/* + output form of name is padded with blanks and preceded + with a storage class digit +*/ + char* +#ifdef KR_headers +dataname(stg, memno) + int stg; + long memno; +#else +dataname(int stg, long memno) +#endif +{ + static char varname[64]; + register char *s, *t; + char buf[16]; + + if (stg == STGCOMMON) { + varname[0] = '2'; + sprintf(s = buf, "Q.%ld", memno); + } + else { + varname[0] = stg==STGEQUIV ? '1' : '0'; + s = memname(stg, memno); + } + t = varname + 1; + while(*t++ = *s++); + *t = 0; + return(varname); +} + + + + + void +#ifdef KR_headers +frdata(p0) + chainp p0; +#else +frdata(chainp p0) +#endif +{ + register struct Chain *p; + register tagptr q; + + for(p = p0 ; p ; p = p->nextp) + { + q = (tagptr)p->datap; + if(q->tag == TIMPLDO) + { + if(q->impldoblock.isbusy) + return; /* circular chain completed */ + q->impldoblock.isbusy = YES; + frdata(q->impldoblock.datalist); + free( (charptr) q); + } + else + frexpr(q); + } + + frchain( &p0); +} + + + void +#ifdef KR_headers +dataline(varname, offset, type) + char *varname; + ftnint offset; + int type; +#else +dataline(char *varname, ftnint offset, int type) +#endif +{ + fprintf(dfile, datafmt, varname, offset, type); +} + + void +#ifdef KR_headers +make_param(p, e) + register struct Paramblock *p; + expptr e; +#else +make_param(register struct Paramblock *p, expptr e) +#endif +{ + register expptr q; + Constp qc; + + if (p->vstg == STGARG) + errstr("Dummy argument %.50s appears in a parameter statement.", + p->fvarname); + p->vclass = CLPARAM; + impldcl((Namep)p); + if (e->headblock.vtype != TYCHAR) + e = putx(fixtype(e)); + p->paramval = q = mkconv(p->vtype, e); + if (p->vtype == TYCHAR) { + if (q->tag == TEXPR) + p->paramval = q = fixexpr((Exprp)q); + if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) { + qc = mkconst(TYCHAR); + qc->Const = q->addrblock.user.Const; + qc->vleng = q->addrblock.vleng; + q->addrblock.vleng = 0; + frexpr(q); + p->paramval = q = (expptr)qc; + } + if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { + errstr("invalid value for character parameter %s", + p->fvarname); + return; + } + if (!(e = p->vleng)) + p->vleng = ICON(q->constblock.vleng->constblock.Const.ci + + q->constblock.Const.ccp1.blanks); + else if (q->constblock.vleng->constblock.Const.ci + > e->constblock.Const.ci) { + q->constblock.vleng->constblock.Const.ci + = e->constblock.Const.ci; + q->constblock.Const.ccp1.blanks = 0; + } + else + q->constblock.Const.ccp1.blanks + = e->constblock.Const.ci + - q->constblock.vleng->constblock.Const.ci; + } + } diff --git a/unix/f2c/src/defines.h b/unix/f2c/src/defines.h new file mode 100644 index 00000000..1ed4537e --- /dev/null +++ b/unix/f2c/src/defines.h @@ -0,0 +1,300 @@ +#define PDP11 4 + +#define BIGGEST_CHAR 0x7f /* Assumes 32-bit arithmetic */ +#define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */ +#define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */ + +#define M(x) (1<tag==TCONST && ISINT(z->constblock.vtype)) +#define ISLOGICAL(z) ONEOF(z, MSKLOGICAL) + +/* ISCHAR assumes that z has some kind of structure, i.e. is not null */ + +#define ISCHAR(z) (z->headblock.vtype==TYCHAR) +#define ISINT(z) ONEOF(z, MSKINT) /* z is a tag, i.e. a mask number */ +#define ISCONST(z) (z->tag==TCONST) +#define ISERROR(z) (z->tag==TERROR) +#define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS) +#define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR) +#define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1) +#define INT(z) ONEOF(z, MSKINT|MSKCHAR) /* has INT storage in real life */ +#define ICON(z) mkintcon( (ftnint)(z) ) + +/* NO66 -- F77 feature is being used + NOEXT -- F77 extension is being used */ + +#define NO66(s) if(no66flag) err66(s) +#define NOEXT(s) if(noextflag) errext(s) diff --git a/unix/f2c/src/defs.h b/unix/f2c/src/defs.h new file mode 100644 index 00000000..0f0a1c2d --- /dev/null +++ b/unix/f2c/src/defs.h @@ -0,0 +1,1073 @@ +/**************************************************************** +Copyright 1990 - 1996, 1999-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "sysdep.h" + +#include "ftypes.h" +#include "defines.h" +#include "machdefs.h" + +#define MAXDIM 20 +#define MAXINCLUDES 10 +#define MAXLITERALS 200 /* Max number of constants in the literal + pool */ +#define MAXCTL 20 +#define MAXHASH 802 +#define MAXSTNO 801 +#define MAXEXT 400 +#define MAXEQUIV 300 +#define MAXLABLIST 258 /* Max number of labels in an alternate + return CALL or computed GOTO */ +#define MAXCONTIN 99 /* Max continuation lines */ +#define MAX_SHARPLINE_LEN 1000 /* Elbow room for #line lines with long names */ +/* These are the primary pointer types used in the compiler */ + +typedef union Expression *expptr, *tagptr; +typedef struct Chain *chainp; +typedef struct Addrblock *Addrp; +typedef struct Constblock *Constp; +typedef struct Exprblock *Exprp; +typedef struct Nameblock *Namep; + +extern FILEP infile; +extern FILEP diagfile; +extern FILEP textfile; +extern FILEP asmfile; +extern FILEP c_file; /* output file for all functions; extern + declarations will have to be prepended */ +extern FILEP pass1_file; /* Temp file to hold the function bodies + read on pass 1 */ +extern FILEP expr_file; /* Debugging file */ +extern FILEP initfile; /* Intermediate data file pointer */ +extern FILEP blkdfile; /* BLOCK DATA file */ + +extern int current_ftn_file; +extern int maxcontin; + +extern char *blkdfname, *initfname, *sortfname; +extern long headoffset; /* Since the header block requires data we + don't know about until AFTER each + function has been processed, we keep a + pointer to the current (dummy) header + block (at the top of the assembly file) + here */ + +extern char main_alias[]; /* name given to PROGRAM psuedo-op */ +extern char *token; +extern int maxtoklen, toklen; +extern long err_lineno, lineno; +extern char *infname; +extern int needkwd; +extern struct Labelblock *thislabel; + +/* Used to allow runtime expansion of internal tables. In particular, + these values can exceed their associated constants */ + +extern int maxctl; +extern int maxequiv; +extern int maxstno; +extern int maxhash; +extern int maxext; + +extern flag nowarnflag; +extern flag ftn66flag; /* Generate warnings when weird f77 + features are used (undeclared dummy + procedure, non-char initialized with + string, 1-dim subscript in EQUIV) */ +extern flag no66flag; /* Generate an error when a generic + function (f77 feature) is used */ +extern flag noextflag; /* Generate an error when an extension to + Fortran 77 is used (hex/oct/bin + constants, automatic, static, double + complex types) */ +extern flag zflag; /* enable double complex intrinsics */ +extern flag shiftcase; +extern flag undeftype; +extern flag shortsubs; /* Use short subscripts on arrays? */ +extern flag onetripflag; /* if true, always execute DO loop body */ +extern flag checksubs; +extern flag debugflag; +extern int nerr; +extern int nwarn; + +extern int parstate; +extern flag headerdone; /* True iff the current procedure's header + data has been written */ +extern int blklevel; +extern flag saveall; +extern flag substars; /* True iff some formal parameter is an + asterisk */ +extern int impltype[ ]; +extern ftnint implleng[ ]; +extern int implstg[ ]; + +extern int tycomplex, tyint, tyioint, tyreal; +extern int tylog, tylogical; /* TY____ of the implementation of logical. + This will be LONG unless '-2' is given + on the command line */ +extern int type_choice[]; +extern char *Typename[]; + +extern int typesize[]; /* size (in bytes) of an object of each + type. Indexed by TY___ macros */ +extern int typealign[]; +extern int proctype; /* Type of return value in this procedure */ +extern char * procname; /* External name of the procedure, or last ENTRY name */ +extern int rtvlabel[ ]; /* Return value labels, indexed by TY___ macros */ +extern Addrp retslot; +extern Addrp xretslot[]; +extern int cxslot; /* Complex return argument slot (frame pointer offset)*/ +extern int chslot; /* Character return argument slot (fp offset) */ +extern int chlgslot; /* Argument slot for length of character buffer */ +extern int procclass; /* Class of the current procedure: either CLPROC, + CLMAIN, CLBLOCK or CLUNKNOWN */ +extern ftnint procleng; /* Length of function return value (e.g. char + string length). If this is -1, then the length is + not known at compile time */ +extern int nentry; /* Number of entry points (other than the original + function call) into this procedure */ +extern flag multitype; /* YES iff there is more than one return value + possible */ +extern int blklevel; +extern long lastiolabno; +extern long lastlabno; +extern int lastvarno; +extern int lastargslot; /* integer offset pointing to the next free + location for an argument to the current routine */ +extern int argloc; +extern int autonum[]; /* for numbering + automatic variables, e.g. temporaries */ +extern int retlabel; +extern int ret0label; +extern int dorange; /* Number of the label which terminates + the innermost DO loop */ +extern int regnum[ ]; /* Numbers of DO indicies named in + regnamep (below) */ +extern Namep regnamep[ ]; /* List of DO indicies in registers */ +extern int maxregvar; /* number of elts in regnamep */ +extern int highregvar; /* keeps track of the highest register + number used by DO index allocator */ +extern int nregvar; /* count of DO indicies in registers */ + +extern chainp templist[]; +extern int maxdim; +extern chainp earlylabs; +extern chainp holdtemps; +extern struct Entrypoint *entries; +extern struct Rplblock *rpllist; +extern struct Chain *curdtp; +extern ftnint curdtelt; +extern chainp allargs; /* union of args in entries */ +extern int nallargs; /* total number of args */ +extern int nallchargs; /* total number of character args */ +extern flag toomanyinit; /* True iff too many initializers in a + DATA statement */ + +extern flag inioctl; +extern int iostmt; +extern Addrp ioblkp; +extern int nioctl; +extern int nequiv; +extern int eqvstart; /* offset to eqv number to guarantee uniqueness + and prevent from going negative */ +extern int nintnames; + +/* Chain of tagged blocks */ + +struct Chain + { + chainp nextp; + char * datap; /* Tagged block */ + }; + +extern chainp chains; + +/* Recall that field is intended to hold four-bit characters */ + +/* This structure exists only to defeat the type checking */ + +struct Headblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* Expression for length of char string - + this may be a constant, or an argument + generated by mkarg() */ + } ; + +/* Control construct info (for do loops, else, etc) */ + +struct Ctlframe + { + unsigned ctltype:8; + unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */ + unsigned dowhile:1; + int ctlabels[4]; /* Control labels, defined below */ + int dolabel; /* label marking end of this DO loop */ + Namep donamep; /* DO index variable */ + expptr doinit; /* for use with -onetrip */ + expptr domax; /* constant or temp variable holding MAX + loop value; or expr of while(expr) */ + expptr dostep; /* expression */ + Namep loopname; + }; +#define endlabel ctlabels[0] +#define elselabel ctlabels[1] +#define dobodylabel ctlabels[1] +#define doposlabel ctlabels[2] +#define doneglabel ctlabels[3] +extern struct Ctlframe *ctls; /* Keeps info on DO and BLOCK IF + structures - this is the stack + bottom */ +extern struct Ctlframe *ctlstack; /* Pointer to current nesting + level */ +extern struct Ctlframe *lastctl; /* Point to end of + dynamically-allocated array */ + +typedef struct { + int type; + chainp cp; + } Atype; + +typedef struct { + int defined, dnargs, nargs, changes; + Atype atypes[1]; + } Argtypes; + +/* External Symbols */ + +struct Extsym + { + char *fextname; /* Fortran version of external name */ + char *cextname; /* C version of external name */ + field extstg; /* STG -- should be COMMON, UNKNOWN or EXT + */ + unsigned extype:4; /* for transmitting type to output routines */ + unsigned used_here:1; /* Boolean - true on the second pass + through a function if the block has + been referenced */ + unsigned exused:1; /* Has been used (for help with error msgs + about externals typed differently in + different modules) */ + unsigned exproto:1; /* type specified in a .P file */ + unsigned extinit:1; /* Procedure has been defined, + or COMMON has DATA */ + unsigned extseen:1; /* True if previously referenced */ + chainp extp; /* List of identifiers in the common + block for this function, stored as + Namep (hash table pointers) */ + chainp allextp; /* List of lists of identifiers; we keep one + list for each layout of this common block */ + int curno; /* current number for this common block, + used for constructing appending _nnn + to the common block name */ + int maxno; /* highest curno value for this common block */ + ftnint extleng; + ftnint maxleng; + Argtypes *arginfo; + }; +typedef struct Extsym Extsym; + +extern Extsym *extsymtab; /* External symbol table */ +extern Extsym *nextext; +extern Extsym *lastext; +extern int complex_seen, dcomplex_seen; + +/* Statement labels */ + +struct Labelblock + { + int labelno; /* Internal label */ + unsigned blklevel:8; /* level of nesting, for branch-in-loop + checking */ + unsigned labused:1; + unsigned fmtlabused:1; + unsigned labinacc:1; /* inaccessible? (i.e. has its scope + vanished) */ + unsigned labdefined:1; /* YES or NO */ + unsigned labtype:2; /* LAB{FORMAT,EXEC,etc} */ + ftnint stateno; /* Original label */ + char *fmtstring; /* format string */ + }; + +extern struct Labelblock *labeltab; /* Label table - keeps track of + all labels, including undefined */ +extern struct Labelblock *labtabend; +extern struct Labelblock *highlabtab; + +/* Entry point list */ + +struct Entrypoint + { + struct Entrypoint *entnextp; + Extsym *entryname; /* Name of this ENTRY */ + chainp arglist; + int typelabel; /* Label for function exit; this + will return the proper type of + object */ + Namep enamep; /* External name */ + }; + +/* Primitive block, or Primary block. This is a general template returned + by the parser, which will be interpreted in context. It is a template + for an identifier (variable name, function name), parenthesized + arguments (array subscripts, function parameters) and substring + specifications. */ + +struct Primblock + { + field tag; + field vtype; + unsigned parenused:1; /* distinguish (a) from a */ + Namep namep; /* Pointer to structure Nameblock */ + struct Listblock *argsp; + expptr fcharp; /* first-char-index-pointer (in + substring) */ + expptr lcharp; /* last-char-index-pointer (in + substring) */ + }; + + +struct Hashentry + { + int hashval; + Namep varp; + }; +extern struct Hashentry *hashtab; /* Hash table */ +extern struct Hashentry *lasthash; + +struct Intrpacked /* bits for intrinsic function description */ + { + unsigned f1:4; + unsigned f2:4; + unsigned f3:7; + unsigned f4:1; + }; + +struct Nameblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* length of character string, if applicable */ + char *fvarname; /* name in the Fortran source */ + char *cvarname; /* name in the resulting C */ + chainp vlastdim; /* datap points to new_vars entry for the */ + /* system variable, if any, storing the final */ + /* dimension; we zero the datap if this */ + /* variable is needed */ + unsigned vprocclass:3; /* P____ macros - selects the varxptr + field below */ + unsigned vdovar:1; /* "is it a DO variable?" for register + and multi-level loop checking */ + unsigned vdcldone:1; /* "do I think I'm done?" - set when the + context is sufficient to determine its + status */ + unsigned vadjdim:1; /* "adjustable dimension?" - needed for + information about copies */ + unsigned vsave:1; + unsigned vimpldovar:1; /* used to prevent erroneous error messages + for variables used only in DATA stmt + implicit DOs */ + unsigned vis_assigned:1;/* True if this variable has had some + label ASSIGNED to it; hence + varxptr.assigned_values is valid */ + unsigned vimplstg:1; /* True if storage type is assigned implicitly; + this allows a COMMON variable to participate + in a DIMENSION before the COMMON declaration. + */ + unsigned vcommequiv:1; /* True if EQUIVALENCEd onto STGCOMMON */ + unsigned vfmt_asg:1; /* True if char *var_fmt needed */ + unsigned vpassed:1; /* True if passed as a character-variable arg */ + unsigned vknownarg:1; /* True if seen in a previous entry point */ + unsigned visused:1; /* True if variable is referenced -- so we */ + /* can omit variables that only appear in DATA */ + unsigned vnamelist:1; /* Appears in a NAMELIST */ + unsigned vimpltype:1; /* True if implicitly typed and not + invoked as a function or subroutine + (so we can consistently type procedures + declared external and passed as args + but never invoked). + */ + unsigned vtypewarned:1; /* so we complain just once about + changed types of external procedures */ + unsigned vinftype:1; /* so we can restore implicit type to a + procedure if it is invoked as a function + after being given a different type by -it */ + unsigned vinfproc:1; /* True if -it infers this to be a procedure */ + unsigned vcalled:1; /* has been invoked */ + unsigned vdimfinish:1; /* need to invoke dim_finish() */ + unsigned vrefused:1; /* Need to #define name_ref (for -s) */ + unsigned vsubscrused:1; /* Need to #define name_subscr (for -2) */ + unsigned veqvadjust:1; /* voffset has been adjusted for equivalence */ + +/* The vardesc union below is used to store the number of an intrinsic + function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to + store the index of this external symbol in extsymtab (when vstg == + STGEXT and vprocclass == PEXTERNAL) */ + + union { + int varno; /* Return variable for a function. + This is used when a function is + assigned a return value. Also + used to point to the COMMON + block, when this is a field of + that block. Also points to + EQUIV block when STGEQUIV */ + struct Intrpacked intrdesc; /* bits for intrinsic function*/ + } vardesc; + struct Dimblock *vdim; /* points to the dimensions if they exist */ + ftnint voffset; /* offset in a storage block (the variable + name will be "v.%d", voffset in a + common blck on the vax). Also holds + pointers for automatic variables. When + STGEQUIV, this is -(offset from array + base) */ + union { + chainp namelist; /* points to names in the NAMELIST, + if this is a NAMELIST name */ + chainp vstfdesc; /* points to (formals, expr) pair */ + chainp assigned_values; /* list of integers, each being a + statement label assigned to + this variable in the current function */ + } varxptr; + int argno; /* for multiple entries */ + Argtypes *arginfo; + }; + + +/* PARAMETER statements */ + +struct Paramblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; + char *fvarname; + char *cvarname; + expptr paramval; + } ; + + +/* Expression block */ + +struct Exprblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* in the case of a character expression, this + value is inherited from the children */ + unsigned int opcode; + expptr leftp; + expptr rightp; + int typefixed; + }; + + +union Constant + { + struct { + char *ccp0; + ftnint blanks; + } ccp1; + ftnint ci; /* Constant integer */ +#ifndef NO_LONG_LONG + Llong cq; /* for TYQUAD integer */ + ULlong ucq; +#endif + double cd[2]; + char *cds[2]; + }; +#define ccp ccp1.ccp0 + +struct Constblock + { + field tag; + field vtype; + field vclass; + field vstg; /* vstg = 1 when using Const.cds */ + expptr vleng; + union Constant Const; + }; + + +struct Listblock + { + field tag; + field vtype; + chainp listp; + }; + + + +/* Address block - this is the FINAL form of identifiers before being + sent to pass 2. We'll want to add the original identifier here so that it can + be preserved in the translation. + + An example identifier is q.7. The "q" refers to the storage class + (field vstg), the 7 to the variable number (int memno). */ + +struct Addrblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; + /* put union...user here so the beginning of an Addrblock + * is the same as a Constblock. + */ + union { + Namep name; /* contains a pointer into the hash table */ + char ident[IDENT_LEN + 1]; /* C string form of identifier */ + char *Charp; + union Constant Const; /* Constant value */ + struct { + double dfill[2]; + field vstg1; + } kludge; /* so we can distinguish string vs binary + * floating-point constants */ + } user; + long memno; /* when vstg == STGCONST, this is the + numeric part of the assembler label + where the constant value is stored */ + expptr memoffset; /* used in subscript computations, usually */ + unsigned istemp:1; /* used in stack management of temporary + variables */ + unsigned isarray:1; /* used to show that memoffset is + meaningful, even if zero */ + unsigned ntempelt:10; /* for representing temporary arrays, as + in concatenation */ + unsigned dbl_builtin:1; /* builtin to be declared double */ + unsigned charleng:1; /* so saveargtypes can get i/o calls right */ + unsigned cmplx_sub:1; /* used in complex arithmetic under -s */ + unsigned skip_offset:1; /* used in complex arithmetic under -s */ + unsigned parenused:1; /* distinguish (a) from a */ + ftnint varleng; /* holds a copy of a constant length which + is stored in the vleng field (e.g. + a double is 8 bytes) */ + int uname_tag; /* Tag describing which of the unions() + below to use */ + char *Field; /* field name when dereferencing a struct */ +}; /* struct Addrblock */ + + +/* Errorbock - placeholder for errors, to allow the compilation to + continue */ + +struct Errorblock + { + field tag; + field vtype; + }; + + +/* Implicit DO block, especially related to DATA statements. This block + keeps track of the compiler's location in the implicit DO while it's + running. In particular, the isactive and isbusy flags tell where + it is */ + +struct Impldoblock + { + field tag; + unsigned isactive:1; + unsigned isbusy:1; + Namep varnp; + Constp varvp; + chainp impdospec; + expptr implb; + expptr impub; + expptr impstep; + ftnint impdiff; + ftnint implim; + struct Chain *datalist; + }; + + +/* Each of these components has a first field called tag. This union + exists just for allocation simplicity */ + +union Expression + { + field tag; + struct Addrblock addrblock; + struct Constblock constblock; + struct Errorblock errorblock; + struct Exprblock exprblock; + struct Headblock headblock; + struct Impldoblock impldoblock; + struct Listblock listblock; + struct Nameblock nameblock; + struct Paramblock paramblock; + struct Primblock primblock; + } ; + + + +struct Dimblock + { + int ndim; + expptr nelt; /* This is NULL if the array is unbounded */ + expptr baseoffset; /* a constant or local variable holding + the offset in this procedure */ + expptr basexpr; /* expression for comuting the offset, if + it's not constant. If this is + non-null, the register named in + baseoffset will get initialized to this + value in the procedure's prolog */ + struct + { + expptr dimsize; /* constant or register holding the size + of this dimension */ + expptr dimexpr; /* as above in basexpr, this is an + expression for computing a variable + dimension */ + } dims[1]; /* Dimblocks are allocated with enough + space for this to become dims[ndim] */ + }; + + +/* Statement function identifier stack - this holds the name and value of + the parameters in a statement function invocation. For example, + + f(x,y,z)=x+y+z + . + . + y = f(1,2,3) + + generates a stack of depth 3, with , , AT THE INVOCATION, NOT + at the definition */ + +struct Rplblock /* name replacement block */ + { + struct Rplblock *rplnextp; + Namep rplnp; /* Name of the formal parameter */ + expptr rplvp; /* Value of the actual parameter */ + expptr rplxp; /* Initialization of temporary variable, + if required; else null */ + int rpltag; /* Tag on the value of the actual param */ + }; + + + +/* Equivalence block */ + +struct Equivblock + { + struct Eqvchain *equivs; /* List (Eqvchain) of primblocks + holding variable identifiers */ + flag eqvinit; + long eqvtop; + long eqvbottom; + int eqvtype; + } ; +#define eqvleng eqvtop + +extern struct Equivblock *eqvclass; + + +struct Eqvchain + { + struct Eqvchain *eqvnextp; + union + { + struct Primblock *eqvlhs; + Namep eqvname; + } eqvitem; + long eqvoffset; + } ; + + + +/* For allocation purposes only, and to keep lint quiet. In particular, + don't count on the tag being able to tell you which structure is used */ + + +/* There is a tradition in Fortran that the compiler not generate the same + bit pattern more than is necessary. This structure is used to do just + that; if two integer constants have the same bit pattern, just generate + it once. This could be expanded to optimize without regard to type, by + removing the type check in putconst() */ + +struct Literal + { + short littype; + short lituse; /* usage count */ + long litnum; /* numeric part of the assembler + label for this constant value */ + union { + ftnint litival; + double litdval[2]; + ftnint litival2[2]; /* length, nblanks for strings */ +#ifndef NO_LONG_LONG + Llong litqval; +#endif + } litval; + char *cds[2]; + }; + +extern struct Literal *litpool; +extern int maxliterals, nliterals; +extern unsigned char Letters[]; +#define letter(x) Letters[x] + +struct Dims { expptr lb, ub; }; + +extern int forcedouble; /* force real functions to double */ +extern int doin_setbound; /* special handling for array bounds */ +extern int Ansi; +extern unsigned char hextoi_tab[]; +#define hextoi(x) hextoi_tab[(x) & 0xff] +extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[]; +extern int Castargs, infertypes; +extern FILE *protofile; +extern char binread[], binwrite[], textread[], textwrite[]; +extern char *ei_first, *ei_last, *ei_next; +extern char *wh_first, *wh_last, *wh_next; +extern char *halign, *outbuf, *outbtail; +extern flag keepsubs; +#ifdef TYQUAD +extern flag use_tyquad; +extern unsigned long ff; +#ifndef NO_LONG_LONG +extern flag allow_i8c; +#endif +#endif /*TYQUAD*/ +extern int n_keywords; +extern char *c_keywords[]; + +#ifdef KR_headers +#define Argdcl(x) () +#define Void /* void */ +#else +#define Argdcl(x) x +#define Void void +#endif + +char* Alloc Argdcl((int)); +char* Argtype Argdcl((int, char*)); +void Fatal Argdcl((char*)); +struct Impldoblock* mkiodo Argdcl((chainp, chainp)); +tagptr Inline Argdcl((int, int, chainp)); +struct Labelblock* execlab Argdcl((long)); +struct Labelblock* mklabel Argdcl((long)); +struct Listblock* mklist Argdcl((chainp)); +void Un_link_all Argdcl((int)); +void add_extern_to_list Argdcl((Addrp, chainp*)); +int addressable Argdcl((tagptr)); +tagptr addrof Argdcl((tagptr)); +char* addunder Argdcl((char*)); +void argkludge Argdcl((int*, char***)); +Addrp autovar Argdcl((int, int, tagptr, char*)); +void backup Argdcl((char*, char*)); +void bad_atypes Argdcl((Argtypes*, char*, int, int, int, char*, char*)); +int badchleng Argdcl((tagptr)); +void badop Argdcl((char*, int)); +void badstg Argdcl((char*, int)); +void badtag Argdcl((char*, int)); +void badthing Argdcl((char*, char*, int)); +void badtype Argdcl((char*, int)); +Addrp builtin Argdcl((int, char*, int)); +char* c_name Argdcl((char*, int)); +tagptr call0 Argdcl((int, char*)); +tagptr call1 Argdcl((int, char*, tagptr)); +tagptr call2 Argdcl((int, char*, tagptr, tagptr)); +tagptr call3 Argdcl((int, char*, tagptr, tagptr, tagptr)); +tagptr call4 Argdcl((int, char*, tagptr, tagptr, tagptr, tagptr)); +tagptr callk Argdcl((int, char*, chainp)); +void cast_args Argdcl((int, chainp)); +char* cds Argdcl((char*, char*)); +void changedtype Argdcl((Namep)); +ptr ckalloc Argdcl((int)); +int cktype Argdcl((int, int, int)); +void clf Argdcl((FILEP*, char*, int)); +int cmpstr Argdcl((char*, char*, long, long)); +char* c_type_decl Argdcl((int, int)); +Extsym* comblock Argdcl((char*)); +char* comm_union_name Argdcl((int)); +void consconv Argdcl((int, Constp, Constp)); +void consnegop Argdcl((Constp)); +int conssgn Argdcl((tagptr)); +char* convic Argdcl((long)); +void copy_data Argdcl((chainp)); +char* copyn Argdcl((int, char*)); +char* copys Argdcl((char*)); +tagptr cpblock Argdcl((int, char*)); +tagptr cpexpr Argdcl((tagptr)); +void cpn Argdcl((int, char*, char*)); +char* cpstring Argdcl((char*)); +void dataline Argdcl((char*, long, int)); +char* dataname Argdcl((int, long)); +void dataval Argdcl((tagptr, tagptr)); +void dclerr Argdcl((const char*, Namep)); +void def_commons Argdcl((FILEP)); +void def_start Argdcl((FILEP, char*, char*, char*)); +void deregister Argdcl((Namep)); +void do_uninit_equivs Argdcl((FILEP, ptr)); +void doequiv(Void); +int dofork Argdcl((char*)); +void doinclude Argdcl((char*)); +void doio Argdcl((chainp)); +void done Argdcl((int)); +void donmlist(Void); +int dsort Argdcl((char*, char*)); +char* dtos Argdcl((double)); +void elif_out Argdcl((FILEP, tagptr)); +void end_else_out Argdcl((FILEP)); +void enddcl(Void); +void enddo Argdcl((int)); +void endio(Void); +void endioctl(Void); +void endproc(Void); +void entrypt Argdcl((int, int, long, Extsym*, chainp)); +int eqn Argdcl((int, char*, char*)); +char* equiv_name Argdcl((int, char*)); +void err Argdcl((char*)); +void err66 Argdcl((char*)); +void errext Argdcl((char*)); +void erri Argdcl((char*, int)); +void errl Argdcl((char*, long)); +tagptr errnode(Void); +void errstr Argdcl((const char*, const char*)); +void exarif Argdcl((tagptr, struct Labelblock*, struct Labelblock*, struct Labelblock*)); +void exasgoto Argdcl((Namep)); +void exassign Argdcl((Namep, struct Labelblock*)); +void excall Argdcl((Namep, struct Listblock*, int, struct Labelblock**)); +void exdo Argdcl((int, Namep, chainp)); +void execerr Argdcl((char*, char*)); +void exelif Argdcl((tagptr)); +void exelse(Void); +void exenddo Argdcl((Namep)); +void exendif(Void); +void exequals Argdcl((struct Primblock*, tagptr)); +void exgoto Argdcl((struct Labelblock*)); +void exif Argdcl((tagptr)); +void exreturn Argdcl((tagptr)); +void exstop Argdcl((int, tagptr)); +void extern_out Argdcl((FILEP, Extsym*)); +void fatali Argdcl((char*, int)); +void fatalstr Argdcl((char*, char*)); +void ffilecopy Argdcl((FILEP, FILEP)); +void fileinit(Void); +int fixargs Argdcl((int, struct Listblock*)); +tagptr fixexpr Argdcl((Exprp)); +tagptr fixtype Argdcl((tagptr)); +char* flconst Argdcl((char*, char*)); +void flline(Void); +void fmt_init(Void); +void fmtname Argdcl((Namep, Addrp)); +int fmtstmt Argdcl((struct Labelblock*)); +tagptr fold Argdcl((tagptr)); +void frchain Argdcl((chainp*)); +void frdata Argdcl((chainp)); +void freetemps(Void); +void freqchain Argdcl((struct Equivblock*)); +void frexchain Argdcl((chainp*)); +void frexpr Argdcl((tagptr)); +void frrpl(Void); +void frtemp Argdcl((Addrp)); +char* gmem Argdcl((int, int)); +void hashclear(Void); +chainp hookup Argdcl((chainp, chainp)); +expptr imagpart Argdcl((Addrp)); +void impldcl Argdcl((Namep)); +int in_vector Argdcl((char*, char**, int)); +void incomm Argdcl((Extsym*, Namep)); +void inferdcl Argdcl((Namep, int)); +int inilex Argdcl((char*)); +void initkey(Void); +int inregister Argdcl((Namep)); +long int commlen Argdcl((chainp)); +long int convci Argdcl((int, char*)); +long int iarrlen Argdcl((Namep)); +long int lencat Argdcl((expptr)); +long int lmax Argdcl((long, long)); +long int lmin Argdcl((long, long)); +long int wr_char_len Argdcl((FILEP, struct Dimblock*, ftnint, int)); +Addrp intraddr Argdcl((Namep)); +tagptr intrcall Argdcl((Namep, struct Listblock*, int)); +int intrfunct Argdcl((char*)); +void ioclause Argdcl((int, expptr)); +int iocname(Void); +int is_negatable Argdcl((Constp)); +int isaddr Argdcl((tagptr)); +int isnegative_const Argdcl((Constp)); +int isstatic Argdcl((tagptr)); +chainp length_comp Argdcl((struct Entrypoint*, int)); +int lengtype Argdcl((int, long)); +char* lexline Argdcl((ptr)); +void list_arg_types Argdcl((FILEP, struct Entrypoint*, chainp, int, char*)); +void list_decls Argdcl((FILEP)); +void list_init_data Argdcl((FILE **, char *, FILE *)); +void listargs Argdcl((FILEP, struct Entrypoint*, int, chainp)); +char* lit_name Argdcl((struct Literal*)); +int log_2 Argdcl((long)); +char* lower_string Argdcl((char*, char*)); +int main Argdcl((int, char**)); +expptr make_int_expr Argdcl((expptr)); +void make_param Argdcl((struct Paramblock*, tagptr)); +void many Argdcl((char*, char, int)); +void margin_printf Argdcl((FILEP, const char*, ...)); +int maxtype Argdcl((int, int)); +char* mem Argdcl((int, int)); +void mem_init(Void); +char* memname Argdcl((int, long)); +Addrp memversion Argdcl((Namep)); +tagptr mkaddcon Argdcl((long)); +Addrp mkaddr Argdcl((Namep)); +Addrp mkarg Argdcl((int, int)); +tagptr mkbitcon Argdcl((int, int, char*)); +chainp mkchain Argdcl((char*, chainp)); +Constp mkconst Argdcl((int)); +tagptr mkconv Argdcl((int, tagptr)); +tagptr mkcxcon Argdcl((tagptr, tagptr)); +tagptr mkexpr Argdcl((int, tagptr, tagptr)); +Extsym* mkext Argdcl((char*, char*)); +Extsym* mkext1 Argdcl((char*, char*)); +Addrp mkfield Argdcl((Addrp, char*, int)); +tagptr mkfunct Argdcl((tagptr)); +tagptr mkintcon Argdcl((long)); +tagptr mkintqcon Argdcl((int, char*)); +tagptr mklhs Argdcl((struct Primblock*, int)); +tagptr mklogcon Argdcl((int)); +Namep mkname Argdcl((char*)); +Addrp mkplace Argdcl((Namep)); +tagptr mkprim Argdcl((Namep, struct Listblock*, chainp)); +tagptr mkrealcon Argdcl((int, char*)); +Addrp mkscalar Argdcl((Namep)); +void mkstfunct Argdcl((struct Primblock*, tagptr)); +tagptr mkstrcon Argdcl((int, char*)); +Addrp mktmp Argdcl((int, tagptr)); +Addrp mktmp0 Argdcl((int, tagptr)); +Addrp mktmpn Argdcl((int, int, tagptr)); +void namelist Argdcl((Namep)); +int ncat Argdcl((expptr)); +void negate_const Argdcl((Constp)); +void new_endif(Void); +Extsym* newentry Argdcl((Namep, int)); +long newlabel(Void); +void newproc(Void); +Addrp nextdata Argdcl((long*)); +void nice_printf Argdcl((FILEP, const char*, ...)); +void not_both Argdcl((char*)); +void np_init(Void); +int oneof_stg Argdcl((Namep, int, int)); +int op_assign Argdcl((int)); +tagptr opconv Argdcl((tagptr, int)); +FILEP opf Argdcl((char*, char*)); +void out_addr Argdcl((FILEP, Addrp)); +void out_asgoto Argdcl((FILEP, tagptr)); +void out_call Argdcl((FILEP, int, int, tagptr, tagptr, tagptr)); +void out_const Argdcl((FILEP, Constp)); +void out_else Argdcl((FILEP)); +void out_for Argdcl((FILEP, tagptr, tagptr, tagptr)); +void out_init(Void); +void outbuf_adjust(Void); +void p1_label Argdcl((long)); +void paren_used Argdcl((struct Primblock*)); +void prcona Argdcl((FILEP, long)); +void prconi Argdcl((FILEP, long)); +#ifndef NO_LONG_LONG +void prconq Argdcl((FILEP, Llong)); +#endif +void prconr Argdcl((FILEP, Constp, int)); +void procinit(Void); +void procode Argdcl((FILEP)); +void prolog Argdcl((FILEP, chainp)); +void protowrite Argdcl((FILEP, int, char*, struct Entrypoint*, chainp)); +expptr prune_left_conv Argdcl((expptr)); +int put_one_arg Argdcl((int, char*, char**, char*, char*)); +expptr putassign Argdcl((expptr, expptr)); +Addrp putchop Argdcl((tagptr)); +void putcmgo Argdcl((tagptr, int, struct Labelblock**)); +Addrp putconst Argdcl((Constp)); +tagptr putcxop Argdcl((tagptr)); +void puteq Argdcl((expptr, expptr)); +void putexpr Argdcl((expptr)); +void puthead Argdcl((char*, int)); +void putif Argdcl((tagptr, int)); +void putout Argdcl((tagptr)); +expptr putsteq Argdcl((Addrp, Addrp)); +void putwhile Argdcl((tagptr)); +tagptr putx Argdcl((tagptr)); +void r8fix(Void); +int rdlong Argdcl((FILEP, long*)); +int rdname Argdcl((FILEP, ptr, char*)); +void read_Pfiles Argdcl((char**)); +Addrp realpart Argdcl((Addrp)); +chainp revchain Argdcl((chainp)); +int same_expr Argdcl((tagptr, tagptr)); +int same_ident Argdcl((tagptr, tagptr)); +void save_argtypes Argdcl((chainp, Argtypes**, Argtypes**, int, char*, int, int, int, int)); +void saveargtypes Argdcl((Exprp)); +void set_externs(Void); +void set_tmp_names(Void); +void setbound Argdcl((Namep, int, struct Dims*)); +void setdata Argdcl((Addrp, Constp, long)); +void setext Argdcl((Namep)); +void setfmt Argdcl((struct Labelblock*)); +void setimpl Argdcl((int, long, int, int)); +void setintr Argdcl((Namep)); +void settype Argdcl((Namep, int, long)); +void sigcatch Argdcl((int)); +void sserr Argdcl((Namep)); +void start_formatting(Void); +void startioctl(Void); +void startproc Argdcl((Extsym*, int)); +void startrw(Void); +char* string_num Argdcl((char*, long)); +int struct_eq Argdcl((chainp, chainp)); +tagptr subcheck Argdcl((Namep, tagptr)); +tagptr suboffset Argdcl((struct Primblock*)); +int type_fixup Argdcl((Argtypes*, Atype*, int)); +void unamstring Argdcl((Addrp, char*)); +void unclassifiable(Void); +void vardcl Argdcl((Namep)); +void warn Argdcl((char*)); +void warn1 Argdcl((const char*, const char*)); +void warni Argdcl((char*, int)); +void westart Argdcl((int)); +void wr_abbrevs Argdcl((FILEP, int, chainp)); +char* wr_ardecls Argdcl((FILE*, struct Dimblock*, long)); +void wr_array_init Argdcl((FILEP, int, chainp)); +void wr_common_decls Argdcl((FILEP)); +void wr_equiv_init Argdcl((FILEP, int, chainp*, int)); +void wr_globals Argdcl((FILEP)); +void wr_nv_ident_help Argdcl((FILEP, Addrp)); +void wr_struct Argdcl((FILEP, chainp)); +void wronginf Argdcl((Namep)); +void yyerror Argdcl((char*)); +int yylex(Void); +int yyparse(Void); + +#ifdef USE_DTOA +#define atof(x) strtod(x,0) +void g_fmt Argdcl((char*, double)); +#endif diff --git a/unix/f2c/src/equiv.c b/unix/f2c/src/equiv.c new file mode 100644 index 00000000..bcf07e72 --- /dev/null +++ b/unix/f2c/src/equiv.c @@ -0,0 +1,412 @@ +/**************************************************************** +Copyright 1990, 1993-6, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" + +static void eqvcommon Argdcl((struct Equivblock*, int, long int)); +static void eqveqv Argdcl((int, int, long int)); +static int nsubs Argdcl((struct Listblock*)); + +/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */ + +/* called at end of declarations section to process chains + created by EQUIVALENCE statements + */ + void +doequiv(Void) +{ + register int i; + int inequiv; /* True if one namep occurs in + several EQUIV declarations */ + int comno; /* Index into Extsym table of the last + COMMON block seen (implicitly assuming + that only one will be given) */ + int ovarno; + ftnint comoffset; /* Index into the COMMON block */ + ftnint offset; /* Offset from array base */ + ftnint leng; + register struct Equivblock *equivdecl; + register struct Eqvchain *q; + struct Primblock *primp; + register Namep np; + int k, k1, ns, pref, t; + chainp cp; + extern int type_pref[]; + + for(i = 0 ; i < nequiv ; ++i) + { + +/* Handle each equivalence declaration */ + + equivdecl = &eqvclass[i]; + equivdecl->eqvbottom = equivdecl->eqvtop = 0; + comno = -1; + + + + for(q = equivdecl->equivs ; q ; q = q->eqvnextp) + { + offset = 0; + if (!(primp = q->eqvitem.eqvlhs)) + continue; + vardcl(np = primp->namep); + if(primp->argsp || primp->fcharp) + { + expptr offp; + +/* Pad ones onto the end of an array declaration when needed */ + + if(np->vdim!=NULL && np->vdim->ndim>1 && + nsubs(primp->argsp)==1 ) + { + if(! ftn66flag) + warni + ("1-dim subscript in EQUIVALENCE, %d-dim declared", + np -> vdim -> ndim); + cp = NULL; + ns = np->vdim->ndim; + while(--ns > 0) + cp = mkchain((char *)ICON(1), cp); + primp->argsp->listp->nextp = cp; + } + + offp = suboffset(primp); + if(ISICON(offp)) + offset = offp->constblock.Const.ci; + else { + dclerr + ("nonconstant subscript in equivalence ", + np); + np = NULL; + } + frexpr(offp); + } + +/* Free up the primblock, since we now have a hash table (Namep) entry */ + + frexpr((expptr)primp); + + if(np && (leng = iarrlen(np))<0) + { + dclerr("adjustable in equivalence", np); + np = NULL; + } + + if(np) switch(np->vstg) + { + case STGUNKNOWN: + case STGBSS: + case STGEQUIV: + break; + + case STGCOMMON: + +/* The code assumes that all COMMON references in a given EQUIVALENCE will + be to the same COMMON block, and will all be consistent */ + + comno = np->vardesc.varno; + comoffset = np->voffset + offset; + break; + + default: + dclerr("bad storage class in equivalence", np); + np = NULL; + break; + } + + if(np) + { + q->eqvoffset = offset; + +/* eqvbottom gets the largest difference between the array base address + and the address specified in the EQUIV declaration */ + + equivdecl->eqvbottom = + lmin(equivdecl->eqvbottom, -offset); + +/* eqvtop gets the largest difference between the end of the array and + the address given in the EQUIVALENCE */ + + equivdecl->eqvtop = + lmax(equivdecl->eqvtop, leng-offset); + } + q->eqvitem.eqvname = np; + } + +/* Now all equivalenced variables are in the hash table with the proper + offset, and eqvtop and eqvbottom are set. */ + + if(comno >= 0) + +/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables + */ + + eqvcommon(equivdecl, comno, comoffset); + else for(q = equivdecl->equivs ; q ; q = q->eqvnextp) + { + if(np = q->eqvitem.eqvname) + { + inequiv = NO; + if(np->vstg==STGEQUIV) + if( (ovarno = np->vardesc.varno) == i) + { + +/* Can't EQUIV different elements of the same array */ + + if(np->voffset + q->eqvoffset != 0) + dclerr + ("inconsistent equivalence", np); + } + else { + offset = np->voffset; + inequiv = YES; + } + + np->vstg = STGEQUIV; + np->vardesc.varno = i; + np->voffset = - q->eqvoffset; + + if(inequiv) + +/* Combine 2 equivalence declarations */ + + eqveqv(i, ovarno, q->eqvoffset + offset); + } + } + } + +/* Now each equivalence declaration is distinct (all connections have been + merged in eqveqv()), and some may be empty. */ + + for(i = 0 ; i < nequiv ; ++i) + { + equivdecl = & eqvclass[i]; + if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) { + +/* a live chain */ + + k = TYCHAR; + pref = 1; + for(q = equivdecl->equivs ; q; q = q->eqvnextp) + if ((np = q->eqvitem.eqvname) + && !np->veqvadjust) { + np->veqvadjust = 1; + np->voffset -= equivdecl->eqvbottom; + t = typealign[k1 = np->vtype]; + if (pref < type_pref[k1]) { + k = k1; + pref = type_pref[k1]; + } + if(np->voffset % t != 0) { + dclerr("bad alignment forced by equivalence", np); + --nerr; /* don't give bad return code for this */ + } + } + equivdecl->eqvtype = k; + } + freqchain(equivdecl); + } +} + + + + + +/* put equivalence chain p at common block comno + comoffset */ + + LOCAL void +#ifdef KR_headers +eqvcommon(p, comno, comoffset) + struct Equivblock *p; + int comno; + ftnint comoffset; +#else +eqvcommon(struct Equivblock *p, int comno, ftnint comoffset) +#endif +{ + int ovarno; + ftnint k, offq; + register Namep np; + register struct Eqvchain *q; + + if(comoffset + p->eqvbottom < 0) + { + errstr("attempt to extend common %s backward", + extsymtab[comno].fextname); + freqchain(p); + return; + } + + if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng) + extsymtab[comno].extleng = k; + + + for(q = p->equivs ; q ; q = q->eqvnextp) + if(np = q->eqvitem.eqvname) + { + switch(np->vstg) + { + case STGUNKNOWN: + case STGBSS: + np->vstg = STGCOMMON; + np->vcommequiv = 1; + np->vardesc.varno = comno; + +/* np -> voffset will point to the base of the array */ + + np->voffset = comoffset - q->eqvoffset; + break; + + case STGEQUIV: + ovarno = np->vardesc.varno; + +/* offq will point to the current element, even if it's in an array */ + + offq = comoffset - q->eqvoffset - np->voffset; + np->vstg = STGCOMMON; + np->vcommequiv = 1; + np->vardesc.varno = comno; + +/* np -> voffset will point to the base of the array */ + + np->voffset += offq; + if(ovarno != (p - eqvclass)) + eqvcommon(&eqvclass[ovarno], comno, offq); + break; + + case STGCOMMON: + if(comno != np->vardesc.varno || + comoffset != np->voffset+q->eqvoffset) + dclerr("inconsistent common usage", np); + break; + + + default: + badstg("eqvcommon", np->vstg); + } + } + + freqchain(p); + p->eqvbottom = p->eqvtop = 0; +} + + +/* Move all items on ovarno chain to the front of nvarno chain. + * adjust offsets of ovarno elements and top and bottom of nvarno chain + */ + + LOCAL void +#ifdef KR_headers +eqveqv(nvarno, ovarno, delta) + int nvarno; + int ovarno; + ftnint delta; +#else +eqveqv(int nvarno, int ovarno, ftnint delta) +#endif +{ + register struct Equivblock *neweqv, *oldeqv; + register Namep np; + struct Eqvchain *q, *q1; + + neweqv = eqvclass + nvarno; + oldeqv = eqvclass + ovarno; + neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta); + neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta); + oldeqv->eqvbottom = oldeqv->eqvtop = 0; + + for(q = oldeqv->equivs ; q ; q = q1) + { + q1 = q->eqvnextp; + if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno) + { + q->eqvnextp = neweqv->equivs; + neweqv->equivs = q; + q->eqvoffset += delta; + np->vardesc.varno = nvarno; + np->voffset -= delta; + } + else free( (charptr) q); + } + oldeqv->equivs = NULL; +} + + + + void +#ifdef KR_headers +freqchain(p) + register struct Equivblock *p; +#else +freqchain(register struct Equivblock *p) +#endif +{ + register struct Eqvchain *q, *oq; + + for(q = p->equivs ; q ; q = oq) + { + oq = q->eqvnextp; + free( (charptr) q); + } + p->equivs = NULL; +} + + + + + +/* nsubs -- number of subscripts in this arglist (just the length of the + list) */ + + LOCAL int +#ifdef KR_headers +nsubs(p) + register struct Listblock *p; +#else +nsubs(register struct Listblock *p) +#endif +{ + register int n; + register chainp q; + + n = 0; + if(p) + for(q = p->listp ; q ; q = q->nextp) + ++n; + + return(n); +} + + struct Primblock * +#ifdef KR_headers +primchk(e) expptr e; +#else +primchk(expptr e) +#endif +{ + if (e->headblock.tag != TPRIM) { + err("Invalid name in EQUIVALENCE."); + return 0; + } + return &e->primblock; + } diff --git a/unix/f2c/src/error.c b/unix/f2c/src/error.c new file mode 100644 index 00000000..d0064f03 --- /dev/null +++ b/unix/f2c/src/error.c @@ -0,0 +1,347 @@ +/**************************************************************** +Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" + + void +#ifdef KR_headers +warni(s, t) + char *s; + int t; +#else +warni(char *s, int t) +#endif +{ + char buf[100]; + sprintf(buf,s,t); + warn(buf); + } + + void +#ifdef KR_headers +warn1(s, t) + char *s; + char *t; +#else +warn1(const char *s, const char *t) +#endif +{ + char buff[100]; + sprintf(buff, s, t); + warn(buff); +} + + void +#ifdef KR_headers +warn(s) + char *s; +#else +warn(char *s) +#endif +{ + if(nowarnflag) + return; + if (infname && *infname) + fprintf(diagfile, "Warning on line %ld of %s: %s\n", + lineno, infname, s); + else + fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s); + fflush(diagfile); + ++nwarn; +} + + void +#ifdef KR_headers +errstr(s, t) + char *s; + char *t; +#else +errstr(const char *s, const char *t) +#endif +{ + char buff[100]; + sprintf(buff, s, t); + err(buff); +} + + + void +#ifdef KR_headers +erri(s, t) + char *s; + int t; +#else +erri(char *s, int t) +#endif +{ + char buff[100]; + sprintf(buff, s, t); + err(buff); +} + + void +#ifdef KR_headers +errl(s, t) + char *s; + long t; +#else +errl(char *s, long t) +#endif +{ + char buff[100]; + sprintf(buff, s, t); + err(buff); +} + + char *err_proc = 0; + + void +#ifdef KR_headers +err(s) + char *s; +#else +err(char *s) +#endif +{ + if (err_proc) + fprintf(diagfile, + "Error processing %s before line %ld", + err_proc, lineno); + else + fprintf(diagfile, "Error on line %ld", lineno); + if (infname && *infname) + fprintf(diagfile, " of %s", infname); + fprintf(diagfile, ": %s\n", s); + fflush(diagfile); + ++nerr; +} + + void +#ifdef KR_headers +yyerror(s) + char *s; +#else +yyerror(char *s) +#endif +{ + err(s); +} + + + void +#ifdef KR_headers +dclerr(s, v) + char *s; + Namep v; +#else +dclerr(const char *s, Namep v) +#endif +{ + char buff[100]; + + if(v) + { + sprintf(buff, "Declaration error for %s: %s", v->fvarname, s); + err(buff); + } + else + errstr("Declaration error %s", s); +} + + + void +#ifdef KR_headers +execerr(s, n) + char *s; + char *n; +#else +execerr(char *s, char *n) +#endif +{ + char buf1[100], buf2[100]; + + sprintf(buf1, "Execution error %s", s); + sprintf(buf2, buf1, n); + err(buf2); +} + + + void +#ifdef KR_headers +Fatal(t) + char *t; +#else +Fatal(char *t) +#endif +{ + fprintf(diagfile, "Compiler error line %ld", lineno); + if (infname) + fprintf(diagfile, " of %s", infname); + fprintf(diagfile, ": %s\n", t); + done(3); +} + + + + void +#ifdef KR_headers +fatalstr(t, s) + char *t; + char *s; +#else +fatalstr(char *t, char *s) +#endif +{ + char buff[100]; + sprintf(buff, t, s); + Fatal(buff); +} + + + void +#ifdef KR_headers +fatali(t, d) + char *t; + int d; +#else +fatali(char *t, int d) +#endif +{ + char buff[100]; + sprintf(buff, t, d); + Fatal(buff); +} + + + void +#ifdef KR_headers +badthing(thing, r, t) + char *thing; + char *r; + int t; +#else +badthing(char *thing, char *r, int t) +#endif +{ + char buff[50]; + sprintf(buff, "Impossible %s %d in routine %s", thing, t, r); + Fatal(buff); +} + + + void +#ifdef KR_headers +badop(r, t) + char *r; + int t; +#else +badop(char *r, int t) +#endif +{ + badthing("opcode", r, t); +} + + + void +#ifdef KR_headers +badtag(r, t) + char *r; + int t; +#else +badtag(char *r, int t) +#endif +{ + badthing("tag", r, t); +} + + + + + void +#ifdef KR_headers +badstg(r, t) + char *r; + int t; +#else +badstg(char *r, int t) +#endif +{ + badthing("storage class", r, t); +} + + + + void +#ifdef KR_headers +badtype(r, t) + char *r; + int t; +#else +badtype(char *r, int t) +#endif +{ + badthing("type", r, t); +} + + void +#ifdef KR_headers +many(s, c, n) + char *s; + char c; + int n; +#else +many(char *s, char c, int n) +#endif +{ + char buff[250]; + + sprintf(buff, + "Too many %s.\nTable limit now %d.\nTry rerunning with the -N%c%d option.\n", + s, n, c, 2*n); + Fatal(buff); +} + + void +#ifdef KR_headers +err66(s) + char *s; +#else +err66(char *s) +#endif +{ + errstr("Fortran 77 feature used: %s", s); + --nerr; +} + + + void +#ifdef KR_headers +errext(s) + char *s; +#else +errext(char *s) +#endif +{ + errstr("f2c extension used: %s", s); + --nerr; +} diff --git a/unix/f2c/src/exec.c b/unix/f2c/src/exec.c new file mode 100644 index 00000000..88932222 --- /dev/null +++ b/unix/f2c/src/exec.c @@ -0,0 +1,984 @@ +/**************************************************************** +Copyright 1990, 1993 - 1996, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "p1defs.h" +#include "names.h" + +static void exar2 Argdcl((int, tagptr, struct Labelblock*, struct Labelblock*)); +static void popctl Argdcl((void)); +static void pushctl Argdcl((int)); + +/* Logical IF codes +*/ + + void +#ifdef KR_headers +exif(p) + expptr p; +#else +exif(expptr p) +#endif +{ + pushctl(CTLIF); + putif(p, 0); /* 0 => if, not elseif */ +} + + + void +#ifdef KR_headers +exelif(p) + expptr p; +#else +exelif(expptr p) +#endif +{ + if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) + putif(p, 1); /* 1 ==> elseif */ + else + execerr("elseif out of place", CNULL); +} + + + + + void +exelse(Void) +{ + register struct Ctlframe *c; + + for(c = ctlstack; c->ctltype == CTLIFX; --c); + if(c->ctltype == CTLIF) { + p1_else (); + c->ctltype = CTLELSE; + } + else + execerr("else out of place", CNULL); + } + + void +#ifdef KR_headers +exendif() +#else +exendif() +#endif +{ + while(ctlstack->ctltype == CTLIFX) { + popctl(); + p1else_end(); + } + if(ctlstack->ctltype == CTLIF) { + popctl(); + p1_endif (); + } + else if(ctlstack->ctltype == CTLELSE) { + popctl(); + p1else_end (); + } + else + execerr("endif out of place", CNULL); + } + + + void +#ifdef KR_headers +new_endif() +#else +new_endif() +#endif +{ + if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) + pushctl(CTLIFX); + else + err("new_endif bug"); + } + +/* pushctl -- Start a new control construct, initialize the labels (to + zero) */ + + LOCAL void +#ifdef KR_headers +pushctl(code) + int code; +#else +pushctl(int code) +#endif +{ + register int i; + + if(++ctlstack >= lastctl) + many("loops or if-then-elses", 'c', maxctl); + ctlstack->ctltype = code; + for(i = 0 ; i < 4 ; ++i) + ctlstack->ctlabels[i] = 0; + ctlstack->dowhile = 0; + ctlstack->domax = ctlstack->dostep = 0; /* in case of errors */ + ++blklevel; +} + + + LOCAL void +popctl(Void) +{ + if( ctlstack-- < ctls ) + Fatal("control stack empty"); + --blklevel; +} + + + +/* poplab -- update the flags in labeltab */ + + LOCAL void +poplab(Void) +{ + register struct Labelblock *lp; + + for(lp = labeltab ; lp < highlabtab ; ++lp) + if(lp->labdefined) + { + /* mark all labels in inner blocks unreachable */ + if(lp->blklevel > blklevel) + lp->labinacc = YES; + } + else if(lp->blklevel > blklevel) + { + /* move all labels referred to in inner blocks out a level */ + lp->blklevel = blklevel; + } +} + + +/* BRANCHING CODE +*/ + void +#ifdef KR_headers +exgoto(lab) + struct Labelblock *lab; +#else +exgoto(struct Labelblock *lab) +#endif +{ + lab->labused = 1; + p1_goto (lab -> stateno); +} + + + static expptr +#ifdef KR_headers +cktype1(p) expptr p; +#else +cktype1(expptr p) +#endif +{ + /* Do things omitted because we might have been parsing a */ + /* statement function... Check types and fold constants. */ + + chainp c; + tagptr t; + + if(p == 0) + return(0); + + switch(p->tag) { + case TCONST: + case TADDR: + case TERROR: + break; + +/* This case means that fixexpr can't call fixtype with any expr, + only a subexpr of its parameter. */ + + case TEXPR: + t = mkexpr(p->exprblock.opcode, cktype1(p->exprblock.leftp), + cktype1(p->exprblock.rightp)); + free((charptr)p); + p = (expptr) t; + break; + + case TLIST: + for(c = p->listblock.listp; c; c = c->nextp) + c->datap = (char*)cktype1((expptr)c->datap); + break; + + case TPRIM: + p->primblock.argsp = (struct Listblock*) + cktype1((expptr)p->primblock.argsp); + p->primblock.fcharp = cktype1(p->primblock.fcharp); + p->primblock.lcharp = cktype1(p->primblock.lcharp); + break; + + default: + badtag("cktype1", p->tag); + } + return p; + } + + + void +#ifdef KR_headers +exequals(lp, rp) + register struct Primblock *lp; + register expptr rp; +#else +exequals(register struct Primblock *lp, register expptr rp) +#endif +{ + if(lp->tag != TPRIM) + { + err("assignment to a non-variable"); + frexpr((expptr)lp); + frexpr(rp); + } + else if(lp->namep->vclass!=CLVAR && lp->argsp) + { + if(parstate >= INEXEC) + errstr("statement function %.62s amid executables.", + lp->namep->fvarname); + mkstfunct(lp, rp); + } + else if (lp->vtype == TYSUBR) + err("illegal use of subroutine name"); + else + { + expptr new_lp, new_rp; + + if(parstate < INDATA) { + enddcl(); + lp = (struct Primblock *)cktype1((expptr)lp); + rp = cktype1(rp); + } + new_lp = mklhs (lp, keepsubs); + new_rp = fixtype (rp); + puteq(new_lp, new_rp); + } +} + + + +/* Make Statement Function */ + +long laststfcn = -1, thisstno; +int doing_stmtfcn; + + void +#ifdef KR_headers +mkstfunct(lp, rp) + struct Primblock *lp; + expptr rp; +#else +mkstfunct(struct Primblock *lp, expptr rp) +#endif +{ + register struct Primblock *p; + register Namep np; + chainp args; + + laststfcn = thisstno; + np = lp->namep; + if(np->vclass == CLUNKNOWN) + np->vclass = CLPROC; + else + { + dclerr("redeclaration of statement function", np); + return; + } + np->vprocclass = PSTFUNCT; + np->vstg = STGSTFUNCT; + +/* Set the type of the function */ + + impldcl(np); + if (np->vtype == TYCHAR && !np->vleng) + err("character statement function with length (*)"); + args = (lp->argsp ? lp->argsp->listp : CHNULL); + np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp); + + for(doing_stmtfcn = 1 ; args ; args = args->nextp) + +/* It is an error for the formal parameters to have arguments or + subscripts */ + + if( ((tagptr)(args->datap))->tag!=TPRIM || + (p = (struct Primblock *)(args->datap) )->argsp || + p->fcharp || p->lcharp ) { + err("non-variable argument in statement function definition"); + args->datap = 0; + } + else + { + +/* Replace the name on the left-hand side */ + + args->datap = (char *)p->namep; + vardcl(p -> namep); + free((char *)p); + } + doing_stmtfcn = 0; +} + + static void +#ifdef KR_headers +mixed_type(np) + Namep np; +#else +mixed_type(Namep np) +#endif +{ + char buf[128]; + sprintf(buf, "%s function %.90s invoked as subroutine", + ftn_types[np->vtype], np->fvarname); + warn(buf); + } + + void +#ifdef KR_headers +excall(name, args, nstars, labels) + Namep name; + struct Listblock *args; + int nstars; + struct Labelblock **labels; +#else +excall(Namep name, struct Listblock *args, int nstars, struct Labelblock **labels) +#endif +{ + register expptr p; + + if (name->vtype != TYSUBR) { + if (name->vinfproc && !name->vcalled) { + name->vtype = TYSUBR; + frexpr(name->vleng); + name->vleng = 0; + } + else if (!name->vimpltype && name->vtype != TYUNKNOWN) + mixed_type(name); + else + settype(name, TYSUBR, (ftnint)0); + } + p = mkfunct( mkprim(name, args, CHNULL) ); + if (p->tag == TERROR) + return; + +/* Subroutines and their identifiers acquire the type INT */ + + p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT; + +/* Handle the alternate return mechanism */ + + if(nstars > 0) + putcmgo(putx(fixtype(p)), nstars, labels); + else + putexpr(p); +} + + + void +#ifdef KR_headers +exstop(stop, p) + int stop; + register expptr p; +#else +exstop(int stop, register expptr p) +#endif +{ + char *str; + int n; + + if(p) + { + if( ! ISCONST(p) ) + { + execerr("pause/stop argument must be constant", CNULL); + frexpr(p); + p = mkstrcon(0, CNULL); + } + else if( ISINT(p->constblock.vtype) ) + { + str = convic(p->constblock.Const.ci); + n = strlen(str); + if(n > 0) + { + p->constblock.Const.ccp = copyn(n, str); + p->constblock.Const.ccp1.blanks = 0; + p->constblock.vtype = TYCHAR; + p->constblock.vleng = (expptr) ICON(n); + } + else + p = (expptr) mkstrcon(0, CNULL); + } + else if(p->constblock.vtype != TYCHAR) + { + execerr("pause/stop argument must be integer or string", CNULL); + p = (expptr) mkstrcon(0, CNULL); + } + } + else p = (expptr) mkstrcon(0, CNULL); + + { + expptr subr_call; + + subr_call = call1(TYSUBR, (char*)(stop ? "s_stop" : "s_paus"), p); + putexpr( subr_call ); + } +} + +/* DO LOOP CODE */ + +#define DOINIT par[0] +#define DOLIMIT par[1] +#define DOINCR par[2] + + +/* Macros for ctlstack -> dostepsign */ + +#define VARSTEP 0 +#define POSSTEP 1 +#define NEGSTEP 2 + + +/* exdo -- generate DO loop code. In the case of a variable increment, + positive increment tests are placed above the body, negative increment + tests are placed below (see enddo() ) */ + + void +#ifdef KR_headers +exdo(range, loopname, spec) + int range; + Namep loopname; + chainp spec; +#else +exdo(int range, Namep loopname, chainp spec) +#endif + /* range = end label */ + /* input spec must have at least 2 exprs */ +{ + register expptr p; + register Namep np; + chainp cp; /* loops over the fields in spec */ + register int i; + int dotype; /* type of the index variable */ + int incsign; /* sign of the increment, if it's constant + */ + Addrp dovarp; /* loop index variable */ + expptr doinit; /* constant or register for init param */ + expptr par[3]; /* local specification parameters */ + + expptr init, test, inc; /* Expressions in the resulting FOR loop */ + + + test = ENULL; + + pushctl(CTLDO); + dorange = ctlstack->dolabel = range; + ctlstack->loopname = loopname; + +/* Declare the loop index */ + + np = (Namep)spec->datap; + ctlstack->donamep = NULL; + if (!np) { /* do while */ + ctlstack->dowhile = 1; +#if 0 + if (loopname) { + if (loopname->vtype == TYUNKNOWN) { + loopname->vdcldone = 1; + loopname->vclass = CLLABEL; + loopname->vprocclass = PLABEL; + loopname->vtype = TYLABEL; + } + if (loopname->vtype == TYLABEL) + if (loopname->vdovar) + dclerr("already in use as a loop name", + loopname); + else + loopname->vdovar = 1; + else + dclerr("already declared; cannot be a loop name", + loopname); + } +#endif + putwhile((expptr)spec->nextp); + NOEXT("do while"); + spec->nextp = 0; + frchain(&spec); + return; + } + if(np->vdovar) + { + errstr("nested loops with variable %s", np->fvarname); + ctlstack->donamep = NULL; + return; + } + +/* Create a memory-resident version of the index variable */ + + dovarp = mkplace(np); + if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) ) + { + err("bad type on do variable"); + return; + } + ctlstack->donamep = np; + + np->vdovar = YES; + +/* Now dovarp points to the index to be used within the loop, dostgp + points to the one which may need to be stored */ + + dotype = dovarp->vtype; + +/* Count the input specifications and type-check each one independently; + this just eliminates non-numeric values from the specification */ + + for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp) + { + p = par[i++] = fixtype((tagptr)cp->datap); + if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) ) + { + err("bad type on DO parameter"); + return; + } + } + + frchain(&spec); + switch(i) + { + case 0: + case 1: + err("too few DO parameters"); + return; + + default: + err("too many DO parameters"); + return; + + case 2: + DOINCR = (expptr) ICON(1); + + case 3: + break; + } + + +/* Now all of the local specification fields are set, but their types are + not yet consistent */ + +/* Declare the loop initialization value, casting it properly and declaring a + register if need be */ + + ctlstack->doinit = 0; + if (ISCONST (DOINIT) || !onetripflag) +/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it + since mkconv is called just before */ + doinit = putx (mkconv (dotype, DOINIT)); + else { + if (onetripflag) + ctlstack->doinit = doinit = (expptr) mktmp0(dotype, ENULL); + else + doinit = (expptr) mktmp(dotype, ENULL); + puteq (cpexpr (doinit), DOINIT); + } /* else */ + +/* Declare the loop ending value, casting it to the type of the index + variable */ + + if( ISCONST(DOLIMIT) ) + ctlstack->domax = mkconv(dotype, DOLIMIT); + else { + ctlstack->domax = (expptr) mktmp0(dotype, ENULL); + puteq (cpexpr (ctlstack -> domax), DOLIMIT); + } /* else */ + +/* Declare the loop increment value, casting it to the type of the index + variable */ + + if( ISCONST(DOINCR) ) + { + ctlstack->dostep = mkconv(dotype, DOINCR); + if( (incsign = conssgn(ctlstack->dostep)) == 0) + err("zero DO increment"); + ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP); + } + else + { + ctlstack->dostep = (expptr) mktmp0(dotype, ENULL); + ctlstack->dostepsign = VARSTEP; + puteq (cpexpr (ctlstack -> dostep), DOINCR); + } + +/* All data is now properly typed and in the ctlstack, except for the + initial value. Assignments of temps have been generated already */ + + switch (ctlstack -> dostepsign) { + case VARSTEP: + test = mkexpr (OPQUEST, mkexpr (OPLT, + cpexpr (ctlstack -> dostep), ICON(0)), + mkexpr (OPCOLON, + mkexpr (OPGE, cpexpr((expptr)dovarp), + cpexpr (ctlstack -> domax)), + mkexpr (OPLE, cpexpr((expptr)dovarp), + cpexpr (ctlstack -> domax)))); + break; + case POSSTEP: + test = mkexpr (OPLE, cpexpr((expptr)dovarp), + cpexpr (ctlstack -> domax)); + break; + case NEGSTEP: + test = mkexpr (OPGE, cpexpr((expptr)dovarp), + cpexpr (ctlstack -> domax)); + break; + default: + erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign); + break; + } /* switch (ctlstack -> dostepsign) */ + + if (onetripflag) + test = mkexpr (OPOR, test, + mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit))); + init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), + ctlstack->doinit ? cpexpr(doinit) : doinit); + inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep)); + + if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit) + && ctlstack -> dostepsign != VARSTEP) { + expptr tester; + + tester = mkexpr (OPMINUS, cpexpr (doinit), + cpexpr (ctlstack -> domax)); + if (incsign == conssgn (tester)) + warn ("DO range never executed"); + frexpr (tester); + } /* if !onetripflag && */ + + p1_for (init, test, inc); +} + + void +#ifdef KR_headers +exenddo(np) + Namep np; +#else +exenddo(Namep np) +#endif +{ + Namep np1; + int here; + struct Ctlframe *cf; + + if( ctlstack < ctls ) + goto misplaced; + here = ctlstack->dolabel; + if (ctlstack->ctltype != CTLDO + || here >= 0 && (!thislabel || thislabel->labelno != here)) { + misplaced: + err("misplaced ENDDO"); + return; + } + if (np != ctlstack->loopname) { + if (np1 = ctlstack->loopname) + errstr("expected \"enddo %s\"", np1->fvarname); + else + err("expected unnamed ENDDO"); + for(cf = ctls; cf < ctlstack; cf++) + if (cf->ctltype == CTLDO && cf->loopname == np) { + here = cf->dolabel; + break; + } + } + enddo(here); + } + + void +#ifdef KR_headers +enddo(here) + int here; +#else +enddo(int here) +#endif +{ + register struct Ctlframe *q; + Namep np; /* name of the current DO index */ + Addrp ap; + register int i; + register expptr e; + +/* Many DO's can end at the same statement, so keep looping over all + nested indicies */ + + while(here == dorange) + { + if(np = ctlstack->donamep) + { + p1for_end (); + +/* Now we're done with all of the tests, and the loop has terminated. + Store the index value back in long-term memory */ + + if(ap = memversion(np)) + puteq((expptr)ap, (expptr)mkplace(np)); + for(i = 0 ; i < 4 ; ++i) + ctlstack->ctlabels[i] = 0; + deregister(ctlstack->donamep); + ctlstack->donamep->vdovar = NO; + /* ctlstack->dostep and ctlstack->domax can be zero */ + /* with sufficiently bizarre (erroneous) syntax */ + if (e = ctlstack->dostep) + if (e->tag == TADDR && e->addrblock.istemp) + frtemp((Addrp)e); + else + frexpr(e); + if (e = ctlstack->domax) + if (e->tag == TADDR && e->addrblock.istemp) + frtemp((Addrp)e); + else + frexpr(e); + if (e = ctlstack->doinit) + frtemp((Addrp)e); + } + else if (ctlstack->dowhile) + p1for_end (); + +/* Set dorange to the closing label of the next most enclosing DO loop + */ + + popctl(); + poplab(); + dorange = 0; + for(q = ctlstack ; q>=ctls ; --q) + if(q->ctltype == CTLDO) + { + dorange = q->dolabel; + break; + } + } +} + + void +#ifdef KR_headers +exassign(vname, labelval) + register Namep vname; + struct Labelblock *labelval; +#else +exassign(register Namep vname, struct Labelblock *labelval) +#endif +{ + Addrp p; + register Addrp q; + char *fs; + register chainp cp, cpprev; + register ftnint k, stno; + + p = mkplace(vname); + if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) { + err("noninteger assign variable"); + return; + } + + /* If the label hasn't been defined, then we do things twice: + * once for an executable stmt label, once for a format + */ + + /* code for executable label... */ + +/* Now store the assigned value in a list associated with this variable. + This will be used later to generate a switch() statement in the C output */ + + fs = labelval->fmtstring; + if (!labelval->labdefined || !fs) { + + if (vname -> vis_assigned == 0) { + vname -> varxptr.assigned_values = CHNULL; + vname -> vis_assigned = 1; + } + + /* don't duplicate labels... */ + + stno = labelval->stateno; + cpprev = 0; + for(k = 0, cp = vname->varxptr.assigned_values; + cp; cpprev = cp, cp = cp->nextp, k++) + if ((ftnint)cp->datap == stno) + break; + if (!cp) { + cp = mkchain((char *)stno, CHNULL); + if (cpprev) + cpprev->nextp = cp; + else + vname->varxptr.assigned_values = cp; + labelval->labused = 1; + } + putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k))); + } + + /* Code for FORMAT label... */ + + if (!labelval->labdefined || fs) { + + labelval->fmtlabused = 1; + p = ALLOC(Addrblock); + p->tag = TADDR; + p->vtype = TYCHAR; + p->vstg = STGAUTO; + p->memoffset = ICON(0); + fmtname(vname, p); + q = ALLOC(Addrblock); + q->tag = TADDR; + q->vtype = TYCHAR; + q->vstg = STGAUTO; + q->ntempelt = 1; + q->memoffset = ICON(0); + q->uname_tag = UNAM_IDENT; + sprintf(q->user.ident, "fmt_%ld", labelval->stateno); + putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q)); + } + +} /* exassign */ + + + void +#ifdef KR_headers +exarif(expr, neglab, zerlab, poslab) + expptr expr; + struct Labelblock *neglab; + struct Labelblock *zerlab; + struct Labelblock *poslab; +#else +exarif(expptr expr, struct Labelblock *neglab, struct Labelblock *zerlab, struct Labelblock *poslab) +#endif +{ + ftnint lm, lz, lp; + + lm = neglab->stateno; + lz = zerlab->stateno; + lp = poslab->stateno; + expr = fixtype(expr); + + if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) ) + { + err("invalid type of arithmetic if expression"); + frexpr(expr); + } + else + { + if (lm == lz && lz == lp) + exgoto (neglab); + else if(lm == lz) + exar2(OPLE, expr, neglab, poslab); + else if(lm == lp) + exar2(OPNE, expr, neglab, zerlab); + else if(lz == lp) + exar2(OPGE, expr, zerlab, neglab); + else { + expptr t; + + if (!addressable (expr)) { + t = (expptr) mktmp(expr -> headblock.vtype, ENULL); + expr = mkexpr (OPASSIGN, cpexpr (t), expr); + } else + t = (expptr) cpexpr (expr); + + p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0))))); + exgoto(neglab); + p1_elif (mkexpr (OPEQ, t, ICON (0))); + exgoto(zerlab); + p1_else (); + exgoto(poslab); + p1else_end (); + } /* else */ + } +} + + + +/* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0) + goto l2 else goto l1. If this seems backwards, that's because it is, + in order to make the 1 pass algorithm work. */ + + LOCAL void +#ifdef KR_headers +exar2(op, e, l1, l2) + int op; + expptr e; + struct Labelblock *l1; + struct Labelblock *l2; +#else +exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2) +#endif +{ + expptr comp; + + comp = mkexpr (op, e, ICON (0)); + p1_if(putx(fixtype(comp))); + exgoto(l1); + p1_else (); + exgoto(l2); + p1else_end (); +} + + +/* exreturn -- return the value in p from a SUBROUTINE call -- used to + implement the alternate return mechanism */ + + void +#ifdef KR_headers +exreturn(p) + register expptr p; +#else +exreturn(register expptr p) +#endif +{ + if(procclass != CLPROC) + warn("RETURN statement in main or block data"); + if(p && (proctype!=TYSUBR || procclass!=CLPROC) ) + { + err("alternate return in nonsubroutine"); + p = 0; + } + + if (p || proctype == TYSUBR) { + if (p == ENULL) p = ICON (0); + p = mkconv (TYLONG, fixtype (p)); + p1_subr_ret (p); + } /* if p || proctype == TYSUBR */ + else + p1_subr_ret((expptr)retslot); +} + + + void +#ifdef KR_headers +exasgoto(labvar) + Namep labvar; +#else +exasgoto(Namep labvar) +#endif +{ + register Addrp p; + + p = mkplace(labvar); + if( ! ISINT(p->vtype) ) + err("assigned goto variable must be integer"); + else { + p1_asgoto (p); + } /* else */ +} diff --git a/unix/f2c/src/expr.c b/unix/f2c/src/expr.c new file mode 100644 index 00000000..d9f86c0f --- /dev/null +++ b/unix/f2c/src/expr.c @@ -0,0 +1,3738 @@ +/**************************************************************** +Copyright 1990 - 1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "output.h" +#include "names.h" + +typedef struct { double dreal, dimag; } dcomplex; + +static void consbinop Argdcl((int, int, Constp, Constp, Constp)); +static void conspower Argdcl((Constp, Constp, long int)); +static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*)); +static tagptr mkpower Argdcl((tagptr)); +static tagptr stfcall Argdcl((Namep, struct Listblock*)); + +extern char dflttype[26]; +extern int htype; + +/* little routines to create constant blocks */ + + Constp +#ifdef KR_headers +mkconst(t) + int t; +#else +mkconst(int t) +#endif +{ + Constp p; + + p = ALLOC(Constblock); + p->tag = TCONST; + p->vtype = t; + return(p); +} + + +/* mklogcon -- Make Logical Constant */ + + expptr +#ifdef KR_headers +mklogcon(l) + int l; +#else +mklogcon(int l) +#endif +{ + Constp p; + + p = mkconst(tylog); + p->Const.ci = l; + return( (expptr) p ); +} + + + +/* mkintcon -- Make Integer Constant */ + + expptr +#ifdef KR_headers +mkintcon(l) + ftnint l; +#else +mkintcon(ftnint l) +#endif +{ + Constp p; + + p = mkconst(tyint); + p->Const.ci = l; + return( (expptr) p ); +} + + + + +/* mkaddcon -- Make Address Constant, given integer value */ + + expptr +#ifdef KR_headers +mkaddcon(l) + long l; +#else +mkaddcon(long l) +#endif +{ + Constp p; + + p = mkconst(TYADDR); + p->Const.ci = l; + return( (expptr) p ); +} + + + +/* mkrealcon -- Make Real Constant. The type t is assumed + to be TYREAL or TYDREAL */ + + expptr +#ifdef KR_headers +mkrealcon(t, d) + int t; + char *d; +#else +mkrealcon(int t, char *d) +#endif +{ + Constp p; + + p = mkconst(t); + p->Const.cds[0] = cds(d,CNULL); + p->vstg = 1; + return( (expptr) p ); +} + + +/* mkbitcon -- Make bit constant. Reads the input string, which is + assumed to correctly specify a number in base 2^shift (where shift + is the input parameter). shift may not exceed 4, i.e. only binary, + quad, octal and hex bases may be input. */ + + expptr +#ifdef KR_headers +mkbitcon(shift, leng, s) + int shift; + int leng; + char *s; +#else +mkbitcon(int shift, int leng, char *s) +#endif +{ + Constp p; + unsigned long m, ovfl, x, y, z; + int L32, len; + char buff[100], *s0 = s; +#ifndef NO_LONG_LONG + ULlong u; +#endif + static char *kind[3] = { "Binary", "Hex", "Octal" }; + + p = mkconst(TYLONG); + /* Song and dance to convert to TYQUAD only if ftnint is too small. */ + m = x = y = ovfl = 0; + /* Older C compilers may not know about */ + /* UL suffixes on hex constants... */ + while(--leng >= 0) + if(*s != ' ') { + if (!m) { + z = x; + x = ((x << shift) | hextoi(*s++)) & ff; + if (!((x >> shift) - z)) + continue; + m = (ff << (L32 = 32 - shift)) & ff; + --s; + x = z; + } + ovfl |= y & m; + y = y << shift | (x >> L32); + x = ((x << shift) | hextoi(*s++)) & ff; + } + /* Don't change the type to short for short constants, as + * that is dangerous -- there is no syntax for long constants + * with small values. + */ + p->Const.ci = (ftnint)x; +#ifndef NO_LONG_LONG + if (m) { + if (allow_i8c) { + u = y; + p->Const.ucq = (u << 32) | x; + p->vtype = TYQUAD; + } + else + ovfl = 1; + } +#else + ovfl |= m; +#endif + if (ovfl) { + if (--shift == 3) + shift = 1; + if ((len = (int)leng) > 60) + sprintf(buff, "%s constant '%.60s' truncated.", + kind[shift], s0); + else + sprintf(buff, "%s constant '%.*s' truncated.", + kind[shift], len, s0); + err(buff); + } + return( (expptr) p ); +} + + + + + +/* mkstrcon -- Make string constant. Allocates storage and initializes + the memory for a copy of the input Fortran-string. */ + + expptr +#ifdef KR_headers +mkstrcon(l, v) + int l; + char *v; +#else +mkstrcon(int l, char *v) +#endif +{ + Constp p; + char *s; + + p = mkconst(TYCHAR); + p->vleng = ICON(l); + p->Const.ccp = s = (char *) ckalloc(l+1); + p->Const.ccp1.blanks = 0; + while(--l >= 0) + *s++ = *v++; + *s = '\0'; + return( (expptr) p ); +} + + + +/* mkcxcon -- Make complex contsant. A complex number is a pair of + values, each of which may be integer, real or double. */ + + expptr +#ifdef KR_headers +mkcxcon(realp, imagp) + expptr realp; + expptr imagp; +#else +mkcxcon(expptr realp, expptr imagp) +#endif +{ + int rtype, itype; + Constp p; + + rtype = realp->headblock.vtype; + itype = imagp->headblock.vtype; + + if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) + { + p = mkconst( (rtype==TYDREAL||itype==TYDREAL) + ? TYDCOMPLEX : tycomplex); + if (realp->constblock.vstg || imagp->constblock.vstg) { + p->vstg = 1; + p->Const.cds[0] = ISINT(rtype) + ? string_num("", realp->constblock.Const.ci) + : realp->constblock.vstg + ? realp->constblock.Const.cds[0] + : dtos(realp->constblock.Const.cd[0]); + p->Const.cds[1] = ISINT(itype) + ? string_num("", imagp->constblock.Const.ci) + : imagp->constblock.vstg + ? imagp->constblock.Const.cds[0] + : dtos(imagp->constblock.Const.cd[0]); + } + else { + p->Const.cd[0] = ISINT(rtype) + ? realp->constblock.Const.ci + : realp->constblock.Const.cd[0]; + p->Const.cd[1] = ISINT(itype) + ? imagp->constblock.Const.ci + : imagp->constblock.Const.cd[0]; + } + } + else + { + err("invalid complex constant"); + p = (Constp)errnode(); + } + + frexpr(realp); + frexpr(imagp); + return( (expptr) p ); +} + + +/* errnode -- Allocate a new error block */ + + expptr +errnode(Void) +{ + struct Errorblock *p; + p = ALLOC(Errorblock); + p->tag = TERROR; + p->vtype = TYERROR; + return( (expptr) p ); +} + + + + + +/* mkconv -- Make type conversion. Cast expression p into type t. + Note that casting to a character copies only the first sizeof(char) + bytes. */ + + expptr +#ifdef KR_headers +mkconv(t, p) + int t; + expptr p; +#else +mkconv(int t, expptr p) +#endif +{ + expptr q; + int pt, charwarn = 1; + + if (t >= 100) { + t -= 100; + charwarn = 0; + } + if(t==TYUNKNOWN || t==TYERROR) + badtype("mkconv", t); + pt = p->headblock.vtype; + +/* Casting to the same type is a no-op */ + + if(t == pt) + return(p); + +/* If we're casting a constant which is not in the literal table ... */ + + else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR + || p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST) + { +#ifndef NO_LONG_LONG + if (t != TYQUAD && pt != TYQUAD) /*20010820*/ +#endif + if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) { + /* avoid trouble with -i2 */ + p->headblock.vtype = t; + return p; + } + q = (expptr) mkconst(t); + consconv(t, &q->constblock, &p->constblock ); + if (p->tag == TADDR) + q->constblock.vstg = p->addrblock.user.kludge.vstg1; + frexpr(p); + } + else { + if (pt == TYCHAR && t != TYADDR && charwarn + && (!halign || p->tag != TADDR + || p->addrblock.uname_tag != UNAM_CONST)) + warn( + "ichar([first char. of] char. string) assumed for conversion to numeric"); + q = opconv(p, t); + } + + if(t == TYCHAR) + q->constblock.vleng = ICON(1); + return(q); +} + + + +/* opconv -- Convert expression p to type t using the main + expression evaluator; returns an OPCONV expression, I think 14-jun-88 mwm */ + + expptr +#ifdef KR_headers +opconv(p, t) + expptr p; + int t; +#else +opconv(expptr p, int t) +#endif +{ + expptr q; + + if (t == TYSUBR) + err("illegal use of subroutine name"); + q = mkexpr(OPCONV, p, ENULL); + q->headblock.vtype = t; + return(q); +} + + + +/* addrof -- Create an ADDR expression operation */ + + expptr +#ifdef KR_headers +addrof(p) + expptr p; +#else +addrof(expptr p) +#endif +{ + return( mkexpr(OPADDR, p, ENULL) ); +} + + + +/* cpexpr - Returns a new copy of input expression p */ + + tagptr +#ifdef KR_headers +cpexpr(p) + tagptr p; +#else +cpexpr(tagptr p) +#endif +{ + tagptr e; + int tag; + chainp ep, pp; + +/* This table depends on the ordering of the T macros, e.g. TNAME */ + + static int blksize[ ] = + { + 0, + sizeof(struct Nameblock), + sizeof(struct Constblock), + sizeof(struct Exprblock), + sizeof(struct Addrblock), + sizeof(struct Primblock), + sizeof(struct Listblock), + sizeof(struct Impldoblock), + sizeof(struct Errorblock) + }; + + if(p == NULL) + return(NULL); + +/* TNAMEs are special, and don't get copied. Each name in the current + symbol table has a unique TNAME structure. */ + + if( (tag = p->tag) == TNAME) + return(p); + + e = cpblock(blksize[p->tag], (char *)p); + + switch(tag) + { + case TCONST: + if(e->constblock.vtype == TYCHAR) + { + e->constblock.Const.ccp = + copyn((int)e->constblock.vleng->constblock.Const.ci+1, + e->constblock.Const.ccp); + e->constblock.vleng = + (expptr) cpexpr(e->constblock.vleng); + } + case TERROR: + break; + + case TEXPR: + e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp); + e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp); + break; + + case TLIST: + if(pp = p->listblock.listp) + { + ep = e->listblock.listp = + mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL); + for(pp = pp->nextp ; pp ; pp = pp->nextp) + ep = ep->nextp = + mkchain((char *)cpexpr((tagptr)pp->datap), + CHNULL); + } + break; + + case TADDR: + e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng); + e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset); + e->addrblock.istemp = NO; + break; + + case TPRIM: + e->primblock.argsp = (struct Listblock *) + cpexpr((expptr)e->primblock.argsp); + e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp); + e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp); + break; + + default: + badtag("cpexpr", tag); + } + + return(e); +} + +/* frexpr -- Free expression -- frees up memory used by expression p */ + + void +#ifdef KR_headers +frexpr(p) + tagptr p; +#else +frexpr(tagptr p) +#endif +{ + chainp q; + + if(p == NULL) + return; + + switch(p->tag) + { + case TCONST: + if( ISCHAR(p) ) + { + free( (charptr) (p->constblock.Const.ccp) ); + frexpr(p->constblock.vleng); + } + break; + + case TADDR: + if (p->addrblock.vtype > TYERROR) /* i/o block */ + break; + frexpr(p->addrblock.vleng); + frexpr(p->addrblock.memoffset); + break; + + case TERROR: + break; + +/* TNAME blocks don't get free'd - probably because they're pointed to in + the hash table. 14-Jun-88 -- mwm */ + + case TNAME: + return; + + case TPRIM: + frexpr((expptr)p->primblock.argsp); + frexpr(p->primblock.fcharp); + frexpr(p->primblock.lcharp); + break; + + case TEXPR: + frexpr(p->exprblock.leftp); + if(p->exprblock.rightp) + frexpr(p->exprblock.rightp); + break; + + case TLIST: + for(q = p->listblock.listp ; q ; q = q->nextp) + frexpr((tagptr)q->datap); + frchain( &(p->listblock.listp) ); + break; + + default: + badtag("frexpr", p->tag); + } + + free( (charptr) p ); +} + + void +#ifdef KR_headers +wronginf(np) + Namep np; +#else +wronginf(Namep np) +#endif +{ + int c; + ftnint k; + warn1("fixing wrong type inferred for %.65s", np->fvarname); + np->vinftype = 0; + c = letter(np->fvarname[0]); + if ((np->vtype = impltype[c]) == TYCHAR + && (k = implleng[c])) + np->vleng = ICON(k); + } + +/* fix up types in expression; replace subtrees and convert + names to address blocks */ + + expptr +#ifdef KR_headers +fixtype(p) + tagptr p; +#else +fixtype(tagptr p) +#endif +{ + + if(p == 0) + return(0); + + switch(p->tag) + { + case TCONST: + if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR| + MSKREAL) ) + return( (expptr) p); + + return( (expptr) putconst((Constp)p) ); + + case TADDR: + p->addrblock.memoffset = fixtype(p->addrblock.memoffset); + return( (expptr) p); + + case TERROR: + return( (expptr) p); + + default: + badtag("fixtype", p->tag); + +/* This case means that fixexpr can't call fixtype with any expr, + only a subexpr of its parameter. */ + + case TEXPR: + if (((Exprp)p)->typefixed) + return (expptr)p; + return( fixexpr((Exprp)p) ); + + case TLIST: + return( (expptr) p ); + + case TPRIM: + if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR) + { + if(p->primblock.namep->vtype == TYSUBR) + { + err("function invocation of subroutine"); + return( errnode() ); + } + else { + if (p->primblock.namep->vinftype) + wronginf(p->primblock.namep); + return( mkfunct(p) ); + } + } + +/* The lack of args makes p a function name, substring reference + or variable name. */ + + else return mklhs((struct Primblock *) p, keepsubs); + } +} + + + int +#ifdef KR_headers +badchleng(p) + expptr p; +#else +badchleng(expptr p) +#endif +{ + if (!p->headblock.vleng) { + if (p->headblock.tag == TADDR + && p->addrblock.uname_tag == UNAM_NAME) + errstr("bad use of character*(*) variable %.60s", + p->addrblock.user.name->fvarname); + else + err("Bad use of character*(*)"); + return 1; + } + return 0; + } + + + static expptr +#ifdef KR_headers +cplenexpr(p) + expptr p; +#else +cplenexpr(expptr p) +#endif +{ + expptr rv; + + if (badchleng(p)) + return ICON(1); + rv = cpexpr(p->headblock.vleng); + if (ISCONST(p) && p->constblock.vtype == TYCHAR) + rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks; + return rv; + } + + +/* special case tree transformations and cleanups of expression trees. + Parameter p should have a TEXPR tag at its root, else an error is + returned */ + + expptr +#ifdef KR_headers +fixexpr(p) + Exprp p; +#else +fixexpr(Exprp p) +#endif +{ + expptr lp, rp, q; + char *hsave; + int opcode, ltype, rtype, ptype, mtype; + + if( ISERROR(p) || p->typefixed ) + return( (expptr) p ); + else if(p->tag != TEXPR) + badtag("fixexpr", p->tag); + opcode = p->opcode; + +/* First set the types of the left and right subexpressions */ + + lp = p->leftp; + if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR) + lp = p->leftp = fixtype(lp); + ltype = lp->headblock.vtype; + + if(opcode==OPASSIGN && lp->tag!=TADDR) + { + err("left side of assignment must be variable"); + eret: + frexpr((expptr)p); + return( errnode() ); + } + + if(rp = p->rightp) + { + if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR) + rp = p->rightp = fixtype(rp); + rtype = rp->headblock.vtype; + } + else + rtype = 0; + + if(ltype==TYERROR || rtype==TYERROR) + goto eret; + +/* Now work on the whole expression */ + + /* force folding if possible */ + + if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) + { + q = opcode == OPCONV && lp->constblock.vtype == p->vtype + ? lp : mkexpr(opcode, lp, rp); + +/* mkexpr is expected to reduce constant expressions */ + + if( ISCONST(q) ) { + p->leftp = p->rightp = 0; + frexpr((expptr)p); + return(q); + } + free( (charptr) q ); /* constants did not fold */ + } + + if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) + goto eret; + + if (ltype == TYCHAR && ISCONST(lp)) { + if (opcode == OPCONV) { + hsave = halign; + halign = 0; + lp = (expptr)putconst((Constp)lp); + halign = hsave; + } + else + lp = (expptr)putconst((Constp)lp); + p->leftp = lp; + } + if (rtype == TYCHAR && ISCONST(rp)) + p->rightp = rp = (expptr)putconst((Constp)rp); + + switch(opcode) + { + case OPCONCAT: + if(p->vleng == NULL) + p->vleng = mkexpr(OPPLUS, cplenexpr(lp), + cplenexpr(rp) ); + break; + + case OPASSIGN: + if (rtype == TYREAL || ISLOGICAL(ptype) + || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp)) + break; + case OPPLUSEQ: + case OPSTAREQ: + if(ltype == rtype) + break; + if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) + break; + if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) + break; + if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) + && typesize[ltype]>=typesize[rtype] ) + break; + +/* Cast the right hand side to match the type of the expression */ + + p->rightp = fixtype( mkconv(ptype, rp) ); + break; + + case OPSLASH: + if( ISCOMPLEX(rtype) ) + { + p = (Exprp) call2(ptype, + +/* Handle double precision complex variables */ + + (char*)(ptype == TYCOMPLEX ? "c_div" : "z_div"), + mkconv(ptype, lp), mkconv(ptype, rp) ); + break; + } + case OPPLUS: + case OPMINUS: + case OPSTAR: + case OPMOD: + if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || + (rtype==TYREAL && ! ISCONST(rp) ) )) + break; + if( ISCOMPLEX(ptype) ) + break; + +/* Cast both sides of the expression to match the type of the whole + expression. */ + + if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL)) + p->leftp = fixtype(mkconv(ptype,lp)); + if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL)) + p->rightp = fixtype(mkconv(ptype,rp)); + break; + + case OPPOWER: + rp = mkpower((expptr)p); + if (rp->tag == TEXPR) + rp->exprblock.typefixed = 1; + return rp; + + case OPLT: + case OPLE: + case OPGT: + case OPGE: + case OPEQ: + case OPNE: + if(ltype == rtype) + break; + if (htype) { + if (ltype == TYCHAR) { + p->leftp = fixtype(mkconv(rtype,lp)); + break; + } + if (rtype == TYCHAR) { + p->rightp = fixtype(mkconv(ltype,rp)); + break; + } + } + mtype = cktype(OPMINUS, ltype, rtype); + if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL)) + break; + if( ISCOMPLEX(mtype) ) + break; + if(ltype != mtype) + p->leftp = fixtype(mkconv(mtype,lp)); + if(rtype != mtype) + p->rightp = fixtype(mkconv(mtype,rp)); + break; + + case OPCONV: + ptype = cktype(OPCONV, p->vtype, ltype); + if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA + && !ISCOMPLEX(ptype)) + { + lp->exprblock.rightp = + fixtype( mkconv(ptype, lp->exprblock.rightp) ); + free( (charptr) p ); + p = (Exprp) lp; + } + break; + + case OPADDR: + if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR) + Fatal("addr of addr"); + break; + + case OPCOMMA: + case OPQUEST: + case OPCOLON: + break; + + case OPMIN: + case OPMAX: + case OPMIN2: + case OPMAX2: + case OPDMIN: + case OPDMAX: + case OPABS: + case OPDABS: + ptype = p->vtype; + break; + + default: + break; + } + + p->vtype = ptype; + p->typefixed = 1; + return((expptr) p); +} + + +/* fix an argument list, taking due care for special first level cases */ + + int +#ifdef KR_headers +fixargs(doput, p0) + int doput; + struct Listblock *p0; +#else +fixargs(int doput, struct Listblock *p0) +#endif + /* doput is true if constants need to be passed by reference */ +{ + chainp p; + tagptr q, t; + int qtag, nargs; + + nargs = 0; + if(p0) + for(p = p0->listp ; p ; p = p->nextp) + { + ++nargs; + q = (tagptr)p->datap; + qtag = q->tag; + if(qtag == TCONST) + { + +/* Call putconst() to store values in a constant table. Since even + constants must be passed by reference, this can optimize on the storage + required */ + + p->datap = doput ? (char *)putconst((Constp)q) + : (char *)q; + continue; + } + +/* Take a function name and turn it into an Addr. This only happens when + nothing else has figured out the function beforehand */ + + if (qtag == TPRIM && q->primblock.argsp == 0) { + if (q->primblock.namep->vclass==CLPROC + && q->primblock.namep->vprocclass != PTHISPROC) { + p->datap = (char *)mkaddr(q->primblock.namep); + continue; + } + + if (q->primblock.namep->vdim != NULL) { + p->datap = (char *)mkscalar(q->primblock.namep); + if ((q->primblock.fcharp||q->primblock.lcharp) + && (q->primblock.namep->vtype != TYCHAR + || q->primblock.namep->vdim)) + sserr(q->primblock.namep); + continue; + } + + if (q->primblock.namep->vdovar + && (t = (tagptr) memversion(q->primblock.namep))) { + p->datap = (char *)fixtype(t); + continue; + } + } + p->datap = (char *)fixtype(q); + } + return(nargs); +} + + + +/* mkscalar -- only called by fixargs above, and by some routines in + io.c */ + + Addrp +#ifdef KR_headers +mkscalar(np) + Namep np; +#else +mkscalar(Namep np) +#endif +{ + Addrp ap; + + vardcl(np); + ap = mkaddr(np); + + /* The prolog causes array arguments to point to the + * (0,...,0) element, unless subscript checking is on. + */ + if( !checksubs && np->vstg==STGARG) + { + struct Dimblock *dp; + dp = np->vdim; + frexpr(ap->memoffset); + ap->memoffset = mkexpr(OPSTAR, + (np->vtype==TYCHAR ? + cpexpr(np->vleng) : + (tagptr)ICON(typesize[np->vtype]) ), + cpexpr(dp->baseoffset) ); + } + return(ap); +} + + + static void +#ifdef KR_headers +adjust_arginfo(np) + Namep np; +#else +adjust_arginfo(Namep np) +#endif + /* adjust arginfo to omit the length arg for the + arg that we now know to be a character-valued + function */ +{ + struct Entrypoint *ep; + chainp args; + Argtypes *at; + + for(ep = entries; ep; ep = ep->entnextp) + for(args = ep->arglist; args; args = args->nextp) + if (np == (Namep)args->datap + && (at = ep->entryname->arginfo)) + --at->nargs; + } + + + expptr +#ifdef KR_headers +mkfunct(p0) + expptr p0; +#else +mkfunct(expptr p0) +#endif +{ + struct Primblock *p = (struct Primblock *)p0; + struct Entrypoint *ep; + Addrp ap; + Extsym *extp; + Namep np; + expptr q; + extern chainp new_procs; + int k, nargs; + int vclass; + + if(p->tag != TPRIM) + return( errnode() ); + + np = p->namep; + vclass = np->vclass; + + + if(vclass == CLUNKNOWN) + { + np->vclass = vclass = CLPROC; + if(np->vstg == STGUNKNOWN) + { + if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname)) + && (zflag || !(*(struct Intrpacked *)&k).f4 + || dcomplex_seen)) + { + np->vstg = STGINTR; + np->vardesc.varno = k; + np->vprocclass = PINTRINSIC; + } + else + { + extp = mkext(np->fvarname, + addunder(np->cvarname)); + extp->extstg = STGEXT; + np->vstg = STGEXT; + np->vardesc.varno = extp - extsymtab; + np->vprocclass = PEXTERNAL; + } + } + else if(np->vstg==STGARG) + { + if(np->vtype == TYCHAR) { + adjust_arginfo(np); + if (np->vpassed) { + char wbuf[160], *who; + who = np->fvarname; + sprintf(wbuf, "%s%s%s\n\t%s%s%s", + "Character-valued dummy procedure ", + who, " not declared EXTERNAL.", + "Code may be wrong for previous function calls having ", + who, " as a parameter."); + warn(wbuf); + } + } + np->vprocclass = PEXTERNAL; + } + } + + if(vclass != CLPROC) { + if (np->vstg == STGCOMMON) + fatalstr( + "Cannot invoke common variable %.50s as a function.", + np->fvarname); + errstr("%.80s cannot be called.", np->fvarname); + goto error; + } + +/* F77 doesn't allow subscripting of function calls */ + + if(p->fcharp || p->lcharp) + { + err("no substring of function call"); + goto error; + } + impldcl(np); + np->vimpltype = 0; /* invoking as function ==> inferred type */ + np->vcalled = 1; + nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp); + + switch(np->vprocclass) + { + case PEXTERNAL: + if(np->vtype == TYUNKNOWN) + { + dclerr("attempt to use untyped function", np); + np->vtype = dflttype[letter(np->fvarname[0])]; + } + ap = mkaddr(np); + if (!extsymtab[np->vardesc.varno].extseen) { + new_procs = mkchain((char *)np, new_procs); + extsymtab[np->vardesc.varno].extseen = 1; + } +call: + q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp); + q->exprblock.vtype = np->vtype; + if(np->vleng) + q->exprblock.vleng = (expptr) cpexpr(np->vleng); + break; + + case PINTRINSIC: + q = intrcall(np, p->argsp, nargs); + break; + + case PSTFUNCT: + q = stfcall(np, p->argsp); + break; + + case PTHISPROC: + warn("recursive call"); + +/* entries is the list of multiple entry points */ + + for(ep = entries ; ep ; ep = ep->entnextp) + if(ep->enamep == np) + break; + if(ep == NULL) + Fatal("mkfunct: impossible recursion"); + + ap = builtin(np->vtype, ep->entryname->cextname, -2); + /* the negative last arg prevents adding */ + /* this name to the list of used builtins */ + goto call; + + default: + fatali("mkfunct: impossible vprocclass %d", + (int) (np->vprocclass) ); + } + free( (charptr) p ); + return(q); + +error: + frexpr((expptr)p); + return( errnode() ); +} + + + + static expptr +#ifdef KR_headers +stfcall(np, actlist) + Namep np; + struct Listblock *actlist; +#else +stfcall(Namep np, struct Listblock *actlist) +#endif +{ + chainp actuals; + int nargs; + chainp oactp, formals; + int type; + expptr Ln, Lq, q, q1, rhs, ap; + Namep tnp; + struct Rplblock *rp; + struct Rplblock *tlist; + + if (np->arginfo) { + errstr("statement function %.66s calls itself.", + np->fvarname); + return ICON(0); + } + np->arginfo = (Argtypes *)np; /* arbitrary nonzero value */ + if(actlist) + { + actuals = actlist->listp; + free( (charptr) actlist); + } + else + actuals = NULL; + oactp = actuals; + + nargs = 0; + tlist = NULL; + if( (type = np->vtype) == TYUNKNOWN) + { + dclerr("attempt to use untyped statement function", np); + type = np->vtype = dflttype[letter(np->fvarname[0])]; + } + formals = (chainp) np->varxptr.vstfdesc->datap; + rhs = (expptr) (np->varxptr.vstfdesc->nextp); + + /* copy actual arguments into temporaries */ + while(actuals!=NULL && formals!=NULL) + { + if (!(tnp = (Namep) formals->datap)) { + /* buggy statement function declaration */ + q = ICON(1); + goto done; + } + rp = ALLOC(Rplblock); + rp->rplnp = tnp; + ap = fixtype((tagptr)actuals->datap); + if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR + && (ap->tag==TCONST || ap->tag==TADDR) ) + { + +/* If actuals are constants or variable names, no temporaries are required */ + rp->rplvp = (expptr) ap; + rp->rplxp = NULL; + rp->rpltag = ap->tag; + } + else { + rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng); + rp -> rplxp = NULL; + putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap)); + if((rp->rpltag = rp->rplvp->tag) == TERROR) + err("disagreement of argument types in statement function call"); + } + rp->rplnextp = tlist; + tlist = rp; + actuals = actuals->nextp; + formals = formals->nextp; + ++nargs; + } + + if(actuals!=NULL || formals!=NULL) + err("statement function definition and argument list differ"); + + /* + now push down names involved in formal argument list, then + evaluate rhs of statement function definition in this environment +*/ + + if(tlist) /* put tlist in front of the rpllist */ + { + for(rp = tlist; rp->rplnextp; rp = rp->rplnextp) + ; + rp->rplnextp = rpllist; + rpllist = tlist; + } + +/* So when the expression finally gets evaled, that evaluator must read + from the globl rpllist 14-jun-88 mwm */ + + q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) ); + + /* get length right of character-valued statement functions... */ + if (type == TYCHAR + && (Ln = np->vleng) + && q->tag != TERROR + && (Lq = q->exprblock.vleng) + && (Lq->tag != TCONST + || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) { + q1 = (expptr) mktmp(type, Ln); + putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q)); + q = q1; + } + + /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ + while(--nargs >= 0) + { + if(rpllist->rplxp) + q = mkexpr(OPCOMMA, rpllist->rplxp, q); + rp = rpllist->rplnextp; + frexpr(rpllist->rplvp); + free((char *)rpllist); + rpllist = rp; + } + done: + frchain( &oactp ); + np->arginfo = 0; + return(q); +} + + +static int replaced; + +/* mkplace -- Figure out the proper storage class for the input name and + return an addrp with the appropriate stuff */ + + Addrp +#ifdef KR_headers +mkplace(np) + Namep np; +#else +mkplace(Namep np) +#endif +{ + Addrp s; + struct Rplblock *rp; + int regn; + + /* is name on the replace list? */ + + for(rp = rpllist ; rp ; rp = rp->rplnextp) + { + if(np == rp->rplnp) + { + replaced = 1; + if(rp->rpltag == TNAME) + { + np = (Namep) (rp->rplvp); + break; + } + else return( (Addrp) cpexpr(rp->rplvp) ); + } + } + + /* is variable a DO index in a register ? */ + + if(np->vdovar && ( (regn = inregister(np)) >= 0) ) + if(np->vtype == TYERROR) + return((Addrp) errnode() ); + else + { + s = ALLOC(Addrblock); + s->tag = TADDR; + s->vstg = STGREG; + s->vtype = TYIREG; + s->memno = regn; + s->memoffset = ICON(0); + s -> uname_tag = UNAM_NAME; + s -> user.name = np; + return(s); + } + + if (np->vclass == CLPROC && np->vprocclass != PTHISPROC) + errstr("external %.60s used as a variable", np->fvarname); + vardcl(np); + return(mkaddr(np)); +} + + static expptr +#ifdef KR_headers +subskept(p, a) + struct Primblock *p; + Addrp a; +#else +subskept(struct Primblock *p, Addrp a) +#endif +{ + expptr ep; + struct Listblock *Lb; + chainp cp; + + if (a->uname_tag != UNAM_NAME) + erri("subskept: uname_tag %d", a->uname_tag); + a->user.name->vrefused = 1; + a->user.name->visused = 1; + a->uname_tag = UNAM_REF; + Lb = (struct Listblock *)cpexpr((tagptr)p->argsp); + for(cp = Lb->listp; cp; cp = cp->nextp) + cp->datap = (char *)putx(fixtype((tagptr)cp->datap)); + if (a->vtype == TYCHAR) { + ep = p->fcharp ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1)) + : ICON(0); + Lb->listp = mkchain((char *)ep, Lb->listp); + } + return (expptr)Lb; + } + + static void +#ifdef KR_headers +substrerr(np) Namep np; +#else +substrerr(Namep np) +#endif +{ + void (*f) Argdcl((const char*, const char*)); + f = checksubs ? errstr : warn1; + (*f)("substring of %.65s is out of bounds.", np->fvarname); + } + + static int doing_vleng; + +/* mklhs -- Compute the actual address of the given expression; account + for array subscripts, stack offset, and substring offsets. The f -> C + translator will need this only to worry about the subscript stuff */ + + expptr +#ifdef KR_headers +mklhs(p, subkeep) + struct Primblock *p; + int subkeep; +#else +mklhs(struct Primblock *p, int subkeep) +#endif +{ + Addrp s; + Namep np; + + if(p->tag != TPRIM) + return( (expptr) p ); + np = p->namep; + + replaced = 0; + s = mkplace(np); + if(s->tag!=TADDR || s->vstg==STGREG) + { + free( (charptr) p ); + return( (expptr) s ); + } + s->parenused = p->parenused; + + /* compute the address modified by subscripts */ + + if (!replaced) + s->memoffset = (subkeep && np->vdim && p->argsp + && (np->vdim->ndim > 1 || np->vtype == TYCHAR + && (!ISCONST(np->vleng) + || np->vleng->constblock.Const.ci != 1))) + ? subskept(p,s) + : mkexpr(OPPLUS, s->memoffset, suboffset(p) ); + frexpr((expptr)p->argsp); + p->argsp = NULL; + + /* now do substring part */ + + if(p->fcharp || p->lcharp) + { + if(np->vtype != TYCHAR) + sserr(np); + else { + if(p->lcharp == NULL) + p->lcharp = (expptr)( + /* s->vleng == 0 only with errors */ + s->vleng ? cpexpr(s->vleng) : ICON(1)); + else if (ISCONST(p->lcharp) + && ISCONST(np->vleng) + && p->lcharp->constblock.Const.ci + > np->vleng->constblock.Const.ci) + substrerr(np); + if(p->fcharp) { + doing_vleng = 1; + s->vleng = fixtype(mkexpr(OPMINUS, + p->lcharp, + mkexpr(OPMINUS, p->fcharp, ICON(1) ))); + doing_vleng = 0; + } + else { + frexpr(s->vleng); + s->vleng = p->lcharp; + } + if (s->memoffset + && ISCONST(s->memoffset) + && s->memoffset->constblock.Const.ci < 0) + substrerr(np); + } + } + + s->vleng = fixtype( s->vleng ); + s->memoffset = fixtype( s->memoffset ); + free( (charptr) p ); + return( (expptr) s ); +} + + + + + +/* deregister -- remove a register allocation from the list; assumes that + names are deregistered in stack order (LIFO order - Last In First Out) */ + + void +#ifdef KR_headers +deregister(np) + Namep np; +#else +deregister(Namep np) +#endif +{ + if(nregvar>0 && regnamep[nregvar-1]==np) + { + --nregvar; + } +} + + + + +/* memversion -- moves a DO index REGISTER into a memory location; other + objects are passed through untouched */ + + Addrp +#ifdef KR_headers +memversion(np) + Namep np; +#else +memversion(Namep np) +#endif +{ + Addrp s; + + if(np->vdovar==NO || (inregister(np)<0) ) + return(NULL); + np->vdovar = NO; + s = mkplace(np); + np->vdovar = YES; + return(s); +} + + + +/* inregister -- looks for the input name in the global list regnamep */ + + int +#ifdef KR_headers +inregister(np) + Namep np; +#else +inregister(Namep np) +#endif +{ + int i; + + for(i = 0 ; i < nregvar ; ++i) + if(regnamep[i] == np) + return( regnum[i] ); + return(-1); +} + + + +/* suboffset -- Compute the offset from the start of the array, given the + subscripts as arguments */ + + expptr +#ifdef KR_headers +suboffset(p) + struct Primblock *p; +#else +suboffset(struct Primblock *p) +#endif +{ + int n; + expptr si, size; + chainp cp; + expptr e, e1, offp, prod; + struct Dimblock *dimp; + expptr sub[MAXDIM+1]; + Namep np; + + np = p->namep; + offp = ICON(0); + n = 0; + if(p->argsp) + for(cp = p->argsp->listp ; cp ; cp = cp->nextp) + { + si = fixtype(cpexpr((tagptr)cp->datap)); + if (!ISINT(si->headblock.vtype)) { + NOEXT("non-integer subscript"); + si = mkconv(TYLONG, si); + } + sub[n++] = si; + if(n > maxdim) + { + erri("more than %d subscripts", maxdim); + break; + } + } + + dimp = np->vdim; + if(n>0 && dimp==NULL) + errstr("subscripts on scalar variable %.68s", np->fvarname); + else if(dimp && dimp->ndim!=n) + errstr("wrong number of subscripts on %.68s", np->fvarname); + else if(n > 0) + { + prod = sub[--n]; + while( --n >= 0) + prod = mkexpr(OPPLUS, sub[n], + mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); + if(checksubs || np->vstg!=STGARG) + prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); + +/* Add in the run-time bounds check */ + + if(checksubs) + prod = subcheck(np, prod); + size = np->vtype == TYCHAR ? + (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]); + prod = mkexpr(OPSTAR, prod, size); + offp = mkexpr(OPPLUS, offp, prod); + } + +/* Check for substring indicator */ + + if(p->fcharp && np->vtype==TYCHAR) { + e = p->fcharp; + e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1)); + if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) { + e = (expptr)mktmp(TYLONG, ENULL); + putout(putassign(cpexpr(e), e1)); + p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1)); + e1 = e; + } + offp = mkexpr(OPPLUS, offp, e1); + } + return(offp); +} + + + + + expptr +#ifdef KR_headers +subcheck(np, p) + Namep np; + expptr p; +#else +subcheck(Namep np, expptr p) +#endif +{ + struct Dimblock *dimp; + expptr t, checkvar, checkcond, badcall; + + dimp = np->vdim; + if(dimp->nelt == NULL) + return(p); /* don't check arrays with * bounds */ + np->vlastdim = 0; + if( ISICON(p) ) + { + +/* check for negative (constant) offset */ + + if(p->constblock.Const.ci < 0) + goto badsub; + if( ISICON(dimp->nelt) ) + +/* see if constant offset exceeds the array declaration */ + + if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci) + return(p); + else + goto badsub; + } + +/* We know that the subscript offset p or dimp -> nelt is not a constant. + Now find a register to use for run-time bounds checking */ + + if(p->tag==TADDR && p->addrblock.vstg==STGREG) + { + checkvar = (expptr) cpexpr(p); + t = p; + } + else { + checkvar = (expptr) mktmp(TYLONG, ENULL); + t = mkexpr(OPASSIGN, cpexpr(checkvar), p); + } + checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); + if( ! ISICON(p) ) + checkcond = mkexpr(OPAND, checkcond, + mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); + +/* Construct the actual test */ + + badcall = call4(p->headblock.vtype, "s_rnge", + mkstrcon(strlen(np->fvarname), np->fvarname), + mkconv(TYLONG, cpexpr(checkvar)), + mkstrcon(strlen(procname), procname), + ICON(lineno) ); + badcall->exprblock.opcode = OPCCALL; + p = mkexpr(OPQUEST, checkcond, + mkexpr(OPCOLON, checkvar, badcall)); + + return(p); + +badsub: + frexpr(p); + errstr("subscript on variable %s out of range", np->fvarname); + return ( ICON(0) ); +} + + + + + Addrp +#ifdef KR_headers +mkaddr(p) + Namep p; +#else +mkaddr(Namep p) +#endif +{ + Extsym *extp; + Addrp t; + int k; + + switch( p->vstg) + { + case STGAUTO: + if(p->vclass == CLPROC && p->vprocclass == PTHISPROC) + return (Addrp) cpexpr((expptr)xretslot[p->vtype]); + goto other; + + case STGUNKNOWN: + if(p->vclass != CLPROC) + break; /* Error */ + extp = mkext(p->fvarname, addunder(p->cvarname)); + extp->extstg = STGEXT; + p->vstg = STGEXT; + p->vardesc.varno = extp - extsymtab; + p->vprocclass = PEXTERNAL; + if ((extp->exproto || infertypes) + && (p->vtype == TYUNKNOWN || p->vimpltype) + && (k = extp->extype)) + inferdcl(p, k); + + + case STGCOMMON: + case STGEXT: + case STGBSS: + case STGINIT: + case STGEQUIV: + case STGARG: + case STGLENG: + other: + t = ALLOC(Addrblock); + t->tag = TADDR; + + t->vclass = p->vclass; + t->vtype = p->vtype; + t->vstg = p->vstg; + t->memno = p->vardesc.varno; + t->memoffset = ICON(p->voffset); + if (p->vdim) + t->isarray = 1; + if(p->vleng) + { + t->vleng = (expptr) cpexpr(p->vleng); + if( ISICON(t->vleng) ) + t->varleng = t->vleng->constblock.Const.ci; + } + +/* Keep the original name around for the C code generation */ + + t -> uname_tag = UNAM_NAME; + t -> user.name = p; + return(t); + + case STGINTR: + + return ( intraddr (p)); + + case STGSTFUNCT: + + errstr("invalid use of statement function %.64s.", p->fvarname); + return putconst((Constp)ICON(0)); + } + badstg("mkaddr", p->vstg); + /* NOT REACHED */ return 0; +} + + + + +/* mkarg -- create storage for a new parameter. This is called when a + function returns a string (for the return value, which is the first + parameter), or when a variable-length string is passed to a function. */ + + Addrp +#ifdef KR_headers +mkarg(type, argno) + int type; + int argno; +#else +mkarg(int type, int argno) +#endif +{ + Addrp p; + + p = ALLOC(Addrblock); + p->tag = TADDR; + p->vtype = type; + p->vclass = CLVAR; + +/* TYLENG is the type of the field holding the length of a character string */ + + p->vstg = (type==TYLENG ? STGLENG : STGARG); + p->memno = argno; + return(p); +} + + + + +/* mkprim -- Create a PRIM (primary/primitive) block consisting of a + Nameblock (or Paramblock), arguments (actual params or array + subscripts) and substring bounds. Requires that v have lots of + extra (uninitialized) storage, since it could be a paramblock or + nameblock */ + + expptr +#ifdef KR_headers +mkprim(v0, args, substr) + Namep v0; + struct Listblock *args; + chainp substr; +#else +mkprim(Namep v0, struct Listblock *args, chainp substr) +#endif +{ + typedef union { + struct Paramblock paramblock; + struct Nameblock nameblock; + struct Headblock headblock; + } *Primu; + Primu v = (Primu)v0; + struct Primblock *p; + + if(v->headblock.vclass == CLPARAM) + { + +/* v is to be a Paramblock */ + + if(args || substr) + { + errstr("no qualifiers on parameter name %s", + v->paramblock.fvarname); + frexpr((expptr)args); + if(substr) + { + frexpr((tagptr)substr->datap); + frexpr((tagptr)substr->nextp->datap); + frchain(&substr); + } + frexpr((expptr)v); + return( errnode() ); + } + return( (expptr) cpexpr(v->paramblock.paramval) ); + } + + p = ALLOC(Primblock); + p->tag = TPRIM; + p->vtype = v->nameblock.vtype; + +/* v is to be a Nameblock */ + + p->namep = (Namep) v; + p->argsp = args; + if(substr) + { + p->fcharp = (expptr) substr->datap; + p->lcharp = (expptr) substr->nextp->datap; + frchain(&substr); + } + return( (expptr) p); +} + + + +/* vardcl -- attempt to fill out the Name template for variable v. + This function is called on identifiers known to be variables or + recursive references to the same function */ + + void +#ifdef KR_headers +vardcl(v) + Namep v; +#else +vardcl(Namep v) +#endif +{ + struct Dimblock *t; + expptr neltp; + extern int doing_stmtfcn; + + if(v->vclass == CLUNKNOWN) { + v->vclass = CLVAR; + if (v->vinftype) { + v->vtype = TYUNKNOWN; + if (v->vdcldone) { + v->vdcldone = 0; + impldcl(v); + } + } + } + if(v->vdcldone) + return; + if(v->vclass == CLNAMELIST) + return; + + if(v->vtype == TYUNKNOWN) + impldcl(v); + else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC) + { + dclerr("used as variable", v); + return; + } + if(v->vstg==STGUNKNOWN) { + if (doing_stmtfcn) { + /* neither declare this variable if its only use */ + /* is in defining a stmt function, nor complain */ + /* that it is never used */ + v->vimpldovar = 1; + return; + } + v->vstg = implstg[ letter(v->fvarname[0]) ]; + v->vimplstg = 1; + } + +/* Compute the actual storage location, i.e. offsets from base addresses, + possibly the stack pointer */ + + switch(v->vstg) + { + case STGBSS: + v->vardesc.varno = ++lastvarno; + break; + case STGAUTO: + if(v->vclass==CLPROC && v->vprocclass==PTHISPROC) + break; + if(t = v->vdim) + if( (neltp = t->nelt) && ISCONST(neltp) ) ; + else + dclerr("adjustable automatic array", v); + break; + + default: + break; + } + v->vdcldone = YES; +} + + + +/* Set the implicit type declaration of parameter p based on its first + letter */ + + void +#ifdef KR_headers +impldcl(p) + Namep p; +#else +impldcl(Namep p) +#endif +{ + int k; + int type; + ftnint leng; + + if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) + return; + if(p->vtype == TYUNKNOWN) + { + k = letter(p->fvarname[0]); + type = impltype[ k ]; + leng = implleng[ k ]; + if(type == TYUNKNOWN) + { + if(p->vclass == CLPROC) + return; + dclerr("attempt to use undefined variable", p); + type = dflttype[k]; + leng = 0; + } + settype(p, type, leng); + p->vimpltype = 1; + } +} + + void +#ifdef KR_headers +inferdcl(np, type) + Namep np; + int type; +#else +inferdcl(Namep np, int type) +#endif +{ + int k = impltype[letter(np->fvarname[0])]; + if (k != type) { + np->vinftype = 1; + np->vtype = type; + frexpr(np->vleng); + np->vleng = 0; + } + np->vimpltype = 0; + np->vinfproc = 1; + } + + LOCAL int +#ifdef KR_headers +zeroconst(e) + expptr e; +#else +zeroconst(expptr e) +#endif +{ + Constp c = (Constp) e; + if (c->tag == TCONST) + switch(c->vtype) { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + return c->Const.ci == 0; +#ifndef NO_LONG_LONG + case TYQUAD: + return c->Const.cq == 0; +#endif + + case TYREAL: + case TYDREAL: + if (c->vstg == 1) + return !strcmp(c->Const.cds[0],"0."); + return c->Const.cd[0] == 0.; + + case TYCOMPLEX: + case TYDCOMPLEX: + if (c->vstg == 1) + return !strcmp(c->Const.cds[0],"0.") + && !strcmp(c->Const.cds[1],"0."); + return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.; + } + return 0; + } + + void +#ifdef KR_headers +paren_used(p) struct Primblock *p; +#else +paren_used(struct Primblock *p) +#endif +{ + Namep np; + + p->parenused = 1; + if (!p->argsp && (np = p->namep) && np->vdim) + warn1("inappropriate operation on unsubscripted array %.50s", + np->fvarname); + } + +#define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c) +#define COMMUTE { e = lp; lp = rp; rp = e; } + +/* mkexpr -- Make expression, and simplify constant subcomponents (tree + order is not preserved). Assumes that lp is nonempty, and uses + fold() to simplify adjacent constants */ + + expptr +#ifdef KR_headers +mkexpr(opcode, lp, rp) + int opcode; + expptr lp; + expptr rp; +#else +mkexpr(int opcode, expptr lp, expptr rp) +#endif +{ + expptr e, e1; + int etype; + int ltype, rtype; + int ltag, rtag; + long L; + static long divlineno; + + if (parstate < INEXEC) { + + /* Song and dance to get statement functions right */ + /* while catching incorrect type combinations in the */ + /* first executable statement. */ + + ltype = lp->headblock.vtype; + ltag = lp->tag; + if(rp && opcode!=OPCALL && opcode!=OPCCALL) + { + rtype = rp->headblock.vtype; + rtag = rp->tag; + } + else rtype = 0; + + etype = cktype(opcode, ltype, rtype); + if(etype == TYERROR) + goto error; + goto no_fold; + } + + ltype = lp->headblock.vtype; + if (ltype == TYUNKNOWN) { + lp = fixtype(lp); + ltype = lp->headblock.vtype; + } + ltag = lp->tag; + if(rp && opcode!=OPCALL && opcode!=OPCCALL) + { + rtype = rp->headblock.vtype; + if (rtype == TYUNKNOWN) { + rp = fixtype(rp); + rtype = rp->headblock.vtype; + } + rtag = rp->tag; + } + else rtype = 0; + + etype = cktype(opcode, ltype, rtype); + if(etype == TYERROR) + goto error; + + switch(opcode) + { + /* check for multiplication by 0 and 1 and addition to 0 */ + + case OPSTAR: + if( ISCONST(lp) ) + COMMUTE + + if( ISICON(rp) ) + { + if(rp->constblock.Const.ci == 0) + goto retright; + goto mulop; + } + break; + + case OPSLASH: + case OPMOD: + if( zeroconst(rp) && lineno != divlineno ) { + warn("attempted division by zero"); + divlineno = lineno; + } + if(opcode == OPMOD) + break; + +/* Handle multiplying or dividing by 1, -1 */ + +mulop: + if( ISICON(rp) ) + { + if(rp->constblock.Const.ci == 1) + goto retleft; + + if(rp->constblock.Const.ci == -1) + { + frexpr(rp); + return( mkexpr(OPNEG, lp, ENULL) ); + } + } + +/* Group all constants together. In particular, + + (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2) + (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2) +*/ + + if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp + || !ISICON(lp->exprblock.rightp)) + break; + + if (lp->exprblock.opcode == OPLSHIFT) { + L = 1 << lp->exprblock.rightp->constblock.Const.ci; + if (opcode == OPSTAR || ISICON(rp) && + !(L % rp->constblock.Const.ci)) { + lp->exprblock.opcode = OPSTAR; + lp->exprblock.rightp->constblock.Const.ci = L; + } + } + + if (lp->exprblock.opcode == OPSTAR) { + if(opcode == OPSTAR) + e = mkexpr(OPSTAR, lp->exprblock.rightp, rp); + else if(ISICON(rp) && + (lp->exprblock.rightp->constblock.Const.ci % + rp->constblock.Const.ci) == 0) + e = mkexpr(OPSLASH, lp->exprblock.rightp, rp); + else break; + + e1 = lp->exprblock.leftp; + free( (charptr) lp ); + return( mkexpr(OPSTAR, e1, e) ); + } + break; + + + case OPPLUS: + if( ISCONST(lp) ) + COMMUTE + goto addop; + + case OPMINUS: + if( ICONEQ(lp, 0) ) + { + frexpr(lp); + return( mkexpr(OPNEG, rp, ENULL) ); + } + + if( ISCONST(rp) && is_negatable((Constp)rp)) + { + opcode = OPPLUS; + consnegop((Constp)rp); + } + +/* Group constants in an addition expression (also subtraction, since the + subtracted value was negated above). In particular, + + (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2) +*/ + +addop: + if( ISICON(rp) ) + { + if(rp->constblock.Const.ci == 0) + goto retleft; + if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) ) + { + e = mkexpr(OPPLUS, lp->exprblock.rightp, rp); + e1 = lp->exprblock.leftp; + free( (charptr) lp ); + return( mkexpr(OPPLUS, e1, e) ); + } + } + if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) { + /* check for (i [+const]) - (i [+const]) */ + if (lp->tag == TPRIM) + e = lp; + else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS + && lp->exprblock.rightp->tag == TCONST) { + e = lp->exprblock.leftp; + if (e->tag != TPRIM) + break; + } + else + break; + if (e->primblock.argsp) + break; + if (rp->tag == TPRIM) + e1 = rp; + else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS + && rp->exprblock.rightp->tag == TCONST) { + e1 = rp->exprblock.leftp; + if (e1->tag != TPRIM) + break; + } + else + break; + if (e->primblock.namep != e1->primblock.namep + || e1->primblock.argsp) + break; + L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci; + if (e1 != rp) + L -= rp->exprblock.rightp->constblock.Const.ci; + frexpr(lp); + frexpr(rp); + return ICON(L); + } + + break; + + + case OPPOWER: + break; + +/* Eliminate outermost double negations */ + + case OPNEG: + case OPNEG1: + if(ltag==TEXPR && lp->exprblock.opcode==OPNEG) + { + e = lp->exprblock.leftp; + free( (charptr) lp ); + return(e); + } + break; + +/* Eliminate outermost double NOTs */ + + case OPNOT: + if(ltag==TEXPR && lp->exprblock.opcode==OPNOT) + { + e = lp->exprblock.leftp; + free( (charptr) lp ); + return(e); + } + break; + + case OPCALL: + case OPCCALL: + etype = ltype; + if(rp!=NULL && rp->listblock.listp==NULL) + { + free( (charptr) rp ); + rp = NULL; + } + break; + + case OPAND: + case OPOR: + if( ISCONST(lp) ) + COMMUTE + + if( ISCONST(rp) ) + { + if(rp->constblock.Const.ci == 0) + if(opcode == OPOR) + goto retleft; + else + goto retright; + else if(opcode == OPOR) + goto retright; + else + goto retleft; + } + case OPEQV: + case OPNEQV: + + case OPBITAND: + case OPBITOR: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + case OPBITTEST: + case OPBITCLR: + case OPBITSET: +#ifdef TYQUAD + case OPQBITCLR: + case OPQBITSET: +#endif + + case OPLT: + case OPGT: + case OPLE: + case OPGE: + case OPEQ: + case OPNE: + + case OPCONCAT: + break; + case OPMIN: + case OPMAX: + case OPMIN2: + case OPMAX2: + case OPDMIN: + case OPDMAX: + + case OPASSIGN: + case OPASSIGNI: + case OPPLUSEQ: + case OPSTAREQ: + case OPMINUSEQ: + case OPSLASHEQ: + case OPMODEQ: + case OPLSHIFTEQ: + case OPRSHIFTEQ: + case OPBITANDEQ: + case OPBITXOREQ: + case OPBITOREQ: + + case OPCONV: + case OPADDR: + case OPWHATSIN: + + case OPCOMMA: + case OPCOMMA_ARG: + case OPQUEST: + case OPCOLON: + case OPDOT: + case OPARROW: + case OPIDENTITY: + case OPCHARCAST: + case OPABS: + case OPDABS: + break; + + default: + badop("mkexpr", opcode); + } + + no_fold: + e = (expptr) ALLOC(Exprblock); + e->exprblock.tag = TEXPR; + e->exprblock.opcode = opcode; + e->exprblock.vtype = etype; + e->exprblock.leftp = lp; + e->exprblock.rightp = rp; + if(ltag==TCONST && (rp==0 || rtag==TCONST) ) + e = fold(e); + return(e); + +retleft: + frexpr(rp); + if (lp->tag == TPRIM) + paren_used(&lp->primblock); + return(lp); + +retright: + frexpr(lp); + if (rp->tag == TPRIM) + paren_used(&rp->primblock); + return(rp); + +error: + frexpr(lp); + if(rp && opcode!=OPCALL && opcode!=OPCCALL) + frexpr(rp); + return( errnode() ); +} + +#define ERR(s) { errs = s; goto error; } + +/* cktype -- Check and return the type of the expression */ + + int +#ifdef KR_headers +cktype(op, lt, rt) + int op; + int lt; + int rt; +#else +cktype(int op, int lt, int rt) +#endif +{ + char *errs; + + if(lt==TYERROR || rt==TYERROR) + goto error1; + + if(lt==TYUNKNOWN) + return(TYUNKNOWN); + if(rt==TYUNKNOWN) + +/* If not unary operation, return UNKNOWN */ + + if(!is_unary_op (op) && op != OPCALL && op != OPCCALL) + return(TYUNKNOWN); + + switch(op) + { + case OPPLUS: + case OPMINUS: + case OPSTAR: + case OPSLASH: + case OPPOWER: + case OPMOD: + if( ISNUMERIC(lt) && ISNUMERIC(rt) ) + return( maxtype(lt, rt) ); + ERR("nonarithmetic operand of arithmetic operator") + + case OPNEG: + case OPNEG1: + if( ISNUMERIC(lt) ) + return(lt); + ERR("nonarithmetic operand of negation") + + case OPNOT: + if(ISLOGICAL(lt)) + return(lt); + ERR("NOT of nonlogical") + + case OPAND: + case OPOR: + case OPEQV: + case OPNEQV: + if(ISLOGICAL(lt) && ISLOGICAL(rt)) + return( maxtype(lt, rt) ); + ERR("nonlogical operand of logical operator") + + case OPLT: + case OPGT: + case OPLE: + case OPGE: + case OPEQ: + case OPNE: + if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) + { + if(lt != rt){ + if (htype + && (lt == TYCHAR && ISNUMERIC(rt) + || rt == TYCHAR && ISNUMERIC(lt))) + return TYLOGICAL; + ERR("illegal comparison") + } + } + + else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) + { + if(op!=OPEQ && op!=OPNE) + ERR("order comparison of complex data") + } + + else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) + ERR("comparison of nonarithmetic data") + case OPBITTEST: + return(TYLOGICAL); + + case OPCONCAT: + if(lt==TYCHAR && rt==TYCHAR) + return(TYCHAR); + ERR("concatenation of nonchar data") + + case OPCALL: + case OPCCALL: + case OPIDENTITY: + return(lt); + + case OPADDR: + case OPCHARCAST: + return(TYADDR); + + case OPCONV: + if(rt == 0) + return(0); + if(lt==TYCHAR && ISINT(rt) ) + return(TYCHAR); + if (ISLOGICAL(lt) && ISLOGICAL(rt) + || ISINT(lt) && rt == TYCHAR) + return lt; + case OPASSIGN: + case OPASSIGNI: + case OPMINUSEQ: + case OPPLUSEQ: + case OPSTAREQ: + case OPSLASHEQ: + case OPMODEQ: + case OPLSHIFTEQ: + case OPRSHIFTEQ: + case OPBITANDEQ: + case OPBITXOREQ: + case OPBITOREQ: + if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN) + return lt; + if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) + if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ) + || (lt!=rt)) + { + ERR("impossible conversion") + } + return(lt); + + case OPMIN: + case OPMAX: + case OPDMIN: + case OPDMAX: + case OPMIN2: + case OPMAX2: + case OPBITOR: + case OPBITAND: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + case OPWHATSIN: + case OPABS: + case OPDABS: + return(lt); + + case OPBITCLR: + case OPBITSET: +#ifdef TYQUAD0 + case OPQBITCLR: + case OPQBITSET: +#endif + if (lt < TYLONG) + lt = TYLONG; + return(lt); +#ifndef NO_LONG_LONG + case OPQBITCLR: + case OPQBITSET: + return TYQUAD; +#endif + + case OPCOMMA: + case OPCOMMA_ARG: + case OPQUEST: + case OPCOLON: /* Only checks the rightmost type because + of C language definition (rightmost + comma-expr is the value of the expr) */ + return(rt); + + case OPDOT: + case OPARROW: + return (lt); + default: + badop("cktype", op); + } +error: + err(errs); +error1: + return(TYERROR); +} + + static void +intovfl(Void) +{ err("overflow simplifying integer constants."); } + +#ifndef NO_LONG_LONG + static void +#ifdef KR_headers +LRget(Lp, Rp, lp, rp) Llong *Lp, *Rp; expptr lp, rp; +#else +LRget(Llong *Lp, Llong *Rp, expptr lp, expptr rp) +#endif +{ + if (lp->headblock.vtype == TYQUAD) + *Lp = lp->constblock.Const.cq; + else + *Lp = lp->constblock.Const.ci; + if (rp->headblock.vtype == TYQUAD) + *Rp = rp->constblock.Const.cq; + else + *Rp = rp->constblock.Const.ci; + } +#endif /*NO_LONG_LONG*/ + +/* fold -- simplifies constant expressions; it assumes that e -> leftp and + e -> rightp are TCONST or NULL */ + + expptr +#ifdef KR_headers +fold(e) + expptr e; +#else +fold(expptr e) +#endif +{ + Constp p; + expptr lp, rp; + int etype, mtype, ltype, rtype, opcode; + ftnint i, bl, ll, lr; + char *q, *s; + struct Constblock lcon, rcon; + ftnint L; + double d; +#ifndef NO_LONG_LONG + Llong LL, LR; +#endif + + opcode = e->exprblock.opcode; + etype = e->exprblock.vtype; + + lp = e->exprblock.leftp; + ltype = lp->headblock.vtype; + rp = e->exprblock.rightp; + + if(rp == 0) + switch(opcode) + { + case OPNOT: +#ifndef NO_LONG_LONG + if (ltype == TYQUAD) + lp->constblock.Const.cq = ! lp->constblock.Const.cq; + else +#endif + lp->constblock.Const.ci = ! lp->constblock.Const.ci; + retlp: + e->exprblock.leftp = 0; + frexpr(e); + return(lp); + + case OPBITNOT: +#ifndef NO_LONG_LONG + if (ltype == TYQUAD) + lp->constblock.Const.cq = ~ lp->constblock.Const.cq; + else +#endif + lp->constblock.Const.ci = ~ lp->constblock.Const.ci; + goto retlp; + + case OPNEG: + case OPNEG1: + consnegop((Constp)lp); + goto retlp; + + case OPCONV: + case OPADDR: + return(e); + + case OPABS: + case OPDABS: + switch(ltype) { + case TYINT1: + case TYSHORT: + case TYLONG: + if ((L = lp->constblock.Const.ci) < 0) { + lp->constblock.Const.ci = -L; + if (L != -lp->constblock.Const.ci) + intovfl(); + } + goto retlp; +#ifndef NO_LONG_LONG + case TYQUAD: + if ((LL = lp->constblock.Const.cq) < 0) { + lp->constblock.Const.cq = -LL; + if (LL != -lp->constblock.Const.cq) + intovfl(); + } + goto retlp; +#endif + case TYREAL: + case TYDREAL: + if (lp->constblock.vstg) { + s = lp->constblock.Const.cds[0]; + if (*s == '-') + lp->constblock.Const.cds[0] = s + 1; + goto retlp; + } + if ((d = lp->constblock.Const.cd[0]) < 0.) + lp->constblock.Const.cd[0] = -d; + case TYCOMPLEX: + case TYDCOMPLEX: + return e; /* lazy way out */ + } + default: + badop("fold", opcode); + } + + rtype = rp->headblock.vtype; + + p = ALLOC(Constblock); + p->tag = TCONST; + p->vtype = etype; + p->vleng = e->exprblock.vleng; + + switch(opcode) + { + case OPCOMMA: + case OPCOMMA_ARG: + case OPQUEST: + case OPCOLON: + goto ereturn; + + case OPAND: + p->Const.ci = lp->constblock.Const.ci && + rp->constblock.Const.ci; + break; + + case OPOR: + p->Const.ci = lp->constblock.Const.ci || + rp->constblock.Const.ci; + break; + + case OPEQV: + p->Const.ci = lp->constblock.Const.ci == + rp->constblock.Const.ci; + break; + + case OPNEQV: + p->Const.ci = lp->constblock.Const.ci != + rp->constblock.Const.ci; + break; + + case OPBITAND: +#ifndef NO_LONG_LONG + if (etype == TYQUAD) { + LRget(&LL, &LR, lp, rp); + p->Const.cq = LL & LR; + } + else +#endif + p->Const.ci = lp->constblock.Const.ci & + rp->constblock.Const.ci; + break; + + case OPBITOR: +#ifndef NO_LONG_LONG + if (etype == TYQUAD) { + LRget(&LL, &LR, lp, rp); + p->Const.cq = LL | LR; + } + else +#endif + p->Const.ci = lp->constblock.Const.ci | + rp->constblock.Const.ci; + break; + + case OPBITXOR: +#ifndef NO_LONG_LONG + if (etype == TYQUAD) { + LRget(&LL, &LR, lp, rp); + p->Const.cq = LL ^ LR; + } + else +#endif + p->Const.ci = lp->constblock.Const.ci ^ + rp->constblock.Const.ci; + break; + + case OPLSHIFT: +#ifndef NO_LONG_LONG + if (etype == TYQUAD) { + LRget(&LL, &LR, lp, rp); + p->Const.cq = LL << (int)LR; + if (p->Const.cq >> (int)LR != LL) + intovfl(); + break; + } +#endif + p->Const.ci = lp->constblock.Const.ci << + rp->constblock.Const.ci; + if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci) + != lp->constblock.Const.ci) + intovfl(); + break; + + case OPRSHIFT: +#ifndef NO_LONG_LONG + if (etype == TYQUAD) { + LRget(&LL, &LR, lp, rp); + p->Const.cq = LL >> (int)LR; + } + else +#endif + p->Const.ci = (unsigned long)lp->constblock.Const.ci >> + rp->constblock.Const.ci; + break; + + case OPBITTEST: +#ifndef NO_LONG_LONG + if (ltype == TYQUAD) + p->Const.ci = (lp->constblock.Const.cq & + 1LL << rp->constblock.Const.ci) != 0; + else +#endif + p->Const.ci = (lp->constblock.Const.ci & + 1L << rp->constblock.Const.ci) != 0; + break; + + case OPBITCLR: +#ifndef NO_LONG_LONG + if (etype == TYQUAD) { + LRget(&LL, &LR, lp, rp); + p->Const.cq = LL & ~(1LL << (int)LR); + } + else +#endif + p->Const.ci = lp->constblock.Const.ci & + ~(1L << rp->constblock.Const.ci); + break; + + case OPBITSET: +#ifndef NO_LONG_LONG + if (etype == TYQUAD) { + LRget(&LL, &LR, lp, rp); + p->Const.cq = LL | (1LL << (int)LR); + } + else +#endif + p->Const.ci = lp->constblock.Const.ci | + 1L << rp->constblock.Const.ci; + break; + + case OPCONCAT: + ll = lp->constblock.vleng->constblock.Const.ci; + lr = rp->constblock.vleng->constblock.Const.ci; + bl = lp->constblock.Const.ccp1.blanks; + p->Const.ccp = q = (char *) ckalloc(ll+lr+bl); + p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks; + p->vleng = ICON(ll+lr+bl); + s = lp->constblock.Const.ccp; + for(i = 0 ; i < ll ; ++i) + *q++ = *s++; + for(i = 0 ; i < bl ; i++) + *q++ = ' '; + s = rp->constblock.Const.ccp; + for(i = 0; i < lr; ++i) + *q++ = *s++; + break; + + + case OPPOWER: + if( !ISINT(rtype) + || rp->constblock.Const.ci < 0 && zeroconst(lp)) + goto ereturn; + conspower(p, (Constp)lp, rp->constblock.Const.ci); + break; + + case OPSLASH: + if (zeroconst(rp)) + goto ereturn; + /* no break */ + + default: + if(ltype == TYCHAR) + { + lcon.Const.ci = cmpstr(lp->constblock.Const.ccp, + rp->constblock.Const.ccp, + lp->constblock.vleng->constblock.Const.ci, + rp->constblock.vleng->constblock.Const.ci); + rcon.Const.ci = 0; + mtype = tyint; + } + else { + mtype = maxtype(ltype, rtype); + consconv(mtype, &lcon, &lp->constblock); + consconv(mtype, &rcon, &rp->constblock); + } + consbinop(opcode, mtype, p, &lcon, &rcon); + break; + } + + frexpr(e); + return( (expptr) p ); + ereturn: + free((char *)p); + return e; +} + + + +/* assign constant l = r , doing coercion */ + + void +#ifdef KR_headers +consconv(lt, lc, rc) + int lt; + Constp lc; + Constp rc; +#else +consconv(int lt, Constp lc, Constp rc) +#endif +{ + int rt = rc->vtype; + union Constant *lv = &lc->Const, *rv = &rc->Const; + + lc->vtype = lt; + if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) { + memcpy((char *)lv, (char *)rv, sizeof(union Constant)); + lc->vstg = rc->vstg; + if (ISCOMPLEX(lt) && ISREAL(rt)) { + if (rc->vstg) + lv->cds[1] = cds("0",CNULL); + else + lv->cd[1] = 0.; + } + return; + } + lc->vstg = 0; + + switch(lt) + { + +/* Casting to character means just copying the first sizeof (character) + bytes into a new 1 character string. This is weird. */ + + case TYCHAR: + *(lv->ccp = (char *) ckalloc(1)) = (char)rv->ci; + lv->ccp1.blanks = 0; + break; + + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + if(rt == TYCHAR) + lv->ci = rv->ccp[0]; + else if( ISINT(rt) ) { +#ifndef NO_LONG_LONG + if (rt == TYQUAD) + lv->ci = rv->cq; + else +#endif + lv->ci = rv->ci; + } + else lv->ci = (ftnint)(rc->vstg + ? atof(rv->cds[0]) : rv->cd[0]); + + break; +#ifndef NO_LONG_LONG + case TYQUAD: + if(rt == TYCHAR) + lv->cq = rv->ccp[0]; + else if( ISINT(rt) ) { + if (rt == TYQUAD) + lv->cq = rv->cq; + else + lv->cq = rv->ci; + } + else lv->cq = (ftnint)(rc->vstg + ? atof(rv->cds[0]) : rv->cd[0]); + + break; +#endif + + case TYCOMPLEX: + case TYDCOMPLEX: + lv->cd[1] = 0.; + + case TYREAL: + case TYDREAL: +#ifndef NO_LONG_LONG + if (rt == TYQUAD) + lv->cd[0] = rv->cq; + else +#endif + lv->cd[0] = rv->ci; + break; + + case TYLOGICAL: + case TYLOGICAL1: + case TYLOGICAL2: + lv->ci = rv->ci; + break; + } +} + + + +/* Negate constant value -- changes the input node's value */ + + void +#ifdef KR_headers +consnegop(p) + Constp p; +#else +consnegop(Constp p) +#endif +{ + char *s; + ftnint L; +#ifndef NO_LONG_LONG + Llong LL; +#endif + + if (p->vstg) { + /* 20010820: comment out "*s == '0' ? s :" to preserve */ + /* the sign of zero */ + if (ISCOMPLEX(p->vtype)) { + s = p->Const.cds[1]; + p->Const.cds[1] = *s == '-' ? s+1 + : /* *s == '0' ? s : */ s-1; + } + s = p->Const.cds[0]; + p->Const.cds[0] = *s == '-' ? s+1 + : /* *s == '0' ? s : */ s-1; + return; + } + switch(p->vtype) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + p->Const.ci = -(L = p->Const.ci); + if (L != -p->Const.ci) + intovfl(); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + p->Const.cq = -(LL = p->Const.cq); + if (LL != -p->Const.cq) + intovfl(); + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + p->Const.cd[1] = - p->Const.cd[1]; + /* fall through and do the real parts */ + case TYREAL: + case TYDREAL: + p->Const.cd[0] = - p->Const.cd[0]; + break; + default: + badtype("consnegop", p->vtype); + } +} + + + +/* conspower -- Expand out an exponentiation */ + + LOCAL void +#ifdef KR_headers +conspower(p, ap, n) + Constp p; + Constp ap; + ftnint n; +#else +conspower(Constp p, Constp ap, ftnint n) +#endif +{ + union Constant *powp = &p->Const; + int type; + struct Constblock x, x0; + + if (n == 1) { + memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const)); + return; + } + + switch(type = ap->vtype) /* pow = 1 */ + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + powp->ci = 1; + break; +#ifndef NO_LONG_LONG + case TYQUAD: + powp->cq = 1; + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + powp->cd[1] = 0; + case TYREAL: + case TYDREAL: + powp->cd[0] = 1; + break; + default: + badtype("conspower", type); + } + + if(n == 0) + return; + switch(type) /* x0 = ap */ + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + x0.Const.ci = ap->Const.ci; + break; +#ifndef NO_LONG_LONG + case TYQUAD: + x0.Const.cq = ap->Const.cq; + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + x0.Const.cd[1] = + ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1]; + case TYREAL: + case TYDREAL: + x0.Const.cd[0] = + ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0]; + break; + } + x0.vtype = type; + x0.vstg = 0; + if(n < 0) + { + n = -n; + if( ISINT(type) ) + { + switch(ap->Const.ci) { + case 0: + err("0 ** negative number"); + return; + case 1: + case -1: + goto mult; + } + err("integer ** negative number"); + return; + } + else if (!x0.Const.cd[0] + && (!ISCOMPLEX(type) || !x0.Const.cd[1])) { + err("0.0 ** negative number"); + return; + } + consbinop(OPSLASH, type, &x, p, &x0); + } + else + mult: consbinop(OPSTAR, type, &x, p, &x0); + + for( ; ; ) + { + if(n & 01) + consbinop(OPSTAR, type, p, p, &x); + if(n >>= 1) + consbinop(OPSTAR, type, &x, &x, &x); + else + break; + } +} + + + +/* do constant operation cp = a op b -- assumes that ap and bp have data + matching the input type */ + + LOCAL void +#ifdef KR_headers +consbinop(opcode, type, cpp, app, bpp) + int opcode; + int type; + Constp cpp; + Constp app; + Constp bpp; +#else +consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp) +#endif +{ + union Constant *ap = &app->Const, + *bp = &bpp->Const, + *cp = &cpp->Const; + ftnint k; + double ad[2], bd[2], temp; + ftnint a, b; +#ifndef NO_LONG_LONG + Llong aL, bL; +#endif + + cpp->vstg = 0; + + if (ONEOF(type, MSKREAL|MSKCOMPLEX)) { + ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0]; + bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0]; + if (ISCOMPLEX(type)) { + ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1]; + bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1]; + } + } + switch(opcode) + { + case OPPLUS: + switch(type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + cp->ci = ap->ci + bp->ci; + if (ap->ci != cp->ci - bp->ci) + intovfl(); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + cp->cq = ap->cq + bp->cq; + if (ap->cq != cp->cq - bp->cq) + intovfl(); + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + cp->cd[1] = ad[1] + bd[1]; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] + bd[0]; + break; + } + break; + + case OPMINUS: + switch(type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + cp->ci = ap->ci - bp->ci; + if (ap->ci != bp->ci + cp->ci) + intovfl(); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + cp->cq = ap->cq - bp->cq; + if (ap->cq != bp->cq + cp->cq) + intovfl(); + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + cp->cd[1] = ad[1] - bd[1]; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] - bd[0]; + break; + } + break; + + case OPSTAR: + switch(type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + cp->ci = (a = ap->ci) * (b = bp->ci); + if (a && cp->ci / a != b) + intovfl(); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + cp->cq = (aL = ap->cq) * (bL = bp->cq); + if (aL && cp->cq / aL != bL) + intovfl(); + break; +#endif + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] * bd[0]; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + temp = ad[0] * bd[0] - ad[1] * bd[1] ; + cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ; + cp->cd[0] = temp; + break; + } + break; + case OPSLASH: + switch(type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + cp->ci = ap->ci / bp->ci; + break; +#ifndef NO_LONG_LONG + case TYQUAD: + cp->cq = ap->cq / bp->cq; + break; +#endif + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] / bd[0]; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd); + break; + } + break; + + case OPMOD: + if( ISINT(type) ) + { +#ifndef NO_LONG_LONG + if (type == TYQUAD) + cp->cq = ap->cq % bp->cq; + else +#endif + cp->ci = ap->ci % bp->ci; + break; + } + else + Fatal("inline mod of noninteger"); + + case OPMIN2: + case OPDMIN: + switch(type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci; + break; +#ifndef NO_LONG_LONG + case TYQUAD: + cp->cq = ap->cq <= bp->cq ? ap->cq : bp->cq; + break; +#endif + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0]; + break; + default: + Fatal("inline min of exected type"); + } + break; + + case OPMAX2: + case OPDMAX: + switch(type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci; + break; +#ifndef NO_LONG_LONG + case TYQUAD: + cp->cq = ap->cq >= bp->cq ? ap->cq : bp->cq; + break; +#endif + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0]; + break; + default: + Fatal("inline max of exected type"); + } + break; + + default: /* relational ops */ + switch(type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + if(ap->ci < bp->ci) + k = -1; + else if(ap->ci == bp->ci) + k = 0; + else k = 1; + break; +#ifndef NO_LONG_LONG + case TYQUAD: + if(ap->cq < bp->cq) + k = -1; + else if(ap->cq == bp->cq) + k = 0; + else k = 1; + break; +#endif + case TYREAL: + case TYDREAL: + if(ad[0] < bd[0]) + k = -1; + else if(ad[0] == bd[0]) + k = 0; + else k = 1; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + if(ad[0] == bd[0] && + ad[1] == bd[1] ) + k = 0; + else k = 1; + break; + case TYLOGICAL: + k = ap->ci - bp->ci; + } + + switch(opcode) + { + case OPEQ: + cp->ci = (k == 0); + break; + case OPNE: + cp->ci = (k != 0); + break; + case OPGT: + cp->ci = (k == 1); + break; + case OPLT: + cp->ci = (k == -1); + break; + case OPGE: + cp->ci = (k >= 0); + break; + case OPLE: + cp->ci = (k <= 0); + break; + } + break; + } +} + + + +/* conssgn - returns the sign of a Fortran constant */ + + int +#ifdef KR_headers +conssgn(p) + expptr p; +#else +conssgn(expptr p) +#endif +{ + char *s; + + if( ! ISCONST(p) ) + Fatal( "sgn(nonconstant)" ); + + switch(p->headblock.vtype) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + if(p->constblock.Const.ci > 0) return(1); + if(p->constblock.Const.ci < 0) return(-1); + return(0); +#ifndef NO_LONG_LONG + case TYQUAD: + if(p->constblock.Const.cq > 0) return(1); + if(p->constblock.Const.cq < 0) return(-1); + return(0); +#endif + + case TYREAL: + case TYDREAL: + if (p->constblock.vstg) { + s = p->constblock.Const.cds[0]; + if (*s == '-') + return -1; + if (*s == '0') + return 0; + return 1; + } + if(p->constblock.Const.cd[0] > 0) return(1); + if(p->constblock.Const.cd[0] < 0) return(-1); + return(0); + + +/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */ + + case TYCOMPLEX: + case TYDCOMPLEX: + if (p->constblock.vstg) + return *p->constblock.Const.cds[0] != '0' + && *p->constblock.Const.cds[1] != '0'; + return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0); + + default: + badtype( "conssgn", p->constblock.vtype); + } + /* NOT REACHED */ return 0; +} + +char *powint[ ] = { + "pow_ii", +#ifdef TYQUAD + "pow_qq", +#endif + "pow_ri", "pow_di", "pow_ci", "pow_zi" }; + + LOCAL expptr +#ifdef KR_headers +mkpower(p) + expptr p; +#else +mkpower(expptr p) +#endif +{ + expptr q, lp, rp; + int ltype, rtype, mtype, tyi; + + lp = p->exprblock.leftp; + rp = p->exprblock.rightp; + ltype = lp->headblock.vtype; + rtype = rp->headblock.vtype; + + if (lp->tag == TADDR) + lp->addrblock.parenused = 0; + + if (rp->tag == TADDR) + rp->addrblock.parenused = 0; + + if(ISICON(rp)) + { + if(rp->constblock.Const.ci == 0) + { + frexpr(p); + if( ISINT(ltype) ) + return( ICON(1) ); + else if (ISREAL (ltype)) + return mkconv (ltype, ICON (1)); + else + return( (expptr) putconst((Constp) + mkconv(ltype, ICON(1))) ); + } + if(rp->constblock.Const.ci < 0) + { + if( ISINT(ltype) ) + { + frexpr(p); + err("integer**negative"); + return( errnode() ); + } + rp->constblock.Const.ci = - rp->constblock.Const.ci; + p->exprblock.leftp = lp + = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp)); + } + if(rp->constblock.Const.ci == 1) + { + frexpr(rp); + free( (charptr) p ); + return(lp); + } + + if( ONEOF(ltype, MSKINT|MSKREAL) ) { + p->exprblock.vtype = ltype; + return(p); + } + } + if( ISINT(rtype) ) + { + if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) ) + q = call2(TYSHORT, "pow_hh", lp, rp); + else { + if(ONEOF(ltype,M(TYINT1)|M(TYSHORT))) + { + ltype = TYLONG; + lp = mkconv(TYLONG,lp); + } +#ifdef TYQUAD + if (ltype == TYQUAD) + rp = mkconv(TYQUAD,rp); + else +#endif + rp = mkconv(TYLONG,rp); + if (ISCONST(rp)) { + tyi = tyint; + tyint = TYLONG; + rp = (expptr)putconst((Constp)rp); + tyint = tyi; + } + q = call2(ltype, powint[ltype-TYLONG], lp, rp); + } + } + else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) { + extern int callk_kludge; + callk_kludge = TYDREAL; + q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); + callk_kludge = 0; + } + else { + q = call2(TYDCOMPLEX, "pow_zz", + mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); + if(mtype == TYCOMPLEX) + q = mkconv(TYCOMPLEX, q); + } + free( (charptr) p ); + return(q); +} + + +/* Complex Division. Same code as in Runtime Library +*/ + + + LOCAL void +#ifdef KR_headers +zdiv(c, a, b) + dcomplex *c; + dcomplex *a; + dcomplex *b; +#else +zdiv(dcomplex *c, dcomplex *a, dcomplex *b) +#endif +{ + double ratio, den; + double abr, abi; + + if( (abr = b->dreal) < 0.) + abr = - abr; + if( (abi = b->dimag) < 0.) + abi = - abi; + if( abr <= abi ) + { + if(abi == 0) + Fatal("complex division by zero"); + ratio = b->dreal / b->dimag ; + den = b->dimag * (1 + ratio*ratio); + c->dreal = (a->dreal*ratio + a->dimag) / den; + c->dimag = (a->dimag*ratio - a->dreal) / den; + } + + else + { + ratio = b->dimag / b->dreal ; + den = b->dreal * (1 + ratio*ratio); + c->dreal = (a->dreal + a->dimag*ratio) / den; + c->dimag = (a->dimag - a->dreal*ratio) / den; + } +} + + + void +#ifdef KR_headers +sserr(np) Namep np; +#else +sserr(Namep np) +#endif +{ + errstr(np->vtype == TYCHAR + ? "substring of character array %.70s" + : "substring of noncharacter %.73s", np->fvarname); + } diff --git a/unix/f2c/src/f2c.1 b/unix/f2c/src/f2c.1 new file mode 100644 index 00000000..3bdbc8b8 --- /dev/null +++ b/unix/f2c/src/f2c.1 @@ -0,0 +1,222 @@ + + F2C(1) UNIX System V F2C(1) + + NAME + f2c - Convert Fortran 77 to C or C++ + + SYNOPSIS + f2c [ option ... ] file ... + + DESCRIPTION + F2c converts Fortran 77 source code in files with names end- + ing in `.f' or `.F' to C (or C++) source files in the cur- + rent directory, with `.c' substituted for the final `.f' or + `.F'. If no Fortran files are named, f2c reads Fortran from + standard input and writes C on standard output. File names + that end with `.p' or `.P' are taken to be prototype files, + as produced by option `-P', and are read first. + + The following options have the same meaning as in f77(1). + + -C Compile code to check that subscripts are within + declared array bounds. + + -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long + int. Assume the default libF77 and libI77: allow only + INTEGER*4 (and no LOGICAL) variables in INQUIREs. + Option `-I4' confirms the default rendering of INTEGER + as long int. + + -Idir + Look for a non-absolute include file first in the + directory of the current input file, then in directo- + ries specified by -I options (one directory per + option). Options -I2 and -I4 have precedence, so, + e.g., a directory named 2 should be specified by -I./2 + . + + -onetrip + Compile DO loops that are performed at least once if + reached. (Fortran 77 DO loops are not performed at all + if the upper limit is smaller than the lower limit.) + + -U Honor the case of variable and external names. Fortran + keywords must be in lower case. + + -u Make the default type of a variable `undefined' rather + than using the default Fortran rules. + + -w Suppress all warning messages, or, if the option is + `-w66', just Fortran 66 compatibility warnings. + + The following options are peculiar to f2c. + + -A Produce ANSI C (default, starting 20020621). For old- + style C, use option -K. + + Page 1 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + -a Make local variables automatic rather than static + unless they appear in a DATA, EQUIVALENCE, NAMELIST, or + SAVE statement. + + -C++ Output C++ code. + + -c Include original Fortran source as comments. + + -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and + cdsqrt as synonyms for the double complex intrinsics + zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, + nor dreal as a synonym for dble. + + -ddir + Write `.c' files in directory dir instead of the cur- + rent directory. + + -E Declare uninitialized COMMON to be Extern (overridably + defined in f2c.h as extern). + + -ec Place uninitialized COMMON blocks in separate files: + COMMON /ABC/ appears in file abc_com.c. Option `-e1c' + bundles the separate files into the output file, with + comments that give an unbundling sed(1) script. + + -ext Complain about f77(1) extensions. + + -f Assume free-format input: accept text after column 72 + and do not pad fixed-format lines shorter than 72 char- + acters with blanks. + + -72 Treat text appearing after column 72 as an error. + + -g Include original Fortran line numbers in #line lines. + + -h Emulate Fortran 66's treatment of Hollerith: try to + align character strings on word (or, if the option is + `-hd', on double-word) boundaries. + + -i2 Similar to -I2, but assume a modified libF77 and libI77 + (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- + ables may be assigned by INQUIRE and array lengths are + stored in short ints. + + -i90 Do not recognize the Fortran 90 bit-manipulation + intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, + ishft, and ishftc. + + -kr Use temporary values to enforce Fortran expression + evaluation where K&R (first edition) parenthesization + rules allow rearrangement. If the option is `-krd', + use double precision temporaries even for single- + + Page 2 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + precision operands. + + -P Write a file.P of ANSI (or C++) prototypes for defini- + tions in each input file.f or file.F. When reading + Fortran from standard input, write prototypes at the + beginning of standard output. Option -Ps implies -P + and gives exit status 4 if rerunning f2c may change + prototypes or declarations. + + -p Supply preprocessor definitions to make common-block + members look like local variables. + + -R Do not promote REAL functions and operations to DOUBLE + PRECISION. Option `-!R' confirms the default, which + imitates f77. + + -r Cast REAL arguments of intrinsic functions and values + of REAL functions (including intrinsics) to REAL. + + -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE + COMPLEX. + + -s Preserve multidimensional subscripts. Suppressed by + option `-C' . + + -Tdir + Put temporary files in directory dir. + + -trapuv + Dynamically initialize local variables, except those + appearing in SAVE or DATA statements, with values that + may help find references to uninitialized variables. + For example, with IEEE arithmetic, initialize local + floating-point variables to signaling NaNs. + + -w8 Suppress warnings when COMMON or EQUIVALENCE forces + odd-word alignment of doubles. + + -Wn Assume n characters/word (default 4) when initializing + numeric variables with character data. + + -z Do not implicitly recognize DOUBLE COMPLEX. + + -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, + \f, \n, \r, \t, \v) in character strings. + + -!c Inhibit C output, but produce -P output. + + -!I Reject include statements. + + -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', + permit INTEGER*8 but do not promote integer constants + + Page 3 (printed 6/21/02) + + F2C(1) UNIX System V F2C(1) + + to INTEGER*8 when they involve more than 32 bits. + + -!it Don't infer types of untyped EXTERNAL procedures from + use as parameters to previously defined or prototyped + procedures. + + -!P Do not attempt to infer ANSI or C++ prototypes from + usage. + + The resulting C invokes the support routines of f77; object + code should be loaded by f77 or with ld(1) or cc(1) options + -lF77 -lI77 -lm. Calling conventions are those of f77: see + the reference below. + + FILES + file.[fF] input file + + *.c output file + + /usr/include/f2c.h + header file + + /usr/lib/libF77.aintrinsic function library + + /usr/lib/libI77.aFortran I/O library + + /lib/libc.a C library, see section 3 + + SEE ALSO + S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 + Compiler', UNIX Time Sharing System Programmer's Manual, + Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. + + DIAGNOSTICS + The diagnostics produced by f2c are intended to be self- + explanatory. + + BUGS + Floating-point constant expressions are simplified in the + floating-point arithmetic of the machine running f2c, so + they are typically accurate to at most 16 or 17 decimal + places. + Untypable EXTERNAL functions are declared int. + There is no notation for INTEGER*8 constants. + Some intrinsic functions do not yet work with INTEGER*8 . + + Page 4 (printed 6/21/02) + diff --git a/unix/f2c/src/f2c.1t b/unix/f2c/src/f2c.1t new file mode 100644 index 00000000..d73d3347 --- /dev/null +++ b/unix/f2c/src/f2c.1t @@ -0,0 +1,391 @@ +. \" Definitions of F, L and LR for the benefit of systems +. \" whose -man lacks them... +.de F +.nh +.if n \%\&\\$1 +.if t \%\&\f(CW\\$1\fR +.hy 14 +.. +.de L +.nh +.if n \%`\\$1' +.if t \%\&\f(CW\\$1\fR +.hy 14 +.. +.de LR +.nh +.if n \%`\\$1'\\$2 +.if t \%\&\f(CW\\$1\fR\\$2 +.hy 14 +.. +.TH F2C 1 +.CT 1 prog_other +.SH NAME +f2c \- Convert Fortran 77 to C or C++ +. \" f\^2c changed to f2c in the previous line for the benefit of +. \" people on systems (e.g. Sun systems) whose makewhatis cannot +. \" cope with troff formatting commands. +.SH SYNOPSIS +.B f\^2c +[ +.I option ... +] +.I file ... +.SH DESCRIPTION +.I F2c +converts Fortran 77 source code in +.I files +with names ending in +.L .f +or +.L .F +to C (or C++) source files in the +current directory, with +.L .c +substituted +for the final +.L .f +or +.LR .F . +If no Fortran files are named, +.I f\^2c +reads Fortran from standard input and +writes C on standard output. +.I File +names that end with +.L .p +or +.L .P +are taken to be prototype +files, as produced by option +.LR -P , +and are read first. +.PP +The following options have the same meaning as in +.IR f\^77 (1). +.TP +.B -C +Compile code to check that subscripts are within declared array bounds. +.TP +.B -I2 +Render INTEGER and LOGICAL as short, +INTEGER\(**4 as long int. Assume the default \fIlibF77\fR +and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL) +variables in INQUIREs. Option +.L -I4 +confirms the default rendering of INTEGER as long int. +.TP +.BI -I dir +Look for a non-absolute include file first in the directory of the +current input file, then in directories specified by \f(CW-I\fP +options (one directory per option). Options +\f(CW-I2\fP and \f(CW-I4\fP +have precedence, so, e.g., a directory named \f(CW2\fP +should be specified by \f(CW-I./2\fP . +.TP +.B -onetrip +Compile DO loops that are performed at least once if reached. +(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) +.TP +.B -U +Honor the case of variable and external names. Fortran keywords must be in +.I +lower +case. +.TP +.B -u +Make the default type of a variable `undefined' rather than using the default Fortran rules. +.TP +.B -w +Suppress all warning messages, or, if the option is +.LR -w66 , +just Fortran 66 compatibility warnings. +.PP +The following options are peculiar to +.IR f\^2c . +.TP +.B -A +Produce +.SM ANSI +C (default, starting 20020621). +For old-style C, use option \f(CW-K\fP. +.TP +.B -a +Make local variables automatic rather than static +unless they appear in a +.SM "DATA, EQUIVALENCE, NAMELIST," +or +.SM SAVE +statement. +.TP +.B -C++ +Output C++ code. +.TP +.B -c +Include original Fortran source as comments. +.TP +.B -cd +Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt +as synonyms for the double complex intrinsics +zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, +nor dreal as a synonym for dble. +.TP +.BI -d dir +Write +.L .c +files in directory +.I dir +instead of the current directory. +.TP +.B -E +Declare uninitialized +.SM COMMON +to be +.B Extern +(overridably defined in +.F f2c.h +as +.B extern). +.TP +.B -ec +Place uninitialized +.SM COMMON +blocks in separate files: +.B COMMON /ABC/ +appears in file +.BR abc_com.c . +Option +.LR -e1c +bundles the separate files +into the output file, with comments that give an unbundling +.IR sed (1) +script. +.TP +.B -ext +Complain about +.IR f\^77 (1) +extensions. +.TP +.B -f +Assume free-format input: accept text after column 72 and do not +pad fixed-format lines shorter than 72 characters with blanks. +.TP +.B -72 +Treat text appearing after column 72 as an error. +.TP +.B -g +Include original Fortran line numbers in \f(CW#line\fR lines. +.TP +.B -h +Emulate Fortran 66's treatment of Hollerith: try to align character strings on +word (or, if the option is +.LR -hd , +on double-word) boundaries. +.TP +.B -i2 +Similar to +.BR -I2 , +but assume a modified +.I libF77 +and +.I libI77 +(compiled with +.BR -Df\^2c_i2 ), +so +.SM INTEGER +and +.SM LOGICAL +variables may be assigned by +.SM INQUIRE +and array lengths are stored in short ints. +.TP +.B -i90 +Do not recognize the Fortran 90 bit-manipulation intrinsics +btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. +.TP +.B -kr +Use temporary values to enforce Fortran expression evaluation +where K&R (first edition) parenthesization rules allow rearrangement. +If the option is +.LR -krd , +use double precision temporaries even for single-precision operands. +.TP +.B -P +Write a +.IB file .P +of ANSI (or C++) prototypes +for definitions in each input +.IB file .f +or +.IB file .F . +When reading Fortran from standard input, write prototypes +at the beginning of standard output. Option +.B -Ps +implies +.B -P +and gives exit status 4 if rerunning +.I f\^2c +may change prototypes or declarations. +.TP +.B -p +Supply preprocessor definitions to make common-block members +look like local variables. +.TP +.B -R +Do not promote +.SM REAL +functions and operations to +.SM DOUBLE PRECISION. +Option +.L -!R +confirms the default, which imitates +.IR f\^77 . +.TP +.B -r +Cast REAL arguments of intrinsic functions and values of REAL +functions (including intrinsics) to REAL. +.TP +.B -r8 +Promote +.SM REAL +to +.SM DOUBLE PRECISION, COMPLEX +to +.SM DOUBLE COMPLEX. +.TP +.B -s +Preserve multidimensional subscripts. Suppressed by option +.L -C +\&. +.TP +.BI -T dir +Put temporary files in directory +.I dir. +.TP +.B -trapuv +Dynamically initialize local variables, except those appearing in +.SM SAVE +or +.SM DATA +statements, with values that may help find references to +uninitialized variables. For example, with IEEE arithmetic, +initialize local floating-point variables to signaling NaNs. +.TP +.B -w8 +Suppress warnings when +.SM COMMON +or +.SM EQUIVALENCE +forces odd-word alignment of doubles. +.TP +.BI -W n +Assume +.I n +characters/word (default 4) +when initializing numeric variables with character data. +.TP +.B -z +Do not implicitly recognize +.SM DOUBLE COMPLEX. +.TP +.B -!bs +Do not recognize \fIb\fRack\fIs\fRlash escapes +(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings. +.TP +.B -!c +Inhibit C output, but produce +.B -P +output. +.TP +.B -!I +Reject +.B include +statements. +.TP +.B -!i8 +Disallow +.SM INTEGER*8 , +or, if the option is +.LR -!i8const , +permit +.SM INTEGER*8 +but do not promote integer +constants to +.SM INTEGER*8 +when they involve more than 32 bits. +.TP +.B -!it +Don't infer types of untyped +.SM EXTERNAL +procedures from use as parameters to previously defined or prototyped +procedures. +.TP +.B -!P +Do not attempt to infer +.SM ANSI +or C++ +prototypes from usage. +.PP +The resulting C invokes the support routines of +.IR f\^77 ; +object code should be loaded by +.I f\^77 +or with +.IR ld (1) +or +.IR cc (1) +options +.BR "-lF77 -lI77 -lm" . +Calling conventions +are those of +.IR f\&77 : +see the reference below. +.br +.SH FILES +.TP +.nr )I 1.75i +.IB file .[fF] +input file +.TP +.B *.c +output file +.TP +.F /usr/include/f2c.h +header file +.TP +.F /usr/lib/libF77.a +intrinsic function library +.TP +.F /usr/lib/libI77.a +Fortran I/O library +.TP +.F /lib/libc.a +C library, see section 3 +.SH "SEE ALSO" +S. I. Feldman and +P. J. Weinberger, +`A Portable Fortran 77 Compiler', +\fIUNIX Time Sharing System Programmer's Manual\fR, +Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. +.SH DIAGNOSTICS +The diagnostics produced by +.I f\^2c +are intended to be +self-explanatory. +.SH BUGS +Floating-point constant expressions are simplified in +the floating-point arithmetic of the machine running +.IR f\^2c , +so they are typically accurate to at most 16 or 17 decimal places. +.br +Untypable +.SM EXTERNAL +functions are declared +.BR int . +.br +There is no notation for +.SM INTEGER*8 +constants. +.br +Some intrinsic functions do not yet work with +.SM INTEGER*8 . diff --git a/unix/f2c/src/f2c.h b/unix/f2c/src/f2c.h new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/src/f2c.h @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef long int integer; +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/unix/f2c/src/format.c b/unix/f2c/src/format.c new file mode 100644 index 00000000..96f2acf9 --- /dev/null +++ b/unix/f2c/src/format.c @@ -0,0 +1,2613 @@ +/**************************************************************** +Copyright 1990-1996, 1999-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* Format.c -- this file takes an intermediate file (generated by pass 1 + of the translator) and some state information about the contents of that + file, and generates C program text. */ + +#include "defs.h" +#include "p1defs.h" +#include "format.h" +#include "output.h" +#include "names.h" +#include "iob.h" + +int c_output_line_length = DEF_C_LINE_LENGTH; + +int last_was_label; /* Boolean used to generate semicolons + when a label terminates a block */ +static char this_proc_name[52]; /* Name of the current procedure. This is + probably too simplistic to handle + multiple entry points */ + +static tagptr do_format Argdcl((FILEP, FILEP)); +static void do_p1_1while Argdcl((FILEP)); +static void do_p1_2while Argdcl((FILEP, FILEP)); +static tagptr do_p1_addr Argdcl((FILEP, FILEP)); +static void do_p1_asgoto Argdcl((FILEP, FILEP)); +static tagptr do_p1_charp Argdcl((FILEP)); +static void do_p1_comment Argdcl((FILEP, FILEP)); +static void do_p1_comp_goto Argdcl((FILEP, FILEP)); +static tagptr do_p1_const Argdcl((FILEP)); +static void do_p1_elif Argdcl((FILEP, FILEP)); +static void do_p1_else Argdcl((FILEP)); +static void do_p1_elseifstart Argdcl((FILEP)); +static void do_p1_end_for Argdcl((FILEP)); +static void do_p1_endelse Argdcl((FILEP)); +static void do_p1_endif Argdcl((FILEP)); +static tagptr do_p1_expr Argdcl((FILEP, FILEP)); +static tagptr do_p1_extern Argdcl((FILEP)); +static void do_p1_for Argdcl((FILEP, FILEP)); +static void do_p1_fortran Argdcl((FILEP, FILEP)); +static void do_p1_goto Argdcl((FILEP, FILEP)); +static tagptr do_p1_head Argdcl((FILEP, FILEP)); +static tagptr do_p1_ident Argdcl((FILEP)); +static void do_p1_if Argdcl((FILEP, FILEP)); +static void do_p1_label Argdcl((FILEP, FILEP)); +static tagptr do_p1_list Argdcl((FILEP, FILEP)); +static tagptr do_p1_literal Argdcl((FILEP)); +static tagptr do_p1_name_pointer Argdcl((FILEP)); +static void do_p1_set_line Argdcl((FILEP)); +static void do_p1_subr_ret Argdcl((FILEP, FILEP)); +static int get_p1_token Argdcl((FILEP)); +static int p1get_const Argdcl((FILEP, int, Constp*)); +static int p1getd Argdcl((FILEP, long int*)); +static int p1getf Argdcl((FILEP, char**)); +static int p1getn Argdcl((FILEP, int, char**)); +static int p1gets Argdcl((FILEP, char*, int)); +static void proto Argdcl((FILEP, Argtypes*, char*)); + +extern chainp assigned_fmts; +char filename[P1_FILENAME_MAX]; +extern int gflag, sharp_line, trapuv; +extern int typeconv[]; +int gflag1; +extern char *parens; + + void +start_formatting(Void) +{ + FILE *infile; + static int wrote_one = 0; + extern int usedefsforcommon; + extern char *p1_file, *p1_bakfile; + + this_proc_name[0] = '\0'; + last_was_label = 0; + ei_next = ei_first; + wh_next = wh_first; + + (void) fclose (pass1_file); + if ((infile = fopen (p1_file, binread)) == NULL) + Fatal("start_formatting: couldn't open the intermediate file\n"); + + if (wrote_one) + nice_printf (c_file, "\n"); + + while (!feof (infile)) { + expptr this_expr; + + this_expr = do_format (infile, c_file); + if (this_expr) { + out_and_free_statement (c_file, this_expr); + } /* if this_expr */ + } /* while !feof infile */ + + (void) fclose (infile); + + if (last_was_label) + nice_printf (c_file, ";\n"); + + prev_tab (c_file); + gflag1 = sharp_line = 0; + if (this_proc_name[0]) + nice_printf (c_file, "} /* %s */\n", this_proc_name); + + +/* Write the #undefs for common variable reference */ + + if (usedefsforcommon) { + Extsym *ext; + int did_one = 0; + + for (ext = extsymtab; ext < nextext; ext++) + if (ext -> extstg == STGCOMMON && ext -> used_here) { + ext -> used_here = 0; + if (!did_one) + nice_printf (c_file, "\n"); + wr_abbrevs(c_file, 0, ext->extp); + did_one = 1; + ext -> extp = CHNULL; + } /* if */ + + if (did_one) + nice_printf (c_file, "\n"); + } /* if usedefsforcommon */ + + other_undefs(c_file); + + wrote_one = 1; + +/* For debugging only */ + + if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite))) + if (infile = fopen (p1_file, binread)) { + ffilecopy (infile, pass1_file); + fclose (infile); + fclose (pass1_file); + } /* if infile */ + +/* End of "debugging only" */ + + scrub(p1_file); /* optionally unlink */ + + if ((pass1_file = fopen (p1_file, binwrite)) == NULL) + err ("start_formatting: couldn't reopen the pass1 file"); + +} /* start_formatting */ + + + static void +#ifdef KR_headers +put_semi(outfile) + FILE *outfile; +#else +put_semi(FILE *outfile) +#endif +{ + nice_printf (outfile, ";\n"); + last_was_label = 0; + } + +#define SEM_CHECK(x) if (last_was_label) put_semi(x) + +/* do_format -- takes an input stream (a file in pass1 format) and writes + the appropriate C code to outfile when possible. When reading an + expression, the expression tree is returned instead. */ + + static expptr +#ifdef KR_headers +do_format(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_format(FILE *infile, FILE *outfile) +#endif +{ + int token_type, was_c_token; + expptr retval = ENULL; + + token_type = get_p1_token (infile); + was_c_token = 1; + switch (token_type) { + case P1_COMMENT: + do_p1_comment (infile, outfile); + was_c_token = 0; + break; + case P1_SET_LINE: + do_p1_set_line (infile); + was_c_token = 0; + break; + case P1_FILENAME: + p1gets(infile, filename, P1_FILENAME_MAX); + was_c_token = 0; + break; + case P1_NAME_POINTER: + retval = do_p1_name_pointer (infile); + break; + case P1_CONST: + retval = do_p1_const (infile); + break; + case P1_EXPR: + retval = do_p1_expr (infile, outfile); + break; + case P1_IDENT: + retval = do_p1_ident(infile); + break; + case P1_CHARP: + retval = do_p1_charp(infile); + break; + case P1_EXTERN: + retval = do_p1_extern (infile); + break; + case P1_HEAD: + gflag1 = sharp_line = 0; + retval = do_p1_head (infile, outfile); + gflag1 = sharp_line = gflag; + break; + case P1_LIST: + retval = do_p1_list (infile, outfile); + break; + case P1_LITERAL: + retval = do_p1_literal (infile); + break; + case P1_LABEL: + do_p1_label (infile, outfile); + /* last_was_label = 1; -- now set in do_p1_label */ + was_c_token = 0; + break; + case P1_ASGOTO: + do_p1_asgoto (infile, outfile); + break; + case P1_GOTO: + do_p1_goto (infile, outfile); + break; + case P1_IF: + do_p1_if (infile, outfile); + break; + case P1_ELSE: + SEM_CHECK(outfile); + do_p1_else (outfile); + break; + case P1_ELIF: + SEM_CHECK(outfile); + do_p1_elif (infile, outfile); + break; + case P1_ENDIF: + SEM_CHECK(outfile); + do_p1_endif (outfile); + break; + case P1_ENDELSE: + SEM_CHECK(outfile); + do_p1_endelse (outfile); + break; + case P1_ADDR: + retval = do_p1_addr (infile, outfile); + break; + case P1_SUBR_RET: + do_p1_subr_ret (infile, outfile); + break; + case P1_COMP_GOTO: + do_p1_comp_goto (infile, outfile); + break; + case P1_FOR: + do_p1_for (infile, outfile); + break; + case P1_ENDFOR: + SEM_CHECK(outfile); + do_p1_end_for (outfile); + break; + case P1_WHILE1START: + do_p1_1while(outfile); + break; + case P1_WHILE2START: + do_p1_2while(infile, outfile); + break; + case P1_PROCODE: + procode(outfile); + break; + case P1_ELSEIFSTART: + SEM_CHECK(outfile); + do_p1_elseifstart(outfile); + break; + case P1_FORTRAN: + do_p1_fortran(infile, outfile); + /* no break; */ + case P1_EOF: + was_c_token = 0; + break; + case P1_UNKNOWN: + Fatal("do_format: Unknown token type in intermediate file"); + break; + default: + Fatal("do_format: Bad token type in intermediate file"); + break; + } /* switch */ + + if (was_c_token) + last_was_label = 0; + return retval; +} /* do_format */ + + + static void +#ifdef KR_headers +do_p1_comment(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_comment(FILE *infile, FILE *outfile) +#endif +{ + extern int in_comment; + + char storage[COMMENT_BUFFER_SIZE + 1]; + int length; + + if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1)) + return; + + length = strlen (storage); + + gflag1 = sharp_line = 0; + in_comment = 1; + margin_printf(outfile, length ? "/* %s */\n" : "\n", storage); + in_comment = 0; + gflag1 = sharp_line = gflag; +} /* do_p1_comment */ + + static void +#ifdef KR_headers +do_p1_set_line(infile) + FILE *infile; +#else +do_p1_set_line(FILE *infile) +#endif +{ + int status; + long new_line_number = -1; + + status = p1getd (infile, &new_line_number); + + if (status == EOF) + err ("do_p1_set_line: Missing line number at end of file\n"); + else if (status == 0 || new_line_number == -1) + errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n", + new_line_number); + else { + lineno = new_line_number; + } +} /* do_p1_set_line */ + + + static expptr +#ifdef KR_headers +do_p1_name_pointer(infile) + FILE *infile; +#else +do_p1_name_pointer(FILE *infile) +#endif +{ + Namep namep = (Namep) NULL; + int status; + + status = p1getd (infile, (long *) &namep); + + if (status == EOF) + err ("do_p1_name_pointer: Missing pointer at end of file\n"); + else if (status == 0 || namep == (Namep) NULL) + erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '#%lx'\n", + (unsigned long) namep); + + return (expptr) namep; +} /* do_p1_name_pointer */ + + + + static expptr +#ifdef KR_headers +do_p1_const(infile) + FILE *infile; +#else +do_p1_const(FILE *infile) +#endif +{ + struct Constblock *c = (struct Constblock *) NULL; + long type = -1; + int status; + + status = p1getd (infile, &type); + + if (status == EOF) + err ("do_p1_const: Missing constant type at end of file\n"); + else if (status == 0) + errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type); + else { + status = p1get_const (infile, (int)type, &c); + + if (status == EOF) { + err ("do_p1_const: Missing constant value at end of file\n"); + c = (struct Constblock *) NULL; + } else if (status == 0) { + err ("do_p1_const: Illegal constant value in p1 file\n"); + c = (struct Constblock *) NULL; + } /* else */ + } /* else */ + return (expptr) c; +} /* do_p1_const */ + + void +#ifdef KR_headers +addrlit(addrp) + Addrp addrp; +#else +addrlit(Addrp addrp) +#endif +{ + long memno = addrp->memno; + struct Literal *litp, *lastlit; + + lastlit = litpool + nliterals; + for (litp = litpool; litp < lastlit; litp++) + if (litp->litnum == memno) { + addrp->vtype = litp->littype; + *((union Constant *) &(addrp->user)) = + *((union Constant *) &(litp->litval)); + addrp->vstg = STGMEMNO; + return; + } + err("addrlit failure!"); + } + + static expptr +#ifdef KR_headers +do_p1_literal(infile) + FILE *infile; +#else +do_p1_literal(FILE *infile) +#endif +{ + int status; + long memno; + Addrp addrp; + + status = p1getd (infile, &memno); + + if (status == EOF) + err ("do_p1_literal: Missing memno at end of file"); + else if (status == 0) + err ("do_p1_literal: Missing memno in p1 file"); + else { + addrp = ALLOC (Addrblock); + addrp -> tag = TADDR; + addrp -> vtype = TYUNKNOWN; + addrp -> Field = NULL; + addrp -> memno = memno; + addrlit(addrp); + addrp -> uname_tag = UNAM_CONST; + } /* else */ + + return (expptr) addrp; +} /* do_p1_literal */ + + + static void +#ifdef KR_headers +do_p1_label(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_label(FILE *infile, FILE *outfile) +#endif +{ + int status; + ftnint stateno; + struct Labelblock *L; + char *fmt; + + status = p1getd (infile, &stateno); + + if (status == EOF) + err ("do_p1_label: Missing label at end of file"); + else if (status == 0) + err ("do_p1_label: Missing label in p1 file "); + else if (stateno < 0) { /* entry */ + margin_printf(outfile, "\n%s:\n", user_label(stateno)); + last_was_label = 1; + } + else { + L = labeltab + stateno; + if (L->labused) { + fmt = "%s:\n"; + last_was_label = 1; + } + else + fmt = "/* %s: */\n"; + margin_printf(outfile, fmt, user_label(L->stateno)); + } /* else */ +} /* do_p1_label */ + + + + static void +#ifdef KR_headers +do_p1_asgoto(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_asgoto(FILE *infile, FILE *outfile) +#endif +{ + expptr expr; + + expr = do_format (infile, outfile); + out_asgoto (outfile, expr); + +} /* do_p1_asgoto */ + + + static void +#ifdef KR_headers +do_p1_goto(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_goto(FILE *infile, FILE *outfile) +#endif +{ + int status; + long stateno; + + status = p1getd (infile, &stateno); + + if (status == EOF) + err ("do_p1_goto: Missing goto label at end of file"); + else if (status == 0) + err ("do_p1_goto: Missing goto label in p1 file"); + else { + nice_printf (outfile, "goto %s;\n", user_label (stateno)); + } /* else */ +} /* do_p1_goto */ + + + static void +#ifdef KR_headers +do_p1_if(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_if(FILE *infile, FILE *outfile) +#endif +{ + expptr cond; + + do { + cond = do_format (infile, outfile); + } while (cond == ENULL); + + out_if (outfile, cond); +} /* do_p1_if */ + + + static void +#ifdef KR_headers +do_p1_else(outfile) + FILE *outfile; +#else +do_p1_else(FILE *outfile) +#endif +{ + out_else (outfile); +} /* do_p1_else */ + + + static void +#ifdef KR_headers +do_p1_elif(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_elif(FILE *infile, FILE *outfile) +#endif +{ + expptr cond; + + do { + cond = do_format (infile, outfile); + } while (cond == ENULL); + + elif_out (outfile, cond); +} /* do_p1_elif */ + + static void +#ifdef KR_headers +do_p1_endif(outfile) + FILE *outfile; +#else +do_p1_endif(FILE *outfile) +#endif +{ + endif_out (outfile); +} /* do_p1_endif */ + + + static void +#ifdef KR_headers +do_p1_endelse(outfile) + FILE *outfile; +#else +do_p1_endelse(FILE *outfile) +#endif +{ + end_else_out (outfile); +} /* do_p1_endelse */ + + + static expptr +#ifdef KR_headers +do_p1_addr(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_addr(FILE *infile, FILE *outfile) +#endif +{ + Addrp addrp = (Addrp) NULL; + int status; + + status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp); + + if (status == EOF) + err ("do_p1_addr: Missing Addrp at end of file"); + else if (status == 0) + err ("do_p1_addr: Missing Addrp in p1 file"); + else if (addrp == (Addrp) NULL) + err ("do_p1_addr: Null addrp in p1 file"); + else if (addrp -> tag != TADDR) + erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag); + else { + addrp -> vleng = do_format (infile, outfile); + addrp -> memoffset = do_format (infile, outfile); + } + + return (expptr) addrp; +} /* do_p1_addr */ + + + + static void +#ifdef KR_headers +do_p1_subr_ret(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_subr_ret(FILE *infile, FILE *outfile) +#endif +{ + expptr retval; + + nice_printf (outfile, "return "); + retval = do_format (infile, outfile); + if (!multitype) + if (retval) + expr_out (outfile, retval); + + nice_printf (outfile, ";\n"); +} /* do_p1_subr_ret */ + + + + static void +#ifdef KR_headers +do_p1_comp_goto(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_comp_goto(FILE *infile, FILE *outfile) +#endif +{ + expptr index; + expptr labels; + + index = do_format (infile, outfile); + + if (index == ENULL) { + err ("do_p1_comp_goto: no expression for computed goto"); + return; + } /* if index == ENULL */ + + labels = do_format (infile, outfile); + + if (labels && labels -> tag != TLIST) + erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag); + else + compgoto_out (outfile, index, labels); +} /* do_p1_comp_goto */ + + + static void +#ifdef KR_headers +do_p1_for(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_for(FILE *infile, FILE *outfile) +#endif +{ + expptr init, test, inc; + + init = do_format (infile, outfile); + test = do_format (infile, outfile); + inc = do_format (infile, outfile); + + out_for (outfile, init, test, inc); +} /* do_p1_for */ + + static void +#ifdef KR_headers +do_p1_end_for(outfile) + FILE *outfile; +#else +do_p1_end_for(FILE *outfile) +#endif +{ + out_end_for (outfile); +} /* do_p1_end_for */ + + + static void +#ifdef KR_headers +do_p1_fortran(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_fortran(FILE *infile, FILE *outfile) +#endif +{ + char buf[P1_STMTBUFSIZE]; + if (!p1gets(infile, buf, P1_STMTBUFSIZE)) + return; + /* bypass nice_printf nonsense */ + fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */ + } + + + static expptr +#ifdef KR_headers +do_p1_expr(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_expr(FILE *infile, FILE *outfile) +#endif +{ + int status; + long opcode, type; + struct Exprblock *result = (struct Exprblock *) NULL; + + status = p1getd (infile, &opcode); + + if (status == EOF) + err ("do_p1_expr: Missing expr opcode at end of file"); + else if (status == 0) + err ("do_p1_expr: Missing expr opcode in p1 file"); + else { + + status = p1getd (infile, &type); + + if (status == EOF) + err ("do_p1_expr: Missing expr type at end of file"); + else if (status == 0) + err ("do_p1_expr: Missing expr type in p1 file"); + else if (opcode == 0) + return ENULL; + else { + result = ALLOC (Exprblock); + + result -> tag = TEXPR; + result -> vtype = (field)type; + result -> opcode = (unsigned int)opcode; + result -> vleng = do_format (infile, outfile); + + if (is_unary_op (opcode)) + result -> leftp = do_format (infile, outfile); + else if (is_binary_op (opcode)) { + result -> leftp = do_format (infile, outfile); + result -> rightp = do_format (infile, outfile); + } else + errl("do_p1_expr: Illegal opcode %ld", opcode); + } /* else */ + } /* else */ + + return (expptr) result; +} /* do_p1_expr */ + + + static expptr +#ifdef KR_headers +do_p1_ident(infile) + FILE *infile; +#else +do_p1_ident(FILE *infile) +#endif +{ + Addrp addrp; + int status; + long vtype, vstg; + + addrp = ALLOC (Addrblock); + addrp -> tag = TADDR; + + status = p1getd (infile, &vtype); + if (status == EOF) + err ("do_p1_ident: Missing identifier type at end of file\n"); + else if (status == 0 || vtype < 0 || vtype >= NTYPES) + errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); + else + addrp -> vtype = (field)vtype; + + status = p1getd (infile, &vstg); + if (status == EOF) + err ("do_p1_ident: Missing identifier storage at end of file\n"); + else if (status == 0 || vstg < 0 || vstg > STGNULL) + errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); + else + addrp -> vstg = (field)vstg; + + status = p1gets(infile, addrp->user.ident, IDENT_LEN); + + if (status == EOF) + err ("do_p1_ident: Missing ident string at end of file"); + else if (status == 0) + err ("do_p1_ident: Missing ident string in intermediate file"); + addrp->uname_tag = UNAM_IDENT; + return (expptr) addrp; +} /* do_p1_ident */ + + static expptr +#ifdef KR_headers +do_p1_charp(infile) + FILE *infile; +#else +do_p1_charp(FILE *infile) +#endif +{ + Addrp addrp; + int status; + long vtype, vstg; + char buf[64]; + + addrp = ALLOC (Addrblock); + addrp -> tag = TADDR; + + status = p1getd (infile, &vtype); + if (status == EOF) + err ("do_p1_ident: Missing identifier type at end of file\n"); + else if (status == 0 || vtype < 0 || vtype >= NTYPES) + errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); + else + addrp -> vtype = (field)vtype; + + status = p1getd (infile, &vstg); + if (status == EOF) + err ("do_p1_ident: Missing identifier storage at end of file\n"); + else if (status == 0 || vstg < 0 || vstg > STGNULL) + errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); + else + addrp -> vstg = (field)vstg; + + status = p1gets(infile, buf, (int)sizeof(buf)); + + if (status == EOF) + err ("do_p1_ident: Missing charp ident string at end of file"); + else if (status == 0) + err ("do_p1_ident: Missing charp ident string in intermediate file"); + addrp->uname_tag = UNAM_CHARP; + addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf); + return (expptr) addrp; +} + + + static expptr +#ifdef KR_headers +do_p1_extern(infile) + FILE *infile; +#else +do_p1_extern(FILE *infile) +#endif +{ + Addrp addrp; + + addrp = ALLOC (Addrblock); + if (addrp) { + int status; + + addrp->tag = TADDR; + addrp->vstg = STGEXT; + addrp->uname_tag = UNAM_EXTERN; + status = p1getd (infile, &(addrp -> memno)); + if (status == EOF) + err ("do_p1_extern: Missing memno at end of file"); + else if (status == 0) + err ("do_p1_extern: Missing memno in intermediate file"); + if (addrp->vtype = extsymtab[addrp->memno].extype) + addrp->vclass = CLPROC; + } /* if addrp */ + + return (expptr) addrp; +} /* do_p1_extern */ + + + + static expptr +#ifdef KR_headers +do_p1_head(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_head(FILE *infile, FILE *outfile) +#endif +{ + int status; + int add_n_; + long Class; + char storage[256]; + + status = p1getd (infile, &Class); + if (status == EOF) + err ("do_p1_head: missing header class at end of file"); + else if (status == 0) + err ("do_p1_head: missing header class in p1 file"); + else { + status = p1gets (infile, storage, (int)sizeof(storage)); + if (status == EOF || status == 0) + storage[0] = '\0'; + } /* else */ + + if (Class == CLPROC || Class == CLMAIN) { + chainp lengths; + + add_n_ = nentry > 1; + lengths = length_comp(entries, add_n_); + + if (!add_n_ && protofile && Class != CLMAIN) + protowrite(protofile, proctype, storage, entries, lengths); + + if (Class == CLMAIN) + nice_printf (outfile, "/* Main program */ int "); + else + nice_printf(outfile, "%s ", multitype ? "VOID" + : c_type_decl(proctype, 1)); + + nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage); + if (!Ansi) { + listargs(outfile, entries, add_n_, lengths); + nice_printf (outfile, "\n"); + } + list_arg_types (outfile, entries, lengths, add_n_, "\n"); + nice_printf (outfile, "{\n"); + frchain(&lengths); + next_tab (outfile); + strcpy(this_proc_name, storage); + list_decls (outfile); + + } else if (Class == CLBLOCK) + next_tab (outfile); + else + errl("do_p1_head: got class %ld", Class); + + return NULL; +} /* do_p1_head */ + + + static expptr +#ifdef KR_headers +do_p1_list(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_list(FILE *infile, FILE *outfile) +#endif +{ + long tag, type, count; + int status; + expptr result; + + status = p1getd (infile, &tag); + if (status == EOF) + err ("do_p1_list: missing list tag at end of file"); + else if (status == 0) + err ("do_p1_list: missing list tag in p1 file"); + else { + status = p1getd (infile, &type); + if (status == EOF) + err ("do_p1_list: missing list type at end of file"); + else if (status == 0) + err ("do_p1_list: missing list type in p1 file"); + else { + status = p1getd (infile, &count); + if (status == EOF) + err ("do_p1_list: missing count at end of file"); + else if (status == 0) + err ("do_p1_list: missing count in p1 file"); + } /* else */ + } /* else */ + + result = (expptr) ALLOC (Listblock); + if (result) { + chainp pointer; + + result -> tag = (field)tag; + result -> listblock.vtype = (field)type; + +/* Assume there will be enough data */ + + if (count--) { + pointer = result->listblock.listp = + mkchain((char *)do_format(infile, outfile), CHNULL); + while (count--) { + pointer -> nextp = + mkchain((char *)do_format(infile, outfile), CHNULL); + pointer = pointer -> nextp; + } /* while (count--) */ + } /* if (count) */ + } /* if (result) */ + + return result; +} /* do_p1_list */ + + + chainp +#ifdef KR_headers +length_comp(e, add_n) + struct Entrypoint *e; + int add_n; +#else +length_comp(struct Entrypoint *e, int add_n) +#endif + /* get lengths of characters args */ +{ + chainp lengths; + chainp args, args1; + Namep arg, np; + int nchargs; + Argtypes *at; + Atype *a; + extern int init_ac[TYSUBR+1]; + + if (!e) + return 0; /* possible only with errors */ + args = args1 = add_n ? allargs : e->arglist; + nchargs = 0; + for (lengths = NULL; args; args = args -> nextp) + if (arg = (Namep)args->datap) { + if (arg->vclass == CLUNKNOWN) + arg->vclass = CLVAR; + if (arg->vtype == TYCHAR && arg->vclass != CLPROC) { + lengths = mkchain((char *)arg, lengths); + nchargs++; + } + } + if (!add_n && (np = e->enamep)) { + /* one last check -- by now we know all we ever will + * about external args... + */ + save_argtypes(e->arglist, &e->entryname->arginfo, + &np->arginfo, 0, np->fvarname, STGEXT, nchargs, + np->vtype, 1); + at = e->entryname->arginfo; + a = at->atypes + init_ac[np->vtype]; + for(; args1; a++, args1 = args1->nextp) { + frchain(&a->cp); + if (arg = (Namep)args1->datap) + switch(arg->vclass) { + case CLPROC: + if (arg->vimpltype + && a->type >= 300) + a->type = TYUNKNOWN + 200; + break; + case CLUNKNOWN: + a->type %= 100; + } + } + } + return revchain(lengths); + } + + void +#ifdef KR_headers +listargs(outfile, entryp, add_n_, lengths) + FILE *outfile; + struct Entrypoint *entryp; + int add_n_; + chainp lengths; +#else +listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths) +#endif +{ + chainp args; + char *s; + Namep arg; + int did_one = 0; + + nice_printf (outfile, "("); + + if (add_n_) { + nice_printf(outfile, "n__"); + did_one = 1; + args = allargs; + } + else { + if (!entryp) + return; /* possible only with errors */ + args = entryp->arglist; + } + + if (multitype) + { + nice_printf(outfile, ", ret_val"); + did_one = 1; + args = allargs; + } + else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR)) + { + s = xretslot[proctype]->user.ident; + nice_printf(outfile, did_one ? ", %s" : "%s", + *s == '(' /*)*/ ? "r_v" : s); + did_one = 1; + if (proctype == TYCHAR) + nice_printf (outfile, ", ret_val_len"); + } + for (; args; args = args -> nextp) + if (arg = (Namep)args->datap) { + nice_printf (outfile, "%s", did_one ? ", " : ""); + out_name (outfile, arg); + did_one = 1; + } + + for (args = lengths; args; args = args -> nextp) + nice_printf(outfile, ", %s", + new_arg_length((Namep)args->datap)); + nice_printf (outfile, ")"); +} /* listargs */ + + + void +#ifdef KR_headers +list_arg_types(outfile, entryp, lengths, add_n_, finalnl) + FILE *outfile; + struct Entrypoint *entryp; + chainp lengths; + int add_n_; + char *finalnl; +#else +list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl) +#endif +{ + chainp args; + int last_type = -1, last_class = -1; + int did_one = 0, done_one, is_ext; + char *s, *sep = "", *sep1; + + if (outfile == (FILE *) NULL) { + err ("list_arg_types: null output file"); + return; + } else if (entryp == (struct Entrypoint *) NULL) { + err ("list_arg_types: null procedure entry pointer"); + return; + } /* else */ + + if (Ansi) { + done_one = 0; + sep1 = ", "; + nice_printf(outfile, "(" /*)*/); + } + else { + done_one = 1; + sep1 = ";\n"; + } + args = entryp->arglist; + if (add_n_) { + nice_printf(outfile, "int n__"); + did_one = done_one; + sep = sep1; + args = allargs; + } + if (multitype) { + nice_printf(outfile, "%sMultitype *ret_val", sep); + did_one = done_one; + sep = sep1; + } + else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) { + s = xretslot[proctype]->user.ident; + nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0), + *s == '(' /*)*/ ? "r_v" : s); + did_one = done_one; + sep = sep1; + if (proctype == TYCHAR) + nice_printf (outfile, "%sftnlen ret_val_len", sep); + } /* if ONEOF proctype */ + for (; args; args = args -> nextp) { + Namep arg = (Namep) args->datap; + +/* Scalars are passed by reference, and arrays will have their lower bound + adjusted, so nearly everything is printed with a star in front. The + exception is character lengths, which are passed by value. */ + + if (arg) { + int type = arg -> vtype, vclass = arg -> vclass; + + if (vclass == CLPROC) + if (arg->vimpltype) + type = Castargs ? TYUNKNOWN : TYSUBR; + else if (type == TYREAL && forcedouble && !Castargs) + type = TYDREAL; + + if (type == last_type && vclass == last_class && did_one) + nice_printf (outfile, ", "); + else + if ((is_ext = vclass == CLPROC) && Castargs) + nice_printf(outfile, "%s%s ", sep, + usedcasts[type] = casttypes[type]); + else + nice_printf(outfile, "%s%s ", sep, + c_type_decl(type, is_ext)); + if (vclass == CLPROC) + if (Castargs) + out_name(outfile, arg); + else { + nice_printf(outfile, "(*"); + out_name(outfile, arg); + nice_printf(outfile, ") %s", parens); + } + else { + nice_printf (outfile, "*"); + out_name (outfile, arg); + } + + last_type = type; + last_class = vclass; + did_one = done_one; + sep = sep1; + } /* if (arg) */ + } /* for args = entryp -> arglist */ + + for (args = lengths; args; args = args -> nextp) + nice_printf(outfile, "%sftnlen %s", sep, + new_arg_length((Namep)args->datap)); + if (did_one) + nice_printf (outfile, ";\n"); + else if (Ansi) + nice_printf(outfile, + /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s", + finalnl); +} /* list_arg_types */ + + static void +#ifdef KR_headers +write_formats(outfile) + FILE *outfile; +#else +write_formats(FILE *outfile) +#endif +{ + register struct Labelblock *lp; + int first = 1; + char *fs; + + for(lp = labeltab ; lp < highlabtab ; ++lp) + if (lp->fmtlabused) { + if (first) { + first = 0; + nice_printf(outfile, "/* Format strings */\n"); + } + nice_printf(outfile, "static char fmt_%ld[] = \"", + lp->stateno); + if (!(fs = lp->fmtstring)) + fs = ""; + nice_printf(outfile, "%s\";\n", fs); + } + if (!first) + nice_printf(outfile, "\n"); + } + + static void +#ifdef KR_headers +write_ioblocks(outfile) + FILE *outfile; +#else +write_ioblocks(FILE *outfile) +#endif +{ + register iob_data *L; + register char *f, **s, *sep; + + nice_printf(outfile, "/* Fortran I/O blocks */\n"); + L = iob_list = (iob_data *)revchain((chainp)iob_list); + do { + nice_printf(outfile, "static %s %s = { ", + L->type, L->name); + sep = 0; + for(s = L->fields; f = *s; s++) { + if (sep) + nice_printf(outfile, sep); + sep = ", "; + if (*f == '"') { /* kludge */ + nice_printf(outfile, "\""); + nice_printf(outfile, "%s\"", f+1); + } + else + nice_printf(outfile, "%s", f); + } + nice_printf(outfile, " };\n"); + } + while(L = L->next); + nice_printf(outfile, "\n\n"); + } + + static void +#ifdef KR_headers +write_assigned_fmts(outfile) + FILE *outfile; +#else +write_assigned_fmts(FILE *outfile) +#endif +{ + register chainp cp; + Namep np; + char *comma, *type; + int did_one = 0; + + cp = assigned_fmts = revchain(assigned_fmts); + nice_printf(outfile, "/* Assigned format variables */\n"); + do { + np = (Namep)cp->datap; + if (did_one == np->vstg) { + comma = ", "; + type = ""; + } + else { + comma = (char*)(did_one ? ";\n" : ""); + type = (char*)(np->vstg == STGAUTO + ? "char " : "static char "); + did_one = np->vstg; + } + nice_printf(outfile, "%s%s*%s_fmt", comma, type, np->fvarname); + } + while(cp = cp->nextp); + nice_printf(outfile, ";\n\n"); + } + + static char * +#ifdef KR_headers +to_upper(s) + register char *s; +#else +to_upper(register char *s) +#endif +{ + static char buf[64]; + register char *t = buf; + register int c; + while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c); + return buf; + } + + +/* This routine creates static structures representing a namelist. + Declarations of the namelist and related structures are: + + struct Vardesc { + char *name; + char *addr; + ftnlen *dims; *//* laid out as struct dimensions below *//* + int type; + }; + typedef struct Vardesc Vardesc; + + struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; + + struct dimensions + { + ftnlen numberofdimensions; + ftnlen numberofelements + ftnlen baseoffset; + ftnlen span[numberofdimensions-1]; + }; + + If dims is not null, then the corner element of the array is at + addr. However, the element with subscripts (i1,...,in) is at + addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset) +*/ + + static void +#ifdef KR_headers +write_namelists(nmch, outfile) + chainp nmch; + FILE *outfile; +#else +write_namelists(chainp nmch, FILE *outfile) +#endif +{ + Namep var; + struct Hashentry *entry; + struct Dimblock *dimp; + int i, nd, type; + char *comma, *name; + register chainp q; + register Namep v; + + nice_printf(outfile, "/* Namelist stuff */\n\n"); + for (entry = hashtab; entry < lasthash; ++entry) { + if (!(v = entry->varp) || !v->vnamelist) + continue; + type = v->vtype; + name = v->cvarname; + if (dimp = v->vdim) { + nd = dimp->ndim; + nice_printf(outfile, + "static ftnlen %s_dims[] = { %d, %ld, %ld", + name, nd, + dimp->nelt->constblock.Const.ci, + dimp->baseoffset->constblock.Const.ci); + for(i = 0, --nd; i < nd; i++) + nice_printf(outfile, ", %ld", + dimp->dims[i].dimsize->constblock.Const.ci); + nice_printf(outfile, " };\n"); + } + nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s", + name, to_upper(v->fvarname), + type == TYCHAR ? "" + : (dimp || oneof_stg(v,v->vstg, + M(STGEQUIV)|M(STGCOMMON))) + ? "(char *)" : "(char *)&"); + out_name(outfile, v); + nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name); + nice_printf(outfile, ", %ld };\n", + type != TYCHAR ? (long)typeconv[type] + : -v->vleng->constblock.Const.ci); + } + + do { + var = (Namep)nmch->datap; + name = var->cvarname; + nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name); + comma = "{"; + i = 0; + for(q = var->varxptr.namelist ; q ; q = q->nextp) { + v = (Namep)q->datap; + if (!v->vnamelist) + continue; + i++; + nice_printf(outfile, "%s &%s_dv", comma, v->cvarname); + comma = ","; + } + nice_printf(outfile, " };\n"); + nice_printf(outfile, + "static Namelist %s = { \"%s\", %s_vl, %d };\n", + name, to_upper(var->fvarname), name, i); + } + while(nmch = nmch->nextp); + nice_printf(outfile, "\n"); + } + +/* fixextype tries to infer from usage in previous procedures + the type of an external procedure declared + external and passed as an argument but never typed or invoked. + */ + + static int +#ifdef KR_headers +fixexttype(var) + Namep var; +#else +fixexttype(Namep var) +#endif +{ + Extsym *e; + int type, type1; + + type = var->vtype; + e = &extsymtab[var->vardesc.varno]; + if ((type1 = e->extype) && type == TYUNKNOWN) + return var->vtype = type1; + if (var->visused) { + if (e->exused && type != type1) + changedtype(var); + e->exused = 1; + e->extype = type; + } + return type; + } + + static void +#ifdef KR_headers +ref_defs(outfile, refdefs) + FILE *outfile; + chainp refdefs; +#else +ref_defs(FILE *outfile, chainp refdefs) +#endif +{ + chainp cp; + int eb, i, j, n; + struct Dimblock *dimp; + expptr b, vl; + Namep var; + char *amp, *comma; + + margin_printf(outfile, "\n"); + for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) { + var = (Namep)cp->datap; + cp->datap = 0; + amp = "_subscr"; + if (!(eb = var->vsubscrused)) { + var->vrefused = 0; + if (!ISCOMPLEX(var->vtype)) + amp = "_ref"; + } + def_start(outfile, var->cvarname, amp, CNULL); + dimp = var->vdim; + vl = 0; + comma = "("; + amp = ""; + if (var->vtype == TYCHAR) { + amp = "&"; + vl = var->vleng; + if (ISCONST(vl) && vl->constblock.Const.ci == 1) + vl = 0; + nice_printf(outfile, "%sa_0", comma); + comma = ","; + } + n = dimp->ndim; + for(i = 1; i <= n; i++, comma = ",") + nice_printf(outfile, "%sa_%d", comma, i); + nice_printf(outfile, ") %s", amp); + if (var->vsubscrused) + var->vsubscrused = 0; + else if (!ISCOMPLEX(var->vtype)) { + out_name(outfile, var); + nice_printf(outfile, "[%s", vl ? "(" : ""); + } + for(j = 2; j < n; j++) + nice_printf(outfile, "("); + while(--i > 1) { + nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")"); + expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize)); + nice_printf(outfile, " + "); + } + nice_printf(outfile, "a_1"); + if (var->vtype == TYCHAR) { + if (vl) { + nice_printf(outfile, ")*"); + expr_out(outfile, cpexpr(vl)); + } + nice_printf(outfile, " + a_0"); + } + if ((var->vstg != STGARG /* || checksubs */ ) + && (b = dimp->baseoffset)) { + b = cpexpr(b); + if (var->vtype == TYCHAR) + b = mkexpr(OPSTAR, cpexpr(var->vleng), b); + nice_printf(outfile, " - "); + expr_out(outfile, b); + } + if (ISCOMPLEX(var->vtype)) { + margin_printf(outfile, "\n"); + def_start(outfile, var->cvarname, "_ref", CNULL); + comma = "("; + for(i = 1; i <= n; i++, comma = ",") + nice_printf(outfile, "%sa_%d", comma, i); + nice_printf(outfile, ") %s[%s_subscr", + var->cvarname, var->cvarname); + comma = "("; + for(i = 1; i <= n; i++, comma = ",") + nice_printf(outfile, "%sa_%d", comma, i); + nice_printf(outfile, ")"); + } + margin_printf(outfile, "]\n" + eb); + } + nice_printf(outfile, "\n"); + frchain(&refdefs); + } + + static long +#ifdef KR_headers +n_elt(vd) struct Dimblock *vd; +#else +n_elt(struct Dimblock *vd) +#endif +{ + expptr ne; + long nv = 1; + if (vd) { + if (!(ne = vd->nelt)) + Fatal("Null nelt in n_elt"); + if (ne->tag != TCONST) + fatali("Unexpected nelt tag %d in n_elt", ne->tag); + if (!ISINT(ne->constblock.vtype)) + fatali("Unexpected vtype %d in n_elt", + ne->constblock.vtype); + nv = ne->constblock.Const.ci; + } + return nv; + } + + void +#ifdef KR_headers +list_decls(outfile) + FILE *outfile; +#else +list_decls(FILE *outfile) +#endif +{ + extern chainp used_builtins; + extern struct Hashentry *hashtab; + struct Hashentry *entry; + int write_header = 1; + int last_class = -1, last_stg = -1; + Namep var; + int Alias, Define, did_one, last_type, stg, type; + extern int def_equivs, useauto; + extern chainp new_vars; /* Compiler-generated locals */ + chainp namelists = 0, refdefs = 0; + char *ctype; + int useauto1 = useauto && !saveall; + long x; + extern int hsize; + +/* First write out the statically initialized data */ + + if (initfile) + list_init_data(&initfile, initfname, outfile); + +/* Next come formats */ + write_formats(outfile); + +/* Now write out the system-generated identifiers */ + + if (new_vars || nequiv) { + chainp args, next_var, this_var; + chainp nv[TYVOID], nv1[TYVOID]; + int i, j; + ftnint k; + Addrp Var; + Namep arg; + + /* zap unused dimension variables */ + + for(args = allargs; args; args = args->nextp) { + arg = (Namep)args->datap; + if (this_var = arg->vlastdim) { + frexpr((tagptr)this_var->datap); + this_var->datap = 0; + } + } + + /* sort new_vars by type, skipping entries just zapped */ + + for(i = TYADDR; i < TYVOID; i++) + nv[i] = 0; + for(this_var = new_vars; this_var; this_var = next_var) { + next_var = this_var->nextp; + if (Var = (Addrp)this_var->datap) { + if (!(this_var->nextp = nv[j = Var->vtype])) + nv1[j] = this_var; + nv[j] = this_var; + } + else { + this_var->nextp = 0; + frchain(&this_var); + } + } + new_vars = 0; + for(i = TYVOID; --i >= TYADDR;) + if (this_var = nv[i]) { + nv1[i]->nextp = new_vars; + new_vars = this_var; + } + + /* write the declarations */ + + did_one = 0; + last_type = -1; + + for (this_var = new_vars; this_var; this_var = this_var -> nextp) { + Var = (Addrp) this_var->datap; + + if (Var == (Addrp) NULL) + err ("list_decls: null variable"); + else if (Var -> tag != TADDR) + erri ("list_decls: bad tag on new variable '%d'", + Var -> tag); + + type = nv_type (Var); + if (Var->vstg == STGINIT + || Var->uname_tag == UNAM_IDENT + && *Var->user.ident == ' ' + && multitype) + continue; + if (!did_one) + nice_printf (outfile, "/* System generated locals */\n"); + + if (last_type == type && did_one) + nice_printf (outfile, ", "); + else { + if (did_one) + nice_printf (outfile, ";\n"); + nice_printf (outfile, "%s ", + c_type_decl (type, Var -> vclass == CLPROC)); + } /* else */ + +/* Character type is really a string type. Put out a '*' for parameters + with unknown length and functions returning character */ + + if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng)) + || Var -> vclass == CLPROC)) + nice_printf (outfile, "*"); + + write_nv_ident(outfile, (Addrp)this_var->datap); + if (Var -> vtype == TYCHAR && Var->vclass != CLPROC && + ISICON((Var -> vleng)) + && (k = Var->vleng->constblock.Const.ci) > 0) + nice_printf (outfile, "[%ld]", (long)k); + + did_one = 1; + last_type = nv_type (Var); + } /* for this_var */ + +/* Handle the uninitialized equivalences */ + + do_uninit_equivs (outfile, &did_one); + + if (did_one) + nice_printf (outfile, ";\n\n"); + } /* if new_vars */ + +/* Write out builtin declarations */ + + if (used_builtins) { + chainp cp; + Extsym *es; + + last_type = -1; + did_one = 0; + + nice_printf (outfile, "/* Builtin functions */"); + + for (cp = used_builtins; cp; cp = cp -> nextp) { + Addrp e = (Addrp)cp->datap; + + switch(type = e->vtype) { + case TYDREAL: + case TYREAL: + /* if (forcedouble || e->dbl_builtin) */ + /* libF77 currently assumes everything double */ + type = TYDREAL; + ctype = "double"; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + type = TYVOID; + /* no break */ + default: + ctype = c_type_decl(type, 0); + } + + if (did_one && last_type == type) + nice_printf(outfile, ", "); + else + nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype); + + extern_out(outfile, es = &extsymtab[e -> memno]); + proto(outfile, es->arginfo, es->fextname); + last_type = type; + did_one = 1; + } /* for cp = used_builtins */ + + nice_printf (outfile, ";\n\n"); + } /* if used_builtins */ + + last_type = -1; + for (entry = hashtab; entry < lasthash; ++entry) { + var = entry -> varp; + + if (var) { + int procclass = var -> vprocclass; + char *comment = NULL; + int vclass = var -> vclass; + stg = var -> vstg; + type = var -> vtype; + + if (var->vrefused) + refdefs = mkchain((char *)var, refdefs); + if (var->vsubscrused) + if (ISCOMPLEX(var->vtype)) + var->vsubscrused = 0; + else + refdefs = mkchain((char *)var, refdefs); + if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT))) + continue; + + if (useauto1 && stg == STGBSS && !var->vsave) + stg = STGAUTO; + + switch (vclass) { + case CLVAR: + break; + case CLPROC: + switch(procclass) { + case PTHISPROC: + extsymtab[var->vardesc.varno].extype = type; + continue; + case PSTFUNCT: + case PINTRINSIC: + continue; + case PUNKNOWN: + err ("list_decls: unknown procedure class"); + continue; + case PEXTERNAL: + if (stg == STGUNKNOWN) { + warn1( + "%.64s declared EXTERNAL but never used.", + var->fvarname); + /* to retain names declared EXTERNAL */ + /* but not referenced, change */ + /* "continue" to "stg = STGEXT" */ + continue; + } + else + type = fixexttype(var); + } + break; + case CLUNKNOWN: + /* declared but never used */ + continue; + case CLPARAM: + continue; + case CLNAMELIST: + if (var->visused) + namelists = mkchain((char *)var, namelists); + continue; + default: + erri("list_decls: can't handle class '%d' yet", + vclass); + Fatal(var->fvarname); + continue; + } /* switch */ + + /* Might be equivalenced to a common. If not, don't process */ + if (stg == STGCOMMON && !var->vcommequiv) + continue; + +/* Only write the header if system-generated locals, builtins, or + uninitialized equivs were already output */ + + if (write_header == 1 && (new_vars || nequiv || used_builtins) + && oneof_stg ( var, stg, + M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) { + nice_printf (outfile, "/* Local variables */\n"); + write_header = 2; + } + + + Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)); + if (Define = (Alias && def_equivs)) { + if (!write_header) + nice_printf(outfile, ";\n"); + def_start(outfile, var->cvarname, CNULL, "("); + goto Alias1; + } + else if (type == last_type && vclass == last_class && + stg == last_stg && !write_header) + nice_printf (outfile, ", "); + else { + if (!write_header && ONEOF(stg, M(STGBSS)| + M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON))) + nice_printf (outfile, ";\n"); + + switch (stg) { + case STGARG: + case STGLENG: + /* Part of the argument list, don't write them out + again */ + continue; /* Go back to top of the loop */ + case STGBSS: + case STGEQUIV: + case STGCOMMON: + nice_printf (outfile, "static "); + break; + case STGEXT: + nice_printf (outfile, "extern "); + break; + case STGAUTO: + break; + case STGINIT: + case STGUNKNOWN: + /* Don't want to touch the initialized data, that will + be handled elsewhere. Unknown data have + already been complained about, so skip them */ + continue; + default: + erri("list_decls: can't handle storage class %d", + stg); + continue; + } /* switch */ + + if (type == TYCHAR && halign && vclass != CLPROC + && ISICON(var->vleng)) { + nice_printf(outfile, "struct { %s fill; char val", + halign); + x = wr_char_len(outfile, var->vdim, + var->vleng->constblock.Const.ci, 1); + if (x %= hsize) + nice_printf(outfile, "; char fill2[%ld]", + hsize - x); + nice_printf(outfile, "; } %s_st;\n", var->cvarname); + def_start(outfile, var->cvarname, CNULL, var->cvarname); + margin_printf(outfile, "_st.val\n"); + last_type = -1; + write_header = 2; + continue; + } + nice_printf(outfile, "%s ", + c_type_decl(type, vclass == CLPROC)); + } /* else */ + +/* Character type is really a string type. Put out a '*' for variable + length strings, and also for equivalences */ + + if (type == TYCHAR && vclass != CLPROC + && (!var->vleng || !ISICON (var -> vleng)) + || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON))) + nice_printf (outfile, "*%s", var->cvarname); + else { + nice_printf (outfile, "%s", var->cvarname); + if (vclass == CLPROC) { + Argtypes *at; + if (!(at = var->arginfo) + && var->vprocclass == PEXTERNAL) + at = extsymtab[var->vardesc.varno].arginfo; + proto(outfile, at, var->fvarname); + } + else if (type == TYCHAR && ISICON ((var -> vleng))) + wr_char_len(outfile, var->vdim, + var->vleng->constblock.Const.ci, 0); + else if (var -> vdim && + !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON))) + comment = wr_ardecls(outfile, var->vdim, 1L); + } + + if (comment) + nice_printf (outfile, "%s", comment); + Alias1: + if (Alias) { + char *amp, *lp, *name, *rp; + ftnint voff = var -> voffset; + int et0, expr_type, k; + Extsym *E; + struct Equivblock *eb; + char buf[MAXNAMELEN+30]; /*30 should be overkill*/ + +/* We DON'T want to use oneof_stg here, because we need to distinguish + between them */ + + if (stg == STGEQUIV) { + name = equiv_name(k = var->vardesc.varno, CNULL); + eb = eqvclass + k; + if (eb->eqvinit) { + amp = "&"; + et0 = TYERROR; + } + else { + amp = ""; + et0 = eb->eqvtype; + } + expr_type = et0; + } + else { + E = &extsymtab[var->vardesc.varno]; + sprintf(name = buf, "%s%d", E->cextname, E->curno); + expr_type = type; + et0 = -1; + amp = "&"; + } /* else */ + + if (!Define) + nice_printf (outfile, " = "); + if (voff) { + k = typesize[type]; + switch((int)(voff % k)) { + case 0: + voff /= k; + expr_type = type; + break; + case SZSHORT: + case SZSHORT+SZLONG: + expr_type = TYSHORT; + voff /= SZSHORT; + break; + case SZLONG: + expr_type = TYLONG; + voff /= SZLONG; + break; + default: + expr_type = TYCHAR; + } + } + + if (expr_type == type) { + lp = rp = ""; + if (et0 == -1 && !voff) + goto cast; + } + else { + lp = "("; + rp = ")"; + cast: + nice_printf(outfile, "(%s *)", c_type_decl(type, 0)); + } + +/* Now worry about computing the offset */ + + if (voff) { + if (expr_type == et0) + nice_printf (outfile, "%s%s + %ld%s", + lp, name, voff, rp); + else + nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp, + c_type_decl (expr_type, 0), amp, + name, voff, rp); + } else + nice_printf(outfile, "%s%s", amp, name); +/* Always put these at the end of the line */ + last_type = last_class = last_stg = -1; + write_header = 0; + if (Define) { + margin_printf(outfile, ")\n"); + write_header = 2; + } + continue; + } + write_header = 0; + last_type = type; + last_class = vclass; + last_stg = stg; + } /* if (var) */ + } /* for (entry = hashtab */ + + if (!write_header) + nice_printf (outfile, ";\n\n"); + else if (write_header == 2) + nice_printf(outfile, "\n"); + +/* Next, namelists, which may reference equivs */ + + if (namelists) { + write_namelists(namelists = revchain(namelists), outfile); + frchain(&namelists); + } + +/* Finally, ioblocks (which may reference equivs and namelists) */ + if (iob_list) + write_ioblocks(outfile); + if (assigned_fmts) + write_assigned_fmts(outfile); + + if (refdefs) + ref_defs(outfile, refdefs); + + if (trapuv) { + for (entry = hashtab; entry < lasthash; ++entry) + if ((var = entry->varp) + && ONEOF(var->vstg, M(STGAUTO)|M(STGBSS)) + && ISNUMERIC(var->vtype) + && var->vclass == CLVAR + && !var->vsave) + nice_printf(outfile, "_uninit_f2c(&%s,%d,%ldL);\n", + var->cvarname, typeconv[var->vtype], + n_elt(var->vdim)); + } + +} /* list_decls */ + + void +#ifdef KR_headers +do_uninit_equivs(outfile, did_one) + FILE *outfile; + int *did_one; +#else +do_uninit_equivs(FILE *outfile, int *did_one) +#endif +{ + extern int nequiv; + struct Equivblock *eqv, *lasteqv = eqvclass + nequiv; + int k, last_type = -1, t; + + for (eqv = eqvclass; eqv < lasteqv; eqv++) + if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) { + if (!*did_one) + nice_printf (outfile, "/* System generated locals */\n"); + t = eqv->eqvtype; + if (last_type == t) + nice_printf (outfile, ", "); + else { + if (*did_one) + nice_printf (outfile, ";\n"); + nice_printf (outfile, "static %s ", c_type_decl(t, 0)); + k = typesize[t]; + } /* else */ + nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL)); + nice_printf(outfile, "[%ld]", + (eqv->eqvtop - eqv->eqvbottom + k - 1) / k); + last_type = t; + *did_one = 1; + } /* if !eqv -> eqvinit */ +} /* do_uninit_equivs */ + + +/* wr_ardecls -- Writes the brackets and size for an array + declaration. Because of the inner workings of the compiler, + multi-dimensional arrays get mapped directly into a one-dimensional + array, so we have to compute the size of the array here. When the + dimension is greater than 1, a string comment about the original size + is returned */ + + char * +#ifdef KR_headers +wr_ardecls(outfile, dimp, size) + FILE *outfile; + struct Dimblock *dimp; + long size; +#else +wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size) +#endif +{ + int i, k; + ftnint j; + static char buf[1000]; + + if (dimp == (struct Dimblock *) NULL) + return NULL; + + sprintf(buf, "\t/* was "); /* would like to say k = sprintf(...), but */ + k = strlen(buf); /* BSD doesn't return char transmitted count */ + + for (i = 0; i < dimp -> ndim; i++) { + expptr this_size = dimp -> dims[i].dimsize; + + if (ISCONST(this_size)) { + if (ISINT(this_size->constblock.vtype)) + j = this_size -> constblock.Const.ci; + else if (ISREAL(this_size->constblock.vtype)) + j = (ftnint)this_size -> constblock.Const.cd[0]; + else + goto non_const; + size *= j; + sprintf(buf+k, "[%ld]", j); + k += strlen(buf+k); + /* BSD prevents getting strlen from sprintf */ + } + else { + non_const: + err ("wr_ardecls: nonconstant array size"); + } + } /* for i = 0 */ + + nice_printf (outfile, "[%ld]", size); + strcat(buf+k, " */"); + + return (i > 1) ? buf : NULL; +} /* wr_ardecls */ + + + +/* ---------------------------------------------------------------------- + + The following routines read from the p1 intermediate file. If + that format changes, only these routines need be changed + + ---------------------------------------------------------------------- */ + + static int +#ifdef KR_headers +get_p1_token(infile) + FILE *infile; +#else +get_p1_token(FILE *infile) +#endif +{ + int token = P1_UNKNOWN; + +/* NOT PORTABLE!! */ + + if (fscanf (infile, "%d", &token) == EOF) + return P1_EOF; + +/* Skip over the ": " */ + + if (getc (infile) != '\n') + getc (infile); + + return token; +} /* get_p1_token */ + + + +/* Returns a (null terminated) string from the input file */ + + static int +#ifdef KR_headers +p1gets(fp, str, size) + FILE *fp; + char *str; + int size; +#else +p1gets(FILE *fp, char *str, int size) +#endif +{ + char c; + + if (str == NULL) + return 0; + + if ((c = getc (fp)) != ' ') + ungetc (c, fp); + + if (fgets (str, size, fp)) { + int length; + + str[size - 1] = '\0'; + length = strlen (str); + +/* Get rid of the newline */ + + if (str[length - 1] == '\n') + str[length - 1] = '\0'; + return 1; + + } else if (feof (fp)) + return EOF; + else + return 0; +} /* p1gets */ + + +#ifndef NO_LONG_LONG + static int +#ifdef KR_headers +p1getq(infile, result) FILE *infile; Llong *result; +#else +p1getq(FILE *infile, Llong *result) +#endif +{ +#ifdef __FreeBSD__ +#ifndef NO_FSCANF_LL_BUG +#define FSCANF_LL_BUG +#endif +#endif +#ifdef FSCANF_LL_BUG + ULlong x = 0; + int c, have_c = 0; + for(;;) { + c = getc(infile); + if (c == EOF) + break; + if (c <= ' ') { + if (!have_c) + continue; + goto done; + } + if (c >= '0' && c <= '9') + c -= '0'; + else if (c >= 'a' && c <= 'f') + c += 10 - 'a'; + else if (c >= 'A' && c <= 'F') + c += 10 - 'A'; + else { + done: + ungetc(c, infile); + break; + } + x = x << 4 | c; + have_c = 1; + } + if (have_c) { + *result = (Llong)x; + return 1; + } + return 0; +#else + return fscanf(infile, "%llx", result); +#endif + } +#endif + + static int +#ifdef KR_headers +p1get_const(infile, type, resultp) + FILE *infile; + int type; + struct Constblock **resultp; +#else +p1get_const(FILE *infile, int type, struct Constblock **resultp) +#endif +{ + int status; + unsigned long a; + struct Constblock *result; + + if (type != TYCHAR) { + *resultp = result = ALLOC(Constblock); + result -> tag = TCONST; + result -> vtype = type; + } + + switch (type) { + case TYINT1: + case TYSHORT: + case TYLONG: + case TYLOGICAL: + case TYLOGICAL1: + case TYLOGICAL2: + status = p1getd (infile, &(result -> Const.ci)); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + status = p1getq(infile, &result->Const.cq); + break; +#endif + case TYREAL: + case TYDREAL: + status = p1getf(infile, &result->Const.cds[0]); + result->vstg = 1; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + status = p1getf(infile, &result->Const.cds[0]); + if (status && status != EOF) + status = p1getf(infile, &result->Const.cds[1]); + result->vstg = 1; + break; + case TYCHAR: + status = fscanf(infile, "%lx", &a); + *resultp = (struct Constblock *) a; + break; + default: + erri ("p1get_const: bad constant type '%d'", type); + status = 0; + break; + } /* switch */ + + return status; +} /* p1get_const */ + + static int +#ifdef KR_headers +p1getd(infile, result) + FILE *infile; + long *result; +#else +p1getd(FILE *infile, long *result) +#endif +{ + return fscanf (infile, "%ld", result); +} /* p1getd */ + + static int +#ifdef KR_headers +p1getf(infile, result) + FILE *infile; + char **result; +#else +p1getf(FILE *infile, char **result) +#endif +{ + + char buf[1324]; + register int k; + + k = fscanf (infile, "%s", buf); + if (k < 1) + k = EOF; + else + strcpy(*result = mem(strlen(buf)+1,0), buf); + return k; +} + + static int +#ifdef KR_headers +p1getn(infile, count, result) + FILE *infile; + int count; + char **result; +#else +p1getn(FILE *infile, int count, char **result) +#endif +{ + + char *bufptr; + + bufptr = (char *) ckalloc (count); + + if (result) + *result = bufptr; + + for (; !feof (infile) && count > 0; count--) + *bufptr++ = getc (infile); + + return feof (infile) ? EOF : 1; +} /* p1getn */ + + static void +#ifdef KR_headers +proto(outfile, at, fname) + FILE *outfile; + Argtypes *at; + char *fname; +#else +proto(FILE *outfile, Argtypes *at, char *fname) +#endif +{ + int i, j, k, n; + char *comma; + Atype *atypes; + Namep np; + chainp cp; + + if (at) { + /* Correct types that we learn on the fly, e.g. + subroutine gotcha(foo) + external foo + call zap(...,foo,...) + call foo(...) + */ + atypes = at->atypes; + n = at->defined ? at->dnargs : at->nargs; + for(i = 0; i++ < n; atypes++) { + if (!(cp = atypes->cp)) + continue; + j = atypes->type; + do { + np = (Namep)cp->datap; + k = np->vtype; + if (np->vclass == CLPROC) { + if (!np->vimpltype && k) + k += 200; + else { + if (j >= 300) + j = TYUNKNOWN + 200; + continue; + } + } + if (j == k) + continue; + if (j >= 300 + || j == 200 && k >= 200) + j = k; + else { + if (at->nargs >= 0) + bad_atypes(at,fname,i,j,k,""," and"); + goto break2; + } + } + while(cp = cp->nextp); + atypes->type = j; + frchain(&atypes->cp); + } + } + break2: + if (parens) { + nice_printf(outfile, parens); + return; + } + + if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) { + nice_printf(outfile, Ansi == 1 ? "()" : "(...)"); + return; + } + + if (n == 0) { + nice_printf(outfile, Ansi == 1 ? "(void)" : "()"); + return; + } + + atypes = at->atypes; + nice_printf(outfile, "("); + comma = ""; + for(; --n >= 0; atypes++) { + k = atypes->type; + if (k == TYADDR) + nice_printf(outfile, "%schar **", comma); + else if (k >= 200) { + k -= 200; + if (k >= 100) + k -= 100; + nice_printf(outfile, "%s%s", comma, + usedcasts[k] = casttypes[k]); + } + else if (k >= 100) + nice_printf(outfile, + k == TYCHAR + 100 ? "%s%s *" : "%s%s", + comma, c_type_decl(k-100, 0)); + else + nice_printf(outfile, "%s%s *", comma, + c_type_decl(k, 0)); + comma = ", "; + } + nice_printf(outfile, ")"); + } + + void +#ifdef KR_headers +protowrite(protofile, type, name, e, lengths) + FILE *protofile; + int type; + char *name; + struct Entrypoint *e; + chainp lengths; +#else +protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths) +#endif +{ + extern char used_rets[]; + int asave; + + if (!(asave = Ansi)) + Castargs = Ansi = 1; + nice_printf(protofile, "extern %s %s", protorettypes[type], name); + list_arg_types(protofile, e, lengths, 0, ";\n"); + used_rets[type] = 1; + if (!(Ansi = asave)) + Castargs = 0; + } + + static void +#ifdef KR_headers +do_p1_1while(outfile) + FILE *outfile; +#else +do_p1_1while(FILE *outfile) +#endif +{ + if (*wh_next) { + nice_printf(outfile, + "for(;;) { /* while(complicated condition) */\n" /*}*/ ); + next_tab(outfile); + } + else + nice_printf(outfile, "while(" /*)*/ ); + } + + static void +#ifdef KR_headers +do_p1_2while(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_2while(FILE *infile, FILE *outfile) +#endif +{ + expptr test; + + test = do_format(infile, outfile); + if (*wh_next) + nice_printf(outfile, "if (!("); + expr_out(outfile, test); + if (*wh_next++) + nice_printf(outfile, "))\n\tbreak;\n"); + else { + nice_printf(outfile, /*(*/ ") {\n"); + next_tab(outfile); + } + } + + static void +#ifdef KR_headers +do_p1_elseifstart(outfile) + FILE *outfile; +#else +do_p1_elseifstart(FILE *outfile) +#endif +{ /* with sufficiently illegal input, ei_next == ei_last == 0 is possible */ + if (ei_next < ei_last && *ei_next++) { + prev_tab(outfile); + nice_printf(outfile, /*{*/ + "} else /* if(complicated condition) */ {\n" /*}*/ ); + next_tab(outfile); + } + } diff --git a/unix/f2c/src/format.h b/unix/f2c/src/format.h new file mode 100644 index 00000000..3de97f6f --- /dev/null +++ b/unix/f2c/src/format.h @@ -0,0 +1,12 @@ +#define DEF_C_LINE_LENGTH 77 +/* actual max will be 79 */ + +extern int c_output_line_length; /* max # chars per line in C source + code */ + +chainp data_value Argdcl((FILEP, long int, int)); +int do_init_data Argdcl((FILEP, FILEP)); +void list_init_data Argdcl((FILEP*, char*, FILEP)); +char* wr_ardecls Argdcl((FILEP, struct Dimblock*, long int)); +void wr_one_init Argdcl((FILEP, char*, chainp*, int)); +void wr_output_values Argdcl((FILEP, Namep, chainp)); diff --git a/unix/f2c/src/formatdata.c b/unix/f2c/src/formatdata.c new file mode 100644 index 00000000..c399c618 --- /dev/null +++ b/unix/f2c/src/formatdata.c @@ -0,0 +1,1263 @@ +/**************************************************************** +Copyright 1990-1, 1993-6, 1999-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "output.h" +#include "names.h" +#include "format.h" + +#define MAX_INIT_LINE 100 +#define VNAME_MAX 64 + +static int memno2info Argdcl((int, Namep*)); + +typedef unsigned long Ulong; + + extern char *initbname; + + void +#ifdef KR_headers +list_init_data(Infile, Inname, outfile) + FILE **Infile; + char *Inname; + FILE *outfile; +#else +list_init_data(FILE **Infile, char *Inname, FILE *outfile) +#endif +{ + FILE *sortfp; + int status; + + fclose(*Infile); + *Infile = 0; + + if (status = dsort(Inname, sortfname)) + fatali ("sort failed, status %d", status); + + scrub(Inname); /* optionally unlink Inname */ + + if ((sortfp = fopen(sortfname, textread)) == NULL) + Fatal("Couldn't open sorted initialization data"); + + do_init_data(outfile, sortfp); + fclose(sortfp); + scrub(sortfname); + +/* Insert a blank line after any initialized data */ + + nice_printf (outfile, "\n"); + + if (debugflag && infname) + /* don't back block data file up -- it won't be overwritten */ + backup(initfname, initbname); +} /* list_init_data */ + + + +/* do_init_data -- returns YES when at least one declaration has been + written */ + + int +#ifdef KR_headers +do_init_data(outfile, infile) + FILE *outfile; + FILE *infile; +#else +do_init_data(FILE *outfile, FILE *infile) +#endif +{ + char varname[VNAME_MAX], ovarname[VNAME_MAX]; + ftnint offset; + ftnint type; + int vargroup; /* 0 --> init, 1 --> equiv, 2 --> common */ + int did_one = 0; /* True when one has been output */ + chainp values = CHNULL; /* Actual data values */ + int keepit = 0; + Namep np; + + ovarname[0] = '\0'; + + while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset) + && rdlong (infile, &type)) { + if (strcmp (varname, ovarname)) { + + /* If this is a new variable name, the old initialization has been + completed */ + + wr_one_init(outfile, ovarname, &values, keepit); + + strcpy (ovarname, varname); + values = CHNULL; + if (vargroup == 0) { + if (memno2info(atoi(varname+2), &np)) { + if (((Addrp)np)->uname_tag != UNAM_NAME) { + err("do_init_data: expected NAME"); + goto Keep; + } + np = ((Addrp)np)->user.name; + } + if (!(keepit = np->visused) && !np->vimpldovar) + warn1("local variable %s never used", + np->fvarname); + } + else { + Keep: + keepit = 1; + } + if (keepit && !did_one) { + nice_printf (outfile, "/* Initialized data */\n\n"); + did_one = YES; + } + } /* if strcmp */ + + values = mkchain((char *)data_value(infile, offset, (int)type), values); + } /* while */ + +/* Write out the last declaration */ + + wr_one_init (outfile, ovarname, &values, keepit); + + return did_one; +} /* do_init_data */ + + + ftnint +#ifdef KR_headers +wr_char_len(outfile, dimp, n, extra1) + FILE *outfile; + struct Dimblock *dimp; + ftnint n; + int extra1; +#else +wr_char_len(FILE *outfile, struct Dimblock *dimp, ftnint n, int extra1) +#endif +{ + int i, nd; + expptr e; + ftnint j, rv; + + if (!dimp) { + nice_printf (outfile, extra1 ? "[%ld+1]" : "[%ld]", (long)n); + return n + extra1; + } + nice_printf(outfile, "[%ld", (long)n); + nd = dimp->ndim; + rv = n; + for(i = 0; i < nd; i++) { + e = dimp->dims[i].dimsize; + if (ISCONST(e)) { + if (ISINT(e->constblock.vtype)) + j = e->constblock.Const.ci; + else if (ISREAL(e->constblock.vtype)) + j = (ftnint)e->constblock.Const.cd[0]; + else + goto non_const; + nice_printf(outfile, "*%ld", j); + rv *= j; + } + else { + non_const: + err ("wr_char_len: nonconstant array size"); + } + } + /* extra1 allows for stupid C compilers that complain about + * too many initializers in + * char x[2] = "ab"; + */ + nice_printf(outfile, extra1 ? "+1]" : "]"); + return extra1 ? rv+1 : rv; + } + + static int ch_ar_dim = -1; /* length of each element of char string array */ + static int eqvmemno; /* kludge */ + + static void +#ifdef KR_headers +write_char_init(outfile, Values, namep) + FILE *outfile; + chainp *Values; + Namep namep; +#else +write_char_init(FILE *outfile, chainp *Values, Namep namep) +#endif +{ + struct Equivblock *eqv; + long size; + struct Dimblock *dimp; + int i, nd, type; + ftnint j; + expptr ds; + + if (!namep) + return; + if(nequiv >= maxequiv) + many("equivalences", 'q', maxequiv); + eqv = &eqvclass[nequiv]; + eqv->eqvbottom = 0; + type = namep->vtype; + size = type == TYCHAR + ? namep->vleng->constblock.Const.ci + : typesize[type]; + if (dimp = namep->vdim) + for(i = 0, nd = dimp->ndim; i < nd; i++) { + ds = dimp->dims[i].dimsize; + if (ISCONST(ds)) { + if (ISINT(ds->constblock.vtype)) + j = ds->constblock.Const.ci; + else if (ISREAL(ds->constblock.vtype)) + j = (ftnint)ds->constblock.Const.cd[0]; + else + goto non_const; + size *= j; + } + else { + non_const: + err("write_char_values: nonconstant array size"); + } + } + *Values = revchain(*Values); + eqv->eqvtop = size; + eqvmemno = ++lastvarno; + eqv->eqvtype = type; + wr_equiv_init(outfile, nequiv, Values, 0); + def_start(outfile, namep->cvarname, CNULL, ""); + if (type == TYCHAR) + margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno); + else + margin_printf(outfile, dimp + ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n", + c_type_decl(type,0), eqvmemno); + } + +/* wr_one_init -- outputs the initialization of the variable pointed to + by info. When is_addr is true, info is an Addrp; otherwise, + treat it as a Namep */ + + void +#ifdef KR_headers +wr_one_init(outfile, varname, Values, keepit) + FILE *outfile; + char *varname; + chainp *Values; + int keepit; +#else +wr_one_init(FILE *outfile, char *varname, chainp *Values, int keepit) +#endif +{ + static int memno; + static union { + Namep name; + Addrp addr; + } info; + Namep namep; + int is_addr, size, type; + ftnint last, loc; + int is_scalar = 0; + char *array_comment = NULL, *name; + chainp cp, values; + extern char datachar[]; + static int e1[3] = {1, 0, 1}; + ftnint x; + extern int hsize; + + if (!keepit) + goto done; + if (varname == NULL || varname[1] != '.') + goto badvar; + +/* Get back to a meaningful representation; find the given memno in one + of the appropriate tables (user-generated variables in the hash table, + system-generated variables in a separate list */ + + memno = atoi(varname + 2); + switch(varname[0]) { + case 'q': + /* Must subtract eqvstart when the source file + * contains more than one procedure. + */ + wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0); + goto done; + case 'Q': + /* COMMON initialization (BLOCK DATA) */ + wr_equiv_init(outfile, memno, Values, 1); + goto done; + case 'v': + break; + default: + badvar: + errstr("wr_one_init: unknown variable name '%s'", varname); + goto done; + } + + is_addr = memno2info (memno, &info.name); + if (info.name == (Namep) NULL) { + err ("wr_one_init -- unknown variable"); + return; + } + if (is_addr) { + if (info.addr -> uname_tag != UNAM_NAME) { + erri ("wr_one_init -- couldn't get name pointer; tag is %d", + info.addr -> uname_tag); + namep = (Namep) NULL; + nice_printf (outfile, " /* bad init data */"); + } else + namep = info.addr -> user.name; + } else + namep = info.name; + + /* check for character initialization */ + + *Values = values = revchain(*Values); + type = info.name->vtype; + if (type == TYCHAR) { + for(last = 0; values; values = values->nextp) { + cp = (chainp)values->datap; + loc = (ftnint)cp->datap; + if (loc > last) { + write_char_init(outfile, Values, namep); + goto done; + } + last = (Ulong)cp->nextp->datap == TYBLANK + ? loc + (Ulong)cp->nextp->nextp->datap + : loc + 1; + } + if (halign && info.name->tag == TNAME) { + nice_printf(outfile, "static struct { %s fill; char val", + halign); + x = wr_char_len(outfile, namep->vdim, ch_ar_dim = + info.name -> vleng -> constblock.Const.ci, 1); + if (x %= hsize) + nice_printf(outfile, "; char fill2[%ld]", hsize - x); + name = info.name->cvarname; + nice_printf(outfile, "; } %s_st = { 0,", name); + wr_output_values(outfile, namep, *Values); + nice_printf(outfile, " };\n"); + ch_ar_dim = -1; + def_start(outfile, name, CNULL, name); + margin_printf(outfile, "_st.val\n"); + goto done; + } + } + else { + size = typesize[type]; + loc = 0; + for(; values; values = values->nextp) { + if ((Ulong)((chainp)values->datap)->nextp->datap == TYCHAR) { + write_char_init(outfile, Values, namep); + goto done; + } + last = ((long) ((chainp) values->datap)->datap) / size; + if (last - loc > 4) { + write_char_init(outfile, Values, namep); + goto done; + } + loc = last; + } + } + values = *Values; + + nice_printf (outfile, "static %s ", c_type_decl (type, 0)); + + if (is_addr) + write_nv_ident (outfile, info.addr); + else + out_name (outfile, info.name); + + if (namep) + is_scalar = namep -> vdim == (struct Dimblock *) NULL; + + if (namep && !is_scalar) + array_comment = type == TYCHAR + ? 0 : wr_ardecls(outfile, namep->vdim, 1L); + + if (type == TYCHAR) + if (ISICON (info.name -> vleng)) + +/* We'll make single strings one character longer, so that we can use the + standard C initialization. All this does is pad an extra zero onto the + end of the string */ + wr_char_len(outfile, namep->vdim, ch_ar_dim = + info.name -> vleng -> constblock.Const.ci, e1[Ansi]); + else + err ("variable length character initialization"); + + if (array_comment) + nice_printf (outfile, "%s", array_comment); + + nice_printf (outfile, " = "); + wr_output_values (outfile, namep, values); + ch_ar_dim = -1; + nice_printf (outfile, ";\n"); + done: + frchain(Values); +} /* wr_one_init */ + + + + + chainp +#ifdef KR_headers +data_value(infile, offset, type) + FILE *infile; + ftnint offset; + int type; +#else +data_value(FILE *infile, ftnint offset, int type) +#endif +{ + char line[MAX_INIT_LINE + 1], *pointer; + chainp vals, prev_val; + char *newval; + + if (fgets (line, MAX_INIT_LINE, infile) == NULL) { + err ("data_value: error reading from intermediate file"); + return CHNULL; + } /* if fgets */ + +/* Get rid of the trailing newline */ + + if (line[0]) + line[strlen (line) - 1] = '\0'; + +#define iswhite(x) (isspace (x) || (x) == ',') + + pointer = line; + prev_val = vals = CHNULL; + + while (*pointer) { + register char *end_ptr, old_val; + +/* Move pointer to the start of the next word */ + + while (*pointer && iswhite (*pointer)) + pointer++; + if (*pointer == '\0') + break; + +/* Move end_ptr to the end of the current word */ + + for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr); + end_ptr++) + ; + + old_val = *end_ptr; + *end_ptr = '\0'; + +/* Add this value to the end of the list */ + +#ifdef NO_LONG_LONG + if (ONEOF(type, MSKREAL|MSKCOMPLEX)) +#else + if (ONEOF(type, MSKREAL|MSKCOMPLEX|M(TYQUAD))) +#endif + newval = cpstring(pointer); + else + newval = (char *)atol(pointer); + if (vals) { + prev_val->nextp = mkchain(newval, CHNULL); + prev_val = prev_val -> nextp; + } else + prev_val = vals = mkchain(newval, CHNULL); + *end_ptr = old_val; + pointer = end_ptr; + } /* while *pointer */ + + return mkchain((char *)offset, mkchain((char *)(Ulong)type, vals)); +} /* data_value */ + + static void +overlapping(Void) +{ + extern char *filename0; + static int warned = 0; + + if (warned) + return; + warned = 1; + + fprintf(stderr, "Error"); + if (filename0) + fprintf(stderr, " in file %s", filename0); + fprintf(stderr, ": overlapping initializations\n"); + nerr++; + } + + static void make_one_const Argdcl((int, union Constant*, chainp)); + static long charlen; + + void +#ifdef KR_headers +wr_output_values(outfile, namep, values) + FILE *outfile; + Namep namep; + chainp values; +#else +wr_output_values(FILE *outfile, Namep namep, chainp values) +#endif +{ + int type = TYUNKNOWN; + struct Constblock Const; + static expptr Vlen; + + if (namep) + type = namep -> vtype; + +/* Handle array initializations away from scalars */ + + if (namep && namep -> vdim) + wr_array_init (outfile, type, values); + + else if (values->nextp && type != TYCHAR) + overlapping(); + + else { + make_one_const(type, &Const.Const, values); + Const.vtype = type; + Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; + if (type== TYCHAR) { + if (!Vlen) + Vlen = ICON(0); + Const.vleng = Vlen; + Vlen->constblock.Const.ci = charlen; + out_const (outfile, &Const); + free (Const.Const.ccp); + } + else { +#ifndef NO_LONG_LONG + if (type == TYQUAD) + Const.Const.cd[1] = 123.456; /* kludge */ + /* kludge assumes max(sizeof(char*), */ + /* sizeof(long long)) <= sizeof(double) */ +#endif + out_const (outfile, &Const); + } + } + } + + + void +#ifdef KR_headers +wr_array_init(outfile, type, values) + FILE *outfile; + int type; + chainp values; +#else +wr_array_init(FILE *outfile, int type, chainp values) +#endif +{ + int size = typesize[type]; + long index, main_index = 0; + int k; + + if (type == TYCHAR) { + nice_printf(outfile, "\""); + k = 0; + if (Ansi != 1) + ch_ar_dim = -1; + } + else + nice_printf (outfile, "{ "); + while (values) { + struct Constblock Const; + + index = ((long) ((chainp) values->datap)->datap) / size; + while (index > main_index) { + +/* Fill with zeros. The structure shorthand works because the compiler + will expand the "0" in braces to fill the size of the entire structure + */ + + switch (type) { + case TYREAL: + case TYDREAL: + nice_printf (outfile, "0.0,"); + break; + case TYCOMPLEX: + case TYDCOMPLEX: + nice_printf (outfile, "{0},"); + break; + case TYCHAR: + nice_printf(outfile, " "); + break; + default: + nice_printf (outfile, "0,"); + break; + } /* switch */ + main_index++; + } /* while index > main_index */ + + if (index < main_index) + overlapping(); + else switch (type) { + case TYCHAR: + { int this_char; + + if (k == ch_ar_dim) { + nice_printf(outfile, "\" \""); + k = 0; + } + this_char = (int)(Ulong) ((chainp) values->datap)-> + nextp->nextp->datap; + if ((Ulong)((chainp)values->datap)->nextp->datap == TYBLANK) { + main_index += this_char; + k += this_char; + while(--this_char >= 0) + nice_printf(outfile, " "); + values = values -> nextp; + continue; + } + nice_printf(outfile, str_fmt[this_char]); + k++; + } /* case TYCHAR */ + break; + +#ifdef TYQUAD + case TYQUAD: +#ifndef NO_LONG_LONG + Const.Const.cd[1] = 123.456; +#endif +#endif + case TYINT1: + case TYSHORT: + case TYLONG: + case TYREAL: + case TYDREAL: + case TYLOGICAL: + case TYLOGICAL1: + case TYLOGICAL2: + case TYCOMPLEX: + case TYDCOMPLEX: + make_one_const(type, &Const.Const, values); + Const.vtype = type; + Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; + out_const(outfile, &Const); + break; + default: + erri("wr_array_init: bad type '%d'", type); + break; + } /* switch */ + values = values->nextp; + + main_index++; + if (values && type != TYCHAR) + nice_printf (outfile, ","); + } /* while values */ + + if (type == TYCHAR) { + nice_printf(outfile, "\""); + } + else + nice_printf (outfile, " }"); +} /* wr_array_init */ + + + static void +#ifdef KR_headers +make_one_const(type, storage, values) + int type; + union Constant *storage; + chainp values; +#else +make_one_const(int type, union Constant *storage, chainp values) +#endif +{ + union Constant *Const; + register char **L; + + if (type == TYCHAR) { + char *str, *str_ptr; + chainp v, prev; + int b = 0, k, main_index = 0; + +/* Find the max length of init string, by finding the highest offset + value stored in the list of initial values */ + + for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp) + ; + if (prev != CHNULL) + k = ((int)(Ulong) (((chainp) prev->datap)->datap)) + 2; + /* + 2 above for null char at end */ + str = Alloc (k); + for (str_ptr = str; values; str_ptr++) { + int index = (int)(Ulong) (((chainp) values->datap)->datap); + + if (index < main_index) + overlapping(); + while (index > main_index++) + *str_ptr++ = ' '; + + k = (int)(Ulong)(((chainp)values->datap)->nextp->nextp->datap); + if ((Ulong)((chainp)values->datap)->nextp->datap == TYBLANK) { + b = k; + break; + } + *str_ptr = (char)k; + values = values -> nextp; + } /* for str_ptr */ + *str_ptr = '\0'; + Const = storage; + Const -> ccp = str; + Const -> ccp1.blanks = b; + charlen = str_ptr - str; + } else { + int i = 0; + chainp vals; + + vals = ((chainp)values->datap)->nextp->nextp; + if (vals) { + L = (char **)storage; + do L[i++] = vals->datap; + while(vals = vals->nextp); + } + + } /* else */ + +} /* make_one_const */ + + + int +#ifdef KR_headers +rdname(infile, vargroupp, name) + FILE *infile; + int *vargroupp; + char *name; +#else +rdname(FILE *infile, int *vargroupp, char *name) +#endif +{ + register int i, c; + + c = getc (infile); + + if (feof (infile)) + return NO; + + *vargroupp = c - '0'; + for (i = 1;; i++) { + if (i >= VNAME_MAX) + Fatal("rdname: oversize name"); + c = getc (infile); + if (feof (infile)) + return NO; + if (c == '\t') + break; + *name++ = c; + } + *name = 0; + return YES; +} /* rdname */ + + int +#ifdef KR_headers +rdlong(infile, n) + FILE *infile; + ftnint *n; +#else +rdlong(FILE *infile, ftnint *n) +#endif +{ + register int c; + + for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile)) + ; + + if (feof (infile)) + return NO; + + for (*n = 0; isdigit (c); c = getc (infile)) + *n = 10 * (*n) + c - '0'; + return YES; +} /* rdlong */ + + + static int +#ifdef KR_headers +memno2info(memno, info) + int memno; + Namep *info; +#else +memno2info(int memno, Namep *info) +#endif +{ + chainp this_var; + extern chainp new_vars; + extern struct Hashentry *hashtab, *lasthash; + struct Hashentry *entry; + + for (this_var = new_vars; this_var; this_var = this_var -> nextp) { + Addrp var = (Addrp) this_var->datap; + + if (var == (Addrp) NULL) + Fatal("memno2info: null variable"); + else if (var -> tag != TADDR) + Fatal("memno2info: bad tag"); + if (memno == var -> memno) { + *info = (Namep) var; + return 1; + } /* if memno == var -> memno */ + } /* for this_var = new_vars */ + + for (entry = hashtab; entry < lasthash; ++entry) { + Namep var = entry -> varp; + + if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) { + *info = (Namep) var; + return 0; + } /* if entry -> vardesc.varno == memno */ + } /* for entry = hashtab */ + + Fatal("memno2info: couldn't find memno"); + return 0; +} /* memno2info */ + + static chainp +#ifdef KR_headers +do_string(outfile, v, nloc) + FILE *outfile; + register chainp v; + ftnint *nloc; +#else +do_string(FILE *outfile, register chainp v, ftnint *nloc) +#endif +{ + register chainp cp, v0; + ftnint dloc, k, loc; + unsigned long uk; + char buf[8], *comma; + + nice_printf(outfile, "{"); + cp = (chainp)v->datap; + loc = (ftnint)cp->datap; + comma = ""; + for(v0 = v;;) { + switch((Ulong)cp->nextp->datap) { + case TYBLANK: + k = (ftnint)cp->nextp->nextp->datap; + loc += k; + while(--k >= 0) { + nice_printf(outfile, "%s' '", comma); + comma = ", "; + } + break; + case TYCHAR: + uk = (ftnint)cp->nextp->nextp->datap; + sprintf(buf, chr_fmt[uk], uk); + nice_printf(outfile, "%s'%s'", comma, buf); + comma = ", "; + loc++; + break; + default: + goto done; + } + v0 = v; + if (!(v = v->nextp) || !(cp = (chainp)v->datap)) + break; + dloc = (ftnint)cp->datap; + if (loc != dloc) + break; + } + done: + nice_printf(outfile, "}"); + *nloc = loc; + return v0; + } + + static chainp +#ifdef KR_headers +Ado_string(outfile, v, nloc) + FILE *outfile; + register chainp v; + ftnint *nloc; +#else +Ado_string(FILE *outfile, register chainp v, ftnint *nloc) +#endif +{ + register chainp cp, v0; + ftnint dloc, k, loc; + + nice_printf(outfile, "\""); + cp = (chainp)v->datap; + loc = (ftnint)cp->datap; + for(v0 = v;;) { + switch((Ulong)cp->nextp->datap) { + case TYBLANK: + k = (ftnint)cp->nextp->nextp->datap; + loc += k; + while(--k >= 0) + nice_printf(outfile, " "); + break; + case TYCHAR: + k = (ftnint)cp->nextp->nextp->datap; + nice_printf(outfile, str_fmt[k]); + loc++; + break; + default: + goto done; + } + v0 = v; + if (!(v = v->nextp) || !(cp = (chainp)v->datap)) + break; + dloc = (ftnint)cp->datap; + if (loc != dloc) + break; + } + done: + nice_printf(outfile, "\""); + *nloc = loc; + return v0; + } + + static char * +#ifdef KR_headers +Len(L, type) + long L; + int type; +#else +Len(long L, int type) +#endif +{ + static char buf[24]; + if (L == 1 && type != TYCHAR) + return ""; + sprintf(buf, "[%ld]", L); + return buf; + } + + static void +#ifdef KR_headers +fill_dcl(outfile, t, k, L) FILE *outfile; int t; int k; ftnint L; +#else +fill_dcl(FILE *outfile, int t, int k, ftnint L) +#endif +{ + nice_printf(outfile, "%s fill_%d[%ld];\n", Typename[t], k, L); + } + + static int +#ifdef KR_headers +fill_type(L, loc, xtype) ftnint L; ftnint loc; int xtype; +#else +fill_type(ftnint L, ftnint loc, int xtype) +#endif +{ + int ft, ft1, szshort; + + if (xtype == TYCHAR) + return xtype; + szshort = typesize[TYSHORT]; + ft = L % szshort ? TYCHAR : type_choice[L/szshort % 4]; + ft1 = loc % szshort ? TYCHAR : type_choice[loc/szshort % 4]; + if (typesize[ft] > typesize[ft1]) + ft = ft1; + return ft; + } + + static ftnint +#ifdef KR_headers +get_fill(dloc, loc, t0, t1, L0, L1, xtype) ftnint dloc; ftnint loc; int *t0; int *t1; ftnint *L0; ftnint *L1; int xtype; +#else +get_fill(ftnint dloc, ftnint loc, int *t0, int *t1, ftnint *L0, ftnint *L1, int xtype) +#endif +{ + ftnint L, L2, loc0; + + if (L = loc % typesize[xtype]) { + loc0 = loc; + loc += L = typesize[xtype] - L; + if (L % typesize[TYSHORT]) + *t0 = TYCHAR; + else + L /= typesize[*t0 = fill_type(L, loc0, xtype)]; + } + if (dloc < loc + typesize[xtype]) + return 0; + *L0 = L; + L2 = (dloc - loc) / typesize[xtype]; + loc += L2*typesize[xtype]; + if (dloc -= loc) + dloc /= typesize[*t1 = fill_type(dloc, loc, xtype)]; + *L1 = dloc; + return L2; + } + + void +#ifdef KR_headers +wr_equiv_init(outfile, memno, Values, iscomm) + FILE *outfile; + int memno; + chainp *Values; + int iscomm; +#else +wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm) +#endif +{ + struct Equivblock *eqv; + int btype, curtype, dtype, filltype, j, k, n, t0, t1; + int wasblank, xfilled, xtype; + static char Blank[] = ""; + register char *comma = Blank; + register chainp cp, v; + chainp sentinel, values, v1, vlast; + ftnint L, L0, L1, L2, dL, dloc, loc, loc0; + union Constant Const; + char imag_buf[50], real_buf[50]; + int szshort = typesize[TYSHORT]; + static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG, +#ifdef TYQUAD + TYQUAD, +#endif + TYREAL, TYDREAL, TYREAL, TYDREAL, + TYLOGICAL1, TYLOGICAL2, + TYLOGICAL, TYCHAR}; + static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG, +#ifdef TYQUAD + TYDREAL, +#endif + TYLONG, TYDREAL, TYLONG, TYDREAL, + TYCHAR, TYSHORT, + TYLONG, TYCHAR, 0 /* for TYBLANK */ }; + extern int htype; + char *z; + + /* add sentinel */ + if (iscomm) { + L = extsymtab[memno].maxleng; + xtype = extsymtab[memno].extype; + } + else { + eqv = &eqvclass[memno]; + L = eqv->eqvtop - eqv->eqvbottom; + xtype = eqv->eqvtype; + } + + if (halign && typealign[typepref[xtype]] < typealign[htype]) + xtype = htype; + xtype = typepref[xtype]; + *Values = values = revchain(vlast = *Values); + + xfilled = 2; + if (xtype != TYCHAR) { + + /* unless the data include a value of the appropriate + * type, we add an extra element in an attempt + * to force correct alignment */ + + btype = basetype[xtype]; + loc = 0; + for(v = *Values;;v = v->nextp) { + if (!v) { + dtype = typepref[xtype]; + z = ISREAL(dtype) ? cpstring("0.") : (char *)0; + k = typesize[dtype]; + if (j = (int)(L % k)) + L += k - j; + v = mkchain((char *)L, + mkchain((char *)(Ulong)dtype, + mkchain(z, CHNULL))); + vlast = vlast->nextp = + mkchain((char *)v, CHNULL); + L += k; + break; + } + cp = (chainp)v->datap; + if (basetype[(Ulong)cp->nextp->datap] == btype) + break; + dloc = (ftnint)cp->datap; + if (get_fill(dloc, loc, &t0, &t1, &L0, &L1, xtype)) { + xfilled = 0; + break; + } + L1 = dloc - loc; + if (L1 > 0 + && !(L1 % szshort) + && !(loc % szshort) + && btype <= type_choice[L1/szshort % 4] + && btype <= type_choice[loc/szshort % 4]) + break; + dtype = (int)(Ulong)cp->nextp->datap; + loc = dloc + (dtype == TYBLANK + ? (ftnint)cp->nextp->nextp->datap + : typesize[dtype]); + } + } + sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL)); + vlast->nextp = mkchain((char *)sentinel, CHNULL); + + /* use doublereal fillers only if there are doublereal values */ + + k = TYLONG; + for(v = values; v; v = v->nextp) + if (ONEOF((Ulong)((chainp)v->datap)->nextp->datap, + M(TYDREAL)|M(TYDCOMPLEX))) { + k = TYDREAL; + break; + } + type_choice[0] = k; + + nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static "); + next_tab(outfile); + loc = loc0 = k = 0; + curtype = -1; + for(v = values; v; v = v->nextp) { + cp = (chainp)v->datap; + dloc = (ftnint)cp->datap; + L = dloc - loc; + if (L < 0) { + overlapping(); + if ((Ulong)cp->nextp->datap != TYERROR) { + v1 = cp; + frchain(&v1); + v->datap = 0; + } + continue; + } + dtype = (int)(Ulong)cp->nextp->datap; + if (dtype == TYBLANK) { + dtype = TYCHAR; + wasblank = 1; + } + else + wasblank = 0; + if (curtype != dtype || L > 0) { + if (curtype != -1) { + L1 = (loc - loc0)/dL; + nice_printf(outfile, "%s e_%d%s;\n", + Typename[curtype], ++k, + Len(L1,curtype)); + } + curtype = dtype; + loc0 = dloc; + } + if (L > 0) { + filltype = fill_type(L, loc, xtype); + L1 = L / typesize[filltype]; + if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1, + &L0, &L1, xtype))) { + xfilled = 1; + if (L0) + fill_dcl(outfile, t0, ++k, L0); + fill_dcl(outfile, xtype, ++k, L2); + if (L1) + fill_dcl(outfile, t1, ++k, L1); + } + else + fill_dcl(outfile, filltype, ++k, L1); + loc = dloc; + } + if (wasblank) { + loc += (ftnint)cp->nextp->nextp->datap; + dL = 1; + } + else { + dL = typesize[dtype]; + loc += dL; + } + } + nice_printf(outfile, "} %s = { ", iscomm + ? extsymtab[memno].cextname + : equiv_name(eqvmemno, CNULL)); + loc = 0; + xfilled &= 2; + for(v = values; ; v = v->nextp) { + cp = (chainp)v->datap; + if (!cp) + continue; + dtype = (int)(Ulong)cp->nextp->datap; + if (dtype == TYERROR) + break; + dloc = (ftnint)cp->datap; + if (dloc > loc) { + n = 1; + if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1, + &L0, &L1, xtype))) { + xfilled = 1; + if (L0) + n = 2; + if (L1) + n++; + } + while(n--) { + nice_printf(outfile, "%s{0}", comma); + comma = ", "; + } + loc = dloc; + } + if (comma != Blank) + nice_printf(outfile, ", "); + comma = ", "; + if (dtype == TYCHAR || dtype == TYBLANK) { + v = Ansi == 1 ? Ado_string(outfile, v, &loc) + : do_string(outfile, v, &loc); + continue; + } + make_one_const(dtype, &Const, v); + switch(dtype) { + case TYLOGICAL: + case TYLOGICAL2: + case TYLOGICAL1: + if (Const.ci < 0 || Const.ci > 1) + errl( + "wr_equiv_init: unexpected logical value %ld", + Const.ci); + nice_printf(outfile, + Const.ci ? "TRUE_" : "FALSE_"); + break; + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + nice_printf(outfile, "%ld", Const.ci); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + nice_printf(outfile, "%s", Const.cds[0]); + break; +#endif + case TYREAL: + nice_printf(outfile, "%s", + flconst(real_buf, Const.cds[0])); + break; + case TYDREAL: + nice_printf(outfile, "%s", Const.cds[0]); + break; + case TYCOMPLEX: + nice_printf(outfile, "%s, %s", + flconst(real_buf, Const.cds[0]), + flconst(imag_buf, Const.cds[1])); + break; + case TYDCOMPLEX: + nice_printf(outfile, "%s, %s", + Const.cds[0], Const.cds[1]); + break; + default: + erri("unexpected type %d in wr_equiv_init", + dtype); + } + loc += typesize[dtype]; + } + nice_printf(outfile, " };\n\n"); + prev_tab(outfile); + frchain(&sentinel); + } diff --git a/unix/f2c/src/ftypes.h b/unix/f2c/src/ftypes.h new file mode 100644 index 00000000..8181d876 --- /dev/null +++ b/unix/f2c/src/ftypes.h @@ -0,0 +1,64 @@ + +/* variable types (stored in the vtype field of expptr) + * numeric assumptions: + * int < reals < complexes + * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX + */ + +#undef TYQUAD0 +#ifdef NO_TYQUAD +#undef TYQUAD +#define TYQUAD_inc 0 +#undef NO_LONG_LONG +#define NO_LONG_LONG +#else +#define TYQUAD 5 +#define TYQUAD_inc 1 +#ifdef NO_LONG_LONG +#define TYQUAD0 +#else +#ifndef Llong +typedef long long Llong; +#endif +#ifndef ULlong +typedef unsigned long long ULlong; +#endif +#endif /*NO_LONG_LONG*/ +#endif /*NO_TYQUAD*/ + +#define TYUNKNOWN 0 +#define TYADDR 1 +#define TYINT1 2 +#define TYSHORT 3 +#define TYLONG 4 +/* #define TYQUAD 5 */ +#define TYREAL (5+TYQUAD_inc) +#define TYDREAL (6+TYQUAD_inc) +#define TYCOMPLEX (7+TYQUAD_inc) +#define TYDCOMPLEX (8+TYQUAD_inc) +#define TYLOGICAL1 (9+TYQUAD_inc) +#define TYLOGICAL2 (10+TYQUAD_inc) +#define TYLOGICAL (11+TYQUAD_inc) +#define TYCHAR (12+TYQUAD_inc) +#define TYSUBR (13+TYQUAD_inc) +#define TYERROR (14+TYQUAD_inc) +#define TYCILIST (15+TYQUAD_inc) +#define TYICILIST (16+TYQUAD_inc) +#define TYOLIST (17+TYQUAD_inc) +#define TYCLLIST (18+TYQUAD_inc) +#define TYALIST (19+TYQUAD_inc) +#define TYINLIST (20+TYQUAD_inc) +#define TYVOID (21+TYQUAD_inc) +#define TYLABEL (22+TYQUAD_inc) +#define TYFTNLEN (23+TYQUAD_inc) +/* TYVOID is not in any tables. */ + +/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by + type. Such tables can include the size (in bytes) of objects of a given + type, or labels for returning objects of different types from procedures + (see array rtvlabels) */ + +#define NTYPES TYVOID +#define NTYPES0 TYCILIST +#define TYBLANK TYSUBR /* Huh? */ + diff --git a/unix/f2c/src/gram.c b/unix/f2c/src/gram.c new file mode 100644 index 00000000..16d524e3 --- /dev/null +++ b/unix/f2c/src/gram.c @@ -0,0 +1,1957 @@ +#define SEOS 1 +#define SCOMMENT 2 +#define SLABEL 3 +#define SUNKNOWN 4 +#define SHOLLERITH 5 +#define SICON 6 +#define SRCON 7 +#define SDCON 8 +#define SBITCON 9 +#define SOCTCON 10 +#define SHEXCON 11 +#define STRUE 12 +#define SFALSE 13 +#define SNAME 14 +#define SNAMEEQ 15 +#define SFIELD 16 +#define SSCALE 17 +#define SINCLUDE 18 +#define SLET 19 +#define SASSIGN 20 +#define SAUTOMATIC 21 +#define SBACKSPACE 22 +#define SBLOCK 23 +#define SCALL 24 +#define SCHARACTER 25 +#define SCLOSE 26 +#define SCOMMON 27 +#define SCOMPLEX 28 +#define SCONTINUE 29 +#define SDATA 30 +#define SDCOMPLEX 31 +#define SDIMENSION 32 +#define SDO 33 +#define SDOUBLE 34 +#define SELSE 35 +#define SELSEIF 36 +#define SEND 37 +#define SENDFILE 38 +#define SENDIF 39 +#define SENTRY 40 +#define SEQUIV 41 +#define SEXTERNAL 42 +#define SFORMAT 43 +#define SFUNCTION 44 +#define SGOTO 45 +#define SASGOTO 46 +#define SCOMPGOTO 47 +#define SARITHIF 48 +#define SLOGIF 49 +#define SIMPLICIT 50 +#define SINQUIRE 51 +#define SINTEGER 52 +#define SINTRINSIC 53 +#define SLOGICAL 54 +#define SNAMELIST 55 +#define SOPEN 56 +#define SPARAM 57 +#define SPAUSE 58 +#define SPRINT 59 +#define SPROGRAM 60 +#define SPUNCH 61 +#define SREAD 62 +#define SREAL 63 +#define SRETURN 64 +#define SREWIND 65 +#define SSAVE 66 +#define SSTATIC 67 +#define SSTOP 68 +#define SSUBROUTINE 69 +#define STHEN 70 +#define STO 71 +#define SUNDEFINED 72 +#define SWRITE 73 +#define SLPAR 74 +#define SRPAR 75 +#define SEQUALS 76 +#define SCOLON 77 +#define SCOMMA 78 +#define SCURRENCY 79 +#define SPLUS 80 +#define SMINUS 81 +#define SSTAR 82 +#define SSLASH 83 +#define SPOWER 84 +#define SCONCAT 85 +#define SAND 86 +#define SOR 87 +#define SNEQV 88 +#define SEQV 89 +#define SNOT 90 +#define SEQ 91 +#define SLT 92 +#define SGT 93 +#define SLE 94 +#define SGE 95 +#define SNE 96 +#define SENDDO 97 +#define SWHILE 98 +#define SSLASHD 99 +#define SBYTE 100 + +/* #line 125 "/n/bopp/v5/dmg/f2c/gram.in" */ +#include "defs.h" +#include "p1defs.h" + +static int nstars; /* Number of labels in an + alternate return CALL */ +static int datagripe; +static int ndim; +static int vartype; +int new_dcl; +static ftnint varleng; +static struct Dims dims[MAXDIM+1]; +extern struct Labelblock **labarray; /* Labels in an alternate + return CALL */ +extern int maxlablist; + +/* The next two variables are used to verify that each statement might be reached + during runtime. lastwasbranch is tested only in the defintion of the + stat: nonterminal. */ + +int lastwasbranch = NO; +static int thiswasbranch = NO; +extern ftnint yystno; +extern flag intonly; +static chainp datastack; +extern long laststfcn, thisstno; +extern int can_include; /* for netlib */ +extern void endcheck Argdcl((void)); +extern struct Primblock *primchk Argdcl((expptr)); + +#define ESNULL (Extsym *)0 +#define NPNULL (Namep)0 +#define LBNULL (struct Listblock *)0 + + static void +pop_datastack(Void) { + chainp d0 = datastack; + if (d0->datap) + curdtp = (chainp)d0->datap; + datastack = d0->nextp; + d0->nextp = 0; + frchain(&d0); + } + + +/* #line 172 "/n/bopp/v5/dmg/f2c/gram.in" */ +typedef union { + int ival; + ftnint lval; + char *charpval; + chainp chval; + tagptr tagval; + expptr expval; + struct Labelblock *labval; + struct Nameblock *namval; + struct Eqvchain *eqvval; + Extsym *extval; + } YYSTYPE; +extern int yyerrflag; +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 150 +#endif +YYSTYPE yylval; +YYSTYPE yyval; +#define YYEOFCODE 1 +#define YYERRCODE 2 +short yyexca[] = +{-1, 1, + 1, -1, + -2, 0, +-1, 20, + 4, 38, + -2, 231, +-1, 24, + 4, 42, + -2, 231, +-1, 151, + 4, 247, + -2, 189, +-1, 175, + 4, 269, + 81, 269, + -2, 189, +-1, 225, + 80, 174, + -2, 140, +-1, 246, + 77, 231, + -2, 228, +-1, 273, + 4, 290, + -2, 144, +-1, 277, + 4, 299, + 81, 299, + -2, 146, +-1, 330, + 80, 175, + -2, 142, +-1, 360, + 4, 271, + 17, 271, + 77, 271, + 81, 271, + -2, 190, +-1, 439, + 94, 0, + 95, 0, + 96, 0, + 97, 0, + 98, 0, + 99, 0, + -2, 154, +-1, 456, + 4, 293, + 81, 293, + -2, 144, +-1, 458, + 4, 295, + 81, 295, + -2, 144, +-1, 460, + 4, 297, + 81, 297, + -2, 144, +-1, 462, + 4, 300, + 81, 300, + -2, 145, +-1, 506, + 81, 293, + -2, 144, +}; +#define YYNPROD 305 +#define YYPRIVATE 57344 +#define YYLAST 1455 +short yyact[] = +{ + 239, 359, 474, 306, 416, 427, 299, 389, 473, 267, + 315, 231, 400, 358, 318, 415, 328, 253, 319, 100, + 224, 297, 294, 280, 402, 401, 305, 117, 185, 265, + 17, 122, 204, 275, 196, 191, 202, 203, 119, 129, + 107, 271, 200, 184, 112, 104, 338, 102, 166, 167, + 336, 337, 338, 344, 343, 342, 121, 157, 120, 345, + 347, 346, 349, 348, 350, 261, 276, 336, 337, 338, + 131, 132, 133, 134, 104, 136, 539, 158, 399, 158, + 313, 166, 167, 336, 337, 338, 344, 343, 342, 341, + 340, 311, 345, 347, 346, 349, 348, 350, 399, 398, + 105, 514, 115, 537, 166, 167, 336, 337, 338, 344, + 343, 342, 341, 340, 238, 345, 347, 346, 349, 348, + 350, 106, 130, 104, 478, 211, 187, 188, 412, 320, + 259, 260, 261, 411, 95, 166, 167, 336, 337, 338, + 186, 213, 296, 212, 194, 486, 195, 542, 245, 96, + 97, 98, 527, 104, 529, 158, 523, 449, 258, 158, + 241, 243, 484, 101, 487, 485, 216, 274, 471, 222, + 217, 472, 221, 158, 483, 465, 430, 220, 166, 167, + 259, 260, 261, 262, 158, 166, 167, 336, 337, 338, + 344, 156, 121, 156, 120, 464, 345, 347, 346, 349, + 348, 350, 463, 373, 281, 282, 283, 236, 104, 232, + 242, 242, 249, 101, 292, 301, 263, 468, 290, 302, + 279, 296, 291, 288, 289, 166, 167, 259, 260, 261, + 264, 317, 455, 335, 189, 351, 312, 310, 446, 453, + 431, 284, 425, 335, 166, 167, 259, 260, 261, 262, + 258, 466, 325, 158, 467, 450, 380, 99, 449, 158, + 158, 158, 158, 158, 258, 258, 357, 379, 269, 156, + 234, 420, 266, 156, 421, 409, 393, 335, 410, 394, + 361, 333, 323, 362, 334, 258, 378, 156, 270, 208, + 326, 101, 330, 178, 113, 332, 374, 111, 156, 375, + 376, 403, 352, 110, 109, 108, 354, 355, 385, 386, + 363, 356, 384, 225, 377, 425, 367, 368, 369, 370, + 371, 422, 223, 364, 335, 538, 391, 335, 534, 533, + 532, 335, 423, 335, 372, 413, 408, 395, 390, 166, + 167, 259, 260, 261, 262, 381, 434, 528, 531, 526, + 494, 429, 237, 335, 496, 335, 335, 335, 104, 104, + 490, 298, 138, 158, 258, 335, 448, 156, 258, 258, + 258, 258, 258, 156, 156, 156, 156, 156, 251, 192, + 451, 103, 335, 454, 309, 277, 277, 360, 287, 426, + 118, 352, 166, 167, 259, 260, 261, 262, 137, 387, + 403, 232, 435, 436, 437, 438, 439, 440, 441, 442, + 443, 444, 477, 247, 469, 406, 482, 470, 308, 269, + 452, 166, 167, 336, 337, 338, 344, 335, 479, 155, + 244, 155, 488, 228, 225, 499, 335, 335, 335, 335, + 335, 335, 335, 335, 335, 335, 383, 497, 273, 273, + 495, 502, 201, 258, 150, 151, 214, 175, 103, 103, + 103, 103, 501, 190, 475, 454, 210, 172, 193, 142, + 503, 197, 198, 199, 504, 510, 335, 156, 207, 403, + 277, 513, 507, 508, 509, 331, 277, 482, 517, 489, + 335, 520, 492, 335, 197, 218, 219, 242, 498, 335, + 525, 519, 518, 516, 515, 524, 353, 155, 404, 512, + 246, 155, 248, 104, 406, 417, 30, 535, 406, 511, + 390, 209, 213, 335, 227, 155, 268, 93, 6, 541, + 250, 335, 171, 173, 177, 82, 155, 335, 4, 475, + 81, 335, 5, 273, 543, 80, 457, 459, 461, 382, + 124, 79, 103, 174, 304, 295, 307, 522, 78, 77, + 76, 60, 49, 242, 48, 45, 424, 322, 33, 114, + 530, 118, 206, 316, 414, 321, 205, 397, 396, 300, + 197, 536, 481, 135, 215, 392, 277, 277, 277, 314, + 540, 116, 26, 406, 25, 353, 24, 23, 22, 21, + 388, 286, 9, 8, 7, 155, 2, 404, 303, 20, + 165, 155, 155, 155, 155, 155, 51, 491, 293, 268, + 230, 329, 268, 268, 166, 167, 336, 337, 338, 344, + 343, 457, 459, 461, 327, 345, 347, 346, 349, 348, + 350, 418, 92, 256, 53, 339, 19, 55, 37, 456, + 458, 460, 226, 3, 1, 0, 0, 0, 0, 0, + 0, 307, 0, 405, 197, 0, 0, 0, 0, 0, + 0, 277, 277, 277, 419, 0, 0, 0, 353, 0, + 321, 0, 0, 0, 0, 0, 404, 0, 0, 0, + 493, 0, 0, 0, 432, 166, 167, 336, 337, 338, + 344, 343, 342, 341, 340, 0, 345, 347, 346, 349, + 348, 350, 0, 0, 0, 155, 0, 500, 0, 0, + 0, 0, 0, 0, 0, 0, 268, 0, 0, 0, + 0, 0, 462, 0, 506, 458, 460, 166, 167, 336, + 337, 338, 344, 343, 342, 341, 340, 0, 345, 347, + 346, 349, 348, 350, 0, 0, 0, 295, 0, 0, + 0, 0, 405, 480, 0, 307, 405, 0, 0, 447, + 0, 0, 0, 0, 166, 167, 336, 337, 338, 344, + 343, 342, 341, 340, 316, 345, 347, 346, 349, 348, + 350, 0, 0, 445, 0, 0, 0, 0, 166, 167, + 336, 337, 338, 344, 343, 342, 341, 340, 268, 345, + 347, 346, 349, 348, 350, 0, 0, 0, 505, 0, + 0, 0, 0, 0, 0, 0, 505, 505, 505, 0, + 0, 0, 0, 0, 0, 0, 307, 12, 0, 0, + 0, 405, 0, 0, 0, 0, 505, 0, 0, 0, + 521, 10, 56, 46, 73, 86, 14, 61, 70, 91, + 38, 66, 47, 42, 68, 72, 31, 67, 35, 34, + 11, 88, 36, 18, 41, 39, 28, 16, 57, 58, + 59, 50, 54, 43, 89, 64, 40, 69, 44, 90, + 29, 62, 85, 13, 0, 83, 65, 52, 87, 27, + 74, 63, 15, 433, 0, 71, 84, 0, 166, 167, + 336, 337, 338, 344, 343, 342, 341, 340, 0, 345, + 347, 346, 349, 348, 350, 0, 0, 0, 0, 0, + 32, 0, 0, 75, 166, 167, 336, 337, 338, 344, + 343, 342, 341, 340, 0, 345, 347, 346, 349, 348, + 350, 73, 0, 0, 0, 70, 0, 0, 66, 0, + 0, 68, 72, 0, 67, 161, 162, 163, 164, 170, + 169, 168, 159, 160, 104, 0, 0, 0, 0, 0, + 0, 0, 64, 0, 69, 0, 0, 0, 0, 0, + 0, 0, 0, 65, 0, 0, 0, 74, 0, 0, + 0, 0, 71, 161, 162, 163, 164, 170, 169, 168, + 159, 160, 104, 0, 161, 162, 163, 164, 170, 169, + 168, 159, 160, 104, 0, 0, 0, 0, 0, 0, + 75, 0, 0, 0, 235, 0, 0, 0, 0, 0, + 166, 167, 365, 0, 366, 0, 0, 0, 0, 0, + 240, 161, 162, 163, 164, 170, 169, 168, 159, 160, + 104, 0, 161, 162, 163, 164, 170, 169, 168, 159, + 160, 104, 235, 229, 0, 0, 0, 0, 166, 167, + 233, 0, 0, 235, 0, 0, 0, 0, 240, 166, + 167, 476, 0, 0, 0, 0, 0, 0, 0, 240, + 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, + 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, + 235, 0, 0, 0, 0, 0, 166, 167, 233, 0, + 0, 235, 0, 0, 0, 0, 240, 166, 167, 428, + 0, 0, 0, 0, 0, 0, 0, 240, 161, 162, + 163, 164, 170, 169, 168, 159, 160, 104, 0, 161, + 162, 163, 164, 170, 169, 168, 159, 160, 104, 278, + 0, 0, 0, 272, 0, 166, 167, 0, 0, 0, + 0, 0, 0, 0, 0, 240, 161, 162, 163, 164, + 170, 169, 168, 159, 160, 104, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 94, 161, 162, 163, 164, + 170, 169, 168, 159, 160, 104, 257, 235, 0, 0, + 0, 0, 0, 166, 167, 0, 0, 0, 278, 0, + 0, 0, 0, 240, 166, 167, 0, 123, 0, 0, + 126, 127, 128, 0, 240, 0, 0, 0, 0, 0, + 0, 0, 139, 140, 0, 324, 141, 0, 143, 144, + 145, 166, 167, 146, 147, 148, 0, 149, 0, 0, + 0, 240, 0, 0, 0, 252, 0, 0, 0, 0, + 0, 166, 167, 254, 0, 255, 0, 179, 180, 181, + 182, 183, 161, 162, 163, 164, 170, 169, 168, 159, + 160, 104, 0, 161, 162, 163, 164, 170, 169, 168, + 159, 160, 104, 161, 162, 163, 164, 170, 169, 168, + 159, 160, 104, 161, 162, 163, 164, 170, 169, 168, + 159, 160, 104, 161, 162, 163, 164, 170, 169, 168, + 159, 160, 104, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 154, 0, 0, 0, 0, 0, 166, 167, 152, + 0, 153, 252, 0, 0, 0, 0, 0, 166, 167, + 285, 0, 154, 0, 0, 0, 0, 0, 166, 167, + 176, 0, 407, 0, 0, 0, 0, 0, 166, 167, + 56, 46, 252, 86, 0, 61, 0, 91, 166, 167, + 47, 0, 0, 0, 0, 0, 0, 0, 0, 88, + 0, 0, 0, 0, 0, 0, 57, 58, 59, 50, + 0, 0, 89, 0, 0, 0, 0, 90, 0, 62, + 85, 0, 0, 83, 0, 52, 87, 0, 0, 63, + 0, 125, 0, 0, 84 +}; +short yypact[] = +{ +-1000, 536, 524, 830,-1000,-1000,-1000,-1000,-1000,-1000, + 519,-1000,-1000,-1000,-1000,-1000,-1000, 210, 496, 19, + 224, 223, 222, 216, 82, 213, 16, 106,-1000,-1000, +-1000,-1000,-1000,1378,-1000,-1000,-1000, 37,-1000,-1000, +-1000,-1000,-1000,-1000,-1000, 496,-1000,-1000,-1000,-1000, +-1000, 392,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, +-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, +-1000,-1000,-1000,-1000,-1000,-1000,1284, 390,1305, 390, + 212,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, +-1000,-1000,-1000,-1000,-1000, 496, 496, 496, 496,-1000, + 496,-1000, 302,-1000,-1000, 496,-1000, -30, 496, 496, + 496, 375,-1000,-1000,-1000, 496, 208,-1000,-1000,-1000, +-1000, 504, 389, 132,-1000,-1000, 379,-1000,-1000,-1000, +-1000, 106, 496, 496, 375,-1000,-1000, 243, 357, 515, +-1000, 356, 995,1140,1140, 353, 513, 496, 336, 496, +-1000,-1000,-1000,-1000,1198,-1000,-1000, 95,1325,-1000, +-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, +-1000,-1000,1198, 191, 207,-1000,-1000,1092,1151,-1000, +-1000,-1000,-1000,1295, 311,-1000,-1000, 302, 302, 496, +-1000,-1000, 136, 284,-1000, 82,-1000, 284,-1000,-1000, +-1000, 496,-1000, 341,-1000, 307, 927, 5, 106, -6, + 496, 82, 28,-1000,-1000,1178,-1000, 496,-1000,-1000, +-1000,-1000,-1000,1140,-1000,1140, 411,-1000,1140,-1000, + 203,-1000, 851, 513,-1000,1140,-1000,-1000,-1000,1140, +1140,-1000, 851,-1000,1140,-1000, 82, 513,-1000, 309, + 202,-1000,1325,-1000,-1000,-1000, 957,-1000,1325,1325, +1325,1325,1325, -22, 256, 122, 342,-1000,-1000, 342, + 342,-1000,1151, 205, 186, 175, 851,-1000,1151,-1000, +-1000,-1000,-1000,-1000, 95,-1000,-1000, 321,-1000,-1000, + 302,-1000,-1000, 198,-1000,-1000,-1000, 37,-1000, -3, +1315, 496,-1000, 197,-1000, 47,-1000,-1000, 341, 498, +-1000, 496,-1000,-1000, 193,-1000, 242, 28,-1000,-1000, +-1000, 163,1140, 851,1054,-1000, 851, 273, 96, 159, + 851, 496, 825,-1000,1043,1140,1140,1140,1140,1140, +1140,1140,1140,1140,1140,-1000,-1000,-1000,-1000,-1000, +-1000,-1000, 715, 157, -41, 102, 691, 289, 177,-1000, +-1000,-1000,1198, 161, 851,-1000,-1000, 45, -22, -22, + -22, 142,-1000, 342, 122, 151, 122,-1000,1151,1151, +1151, 654, 121, 114, 94,-1000,-1000,-1000, 173,-1000, + 138,-1000, 284,-1000, 57,-1000, 90,1006,-1000,1315, +-1000,-1000, 39,1102,-1000,-1000,-1000,1140,-1000,-1000, + 496,-1000, 341, 93, 84,-1000, 61,-1000, 83,-1000, +-1000, 496,1140,-1000, 283,1140, 612,-1000, 272, 277, +1140,1140,-1000, 513,-1000, -18, -41, -41, -41, 338, + -35, -35, 541, 102, 52,-1000,1140,-1000, 513, 513, + 82,-1000, 95,-1000,-1000, 342,-1000,-1000,-1000,-1000, +-1000,-1000,-1000,1151,1151,1151,-1000, 503, 502, 37, +-1000,-1000,1006,-1000,-1000, 21,-1000,-1000,1315,-1000, +-1000,-1000,-1000, 341,-1000, 498, 498, 496,-1000, 851, +1140, 75, 851, 432,-1000,-1000,1140, 271, 851, 71, + 269, 76,-1000,1140, 270, 236, 269, 252, 251, 250, +-1000,-1000,-1000,-1000,1006,-1000,-1000, 17, 247,-1000, +-1000,-1000, -2,1140,-1000,-1000,-1000, 513,-1000,-1000, + 851,-1000,-1000,-1000,-1000,-1000, 851,-1000,-1000,-1000, + 851, 66, 513,-1000 +}; +short yypgo[] = +{ + 0, 654, 653, 1, 652, 167, 9, 30, 648, 647, + 646, 4, 0, 645, 644, 643, 39, 642, 3, 26, + 641, 634, 621, 18, 14, 620, 35, 618, 617, 29, + 41, 33, 20, 362, 22, 616, 34, 352, 66, 270, + 16, 57, 378, 2, 24, 25, 11, 207, 114, 610, + 609, 38, 28, 43, 608, 606, 604, 603, 602,1205, + 134, 601, 600, 7, 599, 598, 597, 596, 594, 592, + 591, 31, 589, 19, 585, 21, 37, 6, 584, 5, + 42, 583, 36, 582, 579, 12, 27, 10, 578, 577, + 8, 13, 32, 576, 574, 572, 15, 569, 516, 568, + 567, 566, 565, 564, 562, 561, 560, 454, 559, 558, + 553, 551, 545, 540, 23, 535, 530, 17 +}; +short yyr1[] = +{ + 0, 1, 1, 55, 55, 55, 55, 55, 55, 55, + 2, 56, 56, 56, 56, 56, 56, 56, 60, 52, + 33, 53, 53, 61, 61, 62, 62, 63, 63, 26, + 26, 26, 27, 27, 34, 34, 17, 57, 57, 57, + 57, 57, 57, 57, 57, 57, 57, 57, 57, 10, + 10, 10, 74, 7, 8, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 16, 16, 16, + 50, 50, 50, 50, 51, 51, 64, 64, 65, 65, + 66, 66, 80, 54, 54, 67, 67, 81, 82, 76, + 83, 84, 77, 77, 85, 85, 45, 45, 45, 70, + 70, 86, 86, 72, 72, 87, 36, 18, 18, 19, + 19, 75, 75, 89, 88, 88, 90, 90, 43, 43, + 91, 91, 3, 68, 68, 92, 92, 95, 93, 94, + 94, 96, 96, 11, 69, 69, 97, 20, 20, 71, + 21, 21, 22, 22, 38, 38, 38, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 12, 12, 13, 13, 13, 13, 13, 13, 37, + 37, 37, 37, 32, 40, 40, 44, 44, 48, 48, + 48, 48, 48, 48, 48, 47, 49, 49, 49, 41, + 41, 42, 42, 42, 42, 42, 42, 42, 42, 58, + 58, 58, 58, 58, 58, 100, 58, 58, 58, 99, + 23, 24, 101, 24, 98, 98, 98, 98, 98, 98, + 98, 98, 98, 98, 98, 4, 102, 103, 103, 103, + 103, 73, 73, 35, 25, 25, 46, 46, 14, 14, + 28, 28, 59, 78, 79, 104, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 106, 113, 113, 113, 108, 115, 115, 115, 110, + 110, 107, 107, 116, 116, 117, 117, 117, 117, 117, + 117, 15, 109, 111, 112, 112, 29, 29, 6, 6, + 30, 30, 30, 31, 31, 31, 31, 31, 31, 5, + 5, 5, 5, 5, 114 +}; +short yyr2[] = +{ + 0, 0, 3, 2, 2, 2, 3, 3, 2, 1, + 1, 3, 4, 3, 4, 4, 5, 3, 0, 1, + 1, 0, 1, 2, 3, 1, 3, 1, 3, 0, + 2, 3, 1, 3, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 2, 1, 5, 7, + 5, 5, 0, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 0, 4, 6, + 3, 4, 5, 3, 1, 3, 3, 3, 3, 3, + 3, 3, 3, 1, 3, 3, 3, 0, 6, 0, + 0, 0, 2, 3, 1, 3, 1, 2, 1, 1, + 3, 1, 1, 1, 3, 3, 2, 1, 5, 1, + 3, 0, 3, 0, 2, 3, 1, 3, 1, 1, + 1, 3, 1, 3, 3, 4, 1, 0, 2, 1, + 3, 1, 3, 1, 1, 2, 4, 1, 3, 0, + 0, 1, 1, 3, 1, 3, 1, 1, 1, 3, + 3, 3, 3, 2, 3, 3, 3, 3, 3, 2, + 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 2, 4, 5, 5, 0, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 5, 1, 1, 1, 1, + 3, 1, 1, 3, 3, 3, 3, 2, 3, 1, + 5, 4, 1, 2, 2, 0, 7, 2, 2, 5, + 3, 1, 0, 5, 4, 5, 2, 1, 1, 10, + 1, 3, 4, 3, 3, 1, 1, 3, 3, 7, + 7, 0, 1, 3, 1, 3, 1, 2, 1, 1, + 1, 3, 0, 0, 0, 1, 2, 2, 2, 2, + 2, 2, 2, 3, 4, 4, 2, 3, 4, 1, + 3, 3, 1, 1, 1, 3, 1, 1, 1, 1, + 1, 3, 3, 1, 3, 1, 1, 1, 2, 2, + 2, 1, 3, 3, 4, 4, 1, 3, 1, 5, + 1, 1, 1, 3, 3, 3, 3, 3, 3, 1, + 3, 5, 5, 5, 0 +}; +short yychk[] = +{ +-1000, -1, -55, -2, 2, 6, 4, -56, -57, -58, + 21, 40, 7, 63, 26, 72, 47, -7, 43, -10, + -50, -64, -65, -66, -67, -68, -69, 69, 46, 60, + -98, 36, 100, -99, 39, 38, 42, -8, 30, 45, + 56, 44, 33, 53, 58,-102, 23, 32,-103,-104, + 51, -35, 67, -14, 52, -9, 22, 48, 49, 50, +-105, 27, 61, 71, 55, 66, 31, 37, 34, 57, + 28, 75, 35, 24, 70, 103,-106,-108,-109,-111, +-112,-113,-115, 65, 76, 62, 25, 68, 41, 54, + 59, 29, -17, 8, -59, -60, -60, -60, -60, 47, + -73, 81, -52, -33, 17, 81, 102, -73, 81, 81, + 81, 81, -73, 81, -97, 86, -70, -86, -33, -51, + 88, 86, -71, -59, -98, 73, -59, -59, -59, -16, + 85, -71, -71, -71, -71, -81, -71, -37, -33, -59, + -59, -59, 77, -59, -59, -59, -59, -59, -59, -59, +-107, -42, 85, 87, 77, -37, -48, -41, -12, 15, + 16, 8, 9, 10, 11, -49, 83, 84, 14, 13, + 12,-107, 77,-107,-110, -42, 85,-107, 81, -59, + -59, -59, -59, -59, -53, -52, -53, -52, -52, -60, + -33, -26, 77, -33, -76, -51, -36, -33, -33, -33, + -80, 77, -82, -76, -92, -93, -95, -33, 81, 17, + 77, -3, -73, 9, 77, -78, -36, -51, -33, -33, + -80, -82, -92, 79, -32, 77, -4, 9, 77, 78, + -25, -46, -38, 85, -39, 77, -47, -37, -48, -12, + 93, -40, -38, -40, 77, -3, -33, 77, -33, -41, +-116, -42, 77,-117, 85, 87, -15, 18, -12, 85, + 86, 87, 88, -41, -41, -29, 81, -6, -37, 77, + 81, -30, 81, -39, -5, -31, -38, -47, 77, -30, +-114,-114,-114,-114, -41, 85, -61, 77, -26, -26, + -52, -71, 78, -27, -34, -33, 85, -75, 77, -77, + -84, -73, -75, -54, -37, -19, -18, -37, 77, 77, + -7, 86, -86, 86, -72, -87, -33, -73, -24, -23, + 101, -33,-100, -38, 77, -36, -38, -21, -40, -22, + -38, 74, -38, 78, 81, -12, 85, 86, 87, -13, + 92, 91, 90, 89, 88, 94, 96, 95, 98, 97, + 99, -3, -38, -39, -38, -38, -38, -73, -91, -3, + 78, 78, 81, -41, -38, 85, 87, -41, -41, -41, + -41, -41, 78, 81, -29, -29, -29, -30, 81, 81, + 81, -38, -39, -5, -31,-114,-114, 78, -62, -63, + 17, -26, -74, 78, 81, -16, -88, -89, 102, 81, + -85, -45, -44, -12, -47, -33, -48, 77, -36, 78, + 81, 86, 81, -19, -94, -96, -11, 17, -20, -33, + 78, 81, 79, -24,-101, 79, -38, -79, 85, 78, + 80, 81, -33, 78, -46, -38, -38, -38, -38, -38, + -38, -38, -38, -38, -38, 78, 81, 78, 77, 81, + 78,-117, -41, 78, -6, 81, -39, -5, -39, -5, + -39, -5, 78, 81, 81, 81, 78, 81, 79, -75, + -34, 78, 81, -90, -43, -38, 85, -85, 85, -44, + -37, -83, -18, 81, 78, 81, 84, 81, -87, -38, + 77, -28, -38, 78, 78, -32, 77, -40, -38, -3, + -39, -91, -3, -73, -23, -33, -39, -23, -23, -23, + -63, 17, -16, -90, 80, -45, -44, -77, -23, -96, + -11, -33, -38, 81, 73, -79, 78, 81, 78, 78, + -38, 78, 78, 78, 78, -43, -38, 86, 78, 78, + -38, -3, 81, -3 +}; +short yydef[] = +{ + 1, -2, 0, 0, 9, 10, 2, 3, 4, 5, + 0, 242, 8, 18, 18, 18, 18, 231, 0, 37, + -2, 39, 40, 41, -2, 43, 44, 45, 47, 139, + 199, 242, 202, 0, 242, 242, 242, 67, 139, 139, + 139, 139, 87, 139, 134, 0, 242, 242, 217, 218, + 242, 220, 242, 242, 242, 54, 226, 242, 242, 242, + 245, 242, 238, 239, 55, 56, 57, 58, 59, 60, + 61, 62, 63, 64, 65, 66, 0, 0, 0, 0, + 259, 242, 242, 242, 242, 242, 262, 263, 264, 266, + 267, 268, 6, 36, 7, 21, 21, 0, 0, 18, + 0, 232, 29, 19, 20, 0, 89, 0, 232, 0, + 0, 0, 89, 127, 135, 0, 46, 99, 101, 102, + 74, 0, 0, 231, 203, 204, 0, 207, 208, 53, + 243, 0, 0, 0, 0, 89, 127, 0, 169, 0, + 216, 0, 0, 174, 174, 0, 0, 0, 0, 0, + 246, -2, 248, 249, 0, 191, 192, 0, 0, 178, + 179, 180, 181, 182, 183, 184, 161, 162, 186, 187, + 188, 250, 0, 251, 252, -2, 270, 256, 0, 304, + 304, 304, 304, 0, 11, 22, 13, 29, 29, 0, + 139, 17, 0, 111, 91, 231, 73, 111, 77, 79, + 81, 0, 86, 0, 124, 126, 0, 0, 0, 0, + 0, 231, 0, 122, 205, 0, 70, 0, 76, 78, + 80, 85, 123, 0, 170, -2, 0, 225, 0, 221, + 0, 234, 236, 0, 144, 0, 146, 147, 148, 0, + 0, 223, 175, 224, 0, 227, -2, 0, 233, 275, + 0, 189, 0, 273, 276, 277, 0, 281, 0, 0, + 0, 0, 0, 197, 275, 253, 0, 286, 288, 0, + 0, 257, 0, -2, 291, 292, 0, -2, 0, 260, + 261, 265, 282, 283, 304, 304, 12, 0, 14, 15, + 29, 52, 30, 0, 32, 34, 35, 67, 113, 0, + 0, 0, 106, 0, 83, 0, 109, 107, 0, 0, + 128, 0, 100, 75, 0, 103, 0, 0, 201, 211, + 212, 0, 0, 244, 0, 71, 214, 0, 0, 141, + -2, 0, 0, 222, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 163, 164, 165, 166, 167, + 168, 237, 0, 144, 153, 159, 0, 0, 0, 120, + -2, 272, 0, 0, 278, 279, 280, 193, 194, 195, + 196, 198, 271, 0, 255, 0, 254, 258, 0, 0, + 0, 0, 144, 0, 0, 284, 285, 23, 0, 25, + 27, 16, 111, 31, 0, 50, 0, 0, 51, 0, + 92, 94, 96, 0, 98, 176, 177, 0, 72, 82, + 0, 90, 0, 0, 0, 129, 131, 133, 136, 137, + 48, 0, 0, 200, 0, 0, 0, 68, 0, 171, + 174, 0, 215, 0, 235, 149, 150, 151, 152, -2, + 155, 156, 157, 158, 160, 145, 0, 209, 0, 0, + 231, 274, 275, 190, 287, 0, -2, 294, -2, 296, + -2, 298, -2, 0, 0, 0, 24, 0, 0, 67, + 33, 112, 0, 114, 116, 119, 118, 93, 0, 97, + 84, 91, 110, 0, 125, 0, 0, 0, 104, 105, + 0, 210, 240, 0, 244, 172, 174, 0, 143, 0, + 144, 0, 121, 0, 0, 169, -2, 0, 0, 0, + 26, 28, 49, 115, 0, 95, 96, 0, 0, 130, + 132, 138, 0, 0, 206, 69, 173, 0, 185, 229, + 230, 289, 301, 302, 303, 117, 119, 88, 108, 213, + 241, 0, 0, 219 +}; +short yytok1[] = +{ + 1, 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, 42, + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, + 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, + 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, + 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, + 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, + 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, + 103 +}; +short yytok2[] = +{ + 2, 3 +}; +long yytok3[] = +{ + 0 +}; +#define YYFLAG -1000 +#define YYERROR goto yyerrlab +#define YYACCEPT return(0) +#define YYABORT return(1) +#define yyclearin yychar = -1 +#define yyerrok yyerrflag = 0 + +#ifdef yydebug +#include "y.debug" +#else +#define yydebug 0 +char* yytoknames[1]; /* for debugging */ +char* yystates[1]; /* for debugging */ +#endif + +/* parser for yacc output */ + +int yynerrs = 0; /* number of errors */ +int yyerrflag = 0; /* error recovery flag */ + +extern int fprint(int, char*, ...); +extern int sprint(char*, char*, ...); + +char* +yytokname(int yyc) +{ + static char x[10]; + + if(yyc > 0 && yyc <= sizeof(yytoknames)/sizeof(yytoknames[0])) + if(yytoknames[yyc-1]) + return yytoknames[yyc-1]; + sprintf(x, "<%d>", yyc); + return x; +} + +char* +yystatname(int yys) +{ + static char x[10]; + + if(yys >= 0 && yys < sizeof(yystates)/sizeof(yystates[0])) + if(yystates[yys]) + return yystates[yys]; + sprintf(x, "<%d>\n", yys); + return x; +} + +long +yylex1(void) +{ + long yychar; + long *t3p; + int c; + + yychar = yylex(); + if(yychar <= 0) { + c = yytok1[0]; + goto out; + } + if(yychar < sizeof(yytok1)/sizeof(yytok1[0])) { + c = yytok1[yychar]; + goto out; + } + if(yychar >= YYPRIVATE) + if(yychar < YYPRIVATE+sizeof(yytok2)/sizeof(yytok2[0])) { + c = yytok2[yychar-YYPRIVATE]; + goto out; + } + for(t3p=yytok3;; t3p+=2) { + c = t3p[0]; + if(c == yychar) { + c = t3p[1]; + goto out; + } + if(c == 0) + break; + } + c = 0; + +out: + if(c == 0) + c = yytok2[1]; /* unknown char */ + if(yydebug >= 3) + printf("lex %.4lX %s\n", yychar, yytokname(c)); + return c; +} + +int +yyparse(void) +{ + struct + { + YYSTYPE yyv; + int yys; + } yys[YYMAXDEPTH], *yyp, *yypt; + short *yyxi; + int yyj, yym, yystate, yyn, yyg; + YYSTYPE save1, save2; + int save3, save4; + long yychar; + + save1 = yylval; + save2 = yyval; + save3 = yynerrs; + save4 = yyerrflag; + + yystate = 0; + yychar = -1; + yynerrs = 0; + yyerrflag = 0; + yyp = &yys[-1]; + goto yystack; + +ret0: + yyn = 0; + goto ret; + +ret1: + yyn = 1; + goto ret; + +ret: + yylval = save1; + yyval = save2; + yynerrs = save3; + yyerrflag = save4; + return yyn; + +yystack: + /* put a state and value onto the stack */ + if(yydebug >= 4) + printf("char %s in %s", yytokname(yychar), yystatname(yystate)); + + yyp++; + if(yyp >= &yys[YYMAXDEPTH]) { + yyerror("yacc stack overflow"); + goto ret1; + } + yyp->yys = yystate; + yyp->yyv = yyval; + +yynewstate: + yyn = yypact[yystate]; + if(yyn <= YYFLAG) + goto yydefault; /* simple state */ + if(yychar < 0) + yychar = yylex1(); + yyn += yychar; + if(yyn < 0 || yyn >= YYLAST) + goto yydefault; + yyn = yyact[yyn]; + if(yychk[yyn] == yychar) { /* valid shift */ + yychar = -1; + yyval = yylval; + yystate = yyn; + if(yyerrflag > 0) + yyerrflag--; + goto yystack; + } + +yydefault: + /* default state action */ + yyn = yydef[yystate]; + if(yyn == -2) { + if(yychar < 0) + yychar = yylex1(); + + /* look through exception table */ + for(yyxi=yyexca;; yyxi+=2) + if(yyxi[0] == -1 && yyxi[1] == yystate) + break; + for(yyxi += 2;; yyxi += 2) { + yyn = yyxi[0]; + if(yyn < 0 || yyn == yychar) + break; + } + yyn = yyxi[1]; + if(yyn < 0) + goto ret0; + } + if(yyn == 0) { + /* error ... attempt to resume parsing */ + switch(yyerrflag) { + case 0: /* brand new error */ + yyerror("syntax error"); + if(yydebug >= 1) { + printf("%s", yystatname(yystate)); + printf("saw %s\n", yytokname(yychar)); + } +yyerrlab: + yynerrs++; + + case 1: + case 2: /* incompletely recovered error ... try again */ + yyerrflag = 3; + + /* find a state where "error" is a legal shift action */ + while(yyp >= yys) { + yyn = yypact[yyp->yys] + YYERRCODE; + if(yyn >= 0 && yyn < YYLAST) { + yystate = yyact[yyn]; /* simulate a shift of "error" */ + if(yychk[yystate] == YYERRCODE) + goto yystack; + } + + /* the current yyp has no shift onn "error", pop stack */ + if(yydebug >= 2) + printf("error recovery pops state %d, uncovers %d\n", + yyp->yys, (yyp-1)->yys ); + yyp--; + } + /* there is no state on the stack with an error shift ... abort */ + goto ret1; + + case 3: /* no shift yet; clobber input char */ + if(yydebug >= YYEOFCODE) + printf("error recovery discards %s\n", yytokname(yychar)); + if(yychar == YYEOFCODE) + goto ret1; + yychar = -1; + goto yynewstate; /* try again in the same state */ + } + } + + /* reduction by production yyn */ + if(yydebug >= 2) + printf("reduce %d in:\n\t%s", yyn, yystatname(yystate)); + + yypt = yyp; + yyp -= yyr2[yyn]; + yyval = (yyp+1)->yyv; + yym = yyn; + + /* consult goto table to find next state */ + yyn = yyr1[yyn]; + yyg = yypgo[yyn]; + yyj = yyg + yyp->yys + 1; + + if(yyj >= YYLAST || yychk[yystate=yyact[yyj]] != -yyn) + yystate = yyact[yyg]; + switch(yym) { + +case 3: +/* #line 220 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ +/* stat: is the nonterminal for Fortran statements */ + + lastwasbranch = NO; } break; +case 5: +/* #line 226 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ /* forbid further statement function definitions... */ + if (parstate == INDATA && laststfcn != thisstno) + parstate = INEXEC; + thisstno++; + if(yypt[-1].yyv.labval && (yypt[-1].yyv.labval->labelno==dorange)) + enddo(yypt[-1].yyv.labval->labelno); + if(lastwasbranch && thislabel==NULL) + warn("statement cannot be reached"); + lastwasbranch = thiswasbranch; + thiswasbranch = NO; + if(yypt[-1].yyv.labval) + { + if(yypt[-1].yyv.labval->labtype == LABFORMAT) + err("label already that of a format"); + else + yypt[-1].yyv.labval->labtype = LABEXEC; + } + freetemps(); + } break; +case 6: +/* #line 246 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if (can_include) + doinclude( yypt[-0].yyv.charpval ); + else { + fprintf(diagfile, "Cannot open file %s\n", yypt[-0].yyv.charpval); + done(1); + } + } break; +case 7: +/* #line 254 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if (yypt[-2].yyv.labval) + lastwasbranch = NO; + endcheck(); + endproc(); /* lastwasbranch = NO; -- set in endproc() */ + } break; +case 8: +/* #line 260 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ unclassifiable(); + +/* flline flushes the current line, ignoring the rest of the text there */ + + flline(); } break; +case 9: +/* #line 266 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ flline(); needkwd = NO; inioctl = NO; + yyerrok; yyclearin; } break; +case 10: +/* #line 271 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + if(yystno != 0) + { + yyval.labval = thislabel = mklabel(yystno); + if( ! headerdone ) { + if (procclass == CLUNKNOWN) + procclass = CLMAIN; + puthead(CNULL, procclass); + } + if(thislabel->labdefined) + execerr("label %s already defined", + convic(thislabel->stateno) ); + else { + if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=LABFORMAT) + warn1("there is a branch to label %s from outside block", + convic( (ftnint) (thislabel->stateno) ) ); + thislabel->blklevel = blklevel; + thislabel->labdefined = YES; + if(thislabel->labtype != LABFORMAT) + p1_label((long)(thislabel - labeltab)); + } + } + else yyval.labval = thislabel = NULL; + } break; +case 11: +/* #line 299 "/n/bopp/v5/dmg/f2c/gram.in" */ +{startproc(yypt[-0].yyv.extval, CLMAIN); } break; +case 12: +/* #line 301 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ warn("ignoring arguments to main program"); + /* hashclear(); */ + startproc(yypt[-1].yyv.extval, CLMAIN); } break; +case 13: +/* #line 305 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(yypt[-0].yyv.extval) NO66("named BLOCKDATA"); + startproc(yypt[-0].yyv.extval, CLBLOCK); } break; +case 14: +/* #line 308 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ entrypt(CLPROC, TYSUBR, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break; +case 15: +/* #line 310 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break; +case 16: +/* #line 312 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ entrypt(CLPROC, yypt[-4].yyv.ival, varleng, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break; +case 17: +/* #line 314 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(parstate==OUTSIDE || procclass==CLMAIN + || procclass==CLBLOCK) + execerr("misplaced entry statement", CNULL); + entrypt(CLENTRY, 0, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval); + } break; +case 18: +/* #line 322 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ newproc(); } break; +case 19: +/* #line 326 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.extval = newentry(yypt[-0].yyv.namval, 1); } break; +case 20: +/* #line 330 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.namval = mkname(token); } break; +case 21: +/* #line 333 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.extval = NULL; } break; +case 29: +/* #line 351 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = 0; } break; +case 30: +/* #line 353 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66(" () argument list"); + yyval.chval = 0; } break; +case 31: +/* #line 356 "/n/bopp/v5/dmg/f2c/gram.in" */ +{yyval.chval = yypt[-1].yyv.chval; } break; +case 32: +/* #line 360 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = (yypt[-0].yyv.namval ? mkchain((char *)yypt[-0].yyv.namval,CHNULL) : CHNULL ); } break; +case 33: +/* #line 362 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(yypt[-0].yyv.namval) yypt[-2].yyv.chval = yyval.chval = mkchain((char *)yypt[-0].yyv.namval, yypt[-2].yyv.chval); } break; +case 34: +/* #line 366 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(yypt[-0].yyv.namval->vstg!=STGUNKNOWN && yypt[-0].yyv.namval->vstg!=STGARG) + dclerr("name declared as argument after use", yypt[-0].yyv.namval); + yypt[-0].yyv.namval->vstg = STGARG; + } break; +case 35: +/* #line 371 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("altenate return argument"); + +/* substars means that '*'ed formal parameters should be replaced. + This is used to specify alternate return labels; in theory, only + parameter slots which have '*' should accept the statement labels. + This compiler chooses to ignore the '*'s in the formal declaration, and + always return the proper value anyway. + + This variable is only referred to in proc.c */ + + yyval.namval = 0; substars = YES; } break; +case 36: +/* #line 387 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + char *s; + s = copyn(toklen+1, token); + s[toklen] = '\0'; + yyval.charpval = s; + } break; +case 45: +/* #line 403 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("SAVE statement"); + saveall = YES; } break; +case 46: +/* #line 406 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("SAVE statement"); } break; +case 47: +/* #line 408 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ fmtstmt(thislabel); setfmt(thislabel); } break; +case 48: +/* #line 410 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("PARAMETER statement"); } break; +case 49: +/* #line 414 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ settype(yypt[-4].yyv.namval, yypt[-6].yyv.ival, yypt[-0].yyv.lval); + if(ndim>0) setbound(yypt[-4].yyv.namval,ndim,dims); + } break; +case 50: +/* #line 418 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ settype(yypt[-2].yyv.namval, yypt[-4].yyv.ival, yypt[-0].yyv.lval); + if(ndim>0) setbound(yypt[-2].yyv.namval,ndim,dims); + } break; +case 51: +/* #line 422 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if (new_dcl == 2) { + err("attempt to give DATA in type-declaration"); + new_dcl = 1; + } + } break; +case 52: +/* #line 429 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ new_dcl = 2; } break; +case 53: +/* #line 432 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ varleng = yypt[-0].yyv.lval; } break; +case 54: +/* #line 436 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ varleng = (yypt[-0].yyv.ival<0 || ONEOF(yypt[-0].yyv.ival,M(TYLOGICAL)|M(TYLONG)) + ? 0 : typesize[yypt[-0].yyv.ival]); + vartype = yypt[-0].yyv.ival; } break; +case 55: +/* #line 441 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = TYLONG; } break; +case 56: +/* #line 442 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = tyreal; } break; +case 57: +/* #line 443 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ++complex_seen; yyval.ival = tycomplex; } break; +case 58: +/* #line 444 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = TYDREAL; } break; +case 59: +/* #line 445 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); yyval.ival = TYDCOMPLEX; } break; +case 60: +/* #line 446 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = TYLOGICAL; } break; +case 61: +/* #line 447 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("CHARACTER statement"); yyval.ival = TYCHAR; } break; +case 62: +/* #line 448 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = TYUNKNOWN; } break; +case 63: +/* #line 449 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = TYUNKNOWN; } break; +case 64: +/* #line 450 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NOEXT("AUTOMATIC statement"); yyval.ival = - STGAUTO; } break; +case 65: +/* #line 451 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NOEXT("STATIC statement"); yyval.ival = - STGBSS; } break; +case 66: +/* #line 452 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = TYINT1; } break; +case 67: +/* #line 456 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.lval = varleng; } break; +case 68: +/* #line 458 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + expptr p; + p = yypt[-1].yyv.expval; + NO66("length specification *n"); + if( ! ISICON(p) || p->constblock.Const.ci <= 0 ) + { + yyval.lval = 0; + dclerr("length must be a positive integer constant", + NPNULL); + } + else { + if (vartype == TYCHAR) + yyval.lval = p->constblock.Const.ci; + else switch((int)p->constblock.Const.ci) { + case 1: yyval.lval = 1; break; + case 2: yyval.lval = typesize[TYSHORT]; break; + case 4: yyval.lval = typesize[TYLONG]; break; + case 8: yyval.lval = typesize[TYDREAL]; break; + case 16: yyval.lval = typesize[TYDCOMPLEX]; break; + default: + dclerr("invalid length",NPNULL); + yyval.lval = varleng; + } + } + } break; +case 69: +/* #line 484 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("length specification *(*)"); yyval.lval = -1; } break; +case 70: +/* #line 488 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ incomm( yyval.extval = comblock("") , yypt[-0].yyv.namval ); } break; +case 71: +/* #line 490 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.extval = yypt[-1].yyv.extval; incomm(yypt[-1].yyv.extval, yypt[-0].yyv.namval); } break; +case 72: +/* #line 492 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.extval = yypt[-2].yyv.extval; incomm(yypt[-2].yyv.extval, yypt[-0].yyv.namval); } break; +case 73: +/* #line 494 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ incomm(yypt[-2].yyv.extval, yypt[-0].yyv.namval); } break; +case 74: +/* #line 498 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.extval = comblock(""); } break; +case 75: +/* #line 500 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.extval = comblock(token); } break; +case 76: +/* #line 504 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ setext(yypt[-0].yyv.namval); } break; +case 77: +/* #line 506 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ setext(yypt[-0].yyv.namval); } break; +case 78: +/* #line 510 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("INTRINSIC statement"); setintr(yypt[-0].yyv.namval); } break; +case 79: +/* #line 512 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ setintr(yypt[-0].yyv.namval); } break; +case 82: +/* #line 520 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + struct Equivblock *p; + if(nequiv >= maxequiv) + many("equivalences", 'q', maxequiv); + p = & eqvclass[nequiv++]; + p->eqvinit = NO; + p->eqvbottom = 0; + p->eqvtop = 0; + p->equivs = yypt[-1].yyv.eqvval; + } break; +case 83: +/* #line 533 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.eqvval=ALLOC(Eqvchain); + yyval.eqvval->eqvitem.eqvlhs = primchk(yypt[-0].yyv.expval); + } break; +case 84: +/* #line 537 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.eqvval=ALLOC(Eqvchain); + yyval.eqvval->eqvitem.eqvlhs = primchk(yypt[-0].yyv.expval); + yyval.eqvval->eqvnextp = yypt[-2].yyv.eqvval; + } break; +case 87: +/* #line 548 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(parstate == OUTSIDE) + { + newproc(); + startproc(ESNULL, CLMAIN); + } + if(parstate < INDATA) + { + enddcl(); + parstate = INDATA; + datagripe = 1; + } + } break; +case 88: +/* #line 563 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ftnint junk; + if(nextdata(&junk) != NULL) + err("too few initializers"); + frdata(yypt[-4].yyv.chval); + frrpl(); + } break; +case 89: +/* #line 571 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ frchain(&datastack); curdtp = 0; } break; +case 90: +/* #line 573 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ pop_datastack(); } break; +case 91: +/* #line 575 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ toomanyinit = NO; } break; +case 94: +/* #line 580 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ dataval(ENULL, yypt[-0].yyv.expval); } break; +case 95: +/* #line 582 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ dataval(yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 97: +/* #line 587 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if( yypt[-1].yyv.ival==OPMINUS && ISCONST(yypt[-0].yyv.expval) ) + consnegop((Constp)yypt[-0].yyv.expval); + yyval.expval = yypt[-0].yyv.expval; + } break; +case 101: +/* #line 599 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ int k; + yypt[-0].yyv.namval->vsave = YES; + k = yypt[-0].yyv.namval->vstg; + if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) + dclerr("can only save static variables", yypt[-0].yyv.namval); + } break; +case 105: +/* #line 613 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(yypt[-2].yyv.namval->vclass == CLUNKNOWN) + make_param((struct Paramblock *)yypt[-2].yyv.namval, yypt[-0].yyv.expval); + else dclerr("cannot make into parameter", yypt[-2].yyv.namval); + } break; +case 106: +/* #line 620 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(ndim>0) setbound(yypt[-1].yyv.namval, ndim, dims); } break; +case 107: +/* #line 624 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ Namep np; + struct Primblock *pp = (struct Primblock *)yypt[-0].yyv.expval; + int tt = yypt[-0].yyv.expval->tag; + if (tt != TPRIM) { + if (tt == TCONST) + err("parameter in data statement"); + else + erri("tag %d in data statement",tt); + yyval.chval = 0; + err_lineno = lineno; + break; + } + np = pp -> namep; + vardcl(np); + if ((pp->fcharp || pp->lcharp) + && (np->vtype != TYCHAR || np->vdim && !pp->argsp)) + sserr(np); + if(np->vstg == STGCOMMON) + extsymtab[np->vardesc.varno].extinit = YES; + else if(np->vstg==STGEQUIV) + eqvclass[np->vardesc.varno].eqvinit = YES; + else if(np->vstg!=STGINIT && np->vstg!=STGBSS) { + errstr(np->vstg == STGARG + ? "Dummy argument \"%.60s\" in data statement." + : "Cannot give data to \"%.75s\"", + np->fvarname); + yyval.chval = 0; + err_lineno = lineno; + break; + } + yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); + } break; +case 108: +/* #line 657 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ chainp p; struct Impldoblock *q; + pop_datastack(); + q = ALLOC(Impldoblock); + q->tag = TIMPLDO; + (q->varnp = (Namep) (yypt[-1].yyv.chval->datap))->vimpldovar = 1; + p = yypt[-1].yyv.chval->nextp; + if(p) { q->implb = (expptr)(p->datap); p = p->nextp; } + if(p) { q->impub = (expptr)(p->datap); p = p->nextp; } + if(p) { q->impstep = (expptr)(p->datap); } + frchain( & (yypt[-1].yyv.chval) ); + yyval.chval = mkchain((char *)q, CHNULL); + q->datalist = hookup(yypt[-3].yyv.chval, yyval.chval); + } break; +case 109: +/* #line 673 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if (!datastack) + curdtp = 0; + datastack = mkchain((char *)curdtp, datastack); + curdtp = yypt[-0].yyv.chval; curdtelt = 0; + } break; +case 110: +/* #line 679 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = hookup(yypt[-2].yyv.chval, yypt[-0].yyv.chval); } break; +case 111: +/* #line 683 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ndim = 0; } break; +case 113: +/* #line 687 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ndim = 0; } break; +case 116: +/* #line 692 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = 0; + dims[ndim].ub = yypt[-0].yyv.expval; + } + ++ndim; + } break; +case 117: +/* #line 702 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = yypt[-2].yyv.expval; + dims[ndim].ub = yypt[-0].yyv.expval; + } + ++ndim; + } break; +case 118: +/* #line 714 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = 0; } break; +case 120: +/* #line 719 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ nstars = 1; labarray[0] = yypt[-0].yyv.labval; } break; +case 121: +/* #line 721 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(nstars < maxlablist) labarray[nstars++] = yypt[-0].yyv.labval; } break; +case 122: +/* #line 725 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.labval = execlab( convci(toklen, token) ); } break; +case 123: +/* #line 729 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("IMPLICIT statement"); } break; +case 126: +/* #line 735 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if (vartype != TYUNKNOWN) + dclerr("-- expected letter range",NPNULL); + setimpl(vartype, varleng, 'a', 'z'); } break; +case 127: +/* #line 740 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ needkwd = 1; } break; +case 131: +/* #line 749 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ setimpl(vartype, varleng, yypt[-0].yyv.ival, yypt[-0].yyv.ival); } break; +case 132: +/* #line 751 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ setimpl(vartype, varleng, yypt[-2].yyv.ival, yypt[-0].yyv.ival); } break; +case 133: +/* #line 755 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(toklen!=1 || token[0]<'a' || token[0]>'z') + { + dclerr("implicit item must be single letter", NPNULL); + yyval.ival = 0; + } + else yyval.ival = token[0]; + } break; +case 136: +/* #line 769 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + if(yypt[-2].yyv.namval->vclass == CLUNKNOWN) + { + yypt[-2].yyv.namval->vclass = CLNAMELIST; + yypt[-2].yyv.namval->vtype = TYINT; + yypt[-2].yyv.namval->vstg = STGBSS; + yypt[-2].yyv.namval->varxptr.namelist = yypt[-0].yyv.chval; + yypt[-2].yyv.namval->vardesc.varno = ++lastvarno; + } + else dclerr("cannot be a namelist name", yypt[-2].yyv.namval); + } break; +case 137: +/* #line 783 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.namval, CHNULL); } break; +case 138: +/* #line 785 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = hookup(yypt[-2].yyv.chval, mkchain((char *)yypt[-0].yyv.namval, CHNULL)); } break; +case 139: +/* #line 789 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ switch(parstate) + { + case OUTSIDE: newproc(); + startproc(ESNULL, CLMAIN); + case INSIDE: parstate = INDCL; + case INDCL: break; + + case INDATA: + if (datagripe) { + errstr( + "Statement order error: declaration after DATA", + CNULL); + datagripe = 0; + } + break; + + default: + dclerr("declaration among executables", NPNULL); + } + } break; +case 140: +/* #line 811 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = 0; } break; +case 141: +/* #line 813 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = revchain(yypt[-0].yyv.chval); } break; +case 142: +/* #line 817 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break; +case 143: +/* #line 819 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval); } break; +case 145: +/* #line 824 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = yypt[-1].yyv.expval; if (yyval.expval->tag == TPRIM) + paren_used(&yyval.expval->primblock); } break; +case 149: +/* #line 832 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 150: +/* #line 834 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPSTAR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 151: +/* #line 836 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPSLASH, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 152: +/* #line 838 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPPOWER, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 153: +/* #line 840 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(yypt[-1].yyv.ival == OPMINUS) + yyval.expval = mkexpr(OPNEG, yypt[-0].yyv.expval, ENULL); + else { + yyval.expval = yypt[-0].yyv.expval; + if (yyval.expval->tag == TPRIM) + paren_used(&yyval.expval->primblock); + } + } break; +case 154: +/* #line 849 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 155: +/* #line 851 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66(".EQV. operator"); + yyval.expval = mkexpr(OPEQV, yypt[-2].yyv.expval,yypt[-0].yyv.expval); } break; +case 156: +/* #line 854 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66(".NEQV. operator"); + yyval.expval = mkexpr(OPNEQV, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 157: +/* #line 857 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPOR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 158: +/* #line 859 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPAND, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 159: +/* #line 861 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPNOT, yypt[-0].yyv.expval, ENULL); } break; +case 160: +/* #line 863 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("concatenation operator //"); + yyval.expval = mkexpr(OPCONCAT, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 161: +/* #line 867 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPPLUS; } break; +case 162: +/* #line 868 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPMINUS; } break; +case 163: +/* #line 871 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPEQ; } break; +case 164: +/* #line 872 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPGT; } break; +case 165: +/* #line 873 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPLT; } break; +case 166: +/* #line 874 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPGE; } break; +case 167: +/* #line 875 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPLE; } break; +case 168: +/* #line 876 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = OPNE; } break; +case 169: +/* #line 880 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkprim(yypt[-0].yyv.namval, LBNULL, CHNULL); } break; +case 170: +/* #line 882 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("substring operator :"); + yyval.expval = mkprim(yypt[-1].yyv.namval, LBNULL, yypt[-0].yyv.chval); } break; +case 171: +/* #line 885 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkprim(yypt[-3].yyv.namval, mklist(yypt[-1].yyv.chval), CHNULL); } break; +case 172: +/* #line 887 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("substring operator :"); + yyval.expval = mkprim(yypt[-4].yyv.namval, mklist(yypt[-2].yyv.chval), yypt[-0].yyv.chval); } break; +case 173: +/* #line 892 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-3].yyv.expval, mkchain((char *)yypt[-1].yyv.expval,CHNULL)); } break; +case 174: +/* #line 896 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = 0; } break; +case 176: +/* #line 901 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(yypt[-0].yyv.namval->vclass == CLPARAM) + yyval.expval = (expptr) cpexpr( + ( (struct Paramblock *) (yypt[-0].yyv.namval) ) -> paramval); + } break; +case 178: +/* #line 908 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mklogcon(1); } break; +case 179: +/* #line 909 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mklogcon(0); } break; +case 180: +/* #line 910 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkstrcon(toklen, token); } break; +case 181: +/* #line 911 "/n/bopp/v5/dmg/f2c/gram.in" */ + { yyval.expval = mkintqcon(toklen, token); } break; +case 182: +/* #line 912 "/n/bopp/v5/dmg/f2c/gram.in" */ + { yyval.expval = mkrealcon(tyreal, token); } break; +case 183: +/* #line 913 "/n/bopp/v5/dmg/f2c/gram.in" */ + { yyval.expval = mkrealcon(TYDREAL, token); } break; +case 185: +/* #line 918 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkcxcon(yypt[-3].yyv.expval,yypt[-1].yyv.expval); } break; +case 186: +/* #line 922 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NOEXT("hex constant"); + yyval.expval = mkbitcon(4, toklen, token); } break; +case 187: +/* #line 925 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NOEXT("octal constant"); + yyval.expval = mkbitcon(3, toklen, token); } break; +case 188: +/* #line 928 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NOEXT("binary constant"); + yyval.expval = mkbitcon(1, toklen, token); } break; +case 190: +/* #line 934 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = yypt[-1].yyv.expval; } break; +case 193: +/* #line 940 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 194: +/* #line 942 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPSTAR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 195: +/* #line 944 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPSLASH, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 196: +/* #line 946 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.expval = mkexpr(OPPOWER, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 197: +/* #line 948 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(yypt[-1].yyv.ival == OPMINUS) + yyval.expval = mkexpr(OPNEG, yypt[-0].yyv.expval, ENULL); + else yyval.expval = yypt[-0].yyv.expval; + } break; +case 198: +/* #line 953 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ NO66("concatenation operator //"); + yyval.expval = mkexpr(OPCONCAT, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 200: +/* #line 958 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + if(yypt[-2].yyv.labval->labdefined) + execerr("no backward DO loops", CNULL); + yypt[-2].yyv.labval->blklevel = blklevel+1; + exdo(yypt[-2].yyv.labval->labelno, NPNULL, yypt[-0].yyv.chval); + } break; +case 201: +/* #line 965 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + exdo((int)(ctls - ctlstack - 2), NPNULL, yypt[-0].yyv.chval); + NOEXT("DO without label"); + } break; +case 202: +/* #line 970 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exenddo(NPNULL); } break; +case 203: +/* #line 972 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exendif(); thiswasbranch = NO; } break; +case 205: +/* #line 974 "/n/bopp/v5/dmg/f2c/gram.in" */ +{westart(1);} break; +case 206: +/* #line 975 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exelif(yypt[-2].yyv.expval); lastwasbranch = NO; } break; +case 207: +/* #line 977 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exelse(); lastwasbranch = NO; } break; +case 208: +/* #line 979 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exendif(); lastwasbranch = NO; } break; +case 209: +/* #line 983 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exif(yypt[-1].yyv.expval); } break; +case 210: +/* #line 987 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-2].yyv.namval, yypt[-0].yyv.chval); } break; +case 212: +/* #line 991 "/n/bopp/v5/dmg/f2c/gram.in" */ +{westart(0);} break; +case 213: +/* #line 992 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain(CNULL, (chainp)yypt[-1].yyv.expval); } break; +case 214: +/* #line 996 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exequals((struct Primblock *)yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; +case 215: +/* #line 998 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exassign(yypt[-0].yyv.namval, yypt[-2].yyv.labval); } break; +case 218: +/* #line 1002 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ inioctl = NO; } break; +case 219: +/* #line 1004 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exarif(yypt[-6].yyv.expval, yypt[-4].yyv.labval, yypt[-2].yyv.labval, yypt[-0].yyv.labval); thiswasbranch = YES; } break; +case 220: +/* #line 1006 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ excall(yypt[-0].yyv.namval, LBNULL, 0, labarray); } break; +case 221: +/* #line 1008 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ excall(yypt[-2].yyv.namval, LBNULL, 0, labarray); } break; +case 222: +/* #line 1010 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(nstars < maxlablist) + excall(yypt[-3].yyv.namval, mklist(revchain(yypt[-1].yyv.chval)), nstars, labarray); + else + many("alternate returns", 'l', maxlablist); + } break; +case 223: +/* #line 1016 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exreturn(yypt[-0].yyv.expval); thiswasbranch = YES; } break; +case 224: +/* #line 1018 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exstop(yypt[-2].yyv.ival, yypt[-0].yyv.expval); thiswasbranch = yypt[-2].yyv.ival; } break; +case 225: +/* #line 1022 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.labval = mklabel( convci(toklen, token) ); } break; +case 226: +/* #line 1026 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(parstate == OUTSIDE) + { + newproc(); + startproc(ESNULL, CLMAIN); + } + } break; +case 227: +/* #line 1035 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exgoto(yypt[-0].yyv.labval); thiswasbranch = YES; } break; +case 228: +/* #line 1037 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exasgoto(yypt[-0].yyv.namval); thiswasbranch = YES; } break; +case 229: +/* #line 1039 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ exasgoto(yypt[-4].yyv.namval); thiswasbranch = YES; } break; +case 230: +/* #line 1041 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(nstars < maxlablist) + putcmgo(putx(fixtype(yypt[-0].yyv.expval)), nstars, labarray); + else + many("labels in computed GOTO list", 'l', maxlablist); + } break; +case 233: +/* #line 1053 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ nstars = 0; yyval.namval = yypt[-0].yyv.namval; } break; +case 234: +/* #line 1057 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = yypt[-0].yyv.expval ? mkchain((char *)yypt[-0].yyv.expval,CHNULL) : CHNULL; } break; +case 235: +/* #line 1059 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = yypt[-0].yyv.expval ? mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval) : yypt[-2].yyv.chval; } break; +case 237: +/* #line 1064 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(nstars < maxlablist) labarray[nstars++] = yypt[-0].yyv.labval; yyval.expval = 0; } break; +case 238: +/* #line 1068 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = 0; } break; +case 239: +/* #line 1070 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = 2; } break; +case 240: +/* #line 1074 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break; +case 241: +/* #line 1076 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = hookup(yypt[-2].yyv.chval, mkchain((char *)yypt[-0].yyv.expval,CHNULL) ); } break; +case 242: +/* #line 1080 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ if(parstate == OUTSIDE) + { + newproc(); + startproc(ESNULL, CLMAIN); + } + +/* This next statement depends on the ordering of the state table encoding */ + + if(parstate < INDATA) enddcl(); + } break; +case 243: +/* #line 1093 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ intonly = YES; } break; +case 244: +/* #line 1097 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ intonly = NO; } break; +case 245: +/* #line 1102 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ endio(); } break; +case 247: +/* #line 1107 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(IOSUNIT, yypt[-0].yyv.expval); endioctl(); } break; +case 248: +/* #line 1109 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(IOSUNIT, ENULL); endioctl(); } break; +case 249: +/* #line 1111 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(IOSUNIT, IOSTDERR); endioctl(); } break; +case 251: +/* #line 1114 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(CHNULL); } break; +case 252: +/* #line 1116 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(CHNULL); } break; +case 253: +/* #line 1118 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(revchain(yypt[-0].yyv.chval)); } break; +case 254: +/* #line 1120 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(revchain(yypt[-0].yyv.chval)); } break; +case 255: +/* #line 1122 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(revchain(yypt[-0].yyv.chval)); } break; +case 256: +/* #line 1124 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(CHNULL); } break; +case 257: +/* #line 1126 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(revchain(yypt[-0].yyv.chval)); } break; +case 258: +/* #line 1128 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(revchain(yypt[-0].yyv.chval)); } break; +case 259: +/* #line 1130 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(CHNULL); } break; +case 260: +/* #line 1132 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ doio(revchain(yypt[-0].yyv.chval)); } break; +case 262: +/* #line 1139 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOBACKSPACE; } break; +case 263: +/* #line 1141 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOREWIND; } break; +case 264: +/* #line 1143 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOENDFILE; } break; +case 266: +/* #line 1150 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOINQUIRE; } break; +case 267: +/* #line 1152 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOOPEN; } break; +case 268: +/* #line 1154 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOCLOSE; } break; +case 269: +/* #line 1158 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, yypt[-0].yyv.expval); + endioctl(); + } break; +case 270: +/* #line 1164 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, ENULL); + endioctl(); + } break; +case 271: +/* #line 1172 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + ioclause(IOSUNIT, yypt[-1].yyv.expval); + endioctl(); + } break; +case 272: +/* #line 1177 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ endioctl(); } break; +case 275: +/* #line 1185 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(IOSPOSITIONAL, yypt[-0].yyv.expval); } break; +case 276: +/* #line 1187 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(IOSPOSITIONAL, ENULL); } break; +case 277: +/* #line 1189 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(IOSPOSITIONAL, IOSTDERR); } break; +case 278: +/* #line 1191 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(yypt[-1].yyv.ival, yypt[-0].yyv.expval); } break; +case 279: +/* #line 1193 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(yypt[-1].yyv.ival, ENULL); } break; +case 280: +/* #line 1195 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ ioclause(yypt[-1].yyv.ival, IOSTDERR); } break; +case 281: +/* #line 1199 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.ival = iocname(); } break; +case 282: +/* #line 1203 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOREAD; } break; +case 283: +/* #line 1207 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ iostmt = IOWRITE; } break; +case 284: +/* #line 1211 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + iostmt = IOWRITE; + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, yypt[-1].yyv.expval); + endioctl(); + } break; +case 285: +/* #line 1218 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ + iostmt = IOWRITE; + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, ENULL); + endioctl(); + } break; +case 286: +/* #line 1227 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, CHNULL); } break; +case 287: +/* #line 1229 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, yypt[-2].yyv.chval); } break; +case 288: +/* #line 1233 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.tagval = (tagptr) yypt[-0].yyv.expval; } break; +case 289: +/* #line 1235 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval,revchain(yypt[-3].yyv.chval)); } break; +case 290: +/* #line 1239 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break; +case 291: +/* #line 1241 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, CHNULL); } break; +case 293: +/* #line 1246 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, mkchain((char *)yypt[-2].yyv.expval, CHNULL) ); } break; +case 294: +/* #line 1248 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, mkchain((char *)yypt[-2].yyv.expval, CHNULL) ); } break; +case 295: +/* #line 1250 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, mkchain((char *)yypt[-2].yyv.tagval, CHNULL) ); } break; +case 296: +/* #line 1252 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, mkchain((char *)yypt[-2].yyv.tagval, CHNULL) ); } break; +case 297: +/* #line 1254 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval); } break; +case 298: +/* #line 1256 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, yypt[-2].yyv.chval); } break; +case 299: +/* #line 1260 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.tagval = (tagptr) yypt[-0].yyv.expval; } break; +case 300: +/* #line 1262 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.tagval = (tagptr) yypt[-1].yyv.expval; } break; +case 301: +/* #line 1264 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, mkchain((char *)yypt[-3].yyv.expval, CHNULL) ); } break; +case 302: +/* #line 1266 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, mkchain((char *)yypt[-3].yyv.tagval, CHNULL) ); } break; +case 303: +/* #line 1268 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, revchain(yypt[-3].yyv.chval)); } break; +case 304: +/* #line 1272 "/n/bopp/v5/dmg/f2c/gram.in" */ +{ startioctl(); } break; + } + goto yystack; /* stack new state and value */ +} diff --git a/unix/f2c/src/gram.dcl b/unix/f2c/src/gram.dcl new file mode 100644 index 00000000..e5c5df0d --- /dev/null +++ b/unix/f2c/src/gram.dcl @@ -0,0 +1,416 @@ +spec: dcl + | common + | external + | intrinsic + | equivalence + | data + | implicit + | namelist + | SSAVE + { NO66("SAVE statement"); + saveall = YES; } + | SSAVE savelist + { NO66("SAVE statement"); } + | SFORMAT + { fmtstmt(thislabel); setfmt(thislabel); } + | SPARAM in_dcl SLPAR paramlist SRPAR + { NO66("PARAMETER statement"); } + ; + +dcl: type opt_comma name in_dcl new_dcl dims lengspec + { settype($3, $1, $7); + if(ndim>0) setbound($3,ndim,dims); + } + | dcl SCOMMA name dims lengspec + { settype($3, $1, $5); + if(ndim>0) setbound($3,ndim,dims); + } + | dcl SSLASHD datainit vallist SSLASHD + { if (new_dcl == 2) { + err("attempt to give DATA in type-declaration"); + new_dcl = 1; + } + } + ; + +new_dcl: { new_dcl = 2; } ; + +type: typespec lengspec + { varleng = $2; } + ; + +typespec: typename + { varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(TYLONG)) + ? 0 : typesize[$1]); + vartype = $1; } + ; + +typename: SINTEGER { $$ = TYLONG; } + | SREAL { $$ = tyreal; } + | SCOMPLEX { ++complex_seen; $$ = tycomplex; } + | SDOUBLE { $$ = TYDREAL; } + | SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; } + | SLOGICAL { $$ = TYLOGICAL; } + | SCHARACTER { NO66("CHARACTER statement"); $$ = TYCHAR; } + | SUNDEFINED { $$ = TYUNKNOWN; } + | SDIMENSION { $$ = TYUNKNOWN; } + | SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; } + | SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; } + | SBYTE { $$ = TYINT1; } + ; + +lengspec: + { $$ = varleng; } + | SSTAR intonlyon expr intonlyoff + { + expptr p; + p = $3; + NO66("length specification *n"); + if( ! ISICON(p) || p->constblock.Const.ci <= 0 ) + { + $$ = 0; + dclerr("length must be a positive integer constant", + NPNULL); + } + else { + if (vartype == TYCHAR) + $$ = p->constblock.Const.ci; + else switch((int)p->constblock.Const.ci) { + case 1: $$ = 1; break; + case 2: $$ = typesize[TYSHORT]; break; + case 4: $$ = typesize[TYLONG]; break; + case 8: $$ = typesize[TYDREAL]; break; + case 16: $$ = typesize[TYDCOMPLEX]; break; + default: + dclerr("invalid length",NPNULL); + $$ = varleng; + } + } + } + | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff + { NO66("length specification *(*)"); $$ = -1; } + ; + +common: SCOMMON in_dcl var + { incomm( $$ = comblock("") , $3 ); } + | SCOMMON in_dcl comblock var + { $$ = $3; incomm($3, $4); } + | common opt_comma comblock opt_comma var + { $$ = $3; incomm($3, $5); } + | common SCOMMA var + { incomm($1, $3); } + ; + +comblock: SCONCAT + { $$ = comblock(""); } + | SSLASH SNAME SSLASH + { $$ = comblock(token); } + ; + +external: SEXTERNAL in_dcl name + { setext($3); } + | external SCOMMA name + { setext($3); } + ; + +intrinsic: SINTRINSIC in_dcl name + { NO66("INTRINSIC statement"); setintr($3); } + | intrinsic SCOMMA name + { setintr($3); } + ; + +equivalence: SEQUIV in_dcl equivset + | equivalence SCOMMA equivset + ; + +equivset: SLPAR equivlist SRPAR + { + struct Equivblock *p; + if(nequiv >= maxequiv) + many("equivalences", 'q', maxequiv); + p = & eqvclass[nequiv++]; + p->eqvinit = NO; + p->eqvbottom = 0; + p->eqvtop = 0; + p->equivs = $2; + } + ; + +equivlist: lhs + { $$=ALLOC(Eqvchain); + $$->eqvitem.eqvlhs = primchk($1); + } + | equivlist SCOMMA lhs + { $$=ALLOC(Eqvchain); + $$->eqvitem.eqvlhs = primchk($3); + $$->eqvnextp = $1; + } + ; + +data: SDATA in_data datalist + | data opt_comma datalist + ; + +in_data: + { if(parstate == OUTSIDE) + { + newproc(); + startproc(ESNULL, CLMAIN); + } + if(parstate < INDATA) + { + enddcl(); + parstate = INDATA; + datagripe = 1; + } + } + ; + +datalist: datainit datavarlist SSLASH datapop vallist SSLASH + { ftnint junk; + if(nextdata(&junk) != NULL) + err("too few initializers"); + frdata($2); + frrpl(); + } + ; + +datainit: /* nothing */ { frchain(&datastack); curdtp = 0; } ; + +datapop: /* nothing */ { pop_datastack(); } ; + +vallist: { toomanyinit = NO; } val + | vallist SCOMMA val + ; + +val: value + { dataval(ENULL, $1); } + | simple SSTAR value + { dataval($1, $3); } + ; + +value: simple + | addop simple + { if( $1==OPMINUS && ISCONST($2) ) + consnegop((Constp)$2); + $$ = $2; + } + | complex_const + ; + +savelist: saveitem + | savelist SCOMMA saveitem + ; + +saveitem: name + { int k; + $1->vsave = YES; + k = $1->vstg; + if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) + dclerr("can only save static variables", $1); + } + | comblock + ; + +paramlist: paramitem + | paramlist SCOMMA paramitem + ; + +paramitem: name SEQUALS expr + { if($1->vclass == CLUNKNOWN) + make_param((struct Paramblock *)$1, $3); + else dclerr("cannot make into parameter", $1); + } + ; + +var: name dims + { if(ndim>0) setbound($1, ndim, dims); } + ; + +datavar: lhs + { Namep np; + struct Primblock *pp = (struct Primblock *)$1; + int tt = $1->tag; + if (tt != TPRIM) { + if (tt == TCONST) + err("parameter in data statement"); + else + erri("tag %d in data statement",tt); + $$ = 0; + err_lineno = lineno; + break; + } + np = pp -> namep; + vardcl(np); + if ((pp->fcharp || pp->lcharp) + && (np->vtype != TYCHAR || np->vdim && !pp->argsp)) + sserr(np); + if(np->vstg == STGCOMMON) + extsymtab[np->vardesc.varno].extinit = YES; + else if(np->vstg==STGEQUIV) + eqvclass[np->vardesc.varno].eqvinit = YES; + else if(np->vstg!=STGINIT && np->vstg!=STGBSS) { + errstr(np->vstg == STGARG + ? "Dummy argument \"%.60s\" in data statement." + : "Cannot give data to \"%.75s\"", + np->fvarname); + $$ = 0; + err_lineno = lineno; + break; + } + $$ = mkchain((char *)$1, CHNULL); + } + | SLPAR datavarlist SCOMMA dospec SRPAR + { chainp p; struct Impldoblock *q; + pop_datastack(); + q = ALLOC(Impldoblock); + q->tag = TIMPLDO; + (q->varnp = (Namep) ($4->datap))->vimpldovar = 1; + p = $4->nextp; + if(p) { q->implb = (expptr)(p->datap); p = p->nextp; } + if(p) { q->impub = (expptr)(p->datap); p = p->nextp; } + if(p) { q->impstep = (expptr)(p->datap); } + frchain( & ($4) ); + $$ = mkchain((char *)q, CHNULL); + q->datalist = hookup($2, $$); + } + ; + +datavarlist: datavar + { if (!datastack) + curdtp = 0; + datastack = mkchain((char *)curdtp, datastack); + curdtp = $1; curdtelt = 0; + } + | datavarlist SCOMMA datavar + { $$ = hookup($1, $3); } + ; + +dims: + { ndim = 0; } + | SLPAR dimlist SRPAR + ; + +dimlist: { ndim = 0; } dim + | dimlist SCOMMA dim + ; + +dim: ubound + { + if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = 0; + dims[ndim].ub = $1; + } + ++ndim; + } + | expr SCOLON ubound + { + if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = $1; + dims[ndim].ub = $3; + } + ++ndim; + } + ; + +ubound: SSTAR + { $$ = 0; } + | expr + ; + +labellist: label + { nstars = 1; labarray[0] = $1; } + | labellist SCOMMA label + { if(nstars < maxlablist) labarray[nstars++] = $3; } + ; + +label: SICON + { $$ = execlab( convci(toklen, token) ); } + ; + +implicit: SIMPLICIT in_dcl implist + { NO66("IMPLICIT statement"); } + | implicit SCOMMA implist + ; + +implist: imptype SLPAR letgroups SRPAR + | imptype + { if (vartype != TYUNKNOWN) + dclerr("-- expected letter range",NPNULL); + setimpl(vartype, varleng, 'a', 'z'); } + ; + +imptype: { needkwd = 1; } type + /* { vartype = $2; } */ + ; + +letgroups: letgroup + | letgroups SCOMMA letgroup + ; + +letgroup: letter + { setimpl(vartype, varleng, $1, $1); } + | letter SMINUS letter + { setimpl(vartype, varleng, $1, $3); } + ; + +letter: SNAME + { if(toklen!=1 || token[0]<'a' || token[0]>'z') + { + dclerr("implicit item must be single letter", NPNULL); + $$ = 0; + } + else $$ = token[0]; + } + ; + +namelist: SNAMELIST + | namelist namelistentry + ; + +namelistentry: SSLASH name SSLASH namelistlist + { + if($2->vclass == CLUNKNOWN) + { + $2->vclass = CLNAMELIST; + $2->vtype = TYINT; + $2->vstg = STGBSS; + $2->varxptr.namelist = $4; + $2->vardesc.varno = ++lastvarno; + } + else dclerr("cannot be a namelist name", $2); + } + ; + +namelistlist: name + { $$ = mkchain((char *)$1, CHNULL); } + | namelistlist SCOMMA name + { $$ = hookup($1, mkchain((char *)$3, CHNULL)); } + ; + +in_dcl: + { switch(parstate) + { + case OUTSIDE: newproc(); + startproc(ESNULL, CLMAIN); + case INSIDE: parstate = INDCL; + case INDCL: break; + + case INDATA: + if (datagripe) { + errstr( + "Statement order error: declaration after DATA", + CNULL); + datagripe = 0; + } + break; + + default: + dclerr("declaration among executables", NPNULL); + } + } + ; diff --git a/unix/f2c/src/gram.exec b/unix/f2c/src/gram.exec new file mode 100644 index 00000000..98a94f90 --- /dev/null +++ b/unix/f2c/src/gram.exec @@ -0,0 +1,143 @@ +exec: iffable + | SDO end_spec label opt_comma dospecw + { + if($3->labdefined) + execerr("no backward DO loops", CNULL); + $3->blklevel = blklevel+1; + exdo($3->labelno, NPNULL, $5); + } + | SDO end_spec opt_comma dospecw + { + exdo((int)(ctls - ctlstack - 2), NPNULL, $4); + NOEXT("DO without label"); + } + | SENDDO + { exenddo(NPNULL); } + | logif iffable + { exendif(); thiswasbranch = NO; } + | logif STHEN + | SELSEIF end_spec SLPAR {westart(1);} expr SRPAR STHEN + { exelif($5); lastwasbranch = NO; } + | SELSE end_spec + { exelse(); lastwasbranch = NO; } + | SENDIF end_spec + { exendif(); lastwasbranch = NO; } + ; + +logif: SLOGIF end_spec SLPAR expr SRPAR + { exif($4); } + ; + +dospec: name SEQUALS exprlist + { $$ = mkchain((char *)$1, $3); } + ; + +dospecw: dospec + | SWHILE {westart(0);} SLPAR expr SRPAR + { $$ = mkchain(CNULL, (chainp)$4); } + ; + +iffable: let lhs SEQUALS expr + { exequals((struct Primblock *)$2, $4); } + | SASSIGN end_spec assignlabel STO name + { exassign($5, $3); } + | SCONTINUE end_spec + | goto + | io + { inioctl = NO; } + | SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label + { exarif($4, $6, $8, $10); thiswasbranch = YES; } + | call + { excall($1, LBNULL, 0, labarray); } + | call SLPAR SRPAR + { excall($1, LBNULL, 0, labarray); } + | call SLPAR callarglist SRPAR + { if(nstars < maxlablist) + excall($1, mklist(revchain($3)), nstars, labarray); + else + many("alternate returns", 'l', maxlablist); + } + | SRETURN end_spec opt_expr + { exreturn($3); thiswasbranch = YES; } + | stop end_spec opt_expr + { exstop($1, $3); thiswasbranch = $1; } + ; + +assignlabel: SICON + { $$ = mklabel( convci(toklen, token) ); } + ; + +let: SLET + { if(parstate == OUTSIDE) + { + newproc(); + startproc(ESNULL, CLMAIN); + } + } + ; + +goto: SGOTO end_spec label + { exgoto($3); thiswasbranch = YES; } + | SASGOTO end_spec name + { exasgoto($3); thiswasbranch = YES; } + | SASGOTO end_spec name opt_comma SLPAR labellist SRPAR + { exasgoto($3); thiswasbranch = YES; } + | SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr + { if(nstars < maxlablist) + putcmgo(putx(fixtype($7)), nstars, labarray); + else + many("labels in computed GOTO list", 'l', maxlablist); + } + ; + +opt_comma: + | SCOMMA + ; + +call: SCALL end_spec name + { nstars = 0; $$ = $3; } + ; + +callarglist: callarg + { $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; } + | callarglist SCOMMA callarg + { $$ = $3 ? mkchain((char *)$3, $1) : $1; } + ; + +callarg: expr + | SSTAR label + { if(nstars < maxlablist) labarray[nstars++] = $2; $$ = 0; } + ; + +stop: SPAUSE + { $$ = 0; } + | SSTOP + { $$ = 2; } + ; + +exprlist: expr + { $$ = mkchain((char *)$1, CHNULL); } + | exprlist SCOMMA expr + { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); } + ; + +end_spec: + { if(parstate == OUTSIDE) + { + newproc(); + startproc(ESNULL, CLMAIN); + } + +/* This next statement depends on the ordering of the state table encoding */ + + if(parstate < INDATA) enddcl(); + } + ; + +intonlyon: + { intonly = YES; } + ; + +intonlyoff: + { intonly = NO; } + ; diff --git a/unix/f2c/src/gram.expr b/unix/f2c/src/gram.expr new file mode 100644 index 00000000..b6ce6ff1 --- /dev/null +++ b/unix/f2c/src/gram.expr @@ -0,0 +1,146 @@ +funarglist: + { $$ = 0; } + | funargs + { $$ = revchain($1); } + ; + +funargs: expr + { $$ = mkchain((char *)$1, CHNULL); } + | funargs SCOMMA expr + { $$ = mkchain((char *)$3, $1); } + ; + + +expr: uexpr + | SLPAR expr SRPAR { $$ = $2; if ($$->tag == TPRIM) + paren_used(&$$->primblock); } + | complex_const + ; + +uexpr: lhs + | simple_const + | expr addop expr %prec SPLUS + { $$ = mkexpr($2, $1, $3); } + | expr SSTAR expr + { $$ = mkexpr(OPSTAR, $1, $3); } + | expr SSLASH expr + { $$ = mkexpr(OPSLASH, $1, $3); } + | expr SPOWER expr + { $$ = mkexpr(OPPOWER, $1, $3); } + | addop expr %prec SSTAR + { if($1 == OPMINUS) + $$ = mkexpr(OPNEG, $2, ENULL); + else { + $$ = $2; + if ($$->tag == TPRIM) + paren_used(&$$->primblock); + } + } + | expr relop expr %prec SEQ + { $$ = mkexpr($2, $1, $3); } + | expr SEQV expr + { NO66(".EQV. operator"); + $$ = mkexpr(OPEQV, $1,$3); } + | expr SNEQV expr + { NO66(".NEQV. operator"); + $$ = mkexpr(OPNEQV, $1, $3); } + | expr SOR expr + { $$ = mkexpr(OPOR, $1, $3); } + | expr SAND expr + { $$ = mkexpr(OPAND, $1, $3); } + | SNOT expr + { $$ = mkexpr(OPNOT, $2, ENULL); } + | expr SCONCAT expr + { NO66("concatenation operator //"); + $$ = mkexpr(OPCONCAT, $1, $3); } + ; + +addop: SPLUS { $$ = OPPLUS; } + | SMINUS { $$ = OPMINUS; } + ; + +relop: SEQ { $$ = OPEQ; } + | SGT { $$ = OPGT; } + | SLT { $$ = OPLT; } + | SGE { $$ = OPGE; } + | SLE { $$ = OPLE; } + | SNE { $$ = OPNE; } + ; + +lhs: name + { $$ = mkprim($1, LBNULL, CHNULL); } + | name substring + { NO66("substring operator :"); + $$ = mkprim($1, LBNULL, $2); } + | name SLPAR funarglist SRPAR + { $$ = mkprim($1, mklist($3), CHNULL); } + | name SLPAR funarglist SRPAR substring + { NO66("substring operator :"); + $$ = mkprim($1, mklist($3), $5); } + ; + +substring: SLPAR opt_expr SCOLON opt_expr SRPAR + { $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); } + ; + +opt_expr: + { $$ = 0; } + | expr + ; + +simple: name + { if($1->vclass == CLPARAM) + $$ = (expptr) cpexpr( + ( (struct Paramblock *) ($1) ) -> paramval); + } + | simple_const + ; + +simple_const: STRUE { $$ = mklogcon(1); } + | SFALSE { $$ = mklogcon(0); } + | SHOLLERITH { $$ = mkstrcon(toklen, token); } + | SICON = { $$ = mkintqcon(toklen, token); } + | SRCON = { $$ = mkrealcon(tyreal, token); } + | SDCON = { $$ = mkrealcon(TYDREAL, token); } + | bit_const + ; + +complex_const: SLPAR uexpr SCOMMA uexpr SRPAR + { $$ = mkcxcon($2,$4); } + ; + +bit_const: SHEXCON + { NOEXT("hex constant"); + $$ = mkbitcon(4, toklen, token); } + | SOCTCON + { NOEXT("octal constant"); + $$ = mkbitcon(3, toklen, token); } + | SBITCON + { NOEXT("binary constant"); + $$ = mkbitcon(1, toklen, token); } + ; + +fexpr: unpar_fexpr + | SLPAR fexpr SRPAR + { $$ = $2; } + ; + +unpar_fexpr: lhs + | simple_const + | fexpr addop fexpr %prec SPLUS + { $$ = mkexpr($2, $1, $3); } + | fexpr SSTAR fexpr + { $$ = mkexpr(OPSTAR, $1, $3); } + | fexpr SSLASH fexpr + { $$ = mkexpr(OPSLASH, $1, $3); } + | fexpr SPOWER fexpr + { $$ = mkexpr(OPPOWER, $1, $3); } + | addop fexpr %prec SSTAR + { if($1 == OPMINUS) + $$ = mkexpr(OPNEG, $2, ENULL); + else $$ = $2; + } + | fexpr SCONCAT fexpr + { NO66("concatenation operator //"); + $$ = mkexpr(OPCONCAT, $1, $3); } + ; diff --git a/unix/f2c/src/gram.head b/unix/f2c/src/gram.head new file mode 100644 index 00000000..be17cd29 --- /dev/null +++ b/unix/f2c/src/gram.head @@ -0,0 +1,293 @@ +/**************************************************************** +Copyright 1990, 1993 by AT&T Bell Laboratories, Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +%{ +#include "defs.h" +#include "p1defs.h" + +static int nstars; /* Number of labels in an + alternate return CALL */ +static int datagripe; +static int ndim; +static int vartype; +int new_dcl; +static ftnint varleng; +static struct Dims dims[MAXDIM+1]; +extern struct Labelblock **labarray; /* Labels in an alternate + return CALL */ +extern int maxlablist; + +/* The next two variables are used to verify that each statement might be reached + during runtime. lastwasbranch is tested only in the defintion of the + stat: nonterminal. */ + +int lastwasbranch = NO; +static int thiswasbranch = NO; +extern ftnint yystno; +extern flag intonly; +static chainp datastack; +extern long laststfcn, thisstno; +extern int can_include; /* for netlib */ +extern void endcheck Argdcl((void)); +extern struct Primblock *primchk Argdcl((expptr)); + +#define ESNULL (Extsym *)0 +#define NPNULL (Namep)0 +#define LBNULL (struct Listblock *)0 + + static void +pop_datastack(Void) { + chainp d0 = datastack; + if (d0->datap) + curdtp = (chainp)d0->datap; + datastack = d0->nextp; + d0->nextp = 0; + frchain(&d0); + } + +%} + +/* Specify precedences and associativities. */ + +%union { + int ival; + ftnint lval; + char *charpval; + chainp chval; + tagptr tagval; + expptr expval; + struct Labelblock *labval; + struct Nameblock *namval; + struct Eqvchain *eqvval; + Extsym *extval; + } + +%left SCOMMA +%nonassoc SCOLON +%right SEQUALS +%left SEQV SNEQV +%left SOR +%left SAND +%left SNOT +%nonassoc SLT SGT SLE SGE SEQ SNE +%left SCONCAT +%left SPLUS SMINUS +%left SSTAR SSLASH +%right SPOWER + +%start program +%type thislabel label assignlabel +%type other inelt +%type type typespec typename dcl letter addop relop stop nameeq +%type lengspec +%type filename +%type datavar datavarlist namelistlist funarglist funargs +%type dospec dospecw +%type callarglist arglist args exprlist inlist outlist out2 substring +%type name arg call var +%type lhs expr uexpr opt_expr fexpr unpar_fexpr +%type ubound simple value callarg complex_const simple_const bit_const +%type common comblock entryname progname +%type equivlist + +%% + +program: + | program stat SEOS + ; + +stat: thislabel entry + { +/* stat: is the nonterminal for Fortran statements */ + + lastwasbranch = NO; } + | thislabel spec + | thislabel exec + { /* forbid further statement function definitions... */ + if (parstate == INDATA && laststfcn != thisstno) + parstate = INEXEC; + thisstno++; + if($1 && ($1->labelno==dorange)) + enddo($1->labelno); + if(lastwasbranch && thislabel==NULL) + warn("statement cannot be reached"); + lastwasbranch = thiswasbranch; + thiswasbranch = NO; + if($1) + { + if($1->labtype == LABFORMAT) + err("label already that of a format"); + else + $1->labtype = LABEXEC; + } + freetemps(); + } + | thislabel SINCLUDE filename + { if (can_include) + doinclude( $3 ); + else { + fprintf(diagfile, "Cannot open file %s\n", $3); + done(1); + } + } + | thislabel SEND end_spec + { if ($1) + lastwasbranch = NO; + endcheck(); + endproc(); /* lastwasbranch = NO; -- set in endproc() */ + } + | thislabel SUNKNOWN + { unclassifiable(); + +/* flline flushes the current line, ignoring the rest of the text there */ + + flline(); } + | error + { flline(); needkwd = NO; inioctl = NO; + yyerrok; yyclearin; } + ; + +thislabel: SLABEL + { + if(yystno != 0) + { + $$ = thislabel = mklabel(yystno); + if( ! headerdone ) { + if (procclass == CLUNKNOWN) + procclass = CLMAIN; + puthead(CNULL, procclass); + } + if(thislabel->labdefined) + execerr("label %s already defined", + convic(thislabel->stateno) ); + else { + if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=LABFORMAT) + warn1("there is a branch to label %s from outside block", + convic( (ftnint) (thislabel->stateno) ) ); + thislabel->blklevel = blklevel; + thislabel->labdefined = YES; + if(thislabel->labtype != LABFORMAT) + p1_label((long)(thislabel - labeltab)); + } + } + else $$ = thislabel = NULL; + } + ; + +entry: SPROGRAM new_proc progname + {startproc($3, CLMAIN); } + | SPROGRAM new_proc progname progarglist + { warn("ignoring arguments to main program"); + /* hashclear(); */ + startproc($3, CLMAIN); } + | SBLOCK new_proc progname + { if($3) NO66("named BLOCKDATA"); + startproc($3, CLBLOCK); } + | SSUBROUTINE new_proc entryname arglist + { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } + | SFUNCTION new_proc entryname arglist + { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } + | type SFUNCTION new_proc entryname arglist + { entrypt(CLPROC, $1, varleng, $4, $5); } + | SENTRY entryname arglist + { if(parstate==OUTSIDE || procclass==CLMAIN + || procclass==CLBLOCK) + execerr("misplaced entry statement", CNULL); + entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); + } + ; + +new_proc: + { newproc(); } + ; + +entryname: name + { $$ = newentry($1, 1); } + ; + +name: SNAME + { $$ = mkname(token); } + ; + +progname: { $$ = NULL; } + | entryname + ; + +progarglist: + SLPAR SRPAR + | SLPAR progargs SRPAR + ; + +progargs: progarg + | progargs SCOMMA progarg + ; + +progarg: SNAME + | SNAME SEQUALS SNAME + ; + +arglist: + { $$ = 0; } + | SLPAR SRPAR + { NO66(" () argument list"); + $$ = 0; } + | SLPAR args SRPAR + {$$ = $2; } + ; + +args: arg + { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); } + | args SCOMMA arg + { if($3) $1 = $$ = mkchain((char *)$3, $1); } + ; + +arg: name + { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) + dclerr("name declared as argument after use", $1); + $1->vstg = STGARG; + } + | SSTAR + { NO66("altenate return argument"); + +/* substars means that '*'ed formal parameters should be replaced. + This is used to specify alternate return labels; in theory, only + parameter slots which have '*' should accept the statement labels. + This compiler chooses to ignore the '*'s in the formal declaration, and + always return the proper value anyway. + + This variable is only referred to in proc.c */ + + $$ = 0; substars = YES; } + ; + + + +filename: SHOLLERITH + { + char *s; + s = copyn(toklen+1, token); + s[toklen] = '\0'; + $$ = s; + } + ; diff --git a/unix/f2c/src/gram.io b/unix/f2c/src/gram.io new file mode 100644 index 00000000..00ff0f28 --- /dev/null +++ b/unix/f2c/src/gram.io @@ -0,0 +1,175 @@ + /* Input/Output Statements */ + +io: io1 + { endio(); } + ; + +io1: iofmove ioctl + | iofmove unpar_fexpr + { ioclause(IOSUNIT, $2); endioctl(); } + | iofmove SSTAR + { ioclause(IOSUNIT, ENULL); endioctl(); } + | iofmove SPOWER + { ioclause(IOSUNIT, IOSTDERR); endioctl(); } + | iofctl ioctl + | read ioctl + { doio(CHNULL); } + | read infmt + { doio(CHNULL); } + | read ioctl inlist + { doio(revchain($3)); } + | read infmt SCOMMA inlist + { doio(revchain($4)); } + | read ioctl SCOMMA inlist + { doio(revchain($4)); } + | write ioctl + { doio(CHNULL); } + | write ioctl outlist + { doio(revchain($3)); } + | write ioctl SCOMMA outlist + { doio(revchain($4)); } + | print + { doio(CHNULL); } + | print SCOMMA outlist + { doio(revchain($3)); } + ; + +iofmove: fmkwd end_spec in_ioctl + ; + +fmkwd: SBACKSPACE + { iostmt = IOBACKSPACE; } + | SREWIND + { iostmt = IOREWIND; } + | SENDFILE + { iostmt = IOENDFILE; } + ; + +iofctl: ctlkwd end_spec in_ioctl + ; + +ctlkwd: SINQUIRE + { iostmt = IOINQUIRE; } + | SOPEN + { iostmt = IOOPEN; } + | SCLOSE + { iostmt = IOCLOSE; } + ; + +infmt: unpar_fexpr + { + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, $1); + endioctl(); + } + | SSTAR + { + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, ENULL); + endioctl(); + } + ; + +ioctl: SLPAR fexpr SRPAR + { + ioclause(IOSUNIT, $2); + endioctl(); + } + | SLPAR ctllist SRPAR + { endioctl(); } + ; + +ctllist: ioclause + | ctllist SCOMMA ioclause + ; + +ioclause: fexpr + { ioclause(IOSPOSITIONAL, $1); } + | SSTAR + { ioclause(IOSPOSITIONAL, ENULL); } + | SPOWER + { ioclause(IOSPOSITIONAL, IOSTDERR); } + | nameeq expr + { ioclause($1, $2); } + | nameeq SSTAR + { ioclause($1, ENULL); } + | nameeq SPOWER + { ioclause($1, IOSTDERR); } + ; + +nameeq: SNAMEEQ + { $$ = iocname(); } + ; + +read: SREAD end_spec in_ioctl + { iostmt = IOREAD; } + ; + +write: SWRITE end_spec in_ioctl + { iostmt = IOWRITE; } + ; + +print: SPRINT end_spec fexpr in_ioctl + { + iostmt = IOWRITE; + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, $3); + endioctl(); + } + | SPRINT end_spec SSTAR in_ioctl + { + iostmt = IOWRITE; + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, ENULL); + endioctl(); + } + ; + +inlist: inelt + { $$ = mkchain((char *)$1, CHNULL); } + | inlist SCOMMA inelt + { $$ = mkchain((char *)$3, $1); } + ; + +inelt: lhs + { $$ = (tagptr) $1; } + | SLPAR inlist SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4,revchain($2)); } + ; + +outlist: uexpr + { $$ = mkchain((char *)$1, CHNULL); } + | other + { $$ = mkchain((char *)$1, CHNULL); } + | out2 + ; + +out2: uexpr SCOMMA uexpr + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | uexpr SCOMMA other + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | other SCOMMA uexpr + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | other SCOMMA other + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | out2 SCOMMA uexpr + { $$ = mkchain((char *)$3, $1); } + | out2 SCOMMA other + { $$ = mkchain((char *)$3, $1); } + ; + +other: complex_const + { $$ = (tagptr) $1; } + | SLPAR expr SRPAR + { $$ = (tagptr) $2; } + | SLPAR uexpr SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } + | SLPAR other SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } + | SLPAR out2 SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4, revchain($2)); } + ; + +in_ioctl: + { startioctl(); } + ; diff --git a/unix/f2c/src/index.html b/unix/f2c/src/index.html new file mode 100644 index 00000000..c3215ac2 --- /dev/null +++ b/unix/f2c/src/index.html @@ -0,0 +1,150 @@ + +f2c/src + + +

f2c/src

+

+Click here to see the number of accesses to this library. +

+
+#	======  index for f2c/src  ======
+#	NOTE: The E-mail request "send all from f2c/src" retrieves the
+#	complete f2c source (sans libraries).
+#	The remaining files in this directory are the component modules
+#	of "all from f2c/src", so you can request just the modules that
+#	have changed since last you updated your f2c source.  You can
+#	tell what has changed by looking at the timestamps at the end
+#	of "readme from f2c".
+
+file	cds.c  cds.c plus dependencies
+
+file	data.c
+
+file	defines.h  defines.h plus dependencies
+
+file	defs.h
+
+file	equiv.c  equiv.c plus dependencies
+
+file	error.c
+
+file	exec.c  exec.c plus dependencies
+
+file	expr.c
+
+file	f2c.1  f2c.1 plus dependencies
+
+file	f2c.1t
+
+file	f2c.h  f2c.h plus dependencies
+
+file	format.c
+
+file	format.h  format.h plus dependencies
+
+file	formatdata.c
+
+file	ftypes.h  ftypes.h plus dependencies
+
+file	gram.c
+
+file	gram.dcl  gram.dcl plus dependencies
+
+file	gram.exec
+
+file	gram.expr  gram.expr plus dependencies
+
+file	gram.head
+
+file	gram.io  gram.io plus dependencies
+
+file	init.c
+
+file	intr.c  intr.c plus dependencies
+
+file	io.c
+
+file	iob.h  iob.h plus dependencies
+
+file	lex.c
+
+file	machdefs.h  machdefs.h plus dependencies
+
+file	main.c
+
+file	makefile.u  makefile.u plus dependencies
+
+file	makefile.vc
+
+file	malloc.c  malloc.c plus dependencies
+
+file	mem.c
+
+file	memset.c  memset.c plus dependencies
+
+file	misc.c
+
+file	mkfile.plan9  mkfile.plan9 plus dependencies
+for	making f2c under plan 9 (mk -f mkfile.plan9)
+
+file	names.c
+
+file	names.h  names.h plus dependencies
+
+file	niceprintf.c
+
+file	niceprintf.h  niceprintf.h plus dependencies
+
+file	notice
+
+file	output.c
+
+file	output.h  output.h plus dependencies
+
+file	p1defs.h
+
+file	p1output.c  p1output.c plus dependencies
+
+file	parse.h
+
+file	parse_args.c  parse_args.c plus dependencies
+
+file	pccdefs.h
+
+file	pread.c  pread.c plus dependencies
+
+file	proc.c
+
+file	put.c  put.c plus dependencies
+
+file	putpcc.c
+
+file	sysdep.c  sysdep.c plus dependencies
+
+file	sysdep.h
+
+file	sysdeptest.c  sysdeptest.c plus dependencies
+
+file	tokens
+
+file	tokdefs.h  tokdefs.h plus dependencies
+
+file	usignal.h
+
+file	vax.c  vax.c plus dependencies
+
+file	version.c
+
+file	xsum.c  xsum.c plus dependencies
+
+file	xsum0.out
+
+file	Notice
+
+file	README
+
+file	readme
+
+
+ + diff --git a/unix/f2c/src/init.c b/unix/f2c/src/init.c new file mode 100644 index 00000000..752c99a8 --- /dev/null +++ b/unix/f2c/src/init.c @@ -0,0 +1,526 @@ +/**************************************************************** +Copyright 1990, 1992-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "output.h" +#include "iob.h" + +/* State required for the C output */ +char *fl_fmt_string; /* Float format string */ +char *db_fmt_string; /* Double format string */ +char *cm_fmt_string; /* Complex format string */ +char *dcm_fmt_string; /* Double complex format string */ + +chainp new_vars = CHNULL; /* List of newly created locals in this + function. These may have identifiers + which have underscores and more than VL + characters */ +chainp used_builtins = CHNULL; /* List of builtins used by this function. + These are all Addrps with UNAM_EXTERN + */ +chainp assigned_fmts = CHNULL; /* assigned formats */ +chainp allargs; /* union of args in all entry points */ +chainp earlylabs; /* labels seen before enddcl() */ +char main_alias[52]; /* PROGRAM name, if any is given */ +int tab_size = 4; + + +FILEP infile; +FILEP diagfile; + +FILEP c_file; +FILEP pass1_file; +FILEP initfile; +FILEP blkdfile; + + +char *token; +int maxtoklen, toklen; +long err_lineno; +long lineno; /* Current line in the input file, NOT the + Fortran statement label number */ +char *infname; +int needkwd; +struct Labelblock *thislabel = NULL; +int nerr; +int nwarn; + +flag saveall; +flag substars; +int parstate = OUTSIDE; +flag headerdone = NO; +int blklevel; +int doin_setbound; +int impltype[26]; +ftnint implleng[26]; +int implstg[26]; + +int tyint = TYLONG ; +int tylogical = TYLONG; +int tylog = TYLOGICAL; +int typesize[NTYPES] = { + 1, SZADDR, 1, SZSHORT, SZLONG, +#ifdef TYQUAD + 2*SZLONG, +#endif + SZLONG, 2*SZLONG, + 2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0, + 4*SZLONG + SZADDR, /* sizeof(cilist) */ + 4*SZLONG + 2*SZADDR, /* sizeof(icilist) */ + 4*SZLONG + 5*SZADDR, /* sizeof(olist) */ + 2*SZLONG + SZADDR, /* sizeof(cllist) */ + 2*SZLONG, /* sizeof(alist) */ + 11*SZLONG + 15*SZADDR /* sizeof(inlist) */ + }; + +int typealign[NTYPES] = { + 1, ALIADDR, 1, ALISHORT, ALILONG, +#ifdef TYQUAD + ALIDOUBLE, +#endif + ALILONG, ALIDOUBLE, + ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1, + ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG}; + +int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT }; + +char *Typename[] = { + "<>", + "address", + "integer1", + "shortint", + "integer", +#ifdef TYQUAD + "longint", +#endif + "real", + "doublereal", + "complex", + "doublecomplex", + "logical1", + "shortlogical", + "logical", + "char" /* character */ + }; + +int type_pref[NTYPES] = { 0, 0, 3, 5, 7, +#ifdef TYQUAD + 10, +#endif + 8, 11, 9, 12, 1, 4, 6, 2 }; + +char *protorettypes[] = { + "?", "??", "integer1", "shortint", "integer", +#ifdef TYQUAD + "longint", +#endif + "real", "doublereal", + "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int" + }; + +char *casttypes[TYSUBR+1] = { + "U_fp", "??bug??", "I1_fp", + "J_fp", "I_fp", +#ifdef TYQUAD + "Q_fp", +#endif + "R_fp", "D_fp", "C_fp", "Z_fp", + "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp" + }; +char *usedcasts[TYSUBR+1]; + +char *dfltarg[] = { + 0, 0, "(integer1 *)0", + "(shortint *)0", "(integer *)0", +#ifdef TYQUAD + "(longint *)0", +#endif + "(real *)0", + "(doublereal *)0", "(complex *)0", "(doublecomplex *)0", + "(logical1 *)0","(shortlogical *)0", "(logical *)0", "(char *)0" + }; + +static char *dflt0proc[] = { + 0, 0, "(integer1 (*)())0", + "(shortint (*)())0", "(integer (*)())0", +#ifdef TYQUAD + "(longint (*)())0", +#endif + "(real (*)())0", + "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0", + "(logical1 (*)())0", "(shortlogical (*)())0", + "(logical (*)())0", "(char (*)())0", "(int (*)())0" + }; + +char *dflt1proc[] = { "(U_fp)0", "( ??bug?? )0", "(I1_fp)0", + "(J_fp)0", "(I_fp)0", +#ifdef TYQUAD + "(Q_fp)0", +#endif + "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0", + "(L1_fp)0","(L2_fp)0", + "(L_fp)0", "(H_fp)0", "(S_fp)0" + }; + +char **dfltproc = dflt0proc; + +static char Bug[] = "bug"; + +char *ftn_types[] = { "external", "??", "integer*1", + "integer*2", "integer", +#ifdef TYQUAD + "integer*8", +#endif + "real", + "double precision", "complex", "double complex", + "logical*1", "logical*2", + "logical", "character", "subroutine", + Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen" + }; + +int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0, +#ifdef TYQUAD + 0, +#endif + 1, 1, 0, 0, 0, 2}; + +int proctype = TYUNKNOWN; +char *procname; +int rtvlabel[NTYPES0]; +Addrp retslot; /* Holds automatic variable which was + allocated the function return value + */ +Addrp xretslot[NTYPES0]; /* for multiple entry points */ +int cxslot = -1; +int chslot = -1; +int chlgslot = -1; +int procclass = CLUNKNOWN; +int nentry; +int nallargs; +int nallchargs; +flag multitype; +ftnint procleng; +long lastiolabno; +long lastlabno; +int lastvarno; +int lastargslot; +int autonum[TYVOID]; +char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i", +#ifdef TYQUAD + "i8", +#endif + "r","d","q","z","L1","L2","L","ch", + "??TYSUBR??", "??TYERROR??","ci", "ici", + "o", "cl", "al", "ioin" }; + +extern int maxctl; +struct Ctlframe *ctls; +struct Ctlframe *ctlstack; +struct Ctlframe *lastctl; + +Namep regnamep[MAXREGVAR]; +int highregvar; +int nregvar; + +extern int maxext; +Extsym *extsymtab; +Extsym *nextext; +Extsym *lastext; + +extern int maxequiv; +struct Equivblock *eqvclass; + +extern int maxhash; +struct Hashentry *hashtab; +struct Hashentry *lasthash; + +extern int maxstno; /* Maximum number of statement labels */ +struct Labelblock *labeltab; +struct Labelblock *labtabend; +struct Labelblock *highlabtab; + +int maxdim = MAXDIM; +struct Rplblock *rpllist = NULL; +struct Chain *curdtp = NULL; +flag toomanyinit; +ftnint curdtelt; +chainp templist[TYVOID]; +chainp holdtemps; +int dorange = 0; +struct Entrypoint *entries = NULL; + +chainp chains = NULL; + +flag inioctl; +int iostmt; +int nioctl; +int nequiv = 0; +int eqvstart = 0; +int nintnames = 0; +extern int maxlablist; +struct Labelblock **labarray; + +struct Literal *litpool; +int nliterals; + +char dflttype[26]; +unsigned char hextoi_tab[Table_size], Letters[Table_size]; +char *ei_first, *ei_next, *ei_last; +char *wh_first, *wh_next, *wh_last; +#ifdef TYQUAD +unsigned long ff; +#endif + +#define ALLOCN(n,x) (struct x *) ckalloc((n)*sizeof(struct x)) + + void +fileinit(Void) +{ + register char *s; + register int i, j; + + lastiolabno = 100000; + lastlabno = 0; + lastvarno = 0; + nliterals = 0; + nerr = 0; + + infile = stdin; + + maxtoklen = 502; + token = (char *)ckalloc(maxtoklen+2); + memset(dflttype, tyreal, 26); + memset(dflttype + ('i' - 'a'), tyint, 6); + memset(hextoi_tab, 16, sizeof(hextoi_tab)); + for(i = 0, s = "0123456789abcdef"; *s; i++, s++) + hextoi(*s) = i; + for(i = 10, s = "ABCDEF"; *s; i++, s++) + hextoi(*s) = i; + for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++) + Letters[i] = Letters[i+'A'-'a'] = j; +#ifdef TYQUAD + /* Older C compilers may not understand UL suffixes. */ + /* It would be much simpler to use 0xffffffffUL some places... */ + ff = 0xffff; + ff = (ff << 16) | ff; +#endif + ctls = ALLOCN(maxctl+1, Ctlframe); + extsymtab = ALLOCN(maxext, Extsym); + eqvclass = ALLOCN(maxequiv, Equivblock); + hashtab = ALLOCN(maxhash, Hashentry); + labeltab = ALLOCN(maxstno, Labelblock); + litpool = ALLOCN(maxliterals, Literal); + labarray = (struct Labelblock **)ckalloc(maxlablist* + sizeof(struct Labelblock *)); + fmt_init(); + mem_init(); + np_init(); + + ctlstack = ctls++; + lastctl = ctls + maxctl; + nextext = extsymtab; + lastext = extsymtab + maxext; + lasthash = hashtab + maxhash; + labtabend = labeltab + maxstno; + highlabtab = labeltab; + main_alias[0] = '\0'; + if (forcedouble) + dfltproc[TYREAL] = dfltproc[TYDREAL]; + +/* Initialize the routines for providing C output */ + + out_init (); +} + + void +hashclear(Void) /* clear hash table */ +{ + register struct Hashentry *hp; + register Namep p; + register struct Dimblock *q; + register int i; + + for(hp = hashtab ; hp < lasthash ; ++hp) + if(p = hp->varp) + { + frexpr(p->vleng); + if(q = p->vdim) + { + for(i = 0 ; i < q->ndim ; ++i) + { + frexpr(q->dims[i].dimsize); + frexpr(q->dims[i].dimexpr); + } + frexpr(q->nelt); + frexpr(q->baseoffset); + frexpr(q->basexpr); + free( (charptr) q); + } + if(p->vclass == CLNAMELIST) + frchain( &(p->varxptr.namelist) ); + free( (charptr) p); + hp->varp = NULL; + } + } + + extern struct memblock *curmemblock, *firstmemblock; + extern char *mem_first, *mem_next, *mem_last, *mem0_last; + + void +procinit(Void) +{ + register struct Labelblock *lp; + struct Chain *cp; + int i; + struct memblock; + + curmemblock = firstmemblock; + mem_next = mem_first; + mem_last = mem0_last; + ei_next = ei_first = ei_last = 0; + wh_next = wh_first = wh_last = 0; + iob_list = 0; + for(i = 0; i < 9; i++) + io_structs[i] = 0; + + parstate = OUTSIDE; + headerdone = NO; + blklevel = 1; + saveall = NO; + substars = NO; + nwarn = 0; + thislabel = NULL; + needkwd = 0; + + proctype = TYUNKNOWN; + procname = "MAIN_"; + procclass = CLUNKNOWN; + nentry = 0; + nallargs = nallchargs = 0; + multitype = NO; + retslot = NULL; + for(i = 0; i < NTYPES0; i++) { + frexpr((expptr)xretslot[i]); + xretslot[i] = 0; + } + cxslot = -1; + chslot = -1; + chlgslot = -1; + procleng = 0; + blklevel = 1; + lastargslot = 0; + + for(lp = labeltab ; lp < labtabend ; ++lp) + lp->stateno = 0; + + hashclear(); + +/* Clear the list of newly generated identifiers from the previous + function */ + + frexchain(&new_vars); + frexchain(&used_builtins); + frchain(&assigned_fmts); + frchain(&allargs); + frchain(&earlylabs); + + nintnames = 0; + highlabtab = labeltab; + + ctlstack = ctls - 1; + for(i = TYADDR; i < TYVOID; i++) { + for(cp = templist[i]; cp ; cp = cp->nextp) + free( (charptr) (cp->datap) ); + frchain(templist + i); + autonum[i] = 0; + } + holdtemps = NULL; + dorange = 0; + nregvar = 0; + highregvar = 0; + entries = NULL; + rpllist = NULL; + inioctl = NO; + eqvstart += nequiv; + nequiv = 0; + dcomplex_seen = 0; + + for(i = 0 ; i c2) { + sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2); + err(buff); + } + else { + c1 = letter(c1); + c2 = letter(c2); + if(type < 0) + for(i = c1 ; i<=c2 ; ++i) + implstg[i] = - type; + else { + type = lengtype(type, length); + if(type == TYCHAR) { + if (length < 0) { + err("length (*) in implicit"); + length = 1; + } + } + else if (type != TYLONG) + length = 0; + for(i = c1 ; i<=c2 ; ++i) { + impltype[i] = type; + implleng[i] = length; + } + } + } + } diff --git a/unix/f2c/src/intr.c b/unix/f2c/src/intr.c new file mode 100644 index 00000000..dcae4db8 --- /dev/null +++ b/unix/f2c/src/intr.c @@ -0,0 +1,1087 @@ +/**************************************************************** +Copyright 1990, 1992, 1994-6, 1998 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "names.h" + +union + { + int ijunk; + struct Intrpacked bits; + } packed; + +struct Intrbits + { + char intrgroup /* :3 */; + char intrstuff /* result type or number of generics */; + char intrno /* :7 */; + char dblcmplx; + char dblintrno; /* for -r8 */ + char extflag; /* for -cd, -i90 */ + }; + +/* List of all intrinsic functions. */ + +LOCAL struct Intrblock + { + char intrfname[8]; + struct Intrbits intrval; + } intrtab[ ] = +{ +"int", { INTRCONV, TYLONG }, +"real", { INTRCONV, TYREAL, 1 }, + /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */ +"dble", { INTRCONV, TYDREAL }, +"dreal", { INTRCONV, TYDREAL, 0, 0, 0, 1 }, +"cmplx", { INTRCONV, TYCOMPLEX }, +"dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 }, +"ifix", { INTRCONV, TYLONG }, +"idint", { INTRCONV, TYLONG }, +"float", { INTRCONV, TYREAL }, +"dfloat", { INTRCONV, TYDREAL }, +"sngl", { INTRCONV, TYREAL }, +"ichar", { INTRCONV, TYLONG }, +"iachar", { INTRCONV, TYLONG }, +"char", { INTRCONV, TYCHAR }, +"achar", { INTRCONV, TYCHAR }, + +/* any MAX or MIN can be used with any types; the compiler will cast them + correctly. So rules against bad syntax in these expressions are not + enforced */ + +"max", { INTRMAX, TYUNKNOWN }, +"max0", { INTRMAX, TYLONG }, +"amax0", { INTRMAX, TYREAL }, +"max1", { INTRMAX, TYLONG }, +"amax1", { INTRMAX, TYREAL }, +"dmax1", { INTRMAX, TYDREAL }, + +"and", { INTRBOOL, TYUNKNOWN, OPBITAND }, +"or", { INTRBOOL, TYUNKNOWN, OPBITOR }, +"xor", { INTRBOOL, TYUNKNOWN, OPBITXOR }, +"not", { INTRBOOL, TYUNKNOWN, OPBITNOT }, +"lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT }, +"rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT }, + +"min", { INTRMIN, TYUNKNOWN }, +"min0", { INTRMIN, TYLONG }, +"amin0", { INTRMIN, TYREAL }, +"min1", { INTRMIN, TYLONG }, +"amin1", { INTRMIN, TYREAL }, +"dmin1", { INTRMIN, TYDREAL }, + +"aint", { INTRGEN, 2, 0 }, +"dint", { INTRSPEC, TYDREAL, 1 }, + +"anint", { INTRGEN, 2, 2 }, +"dnint", { INTRSPEC, TYDREAL, 3 }, + +"nint", { INTRGEN, 4, 4 }, +"idnint", { INTRGEN, 2, 6 }, + +"abs", { INTRGEN, 6, 8 }, +"iabs", { INTRGEN, 2, 9 }, +"dabs", { INTRSPEC, TYDREAL, 11 }, +"cabs", { INTRSPEC, TYREAL, 12, 0, 13 }, +"zabs", { INTRSPEC, TYDREAL, 13, 1 }, + +"mod", { INTRGEN, 4, 14 }, +"amod", { INTRSPEC, TYREAL, 16, 0, 17 }, +"dmod", { INTRSPEC, TYDREAL, 17 }, + +"sign", { INTRGEN, 4, 18 }, +"isign", { INTRGEN, 2, 19 }, +"dsign", { INTRSPEC, TYDREAL, 21 }, + +"dim", { INTRGEN, 4, 22 }, +"idim", { INTRGEN, 2, 23 }, +"ddim", { INTRSPEC, TYDREAL, 25 }, + +"dprod", { INTRSPEC, TYDREAL, 26 }, + +"len", { INTRSPEC, TYLONG, 27 }, +"index", { INTRSPEC, TYLONG, 29 }, + +"imag", { INTRGEN, 2, 31 }, +"aimag", { INTRSPEC, TYREAL, 31, 0, 32 }, +"dimag", { INTRSPEC, TYDREAL, 32 }, + +"conjg", { INTRGEN, 2, 33 }, +"dconjg", { INTRSPEC, TYDCOMPLEX, 34, 1 }, + +"sqrt", { INTRGEN, 4, 35 }, +"dsqrt", { INTRSPEC, TYDREAL, 36 }, +"csqrt", { INTRSPEC, TYCOMPLEX, 37, 0, 38 }, +"zsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1 }, + +"exp", { INTRGEN, 4, 39 }, +"dexp", { INTRSPEC, TYDREAL, 40 }, +"cexp", { INTRSPEC, TYCOMPLEX, 41, 0, 42 }, +"zexp", { INTRSPEC, TYDCOMPLEX, 42, 1 }, + +"log", { INTRGEN, 4, 43 }, +"alog", { INTRSPEC, TYREAL, 43, 0, 44 }, +"dlog", { INTRSPEC, TYDREAL, 44 }, +"clog", { INTRSPEC, TYCOMPLEX, 45, 0, 46 }, +"zlog", { INTRSPEC, TYDCOMPLEX, 46, 1 }, + +"log10", { INTRGEN, 2, 47 }, +"alog10", { INTRSPEC, TYREAL, 47, 0, 48 }, +"dlog10", { INTRSPEC, TYDREAL, 48 }, + +"sin", { INTRGEN, 4, 49 }, +"dsin", { INTRSPEC, TYDREAL, 50 }, +"csin", { INTRSPEC, TYCOMPLEX, 51, 0, 52 }, +"zsin", { INTRSPEC, TYDCOMPLEX, 52, 1 }, + +"cos", { INTRGEN, 4, 53 }, +"dcos", { INTRSPEC, TYDREAL, 54 }, +"ccos", { INTRSPEC, TYCOMPLEX, 55, 0, 56 }, +"zcos", { INTRSPEC, TYDCOMPLEX, 56, 1 }, + +"tan", { INTRGEN, 2, 57 }, +"dtan", { INTRSPEC, TYDREAL, 58 }, + +"asin", { INTRGEN, 2, 59 }, +"dasin", { INTRSPEC, TYDREAL, 60 }, + +"acos", { INTRGEN, 2, 61 }, +"dacos", { INTRSPEC, TYDREAL, 62 }, + +"atan", { INTRGEN, 2, 63 }, +"datan", { INTRSPEC, TYDREAL, 64 }, + +"atan2", { INTRGEN, 2, 65 }, +"datan2", { INTRSPEC, TYDREAL, 66 }, + +"sinh", { INTRGEN, 2, 67 }, +"dsinh", { INTRSPEC, TYDREAL, 68 }, + +"cosh", { INTRGEN, 2, 69 }, +"dcosh", { INTRSPEC, TYDREAL, 70 }, + +"tanh", { INTRGEN, 2, 71 }, +"dtanh", { INTRSPEC, TYDREAL, 72 }, + +"lge", { INTRSPEC, TYLOGICAL, 73}, +"lgt", { INTRSPEC, TYLOGICAL, 75}, +"lle", { INTRSPEC, TYLOGICAL, 77}, +"llt", { INTRSPEC, TYLOGICAL, 79}, + +#if 0 +"epbase", { INTRCNST, 4, 0 }, +"epprec", { INTRCNST, 4, 4 }, +"epemin", { INTRCNST, 2, 8 }, +"epemax", { INTRCNST, 2, 10 }, +"eptiny", { INTRCNST, 2, 12 }, +"ephuge", { INTRCNST, 4, 14 }, +"epmrsp", { INTRCNST, 2, 18 }, +#endif + +"fpexpn", { INTRGEN, 4, 81 }, +"fpabsp", { INTRGEN, 2, 85 }, +"fprrsp", { INTRGEN, 2, 87 }, +"fpfrac", { INTRGEN, 2, 89 }, +"fpmake", { INTRGEN, 2, 91 }, +"fpscal", { INTRGEN, 2, 93 }, + +"cdabs", { INTRSPEC, TYDREAL, 13, 1, 0, 1 }, +"cdsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1, 0, 1 }, +"cdexp", { INTRSPEC, TYDCOMPLEX, 42, 1, 0, 1 }, +"cdlog", { INTRSPEC, TYDCOMPLEX, 46, 1, 0, 1 }, +"cdsin", { INTRSPEC, TYDCOMPLEX, 52, 1, 0, 1 }, +"cdcos", { INTRSPEC, TYDCOMPLEX, 56, 1, 0, 1 }, + +"iand", { INTRBOOL, TYUNKNOWN, OPBITAND, 0, 0, 2 }, +"ior", { INTRBOOL, TYUNKNOWN, OPBITOR, 0, 0, 2 }, +"ieor", { INTRBOOL, TYUNKNOWN, OPBITXOR, 0, 0, 2 }, + +"btest", { INTRBGEN, TYLOGICAL, OPBITTEST,0, 0, 2 }, +"ibclr", { INTRBGEN, TYUNKNOWN, OPBITCLR, 0, 0, 2 }, +"ibset", { INTRBGEN, TYUNKNOWN, OPBITSET, 0, 0, 2 }, +"ibits", { INTRBGEN, TYUNKNOWN, OPBITBITS,0, 0, 2 }, +"ishft", { INTRBGEN, TYUNKNOWN, OPBITSH, 0, 0, 2 }, +"ishftc", { INTRBGEN, TYUNKNOWN, OPBITSHC, 0, 0, 2 }, + +"" }; + + +LOCAL struct Specblock + { + char atype; /* Argument type; every arg must have + this type */ + char rtype; /* Result type */ + char nargs; /* Number of arguments */ + char spxname[8]; /* Name of the function in Fortran */ + char othername; /* index into callbyvalue table */ + } spectab[ ] = +{ + { TYREAL,TYREAL,1,"r_int" }, + { TYDREAL,TYDREAL,1,"d_int" }, + + { TYREAL,TYREAL,1,"r_nint" }, + { TYDREAL,TYDREAL,1,"d_nint" }, + + { TYREAL,TYSHORT,1,"h_nint" }, + { TYREAL,TYLONG,1,"i_nint" }, + + { TYDREAL,TYSHORT,1,"h_dnnt" }, + { TYDREAL,TYLONG,1,"i_dnnt" }, + + { TYREAL,TYREAL,1,"r_abs" }, + { TYSHORT,TYSHORT,1,"h_abs" }, + { TYLONG,TYLONG,1,"i_abs" }, + { TYDREAL,TYDREAL,1,"d_abs" }, + { TYCOMPLEX,TYREAL,1,"c_abs" }, + { TYDCOMPLEX,TYDREAL,1,"z_abs" }, + + { TYSHORT,TYSHORT,2,"h_mod" }, + { TYLONG,TYLONG,2,"i_mod" }, + { TYREAL,TYREAL,2,"r_mod" }, + { TYDREAL,TYDREAL,2,"d_mod" }, + + { TYREAL,TYREAL,2,"r_sign" }, + { TYSHORT,TYSHORT,2,"h_sign" }, + { TYLONG,TYLONG,2,"i_sign" }, + { TYDREAL,TYDREAL,2,"d_sign" }, + + { TYREAL,TYREAL,2,"r_dim" }, + { TYSHORT,TYSHORT,2,"h_dim" }, + { TYLONG,TYLONG,2,"i_dim" }, + { TYDREAL,TYDREAL,2,"d_dim" }, + + { TYREAL,TYDREAL,2,"d_prod" }, + + { TYCHAR,TYSHORT,1,"h_len" }, + { TYCHAR,TYLONG,1,"i_len" }, + + { TYCHAR,TYSHORT,2,"h_indx" }, + { TYCHAR,TYLONG,2,"i_indx" }, + + { TYCOMPLEX,TYREAL,1,"r_imag" }, + { TYDCOMPLEX,TYDREAL,1,"d_imag" }, + { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" }, + { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" }, + + { TYREAL,TYREAL,1,"r_sqrt", 1 }, + { TYDREAL,TYDREAL,1,"d_sqrt", 1 }, + { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" }, + { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" }, + + { TYREAL,TYREAL,1,"r_exp", 2 }, + { TYDREAL,TYDREAL,1,"d_exp", 2 }, + { TYCOMPLEX,TYCOMPLEX,1,"c_exp" }, + { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" }, + + { TYREAL,TYREAL,1,"r_log", 3 }, + { TYDREAL,TYDREAL,1,"d_log", 3 }, + { TYCOMPLEX,TYCOMPLEX,1,"c_log" }, + { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" }, + + { TYREAL,TYREAL,1,"r_lg10" }, + { TYDREAL,TYDREAL,1,"d_lg10" }, + + { TYREAL,TYREAL,1,"r_sin", 4 }, + { TYDREAL,TYDREAL,1,"d_sin", 4 }, + { TYCOMPLEX,TYCOMPLEX,1,"c_sin" }, + { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" }, + + { TYREAL,TYREAL,1,"r_cos", 5 }, + { TYDREAL,TYDREAL,1,"d_cos", 5 }, + { TYCOMPLEX,TYCOMPLEX,1,"c_cos" }, + { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" }, + + { TYREAL,TYREAL,1,"r_tan", 6 }, + { TYDREAL,TYDREAL,1,"d_tan", 6 }, + + { TYREAL,TYREAL,1,"r_asin", 7 }, + { TYDREAL,TYDREAL,1,"d_asin", 7 }, + + { TYREAL,TYREAL,1,"r_acos", 8 }, + { TYDREAL,TYDREAL,1,"d_acos", 8 }, + + { TYREAL,TYREAL,1,"r_atan", 9 }, + { TYDREAL,TYDREAL,1,"d_atan", 9 }, + + { TYREAL,TYREAL,2,"r_atn2", 10 }, + { TYDREAL,TYDREAL,2,"d_atn2", 10 }, + + { TYREAL,TYREAL,1,"r_sinh", 11 }, + { TYDREAL,TYDREAL,1,"d_sinh", 11 }, + + { TYREAL,TYREAL,1,"r_cosh", 12 }, + { TYDREAL,TYDREAL,1,"d_cosh", 12 }, + + { TYREAL,TYREAL,1,"r_tanh", 13 }, + { TYDREAL,TYDREAL,1,"d_tanh", 13 }, + + { TYCHAR,TYLOGICAL,2,"hl_ge" }, + { TYCHAR,TYLOGICAL,2,"l_ge" }, + + { TYCHAR,TYLOGICAL,2,"hl_gt" }, + { TYCHAR,TYLOGICAL,2,"l_gt" }, + + { TYCHAR,TYLOGICAL,2,"hl_le" }, + { TYCHAR,TYLOGICAL,2,"l_le" }, + + { TYCHAR,TYLOGICAL,2,"hl_lt" }, + { TYCHAR,TYLOGICAL,2,"l_lt" }, + + { TYREAL,TYSHORT,1,"hr_expn" }, + { TYREAL,TYLONG,1,"ir_expn" }, + { TYDREAL,TYSHORT,1,"hd_expn" }, + { TYDREAL,TYLONG,1,"id_expn" }, + + { TYREAL,TYREAL,1,"r_absp" }, + { TYDREAL,TYDREAL,1,"d_absp" }, + + { TYREAL,TYDREAL,1,"r_rrsp" }, + { TYDREAL,TYDREAL,1,"d_rrsp" }, + + { TYREAL,TYREAL,1,"r_frac" }, + { TYDREAL,TYDREAL,1,"d_frac" }, + + { TYREAL,TYREAL,2,"r_make" }, + { TYDREAL,TYDREAL,2,"d_make" }, + + { TYREAL,TYREAL,2,"r_scal" }, + { TYDREAL,TYDREAL,2,"d_scal" }, + + { 0 } +} ; + +#if 0 +LOCAL struct Incstblock + { + char atype; + char rtype; + char constno; + } consttab[ ] = +{ + { TYSHORT, TYLONG, 0 }, + { TYLONG, TYLONG, 1 }, + { TYREAL, TYLONG, 2 }, + { TYDREAL, TYLONG, 3 }, + + { TYSHORT, TYLONG, 4 }, + { TYLONG, TYLONG, 5 }, + { TYREAL, TYLONG, 6 }, + { TYDREAL, TYLONG, 7 }, + + { TYREAL, TYLONG, 8 }, + { TYDREAL, TYLONG, 9 }, + + { TYREAL, TYLONG, 10 }, + { TYDREAL, TYLONG, 11 }, + + { TYREAL, TYREAL, 0 }, + { TYDREAL, TYDREAL, 1 }, + + { TYSHORT, TYLONG, 12 }, + { TYLONG, TYLONG, 13 }, + { TYREAL, TYREAL, 2 }, + { TYDREAL, TYDREAL, 3 }, + + { TYREAL, TYREAL, 4 }, + { TYDREAL, TYDREAL, 5 } +}; +#endif + +char *callbyvalue[ ] = + {0, + "sqrt", + "exp", + "log", + "sin", + "cos", + "tan", + "asin", + "acos", + "atan", + "atan2", + "sinh", + "cosh", + "tanh" + }; + + void +r8fix(Void) /* adjust tables for -r8 */ +{ + register struct Intrblock *I; + register struct Specblock *S; + + for(I = intrtab; I->intrfname[0]; I++) + if (I->intrval.intrgroup != INTRGEN) + switch(I->intrval.intrstuff) { + case TYREAL: + I->intrval.intrstuff = TYDREAL; + I->intrval.intrno = I->intrval.dblintrno; + break; + case TYCOMPLEX: + I->intrval.intrstuff = TYDCOMPLEX; + I->intrval.intrno = I->intrval.dblintrno; + I->intrval.dblcmplx = 1; + } + + for(S = spectab; S->atype; S++) + switch(S->atype) { + case TYCOMPLEX: + S->atype = TYDCOMPLEX; + if (S->rtype == TYREAL) + S->rtype = TYDREAL; + else if (S->rtype == TYCOMPLEX) + S->rtype = TYDCOMPLEX; + switch(S->spxname[0]) { + case 'r': + S->spxname[0] = 'd'; + break; + case 'c': + S->spxname[0] = 'z'; + break; + default: + Fatal("r8fix bug"); + } + break; + case TYREAL: + S->atype = TYDREAL; + switch(S->rtype) { + case TYREAL: + S->rtype = TYDREAL; + if (S->spxname[0] != 'r') + Fatal("r8fix bug"); + S->spxname[0] = 'd'; + case TYDREAL: /* d_prod */ + break; + + case TYSHORT: + if (!strcmp(S->spxname, "hr_expn")) + S->spxname[1] = 'd'; + else if (!strcmp(S->spxname, "h_nint")) + strcpy(S->spxname, "h_dnnt"); + else Fatal("r8fix bug"); + break; + + case TYLONG: + if (!strcmp(S->spxname, "ir_expn")) + S->spxname[1] = 'd'; + else if (!strcmp(S->spxname, "i_nint")) + strcpy(S->spxname, "i_dnnt"); + else Fatal("r8fix bug"); + break; + + default: + Fatal("r8fix bug"); + } + } + } + + static expptr +#ifdef KR_headers +foldminmax(ismin, argsp) int ismin; struct Listblock *argsp; +#else +foldminmax(int ismin, struct Listblock *argsp) +#endif +{ +#ifndef NO_LONG_LONG + Llong cq, cq1; +#endif + Constp h; + double cd, cd1; + ftnint ci; + int mtype; + struct Chain *cp, *cpx; + + mtype = argsp->vtype; + cp = cpx = argsp->listp; + h = &((expptr)cp->datap)->constblock; +#ifndef NO_LONG_LONG + if (mtype == TYQUAD) { + cq = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci; + while(cp = cp->nextp) { + h = &((expptr)cp->datap)->constblock; + cq1 = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci; + if (ismin) { + if (cq > cq1) { + cq = cq1; + cpx = cp; + } + } + else { + if (cq < cq1) { + cq = cq1; + cpx = cp; + } + } + } + } + else +#endif + if (ISINT(mtype)) { + ci = h->Const.ci; + if (ismin) + while(cp = cp->nextp) { + h = &((expptr)cp->datap)->constblock; + if (ci > h->Const.ci) { + ci = h->Const.ci; + cpx = cp; + } + } + else + while(cp = cp->nextp) { + h = &((expptr)cp->datap)->constblock; + if (ci < h->Const.ci) { + ci = h->Const.ci; + cpx = cp; + } + } + } + else { + if (ISREAL(h->vtype)) + cd = h->vstg ? atof(h->Const.cds[0]) : h->Const.cd[0]; +#ifndef NO_LONG_LONG + else if (h->vtype == TYQUAD) + cd = h->Const.cq; +#endif + else + cd = h->Const.ci; + while(cp = cp->nextp) { + h = &((expptr)cp->datap)->constblock; + if (ISREAL(h->vtype)) + cd1 = h->vstg ? atof(h->Const.cds[0]) + : h->Const.cd[0]; +#ifndef NO_LONG_LONG + else if (h->vtype == TYQUAD) + cd1 = h->Const.cq; +#endif + else + cd1 = h->Const.ci; + if (ismin) { + if (cd > cd1) { + cd = cd1; + cpx = cp; + } + } + else { + if (cd < cd1) { + cd = cd1; + cpx = cp; + } + } + } + } + h = &((expptr)cpx->datap)->constblock; + cpx->datap = 0; + frexpr((tagptr)argsp); + if (h->vtype != mtype) + return mkconv(mtype, (expptr)h); + return (expptr)h; + } + + + expptr +#ifdef KR_headers +intrcall(np, argsp, nargs) + Namep np; + struct Listblock *argsp; + int nargs; +#else +intrcall(Namep np, struct Listblock *argsp, int nargs) +#endif +{ + int i, rettype; + ftnint k; + Addrp ap; + register struct Specblock *sp; + register struct Chain *cp; + expptr q, ep; + int constargs, mtype, op; + int f1field, f2field, f3field; + char *s; + static char bit_bits[] = "?bit_bits", + bit_shift[] = "?bit_shift", + bit_cshift[] = "?bit_cshift"; + static char *bitop[3] = { bit_bits, bit_shift, bit_cshift }; + static int t_pref[2] = { 'l', 'q' }; + + packed.ijunk = np->vardesc.varno; + f1field = packed.bits.f1; + f2field = packed.bits.f2; + f3field = packed.bits.f3; + if(nargs == 0) + goto badnargs; + + mtype = 0; + constargs = 1; + for(cp = argsp->listp ; cp ; cp = cp->nextp) + { + ep = (expptr)cp->datap; + if (!ISCONST(ep)) + constargs = 0; + else if( ep->headblock.vtype==TYSHORT ) + cp->datap = (char *) mkconv(tyint, ep); + mtype = maxtype(mtype, ep->headblock.vtype); + } + + switch(f1field) + { + case INTRBGEN: + op = f3field; + if( ! ONEOF(mtype, MSKINT) ) + goto badtype; + if (op < OPBITBITS) { + if(nargs != 2) + goto badnargs; + if (op != OPBITTEST) { +#ifdef TYQUAD + if (mtype == TYQUAD) + op += 2; +#endif + goto intrbool2; + } + q = mkexpr(op, (expptr)argsp->listp->datap, + (expptr)argsp->listp->nextp->datap); + q->exprblock.vtype = TYLOGICAL; + goto intrbool2a; + } + if (nargs != 2 && (nargs != 3 || op == OPBITSH)) + goto badnargs; + cp = argsp->listp; + ep = (expptr)cp->datap; + if (ep->headblock.vtype < TYLONG) + cp->datap = (char *)mkconv(TYLONG, ep); + while(cp->nextp) { + cp = cp->nextp; + ep = (expptr)cp->datap; + if (ep->headblock.vtype != TYLONG) + cp->datap = (char *)mkconv(TYLONG, ep); + } + if (op == OPBITSH) { + ep = (expptr)argsp->listp->nextp->datap; + if (ISCONST(ep)) { + if ((k = ep->constblock.Const.ci) < 0) { + q = (expptr)argsp->listp->datap; + if (ISCONST(q)) { + ep->constblock.Const.ci = -k; + op = OPRSHIFT; + goto intrbool2; + } + } + else { + op = OPLSHIFT; + goto intrbool2; + } + } + } + else if (nargs == 2) { + if (op == OPBITBITS) + goto badnargs; + cp->nextp = mkchain((char*)ICON(-1), 0); + } + ep = (expptr)argsp->listp->datap; + i = ep->headblock.vtype; + s = bitop[op - OPBITBITS]; + *s = t_pref[i - TYLONG]; + ap = builtin(i, s, 1); + return fixexpr((Exprp) + mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); + + case INTRBOOL: + op = f3field; + if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) ) + goto badtype; + if(op == OPBITNOT) + { + if(nargs != 1) + goto badnargs; + q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL); + } + else + { + if(nargs != 2) + goto badnargs; + intrbool2: + q = mkexpr(op, (expptr)argsp->listp->datap, + (expptr)argsp->listp->nextp->datap); + } + intrbool2a: + frchain( &(argsp->listp) ); + free( (charptr) argsp); + return(q); + + case INTRCONV: + rettype = f2field; + switch(rettype) { + case TYLONG: + rettype = tyint; + break; + case TYLOGICAL: + rettype = tylog; + } + if( ISCOMPLEX(rettype) && nargs==2) + { + expptr qr, qi; + qr = (expptr) argsp->listp->datap; + qi = (expptr) argsp->listp->nextp->datap; + if (qr->headblock.vtype == TYDREAL + || qi->headblock.vtype == TYDREAL) + rettype = TYDCOMPLEX; + if(ISCONST(qr) && ISCONST(qi)) + q = mkcxcon(qr,qi); + else q = mkexpr(OPCONV,mkconv(rettype-2,qr), + mkconv(rettype-2,qi)); + } + else if(nargs == 1) { + if (f3field && ((Exprp)argsp->listp->datap)->vtype + == TYDCOMPLEX) + rettype = TYDREAL; + q = mkconv(rettype+100, (expptr)argsp->listp->datap); + if (q->tag == TADDR) + q->addrblock.parenused = 1; + } + else goto badnargs; + + q->headblock.vtype = rettype; + frchain(&(argsp->listp)); + free( (charptr) argsp); + return(q); + + +#if 0 + case INTRCNST: + +/* Machine-dependent f77 stuff that f2c omits: + +intcon contains + radix for short int + radix for long int + radix for single precision + radix for double precision + precision for short int + precision for long int + precision for single precision + precision for double precision + emin for single precision + emin for double precision + emax for single precision + emax for double prcision + largest short int + largest long int + +realcon contains + tiny for single precision + tiny for double precision + huge for single precision + huge for double precision + mrsp (epsilon) for single precision + mrsp (epsilon) for double precision +*/ + { register struct Incstblock *cstp; + extern ftnint intcon[14]; + extern double realcon[6]; + + cstp = consttab + f3field; + for(i=0 ; iatype == mtype) + goto foundconst; + else + ++cstp; + goto badtype; + +foundconst: + switch(cstp->rtype) + { + case TYLONG: + return(mkintcon(intcon[cstp->constno])); + + case TYREAL: + case TYDREAL: + return(mkrealcon(cstp->rtype, + realcon[cstp->constno]) ); + + default: + Fatal("impossible intrinsic constant"); + } + } +#endif + + case INTRGEN: + sp = spectab + f3field; + if(no66flag) + if(sp->atype == mtype) + goto specfunct; + else err66("generic function"); + + for(i=0; iatype == mtype) + goto specfunct; + else + ++sp; + warn1 ("bad argument type to intrinsic %s", np->fvarname); + +/* Made this a warning rather than an error so things like "log (5) ==> + log (5.0)" can be accommodated. When none of these cases matches, the + argument is cast up to the first type in the spectab list; this first + type is assumed to be the "smallest" type, e.g. REAL before DREAL + before COMPLEX, before DCOMPLEX */ + + sp = spectab + f3field; + mtype = sp -> atype; + goto specfunct; + + case INTRSPEC: + sp = spectab + f3field; +specfunct: + if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) + && (sp+1)->atype==sp->atype) + ++sp; + + if(nargs != sp->nargs) + goto badnargs; + if(mtype != sp->atype) + goto badtype; + +/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in + the inline expression wouldn't get put into the constant table */ + + fixargs (NO, argsp); + cast_args (mtype, argsp -> listp); + + if(q = Inline((int)(sp-spectab), mtype, argsp->listp)) + { + frchain( &(argsp->listp) ); + free( (charptr) argsp); + } else { + + if(sp->othername) { + /* C library routines that return double... */ + /* sp->rtype might be TYREAL */ + ap = builtin(sp->rtype, + callbyvalue[sp->othername], 1); + q = fixexpr((Exprp) + mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); + } else { + fixargs(YES, argsp); + ap = builtin(sp->rtype, sp->spxname, 0); + q = fixexpr((Exprp) + mkexpr(OPCALL, (expptr)ap, (expptr)argsp) ); + } /* else */ + } /* else */ + return(q); + + case INTRMIN: + case INTRMAX: + if(nargs < 2) + goto badnargs; + if( ! ONEOF(mtype, MSKINT|MSKREAL) ) + goto badtype; + argsp->vtype = mtype; + if (constargs) + q = foldminmax(f1field==INTRMIN, argsp); + else + q = mkexpr(f1field==INTRMIN ? OPMIN : OPMAX, + (expptr)argsp, ENULL); + + q->headblock.vtype = mtype; + rettype = f2field; + if(rettype == TYLONG) + rettype = tyint; + else if(rettype == TYUNKNOWN) + rettype = mtype; + return( mkconv(rettype, q) ); + + default: + fatali("intrcall: bad intrgroup %d", f1field); + } +badnargs: + errstr("bad number of arguments to intrinsic %s", np->fvarname); + goto bad; + +badtype: + errstr("bad argument type to intrinsic %s", np->fvarname); + +bad: + return( errnode() ); +} + + + + int +#ifdef KR_headers +intrfunct(s) + char *s; +#else +intrfunct(char *s) +#endif +{ + register struct Intrblock *p; + int i; + extern int intr_omit; + + for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p) + { + if( !strcmp(s, p->intrfname) ) + { + if (i = p->intrval.extflag) { + if (i & intr_omit) + return 0; + if (noextflag) + errext(s); + } + packed.bits.f1 = p->intrval.intrgroup; + packed.bits.f2 = p->intrval.intrstuff; + packed.bits.f3 = p->intrval.intrno; + packed.bits.f4 = p->intrval.dblcmplx; + return(packed.ijunk); + } + } + + return(0); +} + + + + + + Addrp +#ifdef KR_headers +intraddr(np) + Namep np; +#else +intraddr(Namep np) +#endif +{ + Addrp q; + register struct Specblock *sp; + int f3field; + + if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC) + fatalstr("intraddr: %s is not intrinsic", np->fvarname); + packed.ijunk = np->vardesc.varno; + f3field = packed.bits.f3; + + switch(packed.bits.f1) + { + case INTRGEN: + /* imag, log, and log10 arent specific functions */ + if(f3field==31 || f3field==43 || f3field==47) + goto bad; + + case INTRSPEC: + sp = spectab + f3field; + if (tyint == TYLONG + && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL)) + ++sp; + q = builtin(sp->rtype, sp->spxname, + sp->othername ? 1 : 0); + return(q); + + case INTRCONV: + case INTRMIN: + case INTRMAX: + case INTRBOOL: + case INTRCNST: + case INTRBGEN: +bad: + errstr("cannot pass %s as actual", np->fvarname); + return((Addrp)errnode()); + } + fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1); + /* NOT REACHED */ return 0; +} + + + + void +#ifdef KR_headers +cast_args(maxtype, args) + int maxtype; + chainp args; +#else +cast_args(int maxtype, chainp args) +#endif +{ + for (; args; args = args -> nextp) { + expptr e = (expptr) args->datap; + if (e -> headblock.vtype != maxtype) + if (e -> tag == TCONST) + args->datap = (char *) mkconv(maxtype, e); + else { + Addrp temp = mktmp(maxtype, ENULL); + + puteq(cpexpr((expptr)temp), e); + args->datap = (char *)temp; + } /* else */ + } /* for */ +} /* cast_args */ + + + + expptr +#ifdef KR_headers +Inline(fno, type, args) + int fno; + int type; + struct Chain *args; +#else +Inline(int fno, int type, struct Chain *args) +#endif +{ + register expptr q, t, t1; + + switch(fno) + { + case 8: /* real abs */ + case 9: /* short int abs */ + case 10: /* long int abs */ + case 11: /* double precision abs */ + if( addressable(q = (expptr) args->datap) ) + { + t = q; + q = NULL; + } + else + t = (expptr) mktmp(type,ENULL); + t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS, + cpexpr(t), ENULL); + if(q) + t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1); + frexpr(t); + return(t1); + + case 26: /* dprod */ + q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap), + (expptr)args->nextp->datap); + return(q); + + case 27: /* len of character string */ + q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng); + frexpr((expptr)args->datap); + return mkconv(tyioint, q); + + case 14: /* half-integer mod */ + case 15: /* mod */ + return mkexpr(OPMOD, (expptr) args->datap, + (expptr) args->nextp->datap); + } + return(NULL); +} diff --git a/unix/f2c/src/io.c b/unix/f2c/src/io.c new file mode 100644 index 00000000..ed1ed160 --- /dev/null +++ b/unix/f2c/src/io.c @@ -0,0 +1,1509 @@ +/**************************************************************** +Copyright 1990, 1991, 1993, 1994, 1996, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* Routines to generate code for I/O statements. + Some corrections and improvements due to David Wasley, U. C. Berkeley +*/ + +/* TEMPORARY */ +#define TYIOINT TYLONG +#define SZIOINT SZLONG + +#include "defs.h" +#include "names.h" +#include "iob.h" + +extern int byterev, inqmask; + +static void dofclose Argdcl((void)); +static void dofinquire Argdcl((void)); +static void dofmove Argdcl((char*)); +static void dofopen Argdcl((void)); +static void doiolist Argdcl((chainp)); +static void ioset Argdcl((int, int, expptr)); +static void ioseta Argdcl((int, Addrp)); +static void iosetc Argdcl((int, expptr)); +static void iosetip Argdcl((int, int)); +static void iosetlc Argdcl((int, int, int)); +static void putio Argdcl((expptr, expptr)); +static void putiocall Argdcl((expptr)); + +iob_data *iob_list; +Addrp io_structs[9]; + +LOCAL char ioroutine[12]; + +LOCAL long ioendlab; +LOCAL long ioerrlab; +LOCAL int endbit; +LOCAL int errbit; +LOCAL long jumplab; +LOCAL long skiplab; +LOCAL int ioformatted; +LOCAL int statstruct = NO; +LOCAL struct Labelblock *skiplabel; +Addrp ioblkp; + +#define UNFORMATTED 0 +#define FORMATTED 1 +#define LISTDIRECTED 2 +#define NAMEDIRECTED 3 + +#define V(z) ioc[z].iocval + +#define IOALL 07777 + +LOCAL struct Ioclist +{ + char *iocname; + int iotype; + expptr iocval; +} +ioc[ ] = +{ + { "", 0 }, + { "unit", IOALL }, + { "fmt", M(IOREAD) | M(IOWRITE) }, + { "err", IOALL }, + { "end", M(IOREAD) }, + { "iostat", IOALL }, + { "rec", M(IOREAD) | M(IOWRITE) }, + { "recl", M(IOOPEN) | M(IOINQUIRE) }, + { "file", M(IOOPEN) | M(IOINQUIRE) }, + { "status", M(IOOPEN) | M(IOCLOSE) }, + { "access", M(IOOPEN) | M(IOINQUIRE) }, + { "form", M(IOOPEN) | M(IOINQUIRE) }, + { "blank", M(IOOPEN) | M(IOINQUIRE) }, + { "exist", M(IOINQUIRE) }, + { "opened", M(IOINQUIRE) }, + { "number", M(IOINQUIRE) }, + { "named", M(IOINQUIRE) }, + { "name", M(IOINQUIRE) }, + { "sequential", M(IOINQUIRE) }, + { "direct", M(IOINQUIRE) }, + { "formatted", M(IOINQUIRE) }, + { "unformatted", M(IOINQUIRE) }, + { "nextrec", M(IOINQUIRE) }, + { "nml", M(IOREAD) | M(IOWRITE) } +}; + +#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) + +/* #define IOSUNIT 1 */ +/* #define IOSFMT 2 */ +#define IOSERR 3 +#define IOSEND 4 +#define IOSIOSTAT 5 +#define IOSREC 6 +#define IOSRECL 7 +#define IOSFILE 8 +#define IOSSTATUS 9 +#define IOSACCESS 10 +#define IOSFORM 11 +#define IOSBLANK 12 +#define IOSEXISTS 13 +#define IOSOPENED 14 +#define IOSNUMBER 15 +#define IOSNAMED 16 +#define IOSNAME 17 +#define IOSSEQUENTIAL 18 +#define IOSDIRECT 19 +#define IOSFORMATTED 20 +#define IOSUNFORMATTED 21 +#define IOSNEXTREC 22 +#define IOSNML 23 + +#define IOSTP V(IOSIOSTAT) + + +/* offsets in generated structures */ + +#define SZFLAG SZIOINT + +/* offsets for external READ and WRITE statements */ + +#define XERR 0 +#define XUNIT SZFLAG +#define XEND SZFLAG + SZIOINT +#define XFMT 2*SZFLAG + SZIOINT +#define XREC 2*SZFLAG + SZIOINT + SZADDR + +/* offsets for internal READ and WRITE statements */ + +#define XIUNIT SZFLAG +#define XIEND SZFLAG + SZADDR +#define XIFMT 2*SZFLAG + SZADDR +#define XIRLEN 2*SZFLAG + 2*SZADDR +#define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT +#define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT + +/* offsets for OPEN statements */ + +#define XFNAME SZFLAG + SZIOINT +#define XFNAMELEN SZFLAG + SZIOINT + SZADDR +#define XSTATUS SZFLAG + 2*SZIOINT + SZADDR +#define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR +#define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR +#define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR +#define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR + +/* offset for CLOSE statement */ + +#define XCLSTATUS SZFLAG + SZIOINT + +/* offsets for INQUIRE statement */ + +#define XFILE SZFLAG + SZIOINT +#define XFILELEN SZFLAG + SZIOINT + SZADDR +#define XEXISTS SZFLAG + 2*SZIOINT + SZADDR +#define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR +#define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR +#define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR +#define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR +#define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR +#define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR +#define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR +#define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR +#define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR +#define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR +#define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR +#define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR +#define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR +#define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR +#define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR +#define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR +#define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR +#define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR +#define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR +#define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR +#define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR + +LOCAL char *cilist_names[] = { + "cilist", + "cierr", + "ciunit", + "ciend", + "cifmt", + "cirec" + }; +LOCAL char *icilist_names[] = { + "icilist", + "icierr", + "iciunit", + "iciend", + "icifmt", + "icirlen", + "icirnum" + }; +LOCAL char *olist_names[] = { + "olist", + "oerr", + "ounit", + "ofnm", + "ofnmlen", + "osta", + "oacc", + "ofm", + "orl", + "oblnk" + }; +LOCAL char *cllist_names[] = { + "cllist", + "cerr", + "cunit", + "csta" + }; +LOCAL char *alist_names[] = { + "alist", + "aerr", + "aunit" + }; +LOCAL char *inlist_names[] = { + "inlist", + "inerr", + "inunit", + "infile", + "infilen", + "inex", + "inopen", + "innum", + "innamed", + "inname", + "innamlen", + "inacc", + "inacclen", + "inseq", + "inseqlen", + "indir", + "indirlen", + "infmt", + "infmtlen", + "inform", + "informlen", + "inunf", + "inunflen", + "inrecl", + "innrec", + "inblank", + "inblanklen" + }; + +LOCAL char **io_fields; + +#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t + +LOCAL io_setup io_stuff[] = { + zork(cilist_names, TYCILIST), /* external read/write */ + zork(inlist_names, TYINLIST), /* inquire */ + zork(olist_names, TYOLIST), /* open */ + zork(cllist_names, TYCLLIST), /* close */ + zork(alist_names, TYALIST), /* rewind */ + zork(alist_names, TYALIST), /* backspace */ + zork(alist_names, TYALIST), /* endfile */ + zork(icilist_names,TYICILIST), /* internal read */ + zork(icilist_names,TYICILIST) /* internal write */ + }; + +#undef zork + + int +#ifdef KR_headers +fmtstmt(lp) + register struct Labelblock *lp; +#else +fmtstmt(register struct Labelblock *lp) +#endif +{ + if(lp == NULL) + { + execerr("unlabeled format statement" , CNULL); + return(-1); + } + if(lp->labtype == LABUNKNOWN) + { + lp->labtype = LABFORMAT; + lp->labelno = (int)newlabel(); + } + else if(lp->labtype != LABFORMAT) + { + execerr("bad format number", CNULL); + return(-1); + } + return(lp->labelno); +} + + + void +#ifdef KR_headers +setfmt(lp) + struct Labelblock *lp; +#else +setfmt(struct Labelblock *lp) +#endif +{ + char *s, *s0, *sc, *se, *t; + int k, n, parity; + + s0 = s = lexline(&n); + se = t = s + n; + + /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */ + /* following FORMAT... */ + + if (n <= 0) + warn("No (...) after FORMAT"); + else if (*s != '(') + warni("%c rather than ( after FORMAT", *s); + else if (se[-1] != ')') { + *se = 0; + while(--t > s && *t != ')') ; + if (t <= s) + warn("No ) at end of FORMAT statement"); + else if (se - t > 30) + warn1("Extraneous text at end of FORMAT: ...%s", se-12); + else + warn1("Extraneous text at end of FORMAT: %s", t+1); + t = se; + } + + /* fix MYQUOTES (\002's) and \\'s */ + + parity = 1; + str_fmt['%'] = "%"; + while(s < se) { + k = *(unsigned char *)s++; + if (k == 2) { + if ((parity ^= 1) && *s == 2) { + t -= 2; + ++s; + } + else + t += 3; + } + else { + sc = str_fmt[k]; + while(*++sc) + t++; + } + } + s = s0; + parity = 1; + if (lp) { + lp->fmtstring = t = mem((int)(t - s + 1), 0); + while(s < se) { + k = *(unsigned char *)s++; + if (k == 2) { + if ((parity ^= 1) && *s == 2) + s++; + else { + t[0] = '\\'; + t[1] = '0'; + t[2] = '0'; + t[3] = '2'; + t += 4; + } + } + else { + sc = str_fmt[k]; + do *t++ = *sc++; + while(*sc); + } + } + *t = 0; + } + str_fmt['%'] = "%%"; + flline(); +} + + + void +#ifdef KR_headers +startioctl() +#else +startioctl() +#endif +{ + register int i; + + inioctl = YES; + nioctl = 0; + ioformatted = UNFORMATTED; + for(i = 1 ; i<=NIOS ; ++i) + V(i) = NULL; +} + + static long +newiolabel(Void) { + long rv; + rv = ++lastiolabno; + skiplabel = mklabel(rv); + skiplabel->labdefined = 1; + return rv; + } + + void +endioctl(Void) +{ + int i; + expptr p; + struct io_setup *ios; + + inioctl = NO; + + /* set up for error recovery */ + + ioerrlab = ioendlab = skiplab = jumplab = 0; + + if(p = V(IOSEND)) + if(ISICON(p)) + execlab(ioendlab = p->constblock.Const.ci); + else + err("bad end= clause"); + + if(p = V(IOSERR)) + if(ISICON(p)) + execlab(ioerrlab = p->constblock.Const.ci); + else + err("bad err= clause"); + + if(IOSTP) + if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) + { + err("iostat must be an integer variable"); + frexpr(IOSTP); + IOSTP = NULL; + } + + if(iostmt == IOREAD) + { + if(IOSTP) + { + if(ioerrlab && ioendlab && ioerrlab==ioendlab) + jumplab = ioerrlab; + else + skiplab = jumplab = newiolabel(); + } + else { + if(ioerrlab && ioendlab && ioerrlab!=ioendlab) + { + IOSTP = (expptr) mktmp(TYINT, ENULL); + skiplab = jumplab = newiolabel(); + } + else + jumplab = (ioerrlab ? ioerrlab : ioendlab); + } + } + else if(iostmt == IOWRITE) + { + if(IOSTP && !ioerrlab) + skiplab = jumplab = newiolabel(); + else + jumplab = ioerrlab; + } + else + jumplab = ioerrlab; + + endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ + errbit = IOSTP!=NULL || ioerrlab!=0; + if (jumplab && !IOSTP) + IOSTP = (expptr) mktmp(TYINT, ENULL); + + if(iostmt!=IOREAD && iostmt!=IOWRITE) + { + ios = io_stuff + iostmt; + io_fields = ios->fields; + ioblkp = io_structs[iostmt]; + if(ioblkp == NULL) + io_structs[iostmt] = ioblkp = + autovar(1, ios->type, ENULL, ""); + ioset(TYIOINT, XERR, ICON(errbit)); + } + + switch(iostmt) + { + case IOOPEN: + dofopen(); + break; + + case IOCLOSE: + dofclose(); + break; + + case IOINQUIRE: + dofinquire(); + break; + + case IOBACKSPACE: + dofmove("f_back"); + break; + + case IOREWIND: + dofmove("f_rew"); + break; + + case IOENDFILE: + dofmove("f_end"); + break; + + case IOREAD: + case IOWRITE: + startrw(); + break; + + default: + fatali("impossible iostmt %d", iostmt); + } + for(i = 1 ; i<=NIOS ; ++i) + if(i!=IOSIOSTAT && V(i)!=NULL) + frexpr(V(i)); +} + + + int +iocname(Void) +{ + register int i; + int found, mask; + + found = 0; + mask = M(iostmt); + for(i = 1 ; i <= NIOS ; ++i) + if(!strcmp(ioc[i].iocname, token)) + if(ioc[i].iotype & mask) + return(i); + else { + found = i; + break; + } + if(found) { + if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) { + NOEXT("open with \"name=\" treated as \"file=\""); + for(i = 1; strcmp(ioc[i].iocname, "file"); i++); + return i; + } + errstr("invalid control %s for statement", ioc[found].iocname); + } + else + errstr("unknown iocontrol %s", token); + return(IOSBAD); +} + + + void +#ifdef KR_headers +ioclause(n, p) + register int n; + register expptr p; +#else +ioclause(register int n, register expptr p) +#endif +{ + struct Ioclist *iocp; + + ++nioctl; + if(n == IOSBAD) + return; + if(n == IOSPOSITIONAL) + { + n = nioctl; + if (n == IOSFMT) { + if (iostmt == IOOPEN) { + n = IOSFILE; + NOEXT("file= specifier omitted from open"); + } + else if (iostmt < IOREAD) + goto illegal; + } + else if(n > IOSFMT) + { + illegal: + err("illegal positional iocontrol"); + return; + } + } + else if (n == IOSNML) + n = IOSFMT; + + if(p == NULL) + { + if(n == IOSUNIT) + p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); + else if(n != IOSFMT) + { + err("illegal * iocontrol"); + return; + } + } + if(n == IOSFMT) + ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); + + iocp = & ioc[n]; + if(iocp->iocval == NULL) + { + if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) ) + p = fixtype(p); + else if (p && p->tag == TPRIM + && p->primblock.namep->vclass == CLUNKNOWN) { + /* kludge made necessary by attempt to infer types + * for untyped external parameters: given an error + * in calling sequences, an integer argument might + * tentatively be assumed TYCHAR; this would otherwise + * be corrected too late in startrw after startrw + * had decided this to be an internal file. + */ + vardcl(p->primblock.namep); + p->primblock.vtype = p->primblock.namep->vtype; + } + iocp->iocval = p; + } + else + errstr("iocontrol %s repeated", iocp->iocname); +} + +/* io list item */ + + void +#ifdef KR_headers +doio(list) + chainp list; +#else +doio(chainp list) +#endif +{ + if(ioformatted == NAMEDIRECTED) + { + if(list) + err("no I/O list allowed in NAMELIST read/write"); + } + else + { + doiolist(list); + ioroutine[0] = 'e'; + if (skiplab) + jumplab = 0; + putiocall( call0(TYINT, ioroutine) ); + } +} + + + + + + LOCAL void +#ifdef KR_headers +doiolist(p0) + chainp p0; +#else +doiolist(chainp p0) +#endif +{ + chainp p; + register tagptr q; + register expptr qe; + register Namep qn; + Addrp tp; + int range; + extern char *ohalign; + + for (p = p0 ; p ; p = p->nextp) + { + q = (tagptr)p->datap; + if(q->tag == TIMPLDO) + { + exdo(range = (int)newlabel(), (Namep)0, + q->impldoblock.impdospec); + doiolist(q->impldoblock.datalist); + enddo(range); + free( (charptr) q); + } + else { + if(q->tag==TPRIM && q->primblock.argsp==NULL + && q->primblock.namep->vdim!=NULL) + { + vardcl(qn = q->primblock.namep); + if(qn->vdim->nelt) { + putio( fixtype(cpexpr(qn->vdim->nelt)), + (expptr)mkscalar(qn) ); + qn->vlastdim = 0; + } + else + err("attempt to i/o array of unknown size"); + } + else if(q->tag==TPRIM && q->primblock.argsp==NULL && + (qe = (expptr) memversion(q->primblock.namep)) ) + putio(ICON(1),qe); + else if (ISCONST(q) && q->constblock.vtype == TYCHAR) { + halign = 0; + putio(ICON(1), qe = fixtype(cpexpr(q))); + halign = ohalign; + } + else if(((qe = fixtype(cpexpr(q)))->tag==TADDR && + (qe->addrblock.uname_tag != UNAM_CONST || + !ISCOMPLEX(qe -> addrblock.vtype))) || + (qe -> tag == TCONST && !ISCOMPLEX(qe -> + headblock.vtype))) { + if (qe -> tag == TCONST) + qe = (expptr) putconst((Constp)qe); + putio(ICON(1), qe); + } + else if(qe->headblock.vtype != TYERROR) + { + if(iostmt == IOWRITE) + { + expptr qvl; + qvl = NULL; + if( ISCHAR(qe) ) + { + qvl = (expptr) + cpexpr(qe->headblock.vleng); + tp = mktmp(qe->headblock.vtype, + ICON(lencat(qe))); + } + else + tp = mktmp(qe->headblock.vtype, + qe->headblock.vleng); + puteq( cpexpr((expptr)tp), qe); + if(qvl) /* put right length on block */ + { + frexpr(tp->vleng); + tp->vleng = qvl; + } + putio(ICON(1), (expptr)tp); + } + else + err("non-left side in READ list"); + } + frexpr(q); + } + } + frchain( &p0 ); +} + + int iocalladdr = TYADDR; /* for fixing TYADDR in saveargtypes */ + int typeconv[TYERROR+1] = { +#ifdef TYQUAD + 0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15 +#else + 0, 1, 11, 2, 3, 4, 5, 6, 7, 12, 13, 8, 9, 10, 14 +#endif + }; + + LOCAL void +#ifdef KR_headers +putio(nelt, addr) + expptr nelt; + register expptr addr; +#else +putio(expptr nelt, register expptr addr) +#endif +{ + int type; + register expptr q; + register Addrp c = 0; + + type = addr->headblock.vtype; + if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) + { + nelt = mkexpr(OPSTAR, ICON(2), nelt); + type -= (TYCOMPLEX-TYREAL); + } + + /* pass a length with every item. for noncharacter data, fake one */ + if(type != TYCHAR) + { + + if( ISCONST(addr) ) + addr = (expptr) putconst((Constp)addr); + c = ALLOC(Addrblock); + c->tag = TADDR; + c->vtype = TYLENG; + c->vstg = STGAUTO; + c->ntempelt = 1; + c->isarray = 1; + c->memoffset = ICON(0); + c->uname_tag = UNAM_IDENT; + c->charleng = 1; + sprintf(c->user.ident, "(ftnlen)sizeof(%s)", Typename[type]); + addr = mkexpr(OPCHARCAST, addr, ENULL); + } + + nelt = fixtype( mkconv(tyioint,nelt) ); + if(ioformatted == LISTDIRECTED) { + expptr mc = mkconv(tyioint, ICON(typeconv[type])); + q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c) + : call3(TYINT, "do_lio", mc, nelt, addr); + } + else { + char *s = (char*)(ioformatted==FORMATTED ? "do_fio" + : !byterev ? "do_uio" + : ONEOF(type, M(TYCHAR)|M(TYINT1)|M(TYLOGICAL1)) + ? "do_ucio" : "do_unio"); + q = c ? call3(TYINT, s, nelt, addr, (expptr)c) + : call2(TYINT, s, nelt, addr); + } + iocalladdr = TYCHAR; + putiocall(q); + iocalladdr = TYADDR; +} + + + + void +endio(Void) +{ + if(skiplab) + { + if (ioformatted != NAMEDIRECTED) + p1_label((long)(skiplabel - labeltab)); + if(ioendlab) { + exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0))); + exgoto(execlab(ioendlab)); + exendif(); + } + if(ioerrlab) { + exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE + ? OPGT : OPNE, + cpexpr(IOSTP), ICON(0))); + exgoto(execlab(ioerrlab)); + exendif(); + } + } + + if(IOSTP) + frexpr(IOSTP); +} + + + + LOCAL void +#ifdef KR_headers +putiocall(q) + register expptr q; +#else +putiocall(register expptr q) +#endif +{ + int tyintsave; + + tyintsave = tyint; + tyint = tyioint; /* for -I2 and -i2 */ + + if(IOSTP) + { + q->headblock.vtype = TYINT; + q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q)); + } + putexpr(q); + if(jumplab) { + exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0))); + exgoto(execlab(jumplab)); + exendif(); + } + tyint = tyintsave; +} + + void +#ifdef KR_headers +fmtname(np, q) + Namep np; + register Addrp q; +#else +fmtname(Namep np, register Addrp q) +#endif +{ + register int k; + register char *s, *t; + extern chainp assigned_fmts; + + if (!np->vfmt_asg) { + np->vfmt_asg = 1; + assigned_fmts = mkchain((char *)np, assigned_fmts); + } + k = strlen(s = np->fvarname); + if (k < IDENT_LEN - 4) { + q->uname_tag = UNAM_IDENT; + t = q->user.ident; + } + else { + q->uname_tag = UNAM_CHARP; + q->user.Charp = t = mem(k + 5,0); + } + sprintf(t, "%s_fmt", s); + } + + LOCAL Addrp +#ifdef KR_headers +asg_addr(p) + union Expression *p; +#else +asg_addr(union Expression *p) +#endif +{ + register Addrp q; + + if (p->tag != TPRIM) + badtag("asg_addr", p->tag); + q = ALLOC(Addrblock); + q->tag = TADDR; + q->vtype = TYCHAR; + q->vstg = STGAUTO; + q->ntempelt = 1; + q->isarray = 0; + q->memoffset = ICON(0); + fmtname(p->primblock.namep, q); + return q; + } + + void +startrw(Void) +{ + register expptr p; + register Namep np; + register Addrp unitp, fmtp, recp; + register expptr nump; + int iostmt1; + flag intfile, sequential, ok, varfmt; + struct io_setup *ios; + + /* First look at all the parameters and determine what is to be done */ + + ok = YES; + statstruct = YES; + + intfile = NO; + if(p = V(IOSUNIT)) + { + if( ISINT(p->headblock.vtype) ) { + int_unit: + unitp = (Addrp) cpexpr(p); + } + else if(p->headblock.vtype == TYCHAR) + { + if (nioctl == 1 && iostmt == IOREAD) { + /* kludge to recognize READ(format expr) */ + V(IOSFMT) = p; + V(IOSUNIT) = p = (expptr) IOSTDIN; + ioformatted = FORMATTED; + goto int_unit; + } + intfile = YES; + if(p->tag==TPRIM && p->primblock.argsp==NULL && + (np = p->primblock.namep)->vdim!=NULL) + { + vardcl(np); + if(nump = np->vdim->nelt) + { + nump = fixtype(cpexpr(nump)); + if( ! ISCONST(nump) ) { + statstruct = NO; + np->vlastdim = 0; + } + } + else + { + err("attempt to use internal unit array of unknown size"); + ok = NO; + nump = ICON(1); + } + unitp = mkscalar(np); + } + else { + nump = ICON(1); + unitp = (Addrp /*pjw */) fixtype(cpexpr(p)); + } + if(! isstatic((expptr)unitp) ) + statstruct = NO; + } + else { + err("unit specifier not of type integer or character"); + ok = NO; + } + } + else + { + err("bad unit specifier"); + ok = NO; + } + + sequential = YES; + if(p = V(IOSREC)) + if( ISINT(p->headblock.vtype) ) + { + recp = (Addrp) cpexpr(p); + sequential = NO; + } + else { + err("bad REC= clause"); + ok = NO; + } + else + recp = NULL; + + + varfmt = YES; + fmtp = NULL; + if(p = V(IOSFMT)) + { + if(p->tag==TPRIM && p->primblock.argsp==NULL) + { + np = p->primblock.namep; + if(np->vclass == CLNAMELIST) + { + ioformatted = NAMEDIRECTED; + fmtp = (Addrp) fixtype(p); + V(IOSFMT) = (expptr)fmtp; + if (skiplab) + jumplab = 0; + goto endfmt; + } + vardcl(np); + if(np->vdim) + { + if( ! ONEOF(np->vstg, MSKSTATIC) ) + statstruct = NO; + fmtp = mkscalar(np); + goto endfmt; + } + if( ISINT(np->vtype) ) /* ASSIGNed label */ + { + statstruct = NO; + varfmt = YES; + fmtp = asg_addr(p); + goto endfmt; + } + } + p = V(IOSFMT) = fixtype(p); + if(p->headblock.vtype == TYCHAR + /* Since we allow write(6,n) */ + /* we may as well allow write(6,n(2)) */ + || p->tag == TADDR && ISINT(p->addrblock.vtype)) + { + if( ! isstatic(p) ) + statstruct = NO; + fmtp = (Addrp) cpexpr(p); + } + else if( ISICON(p) ) + { + struct Labelblock *lp; + lp = mklabel(p->constblock.Const.ci); + if (fmtstmt(lp) > 0) + { + fmtp = (Addrp)mkaddcon(lp->stateno); + /* lp->stateno for names fmt_nnn */ + lp->fmtlabused = 1; + varfmt = NO; + } + else + ioformatted = UNFORMATTED; + } + else { + err("bad format descriptor"); + ioformatted = UNFORMATTED; + ok = NO; + } + } + else + fmtp = NULL; + +endfmt: + if(intfile) { + if (ioformatted==UNFORMATTED) { + err("unformatted internal I/O not allowed"); + ok = NO; + } + if (recp) { + err("direct internal I/O not allowed"); + ok = NO; + } + } + if(!sequential && ioformatted==LISTDIRECTED) + { + err("direct list-directed I/O not allowed"); + ok = NO; + } + if(!sequential && ioformatted==NAMEDIRECTED) + { + err("direct namelist I/O not allowed"); + ok = NO; + } + + if( ! ok ) { + statstruct = NO; + return; + } + + /* + Now put out the I/O structure, statically if all the clauses + are constants, dynamically otherwise +*/ + + if (intfile) { + ios = io_stuff + iostmt; + iostmt1 = IOREAD; + } + else { + ios = io_stuff; + iostmt1 = 0; + } + io_fields = ios->fields; + if(statstruct) + { + ioblkp = ALLOC(Addrblock); + ioblkp->tag = TADDR; + ioblkp->vtype = ios->type; + ioblkp->vclass = CLVAR; + ioblkp->vstg = STGINIT; + ioblkp->memno = ++lastvarno; + ioblkp->memoffset = ICON(0); + ioblkp -> uname_tag = UNAM_IDENT; + new_iob_data(ios, + temp_name("io_", lastvarno, ioblkp->user.ident)); } + else if(!(ioblkp = io_structs[iostmt1])) + io_structs[iostmt1] = ioblkp = + autovar(1, ios->type, ENULL, ""); + + ioset(TYIOINT, XERR, ICON(errbit)); + if(iostmt == IOREAD) + ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); + + if(intfile) + { + ioset(TYIOINT, XIRNUM, nump); + ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); + ioseta(XIUNIT, unitp); + } + else + ioset(TYIOINT, XUNIT, (expptr) unitp); + + if(recp) + ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp); + + if(varfmt) + ioseta( intfile ? XIFMT : XFMT , fmtp); + else + ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp); + + ioroutine[0] = 's'; + ioroutine[1] = '_'; + ioroutine[2] = iostmt==IOREAD ? 'r' : 'w'; + ioroutine[3] = "ds"[sequential]; + ioroutine[4] = "ufln"[ioformatted]; + ioroutine[5] = "ei"[intfile]; + ioroutine[6] = '\0'; + + putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) )); + + if(statstruct) + { + frexpr((expptr)ioblkp); + statstruct = NO; + ioblkp = 0; /* unnecessary */ + } +} + + + + LOCAL void +dofopen(Void) +{ + register expptr p; + + if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) + ioset(TYIOINT, XUNIT, cpexpr(p) ); + else + err("bad unit in open"); + if( (p = V(IOSFILE)) ) + if(p->headblock.vtype == TYCHAR) + ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); + else + err("bad file in open"); + + iosetc(XFNAME, p); + + if(p = V(IOSRECL)) + if( ISINT(p->headblock.vtype) ) + ioset(TYIOINT, XRECLEN, cpexpr(p) ); + else + err("bad recl"); + else + ioset(TYIOINT, XRECLEN, ICON(0) ); + + iosetc(XSTATUS, V(IOSSTATUS)); + iosetc(XACCESS, V(IOSACCESS)); + iosetc(XFORMATTED, V(IOSFORM)); + iosetc(XBLANK, V(IOSBLANK)); + + putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) )); +} + + + LOCAL void +dofclose(Void) +{ + register expptr p; + + if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) + { + ioset(TYIOINT, XUNIT, cpexpr(p) ); + iosetc(XCLSTATUS, V(IOSSTATUS)); + putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) ); + } + else + err("bad unit in close statement"); +} + + + LOCAL void +dofinquire(Void) +{ + register expptr p; + if(p = V(IOSUNIT)) + { + if( V(IOSFILE) ) + err("inquire by unit or by file, not both"); + ioset(TYIOINT, XUNIT, cpexpr(p) ); + } + else if( ! V(IOSFILE) ) + err("must inquire by unit or by file"); + iosetlc(IOSFILE, XFILE, XFILELEN); + iosetip(IOSEXISTS, XEXISTS); + iosetip(IOSOPENED, XOPEN); + iosetip(IOSNUMBER, XNUMBER); + iosetip(IOSNAMED, XNAMED); + iosetlc(IOSNAME, XNAME, XNAMELEN); + iosetlc(IOSACCESS, XQACCESS, XQACCLEN); + iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); + iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); + iosetlc(IOSFORM, XFORM, XFORMLEN); + iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); + iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); + iosetip(IOSRECL, XQRECL); + iosetip(IOSNEXTREC, XNEXTREC); + iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); + + putiocall( call1(TYINT, "f_inqu", cpexpr((expptr)ioblkp) )); +} + + + + LOCAL void +#ifdef KR_headers +dofmove(subname) + char *subname; +#else +dofmove(char *subname) +#endif +{ + register expptr p; + + if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) + { + ioset(TYIOINT, XUNIT, cpexpr(p) ); + putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) )); + } + else + err("bad unit in I/O motion statement"); +} + +static int ioset_assign = OPASSIGN; + + LOCAL void +#ifdef KR_headers +ioset(type, offset, p) + int type; + int offset; + register expptr p; +#else +ioset(int type, int offset, register expptr p) +#endif +{ + offset /= SZLONG; + if(statstruct && ISCONST(p)) { + register char *s; + switch(type) { + case TYADDR: /* stmt label */ + s = "fmt_"; + break; + case TYIOINT: + s = ""; + break; + default: + badtype("ioset", type); + } + iob_list->fields[offset] = + string_num(s, p->constblock.Const.ci); + frexpr(p); + } + else { + register Addrp q; + + q = ALLOC(Addrblock); + q->tag = TADDR; + q->vtype = type; + q->vstg = STGAUTO; + q->ntempelt = 1; + q->isarray = 0; + q->memoffset = ICON(0); + q->uname_tag = UNAM_IDENT; + sprintf(q->user.ident, "%s.%s", + statstruct ? iob_list->name : ioblkp->user.ident, + io_fields[offset + 1]); + if (type == TYADDR && p->tag == TCONST + && p->constblock.vtype == TYADDR) { + /* kludge */ + register Addrp p1; + p1 = ALLOC(Addrblock); + p1->tag = TADDR; + p1->vtype = type; + p1->vstg = STGAUTO; /* wrong, but who cares? */ + p1->ntempelt = 1; + p1->isarray = 0; + p1->memoffset = ICON(0); + p1->uname_tag = UNAM_IDENT; + sprintf(p1->user.ident, "fmt_%ld", + p->constblock.Const.ci); + frexpr(p); + p = (expptr)p1; + } + if (type == TYADDR && p->headblock.vtype == TYCHAR) + q->vtype = TYCHAR; + putexpr(mkexpr(ioset_assign, (expptr)q, p)); + } +} + + + + + LOCAL void +#ifdef KR_headers +iosetc(offset, p) + int offset; + register expptr p; +#else +iosetc(int offset, register expptr p) +#endif +{ + if(p == NULL) + ioset(TYADDR, offset, ICON(0) ); + else if(p->headblock.vtype == TYCHAR) { + p = putx(fixtype((expptr)putchop(cpexpr(p)))); + ioset(TYADDR, offset, addrof(p)); + } + else + err("non-character control clause"); +} + + + + LOCAL void +#ifdef KR_headers +ioseta(offset, p) + int offset; + register Addrp p; +#else +ioseta(int offset, register Addrp p) +#endif +{ + char *s, *s1; + static char who[] = "ioseta"; + expptr e, mo; + Namep np; + ftnint ci; + int k; + char buf[24], buf1[24]; + Extsym *comm; + extern int usedefsforcommon; + + if(statstruct) + { + if (!p) + return; + if (p->tag != TADDR) + badtag(who, p->tag); + offset /= SZLONG; + switch(p->uname_tag) { + case UNAM_NAME: + mo = p->memoffset; + if (mo->tag != TCONST) + badtag("ioseta/memoffset", mo->tag); + np = p->user.name; + np->visused = 1; + ci = mo->constblock.Const.ci - np->voffset; + if (np->vstg == STGCOMMON + && !np->vcommequiv + && !usedefsforcommon) { + comm = &extsymtab[np->vardesc.varno]; + sprintf(buf, "%d.", comm->curno); + k = strlen(buf) + strlen(comm->cextname) + + strlen(np->cvarname); + if (ci) { + sprintf(buf1, "+%ld", ci); + k += strlen(buf1); + } + else + buf1[0] = 0; + s = mem(k + 1, 0); + sprintf(s, "%s%s%s%s", comm->cextname, buf, + np->cvarname, buf1); + } + else if (ci) { + sprintf(buf,"%ld", ci); + s1 = p->user.name->cvarname; + k = strlen(buf) + strlen(s1); + sprintf(s = mem(k+2,0), "%s+%s", s1, buf); + } + else + s = cpstring(np->cvarname); + break; + case UNAM_CONST: + s = tostring(p->user.Const.ccp1.ccp0, + (int)p->vleng->constblock.Const.ci); + break; + default: + badthing("uname_tag", who, p->uname_tag); + } + /* kludge for Hollerith */ + if (p->vtype != TYCHAR) { + s1 = mem(strlen(s)+10,0); + sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s); + s = s1; + } + iob_list->fields[offset] = s; + } + else { + if (!p) + e = ICON(0); + else if (p->vtype != TYCHAR) { + NOEXT("non-character variable as format or internal unit"); + e = mkexpr(OPCHARCAST, (expptr)p, ENULL); + } + else + e = addrof((expptr)p); + ioset(TYADDR, offset, e); + } +} + + + + + LOCAL void +#ifdef KR_headers +iosetip(i, offset) + int i; + int offset; +#else +iosetip(int i, int offset) +#endif +{ + register expptr p; + + if(p = V(i)) + if(p->tag==TADDR && + ONEOF(p->addrblock.vtype, inqmask) ) { + ioset_assign = OPASSIGNI; + ioset(TYADDR, offset, addrof(cpexpr(p)) ); + ioset_assign = OPASSIGN; + } + else + errstr("impossible inquire parameter %s", ioc[i].iocname); + else + ioset(TYADDR, offset, ICON(0) ); +} + + + + LOCAL void +#ifdef KR_headers +iosetlc(i, offp, offl) + int i; + int offp; + int offl; +#else +iosetlc(int i, int offp, int offl) +#endif +{ + register expptr p; + if( (p = V(i)) && p->headblock.vtype==TYCHAR) + ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); + iosetc(offp, p); +} diff --git a/unix/f2c/src/iob.h b/unix/f2c/src/iob.h new file mode 100644 index 00000000..065d813a --- /dev/null +++ b/unix/f2c/src/iob.h @@ -0,0 +1,26 @@ +struct iob_data { + struct iob_data *next; + char *type; + char *name; + char *fields[1]; + }; +struct io_setup { + char **fields; + int nelt, type; + }; + +struct defines { + struct defines *next; + char defname[1]; + }; + +typedef struct iob_data iob_data; +typedef struct io_setup io_setup; +typedef struct defines defines; + +extern iob_data *iob_list; +extern struct Addrblock *io_structs[9]; +void def_start Argdcl((FILEP, char*, char*, char*)); +void new_iob_data Argdcl((io_setup*, char*)); +void other_undefs Argdcl((FILEP)); +char* tostring Argdcl((char*, int)); diff --git a/unix/f2c/src/lex.c b/unix/f2c/src/lex.c new file mode 100644 index 00000000..4b4bce4a --- /dev/null +++ b/unix/f2c/src/lex.c @@ -0,0 +1,1749 @@ +/**************************************************************** +Copyright 1990, 1992 - 1997, 1999, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "tokdefs.h" +#include "p1defs.h" + +#ifdef _WIN32 +#undef MSDOS +#define MSDOS +#endif + +#ifdef NO_EOF_CHAR_CHECK +#undef EOF_CHAR +#else +#ifndef EOF_CHAR +#define EOF_CHAR 26 /* ASCII control-Z */ +#endif +#endif + +#define BLANK ' ' +#define MYQUOTE (2) +#define SEOF 0 + +/* card types */ + +#define STEOF 1 +#define STINITIAL 2 +#define STCONTINUE 3 + +/* lex states */ + +#define NEWSTMT 1 +#define FIRSTTOKEN 2 +#define OTHERTOKEN 3 +#define RETEOS 4 + + +LOCAL int stkey; /* Type of the current statement (DO, END, IF, etc) */ +static int needwkey; +ftnint yystno; +flag intonly; +extern int new_dcl; +LOCAL long int stno; +LOCAL long int nxtstno; /* Statement label */ +LOCAL int parlev; /* Parentheses level */ +LOCAL int parseen; +LOCAL int expcom; +LOCAL int expeql; +LOCAL char *nextch; +LOCAL char *lastch; +LOCAL char *nextcd = NULL; +LOCAL char *endcd; +LOCAL long prevlin; +LOCAL long thislin; +LOCAL int code; /* Card type; INITIAL, CONTINUE or EOF */ +LOCAL int lexstate = NEWSTMT; +LOCAL char *sbuf; /* Main buffer for Fortran source input. */ +LOCAL char *send; /* Was = sbuf+20*66 with sbuf[1390]. */ +LOCAL char *shend; /* reflects elbow room for #line lines */ +LOCAL int maxcont; +LOCAL int nincl = 0; /* Current number of include files */ +LOCAL long firstline; +LOCAL char *infname1, *infname2, *laststb, *stb0; +extern int addftnsrc; +static char **linestart; +LOCAL int ncont; +LOCAL char comstart[Table_size]; +#define USC (unsigned char *) + +static char anum_buf[Table_size]; +#define isalnum_(x) anum_buf[x] +#define isalpha_(x) (anum_buf[x] == 1) + +#define COMMENT_BUF_STORE 4088 + +typedef struct comment_buf { + struct comment_buf *next; + char *last; + char buf[COMMENT_BUF_STORE]; + } comment_buf; +static comment_buf *cbfirst, *cbcur; +static char *cbinit, *cbnext, *cblast; +static void flush_comments Argdcl((void)); +extern flag use_bs; +static char *lastfile = "??", *lastfile0 = "?"; +static char fbuf[P1_FILENAME_MAX]; +static long lastline; +static void putlineno(Void); + + +/* Comment buffering data + + Comments are kept in a list until the statement before them has + been parsed. This list is implemented with the above comment_buf + structure and the pointers cbnext and cblast. + + The comments are stored with terminating NULL, and no other + intervening space. The last few bytes of each block are likely to + remain unused. +*/ + +/* struct Inclfile holds the state information for each include file */ +struct Inclfile +{ + struct Inclfile *inclnext; + FILEP inclfp; + char *inclname; + int incllno; + char *incllinp; + int incllen; + int inclcode; + ftnint inclstno; +}; + +LOCAL struct Inclfile *inclp = NULL; +struct Keylist { + char *keyname; + int keyval; + char notinf66; +}; +struct Punctlist { + char punchar; + int punval; +}; +struct Fmtlist { + char fmtchar; + int fmtval; +}; +struct Dotlist { + char *dotname; + int dotval; + }; +LOCAL struct Keylist *keystart[26], *keyend[26]; + +/* KEYWORD AND SPECIAL CHARACTER TABLES +*/ + +static struct Punctlist puncts[ ] = +{ + '(', SLPAR, + ')', SRPAR, + '=', SEQUALS, + ',', SCOMMA, + '+', SPLUS, + '-', SMINUS, + '*', SSTAR, + '/', SSLASH, + '$', SCURRENCY, + ':', SCOLON, + '<', SLT, + '>', SGT, + 0, 0 }; + +LOCAL struct Dotlist dots[ ] = +{ + "and.", SAND, + "or.", SOR, + "not.", SNOT, + "true.", STRUE, + "false.", SFALSE, + "eq.", SEQ, + "ne.", SNE, + "lt.", SLT, + "le.", SLE, + "gt.", SGT, + "ge.", SGE, + "neqv.", SNEQV, + "eqv.", SEQV, + 0, 0 }; + +LOCAL struct Keylist keys[ ] = +{ + { "assign", SASSIGN }, + { "automatic", SAUTOMATIC, YES }, + { "backspace", SBACKSPACE }, + { "blockdata", SBLOCK }, + { "byte", SBYTE }, + { "call", SCALL }, + { "character", SCHARACTER, YES }, + { "close", SCLOSE, YES }, + { "common", SCOMMON }, + { "complex", SCOMPLEX }, + { "continue", SCONTINUE }, + { "data", SDATA }, + { "dimension", SDIMENSION }, + { "doubleprecision", SDOUBLE }, + { "doublecomplex", SDCOMPLEX, YES }, + { "elseif", SELSEIF, YES }, + { "else", SELSE, YES }, + { "endfile", SENDFILE }, + { "endif", SENDIF, YES }, + { "enddo", SENDDO, YES }, + { "end", SEND }, + { "entry", SENTRY, YES }, + { "equivalence", SEQUIV }, + { "external", SEXTERNAL }, + { "format", SFORMAT }, + { "function", SFUNCTION }, + { "goto", SGOTO }, + { "implicit", SIMPLICIT, YES }, + { "include", SINCLUDE, YES }, + { "inquire", SINQUIRE, YES }, + { "intrinsic", SINTRINSIC, YES }, + { "integer", SINTEGER }, + { "logical", SLOGICAL }, + { "namelist", SNAMELIST, YES }, + { "none", SUNDEFINED, YES }, + { "open", SOPEN, YES }, + { "parameter", SPARAM, YES }, + { "pause", SPAUSE }, + { "print", SPRINT }, + { "program", SPROGRAM, YES }, + { "punch", SPUNCH, YES }, + { "read", SREAD }, + { "real", SREAL }, + { "return", SRETURN }, + { "rewind", SREWIND }, + { "save", SSAVE, YES }, + { "static", SSTATIC, YES }, + { "stop", SSTOP }, + { "subroutine", SSUBROUTINE }, + { "then", STHEN, YES }, + { "undefined", SUNDEFINED, YES }, + { "while", SWHILE, YES }, + { "write", SWRITE }, + { 0, 0 } +}; + +static void analyz Argdcl((void)); +static void crunch Argdcl((void)); +static int getcd Argdcl((char*, int)); +static int getcds Argdcl((void)); +static int getkwd Argdcl((void)); +static int gettok Argdcl((void)); +static void store_comment Argdcl((char*)); +LOCAL char *stbuf[3]; + + int +#ifdef KR_headers +inilex(name) + char *name; +#else +inilex(char *name) +#endif +{ + stbuf[0] = Alloc(3*P1_STMTBUFSIZE); + stbuf[1] = stbuf[0] + P1_STMTBUFSIZE; + stbuf[2] = stbuf[1] + P1_STMTBUFSIZE; + nincl = 0; + inclp = NULL; + doinclude(name); + lexstate = NEWSTMT; + return(NO); +} + + + +/* throw away the rest of the current line */ + void +flline(Void) +{ + lexstate = RETEOS; +} + + + + char * +#ifdef KR_headers +lexline(n) + int *n; +#else +lexline(int *n) +#endif +{ + *n = (lastch - nextch) + 1; + return(nextch); +} + + + + + void +#ifdef KR_headers +doinclude(name) + char *name; +#else +doinclude(char *name) +#endif +{ + FILEP fp; + struct Inclfile *t; + char *name0, *lastslash, *s, *s0, *temp; + int j, k; + chainp I; + extern chainp Iargs; + + err_lineno = -1; + if(inclp) + { + inclp->incllno = thislin; + inclp->inclcode = code; + inclp->inclstno = nxtstno; + if(nextcd && (j = endcd - nextcd) > 0) + inclp->incllinp = copyn(inclp->incllen = j, nextcd); + else + inclp->incllinp = 0; + } + nextcd = NULL; + + if(++nincl >= MAXINCLUDES) + Fatal("includes nested too deep"); + if(name[0] == '\0') + fp = stdin; + else if(name[0] == '/' || inclp == NULL +#ifdef MSDOS + || name[0] == '\\' + || name[1] == ':' +#endif + ) + fp = fopen(name, textread); + else { + lastslash = NULL; + s = s0 = inclp->inclname; +#ifdef MSDOS + if (s[1] == ':') + lastslash = s + 1; +#endif + for(; *s ; ++s) + if(*s == '/' +#ifdef MSDOS + || *s == '\\' +#endif + ) + lastslash = s; + name0 = name; + if(lastslash) { + k = lastslash - s0 + 1; + temp = Alloc(k + strlen(name) + 1); + strncpy(temp, s0, k); + strcpy(temp+k, name); + name = temp; + } + fp = fopen(name, textread); + if (!fp && (I = Iargs)) { + k = strlen(name0) + 2; + for(; I; I = I->nextp) { + j = strlen(s = I->datap); + name = Alloc(j + k); + strcpy(name, s); + switch(s[j-1]) { + case '/': +#ifdef MSDOS + case ':': + case '\\': +#endif + break; + default: + name[j++] = '/'; + } + strcpy(name+j, name0); + if (fp = fopen(name, textread)) { + free(name0); + goto havefp; + } + free(name); + name = name0; + } + } + } + if (fp) + { + havefp: + t = inclp; + inclp = ALLOC(Inclfile); + inclp->inclnext = t; + prevlin = thislin = lineno = 0; + infname = inclp->inclname = name; + infile = inclp->inclfp = fp; + lastline = 0; + putlineno(); + lastline = 0; + } + else + { + fprintf(diagfile, "Cannot open file %s\n", name); + done(1); + } +} + + + + + LOCAL int +popinclude(Void) +{ + struct Inclfile *t; + register char *p; + register int k; + + if(infile != stdin) + clf(&infile, infname, 1); /* Close the input file */ + free(infname); + + --nincl; + err_lineno = -1; + t = inclp->inclnext; + free( (charptr) inclp); + inclp = t; + if(inclp == NULL) { + infname = 0; + return(NO); + } + + infile = inclp->inclfp; + infname = inclp->inclname; + lineno = prevlin = thislin = inclp->incllno; + code = inclp->inclcode; + stno = nxtstno = inclp->inclstno; + if(inclp->incllinp) + { + lastline = 0; + putlineno(); + lastline = lineno; + endcd = nextcd = sbuf; + k = inclp->incllen; + p = inclp->incllinp; + while(--k >= 0) + *endcd++ = *p++; + free( (charptr) (inclp->incllinp) ); + } + else + nextcd = NULL; + return(YES); +} + + + void +#ifdef KR_headers +p1_line_number(line_number) + long line_number; +#else +p1_line_number(long line_number) +#endif +{ + if (lastfile != lastfile0) { + p1puts(P1_FILENAME, fbuf); + lastfile0 = lastfile; + } + fprintf(pass1_file, "%d: %ld\n", P1_SET_LINE, line_number); + } + + static void +putlineno(Void) +{ + extern int gflag; + register char *s0, *s1; + + if (gflag) { + if (lastline) + p1_line_number(lastline); + lastline = firstline; + if (lastfile != infname) + if (lastfile = infname) { + strncpy(fbuf, lastfile, sizeof(fbuf)); + fbuf[sizeof(fbuf)-1] = 0; + } + else + fbuf[0] = 0; + } + if (addftnsrc) { + if (laststb && *laststb) { + for(s1 = laststb; *s1; s1++) { + for(s0 = s1; *s1 != '\n'; s1++) + if (*s1 == '*' && s1[1] == '/') + *s1 = '+'; + *s1 = 0; + p1puts(P1_FORTRAN, s0); + } + *laststb = 0; /* prevent trouble after EOF */ + } + laststb = stb0; + } + } + + int +yylex(Void) +{ + static int tokno; + int retval; + + switch(lexstate) + { + case NEWSTMT : /* need a new statement */ + retval = getcds(); + putlineno(); + if(retval == STEOF) { + retval = SEOF; + break; + } /* if getcds() == STEOF */ + crunch(); + tokno = 0; + lexstate = FIRSTTOKEN; + yystno = stno; + stno = nxtstno; + toklen = 0; + retval = SLABEL; + break; + +first: + case FIRSTTOKEN : /* first step on a statement */ + analyz(); + lexstate = OTHERTOKEN; + tokno = 1; + retval = stkey; + break; + + case OTHERTOKEN : /* return next token */ + if(nextch > lastch) + goto reteos; + ++tokno; + if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) + goto first; + + if(stkey==SASSIGN && tokno==3 && nextch sbuf) + { + q = nextcd; + p = sbuf; + while(q < endcd) + *p++ = *q++; + endcd = p; + } + +/* Be aware that the input (i.e. the string at the address nextcd) is NOT + NULL-terminated */ + +/* This loop merges all continuations into one long statement, AND puts the next + card to be read at the end of the buffer (i.e. it stores the look-ahead card + when there's room) */ + + ncont = 0; + for(;;) { + nextcd = endcd; + if (ncont >= maxcont || nextcd+66 > send) + contmax(); + linestart[ncont++] = nextcd; + if ((code = getcd(nextcd,0)) != STCONTINUE) + break; + if (ncont == 20 && noextflag) { + lineno = thislin; + errext("more than 19 continuation lines"); + } + } + nextch = sbuf; + lastch = nextcd - 1; + + lineno = prevlin; + prevlin = thislin; + if (infname2) { + free(infname); + infname = infname2; + if (inclp) + inclp->inclname = infname; + } + infname2 = infname1; + infname1 = 0; + return(STINITIAL); +} + + static void +#ifdef KR_headers +bang(a, b, c, d, e) + char *a; + char *b; + char *c; + register char *d; + register char *e; +#else +bang(char *a, char *b, char *c, register char *d, register char *e) +#endif + /* save ! comments */ +{ + char buf[COMMENT_BUFFER_SIZE + 1]; + register char *p, *pe; + + p = buf; + pe = buf + COMMENT_BUFFER_SIZE; + *pe = 0; + while(a < b) + if (!(*p++ = *a++)) + p[-1] = 0; + if (b < c) + *p++ = '\t'; + while(d < e) { + if (!(*p++ = *d++)) + p[-1] = ' '; + if (p == pe) { + store_comment(buf); + p = buf; + } + } + if (p > buf) { + while(--p >= buf && *p == ' '); + p[1] = 0; + store_comment(buf); + } + } + + +/* getcd - Get next input card + + This function reads the next input card from global file pointer infile. +It assumes that b points to currently empty storage somewhere in sbuf */ + + LOCAL int +#ifdef KR_headers +getcd(b, nocont) + register char *b; + int nocont; +#else +getcd(register char *b, int nocont) +#endif +{ + register int c; + register char *p, *bend; + int speclin; /* Special line - true when the line is allowed + to have more than 66 characters (e.g. the + "&" shorthand for continuation, use of a "\t" + to skip part of the label columns) */ + static char a[6]; /* Statement label buffer */ + static char *aend = a+6; + static char *stb, *stbend; + static int nst; + char *atend, *endcd0; + extern int warn72; + char buf72[24]; + int amp, i; + char storage[COMMENT_BUFFER_SIZE + 1]; + char *pointer; + long L; + +top: + endcd = b; + bend = b+66; + amp = speclin = NO; + atend = aend; + +/* Handle the continuation shorthand of "&" in the first column, which stands + for " x" */ + + if( (c = getc(infile)) == '&') + { + a[0] = c; + a[1] = 0; + a[5] = 'x'; + amp = speclin = YES; + bend = send; + p = aend; + } + +/* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */ + + else if(comstart[c & (Table_size-1)]) + { + if (feof (infile) +#ifdef EOF_CHAR + || c == EOF_CHAR +#endif + ) + return STEOF; + + if (c == '#') { + *endcd++ = c; + while((c = getc(infile)) != '\n') + if (c == EOF) + return STEOF; + else if (endcd < shend) + *endcd++ = c; + ++thislin; + *endcd = 0; + if (b[1] == ' ') + p = b + 2; + else if (!strncmp(b,"#line ",6)) + p = b + 6; + else { + bad_cpp: + lineno = thislin; + errstr("Bad # line: \"%s\"", b); + goto top; + } + if (*p < '1' || *p > '9') + goto bad_cpp; + L = *p - '0'; + while((c = *++p) >= '0' && c <= '9') + L = 10*L + c - '0'; + while(c == ' ') + c = *++p; + if (!c) { + /* accept "# 1234" */ + thislin = L - 1; + goto top; + } + if (c != '"') + goto bad_cpp; + bend = p; + while(*++p != '"') + if (!*p) + goto bad_cpp; + *p = 0; + i = p - bend++; + thislin = L - 1; + if (!infname1 || strcmp(infname1, bend)) { + if (infname1) + free(infname1); + if (infname && !strcmp(infname, bend)) { + infname1 = 0; + goto top; + } + lastfile = 0; + infname1 = Alloc(i); + strcpy(infname1, bend); + if (!infname) { + infname = infname1; + infname1 = 0; + } + } + goto top; + } + + storage[COMMENT_BUFFER_SIZE] = c = '\0'; + pointer = storage; + while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') { + +/* Handle obscure end of file conditions on many machines */ + + if (feof (infile) && (c == '\377' || c == EOF)) { + pointer--; + break; + } /* if (feof (infile)) */ + + if (c == '\0') + *(pointer - 1) = ' '; + + if (pointer == &storage[COMMENT_BUFFER_SIZE]) { + store_comment (storage); + pointer = storage; + } /* if (pointer == BUFFER_SIZE) */ + } /* while */ + + if (pointer > storage) { + if (c == '\n') + +/* Get rid of the newline */ + + pointer[-1] = 0; + else + *pointer = 0; + + store_comment (storage); + } /* if */ + + if (feof (infile)) + if (c != '\n') /* To allow the line index to + increment correctly */ + return STEOF; + + ++thislin; + goto top; + } + + else if(c != EOF) + { + +/* Load buffer a with the statement label */ + + /* a tab in columns 1-6 skips to column 7 */ + ungetc(c, infile); + for(p=a; p= 23) + strcpy(buf72+20, "..."); + lineno = thislin + 1; + errstr("text after column 72: %s", buf72); + } + if(c == EOF) + return(STEOF); + } + + endcd0 = endcd; + if( ! speclin ) + while(endcd < bend) + *endcd++ = BLANK; + } + +/* The flow of control usually gets to this line (unless an earlier RETURN has + been taken) */ + + ++thislin; + + /* Fortran 77 specifies that a 0 in column 6 */ + /* does not signify continuation */ + + if( !isspace(a[5]) && a[5]!='0') { + if (!amp) + for(p = a; p < aend;) + if (*p++ == '!' && p != aend) + goto initcheck; + if (addftnsrc && stb) { + if (stbend > stb + 7) { /* otherwise forget col 1-6 */ + /* kludge around funny p1gets behavior */ + *stb++ = '$'; + if (amp) + *stb++ = '&'; + else + for(p = a; p < atend;) + *stb++ = *p++; + } + if (endcd0 - b > stbend - stb) { + if (stb > stbend) + stb = stbend; + endcd0 = b + (stbend - stb); + } + for(p = b; p < endcd0;) + *stb++ = *p++; + *stb++ = '\n'; + *stb = 0; + } + if (nocont) { + lineno = thislin; + errstr("illegal continuation card (starts \"%.6s\")",a); + } + else if (!amp && strncmp(a," ",5)) { + lineno = thislin; + errstr("labeled continuation line (starts \"%.6s\")",a); + } + return(STCONTINUE); + } +initcheck: + for(p=a; p= linestart[k]) + if (++k >= maxcont) + contmax(); + j0 = linestart[k]; + if (!addftnsrc) + bang(sbuf,sbuf,sbuf,i+1,j0); + i = j0-1; + continue; + } + +/* Keep everything in a quoted string */ + + if(*i=='\'' || *i=='"') + { + int len = 0; + + quote = *i; + *j = MYQUOTE; /* special marker */ + for(;;) + { + if(++i > lastch) + { + err("unbalanced quotes; closing quote supplied"); + if (j >= lastch) + j = lastch - 1; + break; + } + if(*i == quote) + if(i maxtoklen) + adjtoklen(len); + j[1] = MYQUOTE; + j += 2; + prvstr = j; + } + else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */ + { + j0 = j - 1; + if( ! isdigit(*j0)) goto copychar; + nh = *j0 - '0'; + ten = 10; + j1 = prvstr; + if (j1 > sbuf && j1[-1] == MYQUOTE) + --j1; + if (j1+4 < j) + j1 = j-4; + for(;;) { + if (j0-- <= j1) + goto copychar; + if( ! isdigit(*j0 ) ) break; + nh += ten * (*j0-'0'); + ten*=10; + } +/* A Hollerith string must be preceded by a punctuation mark. + '*' is possible only as repetition factor in a data statement + not, in particular, in character*2h . + To avoid some confusion with missing commas in FORMAT statements, + treat a preceding string as a punctuation mark. + */ + + if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/' + && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.' + && *j0 != MYQUOTE) + goto copychar; + nh0 = nh; + if(i+nh > lastch) + { + erri("%dH too big", nh); + nh = lastch - i; + nh0 = -1; + } + if (nh > maxtoklen) + adjtoklen(nh); + j0[1] = MYQUOTE; /* special marker */ + j = j0 + 1; + while(nh-- > 0) + { + if (++i > lastch) { + hol_overflow: + if (nh0 >= 0) + erri("escapes make %dH too big", + nh0); + break; + } + if(*i == '\\' && use_bs) { + if (++i > lastch) + goto hol_overflow; + *i = escapes[*(unsigned char *)i]; + } + *++j = *i; + } + j[1] = MYQUOTE; + j+=2; + prvstr = j; + } + else { + if(*i == '(') parseen = ++parlev; + else if(*i == ')') --parlev; + else if(parlev == 0) + if(*i == '=') expeql = 1; + else if(*i == ',') expcom = 1; +copychar: /*not a string or space -- copy, shifting case if necessary */ + if(shiftcase && isupper(*i)) + *j++ = tolower(*i); + else *j++ = *i; + } + } + lastch = j - 1; + nextch = sbuf; +} + + LOCAL void +analyz(Void) +{ + register char *i; + + if(parlev != 0) + { + err("unbalanced parentheses, statement skipped"); + stkey = SUNKNOWN; + lastch = sbuf - 1; /* prevent double error msg */ + return; + } + if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') + { + /* assignment or if statement -- look at character after balancing paren */ + parlev = 1; + for(i=nextch+3 ; i<=lastch; ++i) + if(*i == (MYQUOTE)) + { + while(*++i != MYQUOTE) + ; + } + else if(*i == '(') + ++parlev; + else if(*i == ')') + { + if(--parlev == 0) + break; + } + if(i >= lastch) + stkey = SLOGIF; + else if(i[1] == '=') + stkey = SLET; + else if( isdigit(i[1]) ) + stkey = SARITHIF; + else stkey = SLOGIF; + if(stkey != SLET) + nextch += 2; + } + else if(expeql) /* may be an assignment */ + { + if(expcom && nextch= '0' && nextch[2] <= '9') + || nextch[2] == ',' + || nextch[2] == 'w')) + { + stkey = SDO; + nextch += 2; + needwkey = 1; + } + /* otherwise search for keyword */ + else { + stkey = getkwd(); + if(stkey==SGOTO && lastch>=nextch) + if(nextch[0]=='(') + stkey = SCOMPGOTO; + else if(isalpha_(* USC nextch)) + stkey = SASGOTO; + } + parlev = 0; +} + + + + LOCAL int +getkwd(Void) +{ + register char *i, *j; + register struct Keylist *pk, *pend; + int k; + + if(! isalpha_(* USC nextch) ) + return(SUNKNOWN); + k = letter(nextch[0]); + if(pk = keystart[k]) + for(pend = keyend[k] ; pk<=pend ; ++pk ) + { + i = pk->keyname; + j = nextch; + while(*++i==*++j && *i!='\0') + ; + if(*i=='\0' && j<=lastch+1) + { + nextch = j; + if(no66flag && pk->notinf66) + errstr("Not a Fortran 66 keyword: %s", + pk->keyname); + return(pk->keyval); + } + } + return(SUNKNOWN); +} + + void +initkey(Void) +{ + register struct Keylist *p; + register int i,j; + register char *s; + + for(i = 0 ; i<26 ; ++i) + keystart[i] = NULL; + + for(p = keys ; p->keyname ; ++p) { + j = letter(p->keyname[0]); + if(keystart[j] == NULL) + keystart[j] = p; + keyend[j] = p; + } + i = (maxcontin + 2) * 66; + sbuf = (char *)ckalloc(i + 70 + MAX_SHARPLINE_LEN); + send = sbuf + i; + shend = send + MAX_SHARPLINE_LEN; + maxcont = maxcontin + 1; + linestart = (char **)ckalloc(maxcont*sizeof(char*)); + comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = + comstart['#'] = 1; +#ifdef EOF_CHAR + comstart[EOF_CHAR] = 1; +#endif + s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"; + while(i = *s++) + anum_buf[i] = 1; + s = "0123456789"; + while(i = *s++) + anum_buf[i] = 2; + } + + LOCAL int +#ifdef KR_headers +hexcheck(key) + int key; +#else +hexcheck(int key) +#endif +{ + register int radix; + register char *p; + char *kind; + + switch(key) { + case 'z': + case 'Z': + case 'x': + case 'X': + radix = 16; + key = SHEXCON; + kind = "hexadecimal"; + break; + case 'o': + case 'O': + radix = 8; + key = SOCTCON; + kind = "octal"; + break; + case 'b': + case 'B': + radix = 2; + key = SBITCON; + kind = "binary"; + break; + default: + err("bad bit identifier"); + return(SNAME); + } + for(p = token; *p; p++) + if (hextoi(*p) >= radix) { + errstr("invalid %s character", kind); + break; + } + return key; + } + +/* gettok -- moves the right amount of text from nextch into the token + buffer. token initially contains garbage (leftovers from the prev token) */ + + LOCAL int +gettok(Void) +{ + int havdot, havexp, havdbl; + int radix, val; + struct Punctlist *pp; + struct Dotlist *pd; + register int ch; + static char Exp_mi[] = "X**-Y treated as X**(-Y)", + Exp_pl[] = "X**+Y treated as X**(+Y)"; + + char *i, *j, *n1, *p; + + ch = * USC nextch; + if(ch == (MYQUOTE)) + { + ++nextch; + p = token; + while(*nextch != MYQUOTE) + *p++ = *nextch++; + toklen = p - token; + *p = 0; + /* allow octal, binary, hex constants of the form 'abc'x (etc.) */ + if (++nextch <= lastch && isalpha_(val = * USC nextch)) { + ++nextch; + return hexcheck(val); + } + return (SHOLLERITH); + } + + if(needkwd) + { + needkwd = 0; + return( getkwd() ); + } + + for(pp=puncts; pp->punchar; ++pp) + if(ch == pp->punchar) { + val = pp->punval; + if (++nextch <= lastch) + switch(ch) { + case '/': + switch(*nextch) { + case '/': + nextch++; + val = SCONCAT; + break; + case '=': + goto sne; + default: + if (new_dcl && parlev == 0) + val = SSLASHD; + } + return val; + case '*': + if (*nextch == '*') { + nextch++; + if (noextflag + && nextch <= lastch) + switch(*nextch) { + case '-': + errext(Exp_mi); + break; + case '+': + errext(Exp_pl); + } + return SPOWER; + } + break; + case '<': + switch(*nextch) { + case '=': + nextch++; + val = SLE; + break; + case '>': + sne: + nextch++; + val = SNE; + } + goto extchk; + case '=': + if (*nextch == '=') { + nextch++; + val = SEQ; + goto extchk; + } + break; + case '>': + if (*nextch == '=') { + nextch++; + val = SGE; + } + extchk: + NOEXT("Fortran 8x comparison operator"); + return val; + } + else if (ch == '/' && new_dcl && parlev == 0) + return SSLASHD; + switch(val) { + case SLPAR: + ++parlev; + break; + case SRPAR: + --parlev; + } + return(val); + } + if(ch == '.') + if(nextch >= lastch) goto badchar; + else if(isdigit(nextch[1])) goto numconst; + else { + for(pd=dots ; (j=pd->dotname) ; ++pd) + { + for(i=nextch+1 ; i<=lastch ; ++i) + if(*i != *j) break; + else if(*i != '.') ++j; + else { + nextch = i+1; + return(pd->dotval); + } + } + goto badchar; + } + if( isalpha_(ch) ) + { + p = token; + *p++ = *nextch++; + while(nextch<=lastch) + if( isalnum_(* USC nextch) ) + *p++ = *nextch++; + else break; + toklen = p - token; + *p = 0; + if (needwkey) { + needwkey = 0; + if (toklen == 5 + && nextch <= lastch && *nextch == '(' /*)*/ + && !strcmp(token,"while")) + return(SWHILE); + } + if(inioctl && nextch<=lastch && *nextch=='=') + { + ++nextch; + return(SNAMEEQ); + } + if(toklen>8 && eqn(8,token,"function") + && isalpha_(* USC (token+8)) && + nextch MAXNAMELEN) + { + char buff[2*MAXNAMELEN+50]; + if (toklen >= MAXNAMELEN+10) + sprintf(buff, + "name %.*s... too long, truncated to %.*s", + MAXNAMELEN+6, token, MAXNAMELEN, token); + else + sprintf(buff, + "name %s too long, truncated to %.*s", + token, MAXNAMELEN, token); + err(buff); + toklen = MAXNAMELEN; + token[MAXNAMELEN] = '\0'; + } + if(toklen==1 && *nextch==MYQUOTE) { + val = token[0]; + ++nextch; + for(p = token ; *nextch!=MYQUOTE ; ) + *p++ = *nextch++; + ++nextch; + toklen = p - token; + *p = 0; + return hexcheck(val); + } + return(SNAME); + } + + if (isdigit(ch)) { + + /* Check for NAG's special hex constant */ + + if (nextch[1] == '#' && nextch < lastch + || nextch[2] == '#' && isdigit(nextch[1]) + && lastch - nextch >= 2) { + + radix = atoi (nextch); + if (*++nextch != '#') + nextch++; + if (radix != 2 && radix != 8 && radix != 16) { + erri("invalid base %d for constant, defaulting to hex", + radix); + radix = 16; + } /* if */ + if (++nextch > lastch) + goto badchar; + for (p = token; hextoi(*nextch) < radix;) { + *p++ = *nextch++; + if (nextch > lastch) + break; + } + toklen = p - token; + *p = 0; + return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON : + SBITCON); + } + } + else + goto badchar; +numconst: + havdot = NO; + havexp = NO; + havdbl = NO; + for(n1 = nextch ; nextch<=lastch ; ++nextch) + { + if(*nextch == '.') + if(havdot) break; + else if(nextch+2<=lastch && isalpha_(* USC (nextch+1)) + && isalpha_(* USC (nextch+2))) + break; + else havdot = YES; + else if( ! isdigit(* USC nextch) ) { + if( !intonly && (*nextch=='d' || *nextch=='e') ) { + p = nextch; + havexp = YES; + if(*nextch == 'd') + havdbl = YES; + if(nextch cblast) { + ncb = 0; + if (cbcur) { + cbcur->last = cbnext; + ncb = cbcur->next; + } + if (!ncb) { + ncb = (comment_buf *) Alloc(sizeof(comment_buf)); + if (cbcur) + cbcur->next = ncb; + else { + cbfirst = ncb; + cbinit = ncb->buf; + } + ncb->next = 0; + } + cbcur = ncb; + cbnext = ncb->buf; + cblast = cbnext + COMMENT_BUF_STORE; + } + strcpy(cbnext, str); + cbnext += len; + } + + static void +flush_comments(Void) +{ + register char *s, *s1; + register comment_buf *cb; + if (cbnext == cbinit) + return; + cbcur->last = cbnext; + for(cb = cbfirst;; cb = cb->next) { + for(s = cb->buf; s < cb->last; s = s1) { + /* compute s1 = new s value first, since */ + /* p1_comment may insert nulls into s */ + s1 = s + strlen(s) + 1; + p1_comment(s); + } + if (cb == cbcur) + break; + } + cbcur = cbfirst; + cbnext = cbinit; + cblast = cbnext + COMMENT_BUF_STORE; + } + + void +unclassifiable(Void) +{ + register char *s, *se; + + s = sbuf; + se = lastch; + if (se < sbuf) + return; + lastch = s - 1; + if (++se - s > 10) + se = s + 10; + for(; s < se; s++) + if (*s == MYQUOTE) { + se = s; + break; + } + *se = 0; + errstr("unclassifiable statement (starts \"%s\")", sbuf); + } + + void +endcheck(Void) +{ + if (nextch <= lastch) + warn("ignoring text after \"end\"."); + lexstate = RETEOS; + } diff --git a/unix/f2c/src/machdefs.h b/unix/f2c/src/machdefs.h new file mode 100644 index 00000000..3ab8961f --- /dev/null +++ b/unix/f2c/src/machdefs.h @@ -0,0 +1,31 @@ +#define TYLENG TYLONG /* char string length field */ + +#define TYINT TYLONG +#define SZADDR 4 +#define SZSHORT 2 +#define SZINT 4 + +#define SZLONG 4 +#define SZLENG SZLONG + +#define SZDREAL 8 + +/* Alignment restrictions */ + +#define ALIADDR SZADDR +#define ALISHORT SZSHORT +#define ALILONG 4 +#define ALIDOUBLE 8 +#define ALIINT ALILONG +#define ALILENG ALILONG + +#define BLANKCOMMON "_BLNK__" /* Name for the unnamed + common block; this is unique + because of underscores */ + +#define LABELFMT "%s:\n" + +#define MAXREGVAR 4 +#define TYIREG TYLONG +#define MSKIREG (M(TYSHORT)|M(TYLONG)) /* allowed types of DO indicies + which can be put in registers */ diff --git a/unix/f2c/src/main.c b/unix/f2c/src/main.c new file mode 100644 index 00000000..14276f6d --- /dev/null +++ b/unix/f2c/src/main.c @@ -0,0 +1,792 @@ +/**************************************************************** +Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +extern char F2C_version[]; + +#include "defs.h" +#include "parse.h" + +int complex_seen, dcomplex_seen; + +LOCAL int Max_ftn_files; + +int badargs; +char **ftn_files; +int current_ftn_file = 0; + +flag ftn66flag = NO; +flag nowarnflag = NO; +flag noextflag = NO; +flag no66flag = NO; /* Must also set noextflag to this + same value */ +flag zflag = YES; /* recognize double complex intrinsics */ +flag debugflag = NO; +flag onetripflag = NO; +flag shiftcase = YES; +flag undeftype = NO; +flag checksubs = NO; +flag r8flag = NO; +flag use_bs = YES; +flag keepsubs = NO; +flag byterev = NO; +int intr_omit; +static int no_cd, no_i90; +#ifdef TYQUAD +flag use_tyquad = YES; +#ifndef NO_LONG_LONG +flag allow_i8c = YES; +#endif +#endif +int tyreal = TYREAL; +int tycomplex = TYCOMPLEX; + +int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */ +int maxequiv = MAXEQUIV; +int maxext = MAXEXT; +int maxstno = MAXSTNO; +int maxctl = MAXCTL; +int maxhash = MAXHASH; +int maxliterals = MAXLITERALS; +int maxcontin = MAXCONTIN; +int maxlablist = MAXLABLIST; +int extcomm, ext1comm, useauto; +int can_include = YES; /* so we can disable includes for netlib */ + +static char *def_i2 = ""; + +static int useshortints = NO; /* YES => tyint = TYSHORT */ +static int uselongints = NO; /* YES => tyint = TYLONG */ +int addftnsrc = NO; /* Include ftn source in output */ +int usedefsforcommon = NO; /* Use #defines for common reference */ +int forcedouble = YES; /* force real functions to double */ +int dneg = NO; /* f77 treatment of unary minus */ +int Ansi = YES; +int def_equivs = YES; +int tyioint = TYLONG; +int szleng = SZLENG; +int inqmask = M(TYLONG)|M(TYLOGICAL); +int wordalign = NO; +int forcereal = NO; +int warn72 = NO; +static int help, showver, skipC, skipversion; +char *file_name, *filename0, *parens; +int Castargs = 1; +static int Castargs1; +static int typedefs = 0; +int chars_per_wd, gflag, protostatus; +int infertypes = 1; +char used_rets[TYSUBR+1]; +extern char *tmpdir; +static int h0align = 0; +char *halign, *ohalign; +int krparens = NO; +int hsize; /* for padding under -h */ +int htype; /* for wr_equiv_init under -h */ +int trapuv; +chainp Iargs; + +#define f2c_entry(swit,count,type,store,size) \ + p_entry ("-", swit, 0, count, type, store, size) + +static arg_info table[] = { + f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES), + f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES), + f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES), + f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES), + f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES), + f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES), + f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES), + f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO), + f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES), + f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0), + f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES), + f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0), + f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0), + f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0), + f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0), + f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0), + f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0), + f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0), + f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0), + f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES), + f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES), + f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO), + f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES), + f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES), + f2c_entry ("K", P_NO_ARGS, P_INT, &Ansi, NO), + f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES), + f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO), + f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES), + f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES), + f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO), + f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES), + f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO), + f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0), + f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES), + f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0), + f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1), + f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1), + f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2), + f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2), + f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3), + f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1), + f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0), + f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1), + f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0), + f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1), + f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2), + f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1), + f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2), + f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO), + f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES), + f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1), + f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2), + f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1), + f2c_entry ("d", P_ONE_ARG, P_STRING, &outbuf, 0), + f2c_entry ("cd", P_NO_ARGS, P_INT, &no_cd, 1), + f2c_entry ("i90", P_NO_ARGS, P_INT, &no_i90, 2), + f2c_entry ("trapuv", P_NO_ARGS, P_INT, &trapuv, 1), +#ifdef TYQUAD +#ifndef NO_LONG_LONG + f2c_entry ("!i8const", P_NO_ARGS, P_INT, &allow_i8c, NO), +#endif + f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO), +#endif + + /* options omitted from man pages */ + + /* -b ==> for unformatted I/O, call do_unio (for noncharacter */ + /* data of length > 1 byte) and do_ucio (for the rest) rather */ + /* than do_uio. This permits modifying libI77 to byte-reverse */ + /* numeric data. */ + + f2c_entry ("b", P_NO_ARGS, P_INT, &byterev, YES), + + /* -ev ==> implement equivalence with initialized pointers */ + f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO), + + /* -!it used to be the default when -it was more agressive */ + + f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1), + + /* -Pd is similar to -P, but omits :ref: lines */ + f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2), + + /* -t ==> emit typedefs (under -A or -C++) for procedure + argument types used. This is meant for netlib's + f2c service, so -A and -C++ will work with older + versions of f2c.h + */ + f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1), + + /* -!V ==> omit version msg (to facilitate using diff in + regression testing) + */ + f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1), + + /* -Dnnn = debug level nnn */ + + f2c_entry ("D", P_ONE_ARG, P_INT, &debugflag, YES), + + /* -dneg ==> under (default) -!R, imitate f77's bizarre */ + /* treatment of unary minus of REAL expressions by */ + /* promoting them to DOUBLE PRECISION . */ + + f2c_entry ("dneg", P_NO_ARGS, P_INT, &dneg, YES), + + /* -?, --help, -v, --version */ + + f2c_entry ("?", P_NO_ARGS, P_INT, &help, YES), + f2c_entry ("-help", P_NO_ARGS, P_INT, &help, YES), + + f2c_entry ("v", P_NO_ARGS, P_INT, &showver, YES), + f2c_entry ("-version", P_NO_ARGS, P_INT, &showver, YES) + +}; /* table */ + +extern char *c_functions; /* "c_functions" */ +extern char *coutput; /* "c_output" */ +extern char *initfname; /* "raw_data" */ +extern char *blkdfname; /* "block_data" */ +extern char *p1_file; /* "p1_file" */ +extern char *p1_bakfile; /* "p1_file.BAK" */ +extern char *sortfname; /* "init_file" */ +extern char *proto_fname; /* "proto_file" */ +FILE *protofile; + + void +set_externs(Void) +{ + static char *hset[3] = { 0, "integer", "doublereal" }; + +/* Adjust the global flags according to the command line parameters */ + + if (chars_per_wd > 0) { + typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] = + typesize[TYLOGICAL] = chars_per_wd; + typesize[TYINT1] = typesize[TYLOGICAL1] = 1; + typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1; + typesize[TYDCOMPLEX] = chars_per_wd << 2; + typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1; + typesize[TYCILIST] = 5*chars_per_wd; + typesize[TYICILIST] = 6*chars_per_wd; + typesize[TYOLIST] = 9*chars_per_wd; + typesize[TYCLLIST] = 3*chars_per_wd; + typesize[TYALIST] = 2*chars_per_wd; + typesize[TYINLIST] = 26*chars_per_wd; + } + + if (wordalign) + typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL]; + if (!tyioint) { + tyioint = TYSHORT; + szleng = typesize[TYSHORT]; + def_i2 = "#define f2c_i2 1\n"; + inqmask = M(TYSHORT)|M(TYLOGICAL2); + goto checklong; + } + else + szleng = typesize[TYLONG]; + if (useshortints) { + /* inqmask = M(TYLONG); */ + /* used to disallow LOGICAL in INQUIRE under -I2 */ + checklong: + protorettypes[TYLOGICAL] = "shortlogical"; + casttypes[TYLOGICAL] = "K_fp"; + if (uselongints) + err ("Can't use both long and short ints"); + else { + tyint = tylogical = TYSHORT; + tylog = TYLOGICAL2; + } + } + else if (uselongints) + tyint = TYLONG; + + if (h0align) { + if (tyint == TYLONG && wordalign) + h0align = 1; + ohalign = halign = hset[h0align]; + htype = h0align == 1 ? tyint : TYDREAL; + hsize = typesize[htype]; + } + + if (no66flag) + noextflag = no66flag; + if (noextflag) + zflag = 0; + + if (r8flag) { + tyreal = TYDREAL; + tycomplex = TYDCOMPLEX; + r8fix(); + } + if (forcedouble) { + protorettypes[TYREAL] = "E_f"; + casttypes[TYREAL] = "E_fp"; + } + else + dneg = 0; + +#ifndef NO_LONG_LONG + if (!use_tyquad) + allow_i8c = 0; +#endif + + if (maxregvar > MAXREGVAR) { + warni("-O%d: too many register variables", maxregvar); + maxregvar = MAXREGVAR; + } /* if maxregvar > MAXREGVAR */ + +/* Check the list of input files */ + + { + int bad, i, cur_max = Max_ftn_files; + + for (i = bad = 0; i < cur_max && ftn_files[i]; i++) + if (ftn_files[i][0] == '-') { + errstr ("Invalid flag '%s'", ftn_files[i]); + bad++; + } + if (bad) + exit(1); + + } /* block */ +} /* set_externs */ + + + static int +comm2dcl(Void) +{ + Extsym *ext; + if (ext1comm) + for(ext = extsymtab; ext < nextext; ext++) + if (ext->extstg == STGCOMMON && !ext->extinit) + return ext1comm; + return 0; + } + + static void +#ifdef KR_headers +write_typedefs(outfile) + FILE *outfile; +#else +write_typedefs(FILE *outfile) +#endif +{ + register int i; + register char *s, *p = 0; + static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR }; + static char stl[4] = { 'E', 'C', 'Z', 'H' }; + + for(i = 0; i <= TYSUBR; i++) + if (s = usedcasts[i]) { + if (!p) { + p = (char*)(Ansi == 1 ? "()" : "(...)"); + nice_printf(outfile, + "/* Types for casting procedure arguments: */\ +\n\n#ifndef F2C_proc_par_types\n"); + if (i == 0) { + nice_printf(outfile, + "typedef int /* Unknown procedure type */ (*%s)%s;\n", + s, p); + continue; + } + } + nice_printf(outfile, "typedef %s (*%s)%s;\n", + c_type_decl(i,1), s, p); + } + for(i = !forcedouble; i < 4; i++) + if (used_rets[st[i]]) + nice_printf(outfile, + "typedef %s %c_f; /* %s function */\n", + p = (char*)(i ? "VOID" : "doublereal"), + stl[i], ftn_types[st[i]]); + if (p) + nice_printf(outfile, "#endif\n\n"); + } + + static void +#ifdef KR_headers +commonprotos(outfile) + register FILE *outfile; +#else +commonprotos(register FILE *outfile) +#endif +{ + register Extsym *e, *ee; + register Argtypes *at; + Atype *a, *ae; + int k; + extern int proc_protochanges; + + if (!outfile) + return; + for (e = extsymtab, ee = nextext; e < ee; e++) + if (e->extstg == STGCOMMON && e->allextp) + nice_printf(outfile, "/* comlen %s %ld */\n", + e->cextname, e->maxleng); + if (Castargs1 < 3) + return; + + /* -Pr: special comments conveying current knowledge + of external references */ + + k = proc_protochanges; + for (e = extsymtab, ee = nextext; e < ee; e++) + if (e->extstg == STGEXT + && e->cextname != e->fextname) /* not a library function */ + if (at = e->arginfo) { + if ((!e->extinit || at->changes & 1) + /* not defined here or + changed since definition */ + && at->nargs >= 0) { + nice_printf(outfile, "/*:ref: %s %d %d", + e->cextname, e->extype, at->nargs); + a = at->atypes; + for(ae = a + at->nargs; a < ae; a++) + nice_printf(outfile, " %d", a->type); + nice_printf(outfile, " */\n"); + if (at->changes & 1) + k++; + } + } + else if (e->extype) + /* typed external, never invoked */ + nice_printf(outfile, "/*:ref: %s %d :*/\n", + e->cextname, e->extype); + if (k) { + nice_printf(outfile, + "/* Rerunning f2c -P may change prototypes or declarations. */\n"); + if (nerr) + return; + if (protostatus) + done(4); + if (protofile != stdout) { + fprintf(diagfile, + "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n", + filename0, proto_fname); + fflush(diagfile); + } + } + } + + static int +#ifdef KR_headers +I_args(argc, a) + int argc; + char **a; +#else +I_args(int argc, char **a) +#endif +{ + char **a0, **a1, **ae, *s; + + ae = a + argc; + a0 = a; + for(a1 = ++a; a < ae; a++) { + if (!(s = *a)) + break; + if (*s == '-' && s[1] == 'I' && s[2] + && (s[3] || s[2] != '2' && s[2] != '4')) + Iargs = mkchain(s+2, Iargs); + else + *a1++ = s; + } + Iargs = revchain(Iargs); + *a1 = 0; + return a1 - a0; + } + + static void +omit_non_f(Void) +{ + /* complain about ftn_files that do not end in .f or .F */ + + char *s, *s1; + int i, k; + + for(i = k = 0; s = ftn_files[k]; k++) { + s1 = s + strlen(s); + if (s1 - s >= 3) { + s1 -= 2; + if (*s1 == '.') switch(s1[1]) { + case 'f': + case 'F': + ftn_files[i++] = s; + continue; + } + } + fprintf(diagfile, "\"%s\" does not end in .f or .F\n", s); + } + if (i != k) { + fflush(diagfile); + if (!i) + exit(1); + ftn_files[i] = 0; + } + } + + static void +show_version(Void) +{ + printf("f2c (Fortran to C Translator) version %s.\n", F2C_version); + } + + static void +#ifdef KR_headers +show_help(progname) char *progname; +#else +show_help(char *progname) +#endif +{ + show_version(); + if (!progname) + progname = "f2c"; + printf("Usage: %s [ option ... ] [file ...]\n%s%s%s%s%s%s%s", + progname, + "For usage details, see the man page, f2c.1.\n", + "For technical details, see the f2c report.\n", + "Both are available from netlib, e.g.,\n", + "\thttp://netlib.bell-labs.com/netlib/f2c/f2c.1.gz\n", + "\thttp://netlib.bell-labs.com/netlib/f2c/f2c.pdf\n", + "or\n\thttp://www.netlib.org/f2c/f2c.1\n", + "\thttp://www.netlib.org/f2c/f2c.pdf\n"); + } + + int retcode = 0; + + int +#ifdef KR_headers +main(argc, argv) + int argc; + char **argv; +#else +main(int argc, char **argv) +#endif +{ + int c2d, k; + FILE *c_output; + char *cdfilename; + static char stderrbuf[BUFSIZ]; + extern char **dfltproc, *dflt1proc[]; + extern char link_msg[]; + + diagfile = stderr; + setbuf(stderr, stderrbuf); /* arrange for fast error msgs */ + + argkludge(&argc, &argv); /* for _WIN32 */ + argc = I_args(argc, argv); /* extract -I args */ + Max_ftn_files = argc - 1; + ftn_files = (char **)ckalloc((argc+1)*sizeof(char *)); + + parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info), + ftn_files, Max_ftn_files); + if (badargs) + return 1; + if (help) { + show_help(argv[0]); + return 0; + } + if (showver && !ftn_files[0]) { + show_version(); + return 0; + } + intr_omit = no_cd | no_i90; + if (keepsubs && checksubs) { + warn("-C suppresses -s\n"); + keepsubs = 0; + } + if (!can_include && ext1comm == 2) + ext1comm = 1; + if (ext1comm && !extcomm) + extcomm = 2; + if (protostatus) + Castargs = 3; + Castargs1 = Castargs; + if (!Ansi) { + Castargs = 0; + parens = "()"; + } + else if (!Castargs) + parens = (char*)(Ansi == 1 ? "()" : "(...)"); + else + dfltproc = dflt1proc; + + outbuf_adjust(); + set_externs(); + fileinit(); + read_Pfiles(ftn_files); + omit_non_f(); + + for(k = 0; ftn_files[k+1]; k++) + if (dofork(ftn_files[k])) + break; + filename0 = file_name = ftn_files[current_ftn_file = k]; + + set_tmp_names(); + sigcatch(0); + + c_file = opf(c_functions, textwrite); + pass1_file=opf(p1_file, binwrite); + initkey(); + if (file_name && *file_name) { + cdfilename = coutput; + if (debugflag != 1) { + coutput = c_name(file_name,'c'); + cdfilename = copys(outbtail); + if (Castargs1 >= 2) + proto_fname = c_name(file_name,'P'); + } + if (skipC) + coutput = 0; + else if (!(c_output = fopen(coutput, textwrite))) { + file_name = coutput; + coutput = 0; /* don't delete read-only .c file */ + fatalstr("can't open %.86s", file_name); + } + + if (Castargs1 >= 2 + && !(protofile = fopen(proto_fname, textwrite))) + fatalstr("Can't open %.84s\n", proto_fname); + } + else { + file_name = ""; + cdfilename = "f2c_out.c"; + c_output = stdout; + coutput = 0; + if (Castargs1 >= 2) { + protofile = stdout; + if (!skipC) + printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n"); + } + } + + if(inilex( copys(file_name) )) + done(1); + if (filename0) { + fprintf(diagfile, "%s:\n", file_name); + fflush(diagfile); + } + + procinit(); + if(k = yyparse()) + { + fprintf(diagfile, "Bad parse, return code %d\n", k); + done(1); + } + + commonprotos(protofile); + if (protofile == stdout && !skipC) + printf("#endif\n\n"); + + if (nerr || skipC) + goto C_skipped; + + +/* Write out the declarations which are global to this file */ + + if ((c2d = comm2dcl()) == 1) + nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\ +/* Split this into several files by piping it through\n\n\ +sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\ + */\n\ +/*<<>>*/\n\ +/*>>>'%s'<<<*/\n", cdfilename); + if (gflag) + nice_printf (c_output, "#line 1 \"%s\"\n", file_name); + if (!skipversion) { + nice_printf (c_output, "/* %s -- translated by f2c ", file_name); + nice_printf (c_output, "(version %s).\n", F2C_version); + nice_printf (c_output, + " You must link the resulting object file with libf2c:\n\ + %s\n*/\n\n", link_msg); + } + if (Ansi == 2) + nice_printf(c_output, + "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"); + nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2); + if (trapuv) + nice_printf(c_output, "extern void _uninit_f2c(%s);\n%s\n\n", + Ansi ? "void*,int,long" : "", "extern double _0;"); + if (gflag) + nice_printf (c_output, "#line 1 \"%s\"\n", file_name); + if (Castargs && typedefs) + write_typedefs(c_output); + nice_printf (c_file, "\n"); + fclose (c_file); + c_file = c_output; /* HACK to get the next indenting + to work */ + wr_common_decls (c_output); + if (blkdfile) + list_init_data(&blkdfile, blkdfname, c_output); + wr_globals (c_output); + if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL) + Fatal("main - couldn't reopen c_functions"); + ffilecopy (c_file, c_output); + if (*main_alias) { + nice_printf (c_output, "/* Main program alias */ "); + nice_printf (c_output, "int %s () { MAIN__ ();%s }\n", + main_alias, Ansi ? " return 0;" : ""); + } + if (Ansi == 2) + nice_printf(c_output, + "#ifdef __cplusplus\n\t}\n#endif\n"); + if (c2d) { + if (c2d == 1) + fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename); + else + fclose(c_output); + def_commons(c_output); + } + if (c2d != 2) + fclose (c_output); + + C_skipped: + if(parstate != OUTSIDE) + { + warn("missing final end statement"); + endproc(); + nerr = 1; + } + done(nerr ? 1 : 0); + /* NOT REACHED */ return 0; +} + + + FILEP +#ifdef KR_headers +opf(fn, mode) + char *fn; + char *mode; +#else +opf(char *fn, char *mode) +#endif +{ + FILEP fp; + if( fp = fopen(fn, mode) ) + return(fp); + + fatalstr("cannot open intermediate file %s", fn); + /* NOT REACHED */ return 0; +} + + + void +#ifdef KR_headers +clf(p, what, quit) + FILEP *p; + char *what; + int quit; +#else +clf(FILEP *p, char *what, int quit) +#endif +{ + if(p!=NULL && *p!=NULL && *p!=stdout) + { + if(ferror(*p)) { + fprintf(stderr, "I/O error on %s\n", what); + if (quit) + done(3); + retcode = 3; + } + fclose(*p); + } + *p = NULL; +} + + + void +#ifdef KR_headers +done(k) + int k; +#else +done(int k) +#endif +{ + clf(&initfile, "initfile", 0); + clf(&c_file, "c_file", 0); + clf(&pass1_file, "pass1_file", 0); + Un_link_all(k); + exit(k|retcode); +} diff --git a/unix/f2c/src/makefile.u b/unix/f2c/src/makefile.u new file mode 100644 index 00000000..0e2c7351 --- /dev/null +++ b/unix/f2c/src/makefile.u @@ -0,0 +1,117 @@ +# Makefile for f2c, a Fortran 77 to C converter + +.SUFFIXES: .c .o +CC = cc +CFLAGS = -O -w $(HSI_CF) +LDFLAGS = $(HSI_LF) +SHELL = /bin/sh +YACC = yacc +YFLAGS = + +.c.o: + $(CC) -c $(CFLAGS) $*.c + +OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \ + expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \ + output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \ + parse_args.o niceprintf.o cds.o sysdep.o version.o + +MALLOC = +# To use the malloc whose source accompanies the f2c source, add malloc.o +# to the right-hand side of the "MALLOC =" line above, so it becomes +# MALLOC = malloc.o +# This gives faster execution on some systems, but some other systems do +# not tolerate replacement of the system's malloc. + +OBJECTS = $(OBJECTSd) $(MALLOC) + +all: f2c + +f2c: $(OBJECTS) + $(CC) $(LDFLAGS) $(OBJECTS) -o f2c + +# The following used to be a rule for gram.c rather than gram1.c, but +# there are too many broken variants of yacc around, so now we +# distribute a correctly functioning gram.c (derived with a Unix variant +# of the yacc from plan9). + +gram1.c: gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h + ( sed gram.in + $(YACC) $(YFLAGS) gram.in + @echo "(There should be 4 shift/reduce conflicts.)" + sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c + rm -f gram.in y.tab.c + +$(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h + +tokdefs.h: tokens + grep -n . tokdefs.h + +cds.o: sysdep.h +exec.o: p1defs.h names.h +expr.o: output.h niceprintf.h names.h +format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h +formatdata.o: format.h output.h niceprintf.h names.h +gram.o: p1defs.h +init.o: output.h niceprintf.h iob.h +intr.o: names.h +io.o: names.h iob.h +lex.o : tokdefs.h p1defs.h +main.o: parse.h usignal.h +mem.o: iob.h +names.o: iob.h names.h output.h niceprintf.h +niceprintf.o: defs.h names.h output.h niceprintf.h +output.o: output.h niceprintf.h names.h +p1output.o: p1defs.h output.h niceprintf.h names.h +parse_args.o: parse.h +proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h +put.o: names.h pccdefs.h p1defs.h +putpcc.o: names.h +vax.o: defs.h output.h pccdefs.h +output.h: niceprintf.h +sysdep.o: sysdep.c sysdep.hd + +put.o putpcc.o: pccdefs.h + +sysdep.hd: + if $(CC) sysdeptest.c; then echo '/*OK*/' > sysdep.hd;\ + elif $(CC) -DNO_MKDTEMP sysdeptest.c; then echo '#define NO_MKDTEMP' >sysdep.hd;\ + else echo '#define NO_MKDTEMP' >sysdep.hd; echo '#define NO_MKSTEMP' >>sysdep.hd; fi + rm -f a.out + +f2c.t: f2c.1t + troff -man f2c.1t >f2c.t + +#f2c.1: f2c.1t +# nroff -man f2c.1t | col -b | uniq >f2c.1 + +clean: + rm -f *.o f2c sysdep.hd tokdefs.h f2c.t + +veryclean: clean + rm -f xsum + +b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ + exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ + ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ + init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile.u makefile.vc \ + malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \ + niceprintf.h output.c output.h p1defs.h p1output.c \ + parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \ + sysdep.c sysdep.h sysdeptest.c tokens usignal.h vax.c version.c xsum.c + +xsum: xsum.c + $(CC) $(CFLAGS) -o xsum xsum.c + +#Check validity of transmitted source... +xsum.out: xsum $b + ./xsum $b >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsum.out + +#On non-Unix systems that end lines with carriage-return/newline pairs, +#use "make xsumr.out" rather than "make xsum.out". The -r flag ignores +#carriage-return characters. +xsumr.out: xsum $b + ./xsum -r $b >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out diff --git a/unix/f2c/src/makefile.vc b/unix/f2c/src/makefile.vc new file mode 100644 index 00000000..e79a6ca8 --- /dev/null +++ b/unix/f2c/src/makefile.vc @@ -0,0 +1,76 @@ +# Microsoft Visual C++ Makefile for f2c, a Fortran 77 to C converter +# Invoke with "nmake -f makefile.vc", or execute the commands +# copy makefile.vc makefile +# nmake . + +CC = cl +CFLAGS = -Ot1 -nologo -DNO_LONG_LONG + +.c.obj: + $(CC) -c $(CFLAGS) $*.c + +OBJECTS = main.obj init.obj gram.obj lex.obj proc.obj equiv.obj data.obj format.obj \ + expr.obj exec.obj intr.obj io.obj misc.obj error.obj mem.obj names.obj \ + output.obj p1output.obj pread.obj put.obj putpcc.obj vax.obj formatdata.obj \ + parse_args.obj niceprintf.obj cds.obj sysdep.obj version.obj + +checkfirst: xsum.out + +f2c.exe: $(OBJECTS) + $(CC) -Fef2c.exe $(OBJECTS) setargv.obj + +$(OBJECTS): defs.h ftypes.h defines.h machdefs.h sysdep.h + +cds.obj: sysdep.h +exec.obj: p1defs.h names.h +expr.obj: output.h niceprintf.h names.h +format.obj: p1defs.h format.h output.h niceprintf.h names.h iob.h +formatdata.obj: format.h output.h niceprintf.h names.h +gram.obj: p1defs.h +init.obj: output.h niceprintf.h iob.h +intr.obj: names.h +io.obj: names.h iob.h +lex.obj : tokdefs.h p1defs.h +main.obj: parse.h usignal.h +mem.obj: iob.h +names.obj: iob.h names.h output.h niceprintf.h +niceprintf.obj: defs.h names.h output.h niceprintf.h +output.obj: output.h niceprintf.h names.h +p1output.obj: p1defs.h output.h niceprintf.h names.h +parse_args.obj: parse.h +proc.obj: tokdefs.h names.h niceprintf.h output.h p1defs.h +put.obj: names.h pccdefs.h p1defs.h +putpcc.obj: names.h +vax.obj: defs.h output.h pccdefs.h +output.h: niceprintf.h + +put.obj putpcc.obj: pccdefs.h + +clean: + deltree /Y *.obj f2c.exe + +veryclean: clean + deltree /Y xsum.exe + +b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ + exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ + ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ + init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile.u makefile.vc \ + malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \ + niceprintf.h output.c output.h p1defs.h p1output.c \ + parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \ + sysdep.c sysdep.h sysdeptest.c tokens usignal.h vax.c version.c xsum.c + +xsum.exe: xsum.c + $(CC) $(CFLAGS) -DMSDOS xsum.c + +#Check validity of transmitted source... +# Unfortunately, conditional execution is hard here, since fc does not set a +# nonzero exit code when files differ. + +xsum.out: xsum.exe $b + xsum $b >xsum1.out + fc xsum0.out xsum1.out + @echo If fc showed no differences, manually rename xsum1.out xsum.out: + @echo if xsum.out exists, first "del xsum.out"; then "ren xsum1.out xsum.out". + @echo Once you are happy that your source is OK, "nmake -f makefile.vc f2c.exe". diff --git a/unix/f2c/src/malloc.c b/unix/f2c/src/malloc.c new file mode 100644 index 00000000..dc32add3 --- /dev/null +++ b/unix/f2c/src/malloc.c @@ -0,0 +1,183 @@ +/**************************************************************** +Copyright 1990, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#ifndef CRAY +#define STACKMIN 512 +#define MINBLK (2*sizeof(struct mem) + 16) +#define F _malloc_free_ +#define SBGULP 8192 +#include "string.h" /* for memcpy */ + +#ifdef KR_headers +#define Char char +#define Unsigned unsigned +#define Int /*int*/ +#else +#define Char void +#define Unsigned size_t +#define Int int +#endif + +typedef struct mem { + struct mem *next; + Unsigned len; + } mem; + +mem *F; + + Char * +#ifdef KR_headers +malloc(size) + register Unsigned size; +#else +malloc(register Unsigned size) +#endif +{ + register mem *p, *q, *r, *s; + unsigned register k, m; + extern Char *sbrk(Int); + char *top, *top1; + + size = (size+7) & ~7; + r = (mem *) &F; + for (p = F, q = 0; p; r = p, p = p->next) { + if ((k = p->len) >= size && (!q || m > k)) { + m = k; + q = p; + s = r; + } + } + if (q) { + if (q->len - size >= MINBLK) { /* split block */ + p = (mem *) (((char *) (q+1)) + size); + p->next = q->next; + p->len = q->len - size - sizeof(mem); + s->next = p; + q->len = size; + } + else + s->next = q->next; + } + else { + top = (Char *)(((long)sbrk(0) + 7) & ~7); + if (F && (char *)(F+1) + F->len == top) { + q = F; + F = F->next; + } + else + q = (mem *) top; + top1 = (char *)(q+1) + size; + if (sbrk((int)(top1-top+SBGULP)) == (Char *) -1) + return 0; + r = (mem *)top1; + r->len = SBGULP - sizeof(mem); + r->next = F; + F = r; + q->len = size; + } + return (Char *) (q+1); + } + + void +#ifdef KR_headers +free(f) + Char *f; +#else +free(Char *f) +#endif +{ + mem *p, *q, *r; + char *pn, *qn; + + if (!f) return; + q = (mem *) ((char *)f - sizeof(mem)); + qn = (char *)f + q->len; + for (p = F, r = (mem *) &F; ; r = p, p = p->next) { + if (qn == (Char *) p) { + q->len += p->len + sizeof(mem); + p = p->next; + } + pn = p ? ((char *) (p+1)) + p->len : 0; + if (pn == (Char *) q) { + p->len += sizeof(mem) + q->len; + q->len = 0; + q->next = p; + r->next = p; + break; + } + if (pn < (char *) q) { + r->next = q; + q->next = p; + break; + } + } + } + + Char * +#ifdef KR_headers +realloc(f, size) + Char *f; + Unsigned size; +#else +realloc(Char *f, Unsigned size) +#endif +{ + mem *p; + Char *q, *f1; + Unsigned s1; + + if (!f) return malloc(size); + p = (mem *) ((char *)f - sizeof(mem)); + s1 = p->len; + free(f); + if (s1 > size) + s1 = size + 7 & ~7; + if (!p->len) { + f1 = (Char *)(p->next + 1); + memcpy(f1, f, s1); + f = f1; + } + q = malloc(size); + if (q && q != f) + memcpy(q, f, s1); + return q; + } + +/* The following (calloc) should really be in a separate file, */ +/* but defining it here sometimes avoids confusion on systems */ +/* that do not provide calloc in its own file. */ + + Char * +#ifdef KR_headers +calloc(n, m) Unsigned m, n; +#else +calloc(Unsigned n, Unsigned m) +#endif +{ + Char *rv; + rv = malloc(n *= m); + if (n && rv) + memset(rv, 0, n); + return rv; + } +#endif diff --git a/unix/f2c/src/mem.c b/unix/f2c/src/mem.c new file mode 100644 index 00000000..2f0aed32 --- /dev/null +++ b/unix/f2c/src/mem.c @@ -0,0 +1,272 @@ +/**************************************************************** +Copyright 1990, 1991, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "iob.h" + +#define MEMBSIZE 32000 +#define GMEMBSIZE 16000 + +#ifdef _WIN32 +#undef MSDOS +#endif + + char * +#ifdef KR_headers +gmem(n, round) + int n; + int round; +#else +gmem(int n, int round) +#endif +{ + static char *last, *next; + char *rv; + if (round) +#ifdef CRAY + if ((long)next & 0xe000000000000000) + next = (char *)(((long)next & 0x1fffffffffffffff) + 1); +#else +#ifdef MSDOS + if ((int)next & 1) + next++; +#else + next = (char *)(((long)next + sizeof(char *)-1) + & ~((long)sizeof(char *)-1)); +#endif +#endif + rv = next; + if ((next += n) > last) { + rv = Alloc(n + GMEMBSIZE); + + next = rv + n; + last = next + GMEMBSIZE; + } + return rv; + } + + struct memblock { + struct memblock *next; + char buf[MEMBSIZE]; + }; + typedef struct memblock memblock; + + static memblock *mem0; + memblock *curmemblock, *firstmemblock; + + char *mem_first, *mem_next, *mem_last, *mem0_last; + + void +mem_init(Void) +{ + curmemblock = firstmemblock = mem0 + = (memblock *)Alloc(sizeof(memblock)); + mem_first = mem0->buf; + mem_next = mem0->buf; + mem_last = mem0->buf + MEMBSIZE; + mem0_last = mem0->buf + MEMBSIZE; + mem0->next = 0; + } + + char * +#ifdef KR_headers +mem(n, round) + int n; + int round; +#else +mem(int n, int round) +#endif +{ + memblock *b; + register char *rv, *s; + + if (round) +#ifdef CRAY + if ((long)mem_next & 0xe000000000000000) + mem_next = (char *)(((long)mem_next & 0x1fffffffffffffff) + 1); +#else +#ifdef MSDOS + if ((int)mem_next & 1) + mem_next++; +#else + mem_next = (char *)(((long)mem_next + sizeof(char *)-1) + & ~((long)sizeof(char *)-1)); +#endif +#endif + rv = mem_next; + s = rv + n; + if (s >= mem_last) { + if (n > MEMBSIZE) { + fprintf(stderr, "mem(%d) failure!\n", n); + exit(1); + } + if (!(b = curmemblock->next)) { + b = (memblock *)Alloc(sizeof(memblock)); + curmemblock->next = b; + b->next = 0; + } + curmemblock = b; + rv = b->buf; + mem_last = rv + sizeof(b->buf); + s = rv + n; + } + mem_next = s; + return rv; + } + + char * +#ifdef KR_headers +tostring(s, n) + register char *s; + int n; +#else +tostring(register char *s, int n) +#endif +{ + register char *s1, *se, **sf; + char *rv, *s0; + register int k = n + 2, t; + + sf = str_fmt; + sf['%'] = "%"; + s0 = s; + se = s + n; + for(; s < se; s++) { + t = *(unsigned char *)s; + s1 = sf[t]; + while(*++s1) + k++; + } + sf['%'] = "%%"; + rv = s1 = mem(k,0); + *s1++ = '"'; + for(s = s0; s < se; s++) { + t = *(unsigned char *)s; + sprintf(s1, sf[t], t); + s1 += strlen(s1); + } + *s1 = 0; + return rv; + } + + char * +#ifdef KR_headers +cpstring(s) + register char *s; +#else +cpstring(register char *s) +#endif +{ + return strcpy(mem(strlen(s)+1,0), s); + } + + void +#ifdef KR_headers +new_iob_data(ios, name) + register io_setup *ios; + char *name; +#else +new_iob_data(register io_setup *ios, char *name) +#endif +{ + register iob_data *iod; + register char **s, **se; + + iod = (iob_data *) + mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1); + iod->next = iob_list; + iob_list = iod; + iod->type = ios->fields[0]; + iod->name = cpstring(name); + s = iod->fields; + se = s + ios->nelt; + while(s < se) + *s++ = "0"; + *s = 0; + } + + char * +#ifdef KR_headers +string_num(pfx, n) + char *pfx; + long n; +#else +string_num(char *pfx, long n) +#endif +{ + char buf[32]; + sprintf(buf, "%s%ld", pfx, n); + /* can't trust return type of sprintf -- BSD gets it wrong */ + return strcpy(mem(strlen(buf)+1,0), buf); + } + +static defines *define_list; + + void +#ifdef KR_headers +def_start(outfile, s1, s2, post) + FILE *outfile; + char *s1; + char *s2; + char *post; +#else +def_start(FILE *outfile, char *s1, char *s2, char *post) +#endif +{ + defines *d; + int n, n1; + extern int in_define; + + n = n1 = strlen(s1); + if (s2) + n += strlen(s2); + d = (defines *)mem(sizeof(defines)+n, 1); + d->next = define_list; + define_list = d; + strcpy(d->defname, s1); + if (s2) + strcpy(d->defname + n1, s2); + in_define = 1; + nice_printf(outfile, "#define %s", d->defname); + if (post) + nice_printf(outfile, " %s", post); + } + + void +#ifdef KR_headers +other_undefs(outfile) + FILE *outfile; +#else +other_undefs(FILE *outfile) +#endif +{ + defines *d; + if (d = define_list) { + define_list = 0; + nice_printf(outfile, "\n"); + do + nice_printf(outfile, "#undef %s\n", d->defname); + while(d = d->next); + nice_printf(outfile, "\n"); + } + } diff --git a/unix/f2c/src/memset.c b/unix/f2c/src/memset.c new file mode 100644 index 00000000..496b6164 --- /dev/null +++ b/unix/f2c/src/memset.c @@ -0,0 +1,72 @@ +/**************************************************************** +Copyright 1990, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* This is for the benefit of people whose systems don't provide + * memset, memcpy, and memcmp. If yours is such a system, adjust + * the makefile by adding memset.o to the "OBJECTS =" assignment. + * WARNING: the memcpy below is adequate for f2c, but is not a + * general memcpy routine (which must correctly handle overlapping + * fields). + */ + + int +#ifdef KR_headers +memcmp(s1, s2, n) char *s1, *s2; int n; +#else +memcmp(char *s1, char *s2, int n) +#endif +{ + char *se; + + for(se = s1 + n; s1 < se; s1++, s2++) + if (*s1 != *s2) + return *s1 - *s2; + return 0; + } + + char * +#ifdef KR_headers +memcpy(s1, s2, n) char *s1, *s2; int n; +#else +memcpy(char *s1, char *s2, int n) +#endif +{ + char *s0 = s1, *se = s1 + n; + + while(s1 < se) + *s1++ = *s2++; + return s0; + } + + void +#ifdef KR_headers +memset(s, c, n) char *s; int c, n; +#else +memset(char *s, int c, int n) +#endif +{ + char *se = s + n; + + while(s < se) + *s++ = c; + } diff --git a/unix/f2c/src/misc.c b/unix/f2c/src/misc.c new file mode 100644 index 00000000..bdb9bcb3 --- /dev/null +++ b/unix/f2c/src/misc.c @@ -0,0 +1,1398 @@ +/**************************************************************** +Copyright 1990, 1992-1995, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "limits.h" + + int +#ifdef KR_headers +oneof_stg(name, stg, mask) + Namep name; + int stg; + int mask; +#else +oneof_stg(Namep name, int stg, int mask) +#endif +{ + if (stg == STGCOMMON && name) { + if ((mask & M(STGEQUIV))) + return name->vcommequiv; + if ((mask & M(STGCOMMON))) + return !name->vcommequiv; + } + return ONEOF(stg, mask); + } + + +/* op_assign -- given a binary opcode, return the associated assignment + operator */ + + int +#ifdef KR_headers +op_assign(opcode) + int opcode; +#else +op_assign(int opcode) +#endif +{ + int retval = -1; + + switch (opcode) { + case OPPLUS: retval = OPPLUSEQ; break; + case OPMINUS: retval = OPMINUSEQ; break; + case OPSTAR: retval = OPSTAREQ; break; + case OPSLASH: retval = OPSLASHEQ; break; + case OPMOD: retval = OPMODEQ; break; + case OPLSHIFT: retval = OPLSHIFTEQ; break; + case OPRSHIFT: retval = OPRSHIFTEQ; break; + case OPBITAND: retval = OPBITANDEQ; break; + case OPBITXOR: retval = OPBITXOREQ; break; + case OPBITOR: retval = OPBITOREQ; break; + default: + erri ("op_assign: bad opcode '%d'", opcode); + break; + } /* switch */ + + return retval; +} /* op_assign */ + + + char * +#ifdef KR_headers +Alloc(n) + int n; +#else +Alloc(int n) +#endif + /* error-checking version of malloc */ + /* ckalloc initializes memory to 0; Alloc does not */ +{ + char errbuf[32]; + register char *rv; + + rv = (char*)malloc(n); + if (!rv) { + sprintf(errbuf, "malloc(%d) failure!", n); + Fatal(errbuf); + } + return rv; + } + + void +#ifdef KR_headers +cpn(n, a, b) + register int n; + register char *a; + register char *b; +#else +cpn(register int n, register char *a, register char *b) +#endif +{ + while(--n >= 0) + *b++ = *a++; +} + + + int +#ifdef KR_headers +eqn(n, a, b) + register int n; + register char *a; + register char *b; +#else +eqn(register int n, register char *a, register char *b) +#endif +{ + while(--n >= 0) + if(*a++ != *b++) + return(NO); + return(YES); +} + + + + + + + int +#ifdef KR_headers +cmpstr(a, b, la, lb) + register char *a; + register char *b; + ftnint la; + ftnint lb; +#else +cmpstr(register char *a, register char *b, ftnint la, ftnint lb) +#endif + /* compare two strings */ +{ + register char *aend, *bend; + aend = a + la; + bend = b + lb; + + + if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { + ++a; + ++b; + } + + while(b < bend) + if(*b != ' ') + return(' ' - *b); + else + ++b; + } + + else + { + while(b < bend) + if(*a != *b) + return( *a - *b ); + else + { + ++a; + ++b; + } + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else + ++a; + } + return(0); +} + + +/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */ + + chainp +#ifdef KR_headers +hookup(x, y) + register chainp x; + register chainp y; +#else +hookup(register chainp x, register chainp y) +#endif +{ + register chainp p; + + if(x == NULL) + return(y); + + for(p = x ; p->nextp ; p = p->nextp) + ; + p->nextp = y; + return(x); +} + + + + struct Listblock * +#ifdef KR_headers +mklist(p) + chainp p; +#else +mklist(chainp p) +#endif +{ + register struct Listblock *q; + + q = ALLOC(Listblock); + q->tag = TLIST; + q->listp = p; + return(q); +} + + + chainp +#ifdef KR_headers +mkchain(p, q) + register char * p; + register chainp q; +#else +mkchain(register char * p, register chainp q) +#endif +{ + register chainp r; + + if(chains) + { + r = chains; + chains = chains->nextp; + } + else + r = ALLOC(Chain); + + r->datap = p; + r->nextp = q; + return(r); +} + + chainp +#ifdef KR_headers +revchain(next) + register chainp next; +#else +revchain(register chainp next) +#endif +{ + register chainp p, prev = 0; + + while(p = next) { + next = p->nextp; + p->nextp = prev; + prev = p; + } + return prev; + } + + +/* addunder -- turn a cvarname into an external name */ +/* The cvarname may already end in _ (to avoid C keywords); */ +/* if not, it has room for appending an _. */ + + char * +#ifdef KR_headers +addunder(s) + register char *s; +#else +addunder(register char *s) +#endif +{ + register int c, i, j; + char *s0 = s; + + i = j = 0; + while(c = *s++) + if (c == '_') + i++, j++; + else + i = 0; + if (!i) { + *s-- = 0; + *s = '_'; + } + else if (j == 2) + s[-2] = 0; + return( s0 ); + } + + +/* copyn -- return a new copy of the input Fortran-string */ + + char * +#ifdef KR_headers +copyn(n, s) + register int n; + register char *s; +#else +copyn(register int n, register char *s) +#endif +{ + register char *p, *q; + + p = q = (char *) Alloc(n); + while(--n >= 0) + *q++ = *s++; + return(p); +} + + + +/* copys -- return a new copy of the input C-string */ + + char * +#ifdef KR_headers +copys(s) + char *s; +#else +copys(char *s) +#endif +{ + return( copyn( strlen(s)+1 , s) ); +} + + + +/* convci -- Convert Fortran-string to integer; assumes that input is a + legal number, with no trailing blanks */ + + ftnint +#ifdef KR_headers +convci(n, s) + register int n; + register char *s; +#else +convci(register int n, register char *s) +#endif +{ + ftnint sum, t; + char buff[100], *s0; + int n0; + + s0 = s; + n0 = n; + sum = 0; + while(n-- > 0) { + /* sum = 10*sum + (*s++ - '0'); */ + t = *s++ - '0'; + if (sum > LONG_MAX/10) { + ovfl: + if (n0 > 60) + n0 = 60; + sprintf(buff, "integer constant %.*s truncated.", + n0, s0); + err(buff); + return LONG_MAX; + } + sum *= 10; + if (sum > LONG_MAX - t) + goto ovfl; + sum += t; + } + return(sum); + } + +/* convic - Convert Integer constant to string */ + + char * +#ifdef KR_headers +convic(n) + ftnint n; +#else +convic(ftnint n) +#endif +{ + static char s[20]; + register char *t; + + s[19] = '\0'; + t = s+19; + + do { + *--t = '0' + n%10; + n /= 10; + } while(n > 0); + + return(t); +} + + + +/* mkname -- add a new identifier to the environment, including the closed + hash table. */ + + Namep +#ifdef KR_headers +mkname(s) + register char *s; +#else +mkname(register char *s) +#endif +{ + struct Hashentry *hp; + register Namep q; + register int c, hash, i; + register char *t; + char *s0; + char errbuf[64]; + + hash = i = 0; + s0 = s; + while(c = *s++) { + hash += c; + if (c == '_') + i = 2; + } + if (!i && in_vector(s0,c_keywords,n_keywords) >= 0) + i = 2; + hash %= maxhash; + +/* Add the name to the closed hash table */ + + hp = hashtab + hash; + + while(q = hp->varp) + if( hash == hp->hashval && !strcmp(s0,q->fvarname) ) + return(q); + else if(++hp >= lasthash) + hp = hashtab; + + if(++nintnames >= maxhash-1) + many("names", 'n', maxhash); /* Fatal error */ + hp->varp = q = ALLOC(Nameblock); + hp->hashval = hash; + q->tag = TNAME; /* TNAME means the tag type is NAME */ + c = s - s0; + if (c > 7 && noextflag) { + sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0, + c > 36 ? "..." : ""); + errext(errbuf); + } + q->fvarname = strcpy(mem(c,0), s0); + t = q->cvarname = mem(c + i + 1, 0); + s = s0; + /* add __ to the end of any name containing _ and to any C keyword */ + while(*t = *s++) + t++; + if (i) { + do *t++ = '_'; + while(--i > 0); + *t = 0; + } + return(q); +} + + + struct Labelblock * +#ifdef KR_headers +mklabel(l) + ftnint l; +#else +mklabel(ftnint l) +#endif +{ + register struct Labelblock *lp; + + if(l <= 0) + return(NULL); + + for(lp = labeltab ; lp < highlabtab ; ++lp) + if(lp->stateno == l) + return(lp); + + if(++highlabtab > labtabend) + many("statement labels", 's', maxstno); + + lp->stateno = l; + lp->labelno = (int)newlabel(); + lp->blklevel = 0; + lp->labused = NO; + lp->fmtlabused = NO; + lp->labdefined = NO; + lp->labinacc = NO; + lp->labtype = LABUNKNOWN; + lp->fmtstring = 0; + return(lp); +} + + long +newlabel(Void) +{ + return ++lastlabno; +} + + +/* this label appears in a branch context */ + + struct Labelblock * +#ifdef KR_headers +execlab(stateno) + ftnint stateno; +#else +execlab(ftnint stateno) +#endif +{ + register struct Labelblock *lp; + + if(lp = mklabel(stateno)) + { + if(lp->labinacc) + warn1("illegal branch to inner block, statement label %s", + convic(stateno) ); + else if(lp->labdefined == NO) + lp->blklevel = blklevel; + if(lp->labtype == LABFORMAT) + err("may not branch to a format"); + else + lp->labtype = LABEXEC; + } + else + execerr("illegal label %s", convic(stateno)); + + return(lp); +} + + +/* find or put a name in the external symbol table */ + + Extsym * +#ifdef KR_headers +mkext1(f, s) + char *f; + char *s; +#else +mkext1(char *f, char *s) +#endif +{ + Extsym *p; + + for(p = extsymtab ; pcextname)) + return( p ); + + if(nextext >= lastext) + many("external symbols", 'x', maxext); + + nextext->fextname = strcpy(gmem(strlen(f)+1,0), f); + nextext->cextname = f == s + ? nextext->fextname + : strcpy(gmem(strlen(s)+1,0), s); + nextext->extstg = STGUNKNOWN; + nextext->extp = 0; + nextext->allextp = 0; + nextext->extleng = 0; + nextext->maxleng = 0; + nextext->extinit = 0; + nextext->curno = nextext->maxno = 0; + return( nextext++ ); +} + + + Extsym * +#ifdef KR_headers +mkext(f, s) + char *f; + char *s; +#else +mkext(char *f, char *s) +#endif +{ + Extsym *e = mkext1(f, s); + if (e->extstg == STGCOMMON) + errstr("%.52s cannot be a subprogram: it is a common block.",f); + return e; + } + + Addrp +#ifdef KR_headers +builtin(t, s, dbi) + int t; + char *s; + int dbi; +#else +builtin(int t, char *s, int dbi) +#endif +{ + register Extsym *p; + register Addrp q; + extern chainp used_builtins; + + p = mkext(s,s); + if(p->extstg == STGUNKNOWN) + p->extstg = STGEXT; + else if(p->extstg != STGEXT) + { + errstr("improper use of builtin %s", s); + return(0); + } + + q = ALLOC(Addrblock); + q->tag = TADDR; + q->vtype = t; + q->vclass = CLPROC; + q->vstg = STGEXT; + q->memno = p - extsymtab; + q->dbl_builtin = dbi; + +/* A NULL pointer here tells you to use memno to check the external + symbol table */ + + q -> uname_tag = UNAM_EXTERN; + +/* Add to the list of used builtins */ + + if (dbi >= 0) + add_extern_to_list (q, &used_builtins); + return(q); +} + + + void +#ifdef KR_headers +add_extern_to_list(addr, list_store) + Addrp addr; + chainp *list_store; +#else +add_extern_to_list(Addrp addr, chainp *list_store) +#endif +{ + chainp last = CHNULL; + chainp list; + int memno; + + if (list_store == (chainp *) NULL || addr == (Addrp) NULL) + return; + + list = *list_store; + memno = addr -> memno; + + for (;list; last = list, list = list -> nextp) { + Addrp This = (Addrp) (list -> datap); + + if (This -> tag == TADDR && This -> uname_tag == UNAM_EXTERN && + This -> memno == memno) + return; + } /* for */ + + if (*list_store == CHNULL) + *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL); + else + last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL); + +} /* add_extern_to_list */ + + + void +#ifdef KR_headers +frchain(p) + register chainp *p; +#else +frchain(register chainp *p) +#endif +{ + register chainp q; + + if(p==0 || *p==0) + return; + + for(q = *p; q->nextp ; q = q->nextp) + ; + q->nextp = chains; + chains = *p; + *p = 0; +} + + void +#ifdef KR_headers +frexchain(p) + register chainp *p; +#else +frexchain(register chainp *p) +#endif +{ + register chainp q, r; + + if (q = *p) { + for(;;q = r) { + frexpr((expptr)q->datap); + if (!(r = q->nextp)) + break; + } + q->nextp = chains; + chains = *p; + *p = 0; + } + } + + + tagptr +#ifdef KR_headers +cpblock(n, p) + register int n; + register char *p; +#else +cpblock(register int n, register char *p) +#endif +{ + register ptr q; + + memcpy((char *)(q = ckalloc(n)), (char *)p, n); + return( (tagptr) q); +} + + + + ftnint +#ifdef KR_headers +lmax(a, b) + ftnint a; + ftnint b; +#else +lmax(ftnint a, ftnint b) +#endif +{ + return( a>b ? a : b); +} + + ftnint +#ifdef KR_headers +lmin(a, b) + ftnint a; + ftnint b; +#else +lmin(ftnint a, ftnint b) +#endif +{ + return(a < b ? a : b); +} + + + + int +#ifdef KR_headers +maxtype(t1, t2) + int t1; + int t2; +#else +maxtype(int t1, int t2) +#endif +{ + int t; + + t = t1 >= t2 ? t1 : t2; + if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) ) + t = TYDCOMPLEX; + return(t); +} + + + +/* return log base 2 of n if n a power of 2; otherwise -1 */ + int +#ifdef KR_headers +log_2(n) + ftnint n; +#else +log_2(ftnint n) +#endif +{ + int k; + + /* trick based on binary representation */ + + if(n<=0 || (n & (n-1))!=0) + return(-1); + + for(k = 0 ; n >>= 1 ; ++k) + ; + return(k); +} + + + void +frrpl(Void) +{ + struct Rplblock *rp; + + while(rpllist) + { + rp = rpllist->rplnextp; + free( (charptr) rpllist); + rpllist = rp; + } +} + + + +/* Call a Fortran function with an arbitrary list of arguments */ + +int callk_kludge; + + expptr +#ifdef KR_headers +callk(type, name, args) + int type; + char *name; + chainp args; +#else +callk(int type, char *name, chainp args) +#endif +{ + register expptr p; + + p = mkexpr(OPCALL, + (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0), + (expptr)args); + p->exprblock.vtype = type; + return(p); +} + + + + expptr +#ifdef KR_headers +call4(type, name, arg1, arg2, arg3, arg4) + int type; + char *name; + expptr arg1; + expptr arg2; + expptr arg3; + expptr arg4; +#else +call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4) +#endif +{ + struct Listblock *args; + args = mklist( mkchain((char *)arg1, + mkchain((char *)arg2, + mkchain((char *)arg3, + mkchain((char *)arg4, CHNULL)) ) ) ); + return( callk(type, name, (chainp)args) ); +} + + + + + expptr +#ifdef KR_headers +call3(type, name, arg1, arg2, arg3) + int type; + char *name; + expptr arg1; + expptr arg2; + expptr arg3; +#else +call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3) +#endif +{ + struct Listblock *args; + args = mklist( mkchain((char *)arg1, + mkchain((char *)arg2, + mkchain((char *)arg3, CHNULL) ) ) ); + return( callk(type, name, (chainp)args) ); +} + + + + + + expptr +#ifdef KR_headers +call2(type, name, arg1, arg2) + int type; + char *name; + expptr arg1; + expptr arg2; +#else +call2(int type, char *name, expptr arg1, expptr arg2) +#endif +{ + struct Listblock *args; + + args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) ); + return( callk(type,name, (chainp)args) ); +} + + + + + expptr +#ifdef KR_headers +call1(type, name, arg) + int type; + char *name; + expptr arg; +#else +call1(int type, char *name, expptr arg) +#endif +{ + return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) )); +} + + + expptr +#ifdef KR_headers +call0(type, name) + int type; + char *name; +#else +call0(int type, char *name) +#endif +{ + return( callk(type, name, CHNULL) ); +} + + + + struct Impldoblock * +#ifdef KR_headers +mkiodo(dospec, list) + chainp dospec; + chainp list; +#else +mkiodo(chainp dospec, chainp list) +#endif +{ + register struct Impldoblock *q; + + q = ALLOC(Impldoblock); + q->tag = TIMPLDO; + q->impdospec = dospec; + q->datalist = list; + return(q); +} + + + + +/* ckalloc -- Allocate 1 memory unit of size n, checking for out of + memory error */ + + ptr +#ifdef KR_headers +ckalloc(n) + register int n; +#else +ckalloc(register int n) +#endif +{ + register ptr p; + p = (ptr)calloc(1, (unsigned) n); + if (p || !n) + return(p); + fprintf(stderr, "failing to get %d bytes\n",n); + Fatal("out of memory"); + /* NOT REACHED */ return 0; +} + + + int +#ifdef KR_headers +isaddr(p) + register expptr p; +#else +isaddr(register expptr p) +#endif +{ + if(p->tag == TADDR) + return(YES); + if(p->tag == TEXPR) + switch(p->exprblock.opcode) + { + case OPCOMMA: + return( isaddr(p->exprblock.rightp) ); + + case OPASSIGN: + case OPASSIGNI: + case OPPLUSEQ: + case OPMINUSEQ: + case OPSLASHEQ: + case OPMODEQ: + case OPLSHIFTEQ: + case OPRSHIFTEQ: + case OPBITANDEQ: + case OPBITXOREQ: + case OPBITOREQ: + return( isaddr(p->exprblock.leftp) ); + } + return(NO); +} + + + + int +#ifdef KR_headers +isstatic(p) + register expptr p; +#else +isstatic(register expptr p) +#endif +{ + extern int useauto; + if(p->headblock.vleng && !ISCONST(p->headblock.vleng)) + return(NO); + + switch(p->tag) + { + case TCONST: + return(YES); + + case TADDR: + if(ONEOF(p->addrblock.vstg,MSKSTATIC) && + ISCONST(p->addrblock.memoffset) && !useauto) + return(YES); + + default: + return(NO); + } +} + + + +/* addressable -- return True iff it is a constant value, or can be + referenced by constant values */ + + int +#ifdef KR_headers +addressable(p) expptr p; +#else +addressable(expptr p) +#endif +{ + if (p) + switch(p->tag) { + case TCONST: + return(YES); + + case TADDR: + return( addressable(p->addrblock.memoffset) ); + } + return(NO); + } + + +/* isnegative_const -- returns true if the constant is negative. Returns + false for imaginary and nonnumeric constants */ + + int +#ifdef KR_headers +isnegative_const(cp) + struct Constblock *cp; +#else +isnegative_const(struct Constblock *cp) +#endif +{ + int retval; + + if (cp == NULL) + return 0; + + switch (cp -> vtype) { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + retval = cp -> Const.ci < 0; + break; + case TYREAL: + case TYDREAL: + retval = cp->vstg ? *cp->Const.cds[0] == '-' + : cp->Const.cd[0] < 0.0; + break; + default: + + retval = 0; + break; + } /* switch */ + + return retval; +} /* isnegative_const */ + + void +#ifdef KR_headers +negate_const(cp) + Constp cp; +#else +negate_const(Constp cp) +#endif +{ + if (cp == (struct Constblock *) NULL) + return; + + switch (cp -> vtype) { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + cp -> Const.ci = - cp -> Const.ci; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + if (cp->vstg) + switch(*cp->Const.cds[1]) { + case '-': + ++cp->Const.cds[1]; + break; + case '0': + break; + default: + --cp->Const.cds[1]; + } + else + cp->Const.cd[1] = -cp->Const.cd[1]; + /* no break */ + case TYREAL: + case TYDREAL: + if (cp->vstg) + switch(*cp->Const.cds[0]) { + case '-': + ++cp->Const.cds[0]; + break; + case '0': + break; + default: + --cp->Const.cds[0]; + } + else + cp->Const.cd[0] = -cp->Const.cd[0]; + break; + case TYCHAR: + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + erri ("negate_const: can't negate type '%d'", cp -> vtype); + break; + default: + erri ("negate_const: bad type '%d'", + cp -> vtype); + break; + } /* switch */ +} /* negate_const */ + + void +#ifdef KR_headers +ffilecopy(infp, outfp) FILE *infp, *outfp; +#else +ffilecopy(FILE *infp, FILE *outfp) +#endif +{ + int c; + while (!feof(infp)) { + c = getc(infp); + if (!feof(infp)) + putc(c, outfp); + } + } + + +/* in_vector -- verifies whether str is in c_keywords. + If so, the index is returned else -1 is returned. + c_keywords must be in alphabetical order (as defined by strcmp). +*/ + + int +#ifdef KR_headers +in_vector(str, keywds, n) + char *str; + char **keywds; + register int n; +#else +in_vector(char *str, char **keywds, register int n) +#endif +{ + register char **K = keywds; + register int n1, t; + + do { + n1 = n >> 1; + if (!(t = strcmp(str, K[n1]))) + return K - keywds + n1; + if (t < 0) + n = n1; + else { + n -= ++n1; + K += n1; + } + } + while(n > 0); + + return -1; + } /* in_vector */ + + + int +#ifdef KR_headers +is_negatable(Const) + Constp Const; +#else +is_negatable(Constp Const) +#endif +{ + int retval = 0; + if (Const != (Constp) NULL) + switch (Const -> vtype) { + case TYINT1: + retval = Const -> Const.ci >= -BIGGEST_CHAR; + break; + case TYSHORT: + retval = Const -> Const.ci >= -BIGGEST_SHORT; + break; + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + retval = Const -> Const.ci >= -BIGGEST_LONG; + break; + case TYREAL: + case TYDREAL: + case TYCOMPLEX: + case TYDCOMPLEX: + retval = 1; + break; + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + case TYCHAR: + case TYSUBR: + default: + retval = 0; + break; + } /* switch */ + + return retval; +} /* is_negatable */ + + void +#ifdef KR_headers +backup(fname, bname) + char *fname; + char *bname; +#else +backup(char *fname, char *bname) +#endif +{ + FILE *b, *f; + static char couldnt[] = "Couldn't open %.80s"; + + if (!(f = fopen(fname, binread))) { + warn1(couldnt, fname); + return; + } + if (!(b = fopen(bname, binwrite))) { + warn1(couldnt, bname); + return; + } + ffilecopy(f, b); + fclose(f); + fclose(b); + } + + +/* struct_eq -- returns YES if structures have the same field names and + types, NO otherwise */ + + int +#ifdef KR_headers +struct_eq(s1, s2) + chainp s1; + chainp s2; +#else +struct_eq(chainp s1, chainp s2) +#endif +{ + struct Dimblock *d1, *d2; + Constp cp1, cp2; + + if (s1 == CHNULL && s2 == CHNULL) + return YES; + for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) { + register Namep v1 = (Namep) s1 -> datap; + register Namep v2 = (Namep) s2 -> datap; + + if (v1 == (Namep) NULL || v1 -> tag != TNAME || + v2 == (Namep) NULL || v2 -> tag != TNAME) + return NO; + + if (v1->vtype != v2->vtype || v1->vclass != v2->vclass + || strcmp(v1->fvarname, v2->fvarname)) + return NO; + + /* compare dimensions (needed for comparing COMMON blocks) */ + + if (d1 = v1->vdim) { + if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST + || !(d2 = v2->vdim) + || !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST + || cp1->Const.ci != cp2->Const.ci) + return NO; + } + else if (v2->vdim) + return NO; + } /* while s1 != CHNULL && s2 != CHNULL */ + + return s1 == CHNULL && s2 == CHNULL; +} /* struct_eq */ + + static int +#ifdef KR_headers +int_trunc(n0, s0) int n0; char *s0; +#else +int_trunc(int n0, char *s0) +#endif +{ + char buff[100]; + + if (n0 > 60) + n0 = 60; + sprintf(buff, "integer constant %.*s truncated.", n0, s0); + err(buff); + return 1; + } + + tagptr +#ifdef KR_headers +mkintqcon(n, s) int n; char *s; +#else +mkintqcon(int n, char *s) +#endif +{ +#ifdef NO_LONG_LONG + return mkintcon(convci(n, s)); +#else +#ifndef LLONG_MAX +#ifdef LONGLONG_MAX +#define LLONG_MAX LONGLONG_MAX +#else +#define LLONG_MAX 0x7fffffffffffffffLL +#endif +#endif + Constp p; + Llong sum, t; + char *s0; + int n0, warned = 0; + + s0 = s; + n0 = n; + sum = 0; + while(n-- > 0) { + /* sum = 10*sum + (*s++ - '0'); */ + t = *s++ - '0'; + if (sum > LLONG_MAX/10) { + ovfl: + warned = int_trunc(n0,s0); + sum = LLONG_MAX; + break; + } + sum *= 10; + if (sum > LLONG_MAX - t) + goto ovfl; + sum += t; + } + p = mkconst(tyint); + if (sum > LONG_MAX) { + if (allow_i8c) { + p->vtype = TYQUAD; + p->Const.cq = sum; + } + else { + p->Const.ci = LONG_MAX; + if (!warned) + int_trunc(n0,s0); + } + } + else + p->Const.ci = (ftnint) sum; + return (tagptr)p; +#endif + } diff --git a/unix/f2c/src/mkfile.plan9 b/unix/f2c/src/mkfile.plan9 new file mode 100644 index 00000000..73466121 --- /dev/null +++ b/unix/f2c/src/mkfile.plan9 @@ -0,0 +1,107 @@ +# Plan 9 mkfile for f2c, a Fortran 77 to C converter + +gram.in + $YACC $YFLAGS gram.in + @echo "(There should be 4 shift/reduce conflicts.)" + sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c + rm -f gram.in y.tab.c + +$OBJECTSd: defs.h ftypes.h defines.h machdefs.h sysdep.h + +tokdefs.h: tokens + grep -n . tokdefs.h + +cds.$O: sysdep.h +exec.$O: p1defs.h names.h +expr.$O: output.h niceprintf.h names.h +format.$O: p1defs.h format.h output.h niceprintf.h names.h iob.h +formatdata.$O: format.h output.h niceprintf.h names.h +gram.$O: p1defs.h +init.$O: output.h niceprintf.h iob.h +intr.$O: names.h +io.$O: names.h iob.h +lex.$O : tokdefs.h p1defs.h +main.$O: parse.h usignal.h +mem.$O: iob.h +names.$O: iob.h names.h output.h niceprintf.h +niceprintf.$O: defs.h names.h output.h niceprintf.h +output.$O: output.h niceprintf.h names.h +p1output.$O: p1defs.h output.h niceprintf.h names.h +parse_args.$O: parse.h +proc.$O: tokdefs.h names.h niceprintf.h output.h p1defs.h +put.$O: names.h pccdefs.h p1defs.h +putpcc.$O: names.h +vax.$O: defs.h output.h pccdefs.h +output.h: niceprintf.h + +put.$O putpcc.$O: pccdefs.h + +f2c.t: f2c.1t + troff -man f2c.1t >f2c.t + +#f2c.1: f2c.1t +# nroff -man f2c.1t | col -b | uniq >f2c.1 + +clean: + rm -f *.$O f2c tokdefs.h f2c.t + +veryclean: clean + rm -f xsum + +b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ + exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ + ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ + init.c intr.c io.c iob.h lex.c machdefs.h main.c \ + malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \ + niceprintf.h output.c output.h p1defs.h p1output.c \ + parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \ + sysdep.c sysdep.h tokens usignal.h vax.c version.c xsum.c + +xsum: xsum.c + $CC $CFLAGS -o xsum xsum.c + +#Check validity of transmitted source... +xsum.out: xsum $b + ./xsum $b >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsum.out + +#On non-Unix systems that end lines with carriage-return/newline pairs, +#use "make xsumr.out" rather than "make xsum.out". The -r flag ignores +#carriage-return characters. +xsumr.out: xsum $b + ./xsum -r $b >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out diff --git a/unix/f2c/src/mkpkg.sh b/unix/f2c/src/mkpkg.sh new file mode 100644 index 00000000..4092705d --- /dev/null +++ b/unix/f2c/src/mkpkg.sh @@ -0,0 +1,5 @@ +# Bootstrap the F2C compiler and libraries. + +make -f makefile.u +mv f2c ../../bin/f2c.e +rm *.o diff --git a/unix/f2c/src/names.c b/unix/f2c/src/names.c new file mode 100644 index 00000000..373f656c --- /dev/null +++ b/unix/f2c/src/names.c @@ -0,0 +1,835 @@ +/**************************************************************** +Copyright 1990, 1992 - 1996, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "output.h" +#include "names.h" +#include "iob.h" + + +/* Names generated by the translator are guaranteed to be unique from the + Fortan names because Fortran does not allow underscores in identifiers, + and all of the system generated names do have underscores. The various + naming conventions are outlined below: + + FORMAT APPLICATION + ---------------------------------------------------------------------- + io_# temporaries generated by IO calls; these will + contain the device number (e.g. 5, 6, 0) + ret_val function return value, required for complex and + character functions. + ret_val_len length of the return value in character functions + + ssss_len length of character argument "ssss" + + c_# member of the literal pool, where # is an + arbitrary label assigned by the system + cs_# short integer constant in the literal pool + t_# expression temporary, # is the depth of arguments + on the stack. + L# label "#", given by user in the Fortran program. + This is unique because Fortran labels are numeric + pad_# label on an init field required for alignment + xxx_init label on a common block union, if a block data + requires a separate declaration +*/ + +/* generate variable references */ + + char * +#ifdef KR_headers +c_type_decl(type, is_extern) + int type; + int is_extern; +#else +c_type_decl(int type, int is_extern) +#endif +{ + static char buff[100]; + + switch (type) { + case TYREAL: if (!is_extern || !forcedouble) + { strcpy (buff, "real");break; } + case TYDREAL: strcpy (buff, "doublereal"); break; + case TYCOMPLEX: if (is_extern) + strcpy (buff, "/* Complex */ VOID"); + else + strcpy (buff, "complex"); + break; + case TYDCOMPLEX:if (is_extern) + strcpy (buff, "/* Double Complex */ VOID"); + else + strcpy (buff, "doublecomplex"); + break; + case TYADDR: + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: strcpy(buff, Typename[type]); + break; + case TYCHAR: if (is_extern) + strcpy (buff, "/* Character */ VOID"); + else + strcpy (buff, "char"); + break; + + case TYUNKNOWN: strcpy (buff, "UNKNOWN"); + +/* If a procedure's type is unknown, assume it's a subroutine */ + + if (!is_extern) + break; + +/* Subroutines must return an INT, because they might return a label + value. Even if one doesn't, the caller will EXPECT it to. */ + + case TYSUBR: strcpy (buff, "/* Subroutine */ int"); + break; + case TYERROR: strcpy (buff, "ERROR"); break; + case TYVOID: strcpy (buff, "void"); break; + case TYCILIST: strcpy (buff, "cilist"); break; + case TYICILIST: strcpy (buff, "icilist"); break; + case TYOLIST: strcpy (buff, "olist"); break; + case TYCLLIST: strcpy (buff, "cllist"); break; + case TYALIST: strcpy (buff, "alist"); break; + case TYINLIST: strcpy (buff, "inlist"); break; + case TYFTNLEN: strcpy (buff, "ftnlen"); break; + default: sprintf (buff, "BAD DECL '%d'", type); + break; + } /* switch */ + + return buff; +} /* c_type_decl */ + + + char * +new_func_length(Void) +{ return "ret_val_len"; } + + char * +#ifdef KR_headers +new_arg_length(arg) + Namep arg; +#else +new_arg_length(Namep arg) +#endif +{ + static char buf[64]; + char *fmt = "%s_len", *s = arg->fvarname; + switch(*s) { + case 'r': + if (!strcmp(s+1, "et_val")) + goto adjust_fmt; + break; + case 'h': + case 'i': + if (!s[1]) { + adjust_fmt: + fmt = "%s_length"; /* avoid conflict with libF77 */ + } + } + sprintf (buf, fmt, s); + return buf; +} /* new_arg_length */ + + +/* declare_new_addr -- Add a new local variable to the function, given a + pointer to an Addrblock structure (which must have the uname_tag set) + This list of idents will be printed in reverse (i.e., chronological) + order */ + + void +#ifdef KR_headers +declare_new_addr(addrp) + struct Addrblock *addrp; +#else +declare_new_addr(struct Addrblock *addrp) +#endif +{ + extern chainp new_vars; + + new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars); +} /* declare_new_addr */ + + + void +#ifdef KR_headers +wr_nv_ident_help(outfile, addrp) + FILE *outfile; + struct Addrblock *addrp; +#else +wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp) +#endif +{ + int eltcount = 0; + + if (addrp == (struct Addrblock *) NULL) + return; + + if (addrp -> isarray) { + frexpr (addrp -> memoffset); + addrp -> memoffset = ICON(0); + eltcount = addrp -> ntempelt; + addrp -> ntempelt = 0; + addrp -> isarray = 0; + } /* if */ + out_addr (outfile, addrp); + if (eltcount) + nice_printf (outfile, "[%d]", eltcount); +} /* wr_nv_ident_help */ + + int +#ifdef KR_headers +nv_type_help(addrp) + struct Addrblock *addrp; +#else +nv_type_help(struct Addrblock *addrp) +#endif +{ + if (addrp == (struct Addrblock *) NULL) + return -1; + + return addrp -> vtype; +} /* nv_type_help */ + + +/* lit_name -- returns a unique identifier for the given literal. Make + the label useful, when possible. For example: + + 1 -> c_1 (constant 1) + 2 -> c_2 (constant 2) + 1000 -> c_1000 (constant 1000) + 1000000 -> c_b (big constant number) + 1.2 -> c_1_2 (constant 1.2) + 1.234345 -> c_b (big constant number) + -1 -> c_n1 (constant -1) + -1.0 -> c_n1_0 (constant -1.0) + .true. -> c_true (constant true) + .false. -> c_false (constant false) + default -> c_b (default label) +*/ + + char * +#ifdef KR_headers +lit_name(litp) + struct Literal *litp; +#else +lit_name(struct Literal *litp) +#endif +{ + static char buf[CONST_IDENT_MAX]; + ftnint val; + char *fmt; + + if (litp == (struct Literal *) NULL) + return NULL; + + switch (litp -> littype) { + case TYINT1: + val = litp -> litval.litival; + if (val >= 256 || val < -255) + sprintf (buf, "ci1_b%ld", litp -> litnum); + else if (val < 0) + sprintf (buf, "ci1_n%ld", -val); + else + sprintf(buf, "ci1__%ld", val); + break; + case TYSHORT: + val = litp -> litval.litival; + if (val >= 32768 || val <= -32769) + sprintf (buf, "cs_b%ld", litp -> litnum); + else if (val < 0) + sprintf (buf, "cs_n%ld", -val); + else + sprintf (buf, "cs__%ld", val); + break; + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + val = litp -> litval.litival; + if (val >= 100000 || val <= -10000) + sprintf (buf, "c_b%ld", litp -> litnum); + else if (val < 0) + sprintf (buf, "c_n%ld", -val); + else + sprintf (buf, "c__%ld", val); + break; + case TYLOGICAL1: + fmt = "cl1_%s"; + goto spr_logical; + case TYLOGICAL2: + fmt = "cl2_%s"; + goto spr_logical; + case TYLOGICAL: + fmt = "c_%s"; + spr_logical: + sprintf (buf, fmt, (litp -> litval.litival + ? "true" : "false")); + break; + case TYREAL: + case TYDREAL: + /* Given a limit of 6 or 8 character on external names, */ + /* few f.p. values can be meaningfully encoded in the */ + /* constant name. Just going with the default cb_# */ + /* seems to be the best course for floating-point */ + /* constants. */ + case TYCHAR: + /* Shouldn't be any of these */ + case TYADDR: + case TYCOMPLEX: + case TYDCOMPLEX: + case TYSUBR: + default: + sprintf (buf, "c_b%ld", litp -> litnum); + } /* switch */ + return buf; +} /* lit_name */ + + + + char * +#ifdef KR_headers +comm_union_name(count) + int count; +#else +comm_union_name(int count) +#endif +{ + static char buf[12]; + + sprintf(buf, "%d", count); + return buf; + } + + + + +/* wr_globals -- after every function has been translated, we need to + output the global declarations, such as the static table of constant + values */ + + void +#ifdef KR_headers +wr_globals(outfile) + FILE *outfile; +#else +wr_globals(FILE *outfile) +#endif +{ + struct Literal *litp, *lastlit; + extern int hsize; + char *litname; + int did_one, t; + struct Constblock cb; + ftnint x, y; + + if (nliterals == 0) + return; + + lastlit = litpool + nliterals; + did_one = 0; + for (litp = litpool; litp < lastlit; litp++) { + if (!litp->lituse) + continue; + litname = lit_name(litp); + if (!did_one) { + margin_printf(outfile, "/* Table of constant values */\n\n"); + did_one = 1; + } + cb.vtype = litp->littype; + if (litp->littype == TYCHAR) { + x = litp->litval.litival2[0] + litp->litval.litival2[1]; + if (y = x % hsize) + x += y = hsize - y; + nice_printf(outfile, + "static struct { %s fill; char val[%ld+1];", halign, x); + nice_printf(outfile, " char fill2[%ld];", hsize - 1); + nice_printf(outfile, " } %s_st = { 0,", litname); + cb.vleng = ICON(litp->litval.litival2[0]); + cb.Const.ccp = litp->cds[0]; + cb.Const.ccp1.blanks = litp->litval.litival2[1] + y; + cb.vtype = TYCHAR; + out_const(outfile, &cb); + frexpr(cb.vleng); + nice_printf(outfile, " };\n"); + nice_printf(outfile, "#define %s %s_st.val\n", litname, litname); + continue; + } + nice_printf(outfile, "static %s %s = ", + c_type_decl(litp->littype,0), litname); + + t = litp->littype; + if (ONEOF(t, MSKREAL|MSKCOMPLEX)) { + cb.vstg = 1; + cb.Const.cds[0] = litp->cds[0]; + cb.Const.cds[1] = litp->cds[1]; + } + else { + memcpy((char *)&cb.Const, (char *)&litp->litval, + sizeof(cb.Const)); + cb.vstg = 0; + } + out_const(outfile, &cb); + + nice_printf (outfile, ";\n"); + } /* for */ + if (did_one) + nice_printf (outfile, "\n"); +} /* wr_globals */ + + ftnint +#ifdef KR_headers +commlen(vl) + register chainp vl; +#else +commlen(register chainp vl) +#endif +{ + ftnint size; + int type; + struct Dimblock *t; + Namep v; + + while(vl->nextp) + vl = vl->nextp; + v = (Namep)vl->datap; + type = v->vtype; + if (type == TYCHAR) + size = v->vleng->constblock.Const.ci; + else + size = typesize[type]; + if ((t = v->vdim) && ISCONST(t->nelt)) + size *= t->nelt->constblock.Const.ci; + return size + v->voffset; + } + + static void /* Pad common block if an EQUIVALENCE extended it. */ +#ifdef KR_headers +pad_common(c) + Extsym *c; +#else +pad_common(Extsym *c) +#endif +{ + register chainp cvl; + register Namep v; + long L = c->maxleng; + int type; + struct Dimblock *t; + int szshort = typesize[TYSHORT]; + + for(cvl = c->allextp; cvl; cvl = cvl->nextp) + if (commlen((chainp)cvl->datap) >= L) + return; + v = ALLOC(Nameblock); + v->vtype = type = L % szshort ? TYCHAR + : type_choice[L/szshort % 4]; + v->vstg = STGCOMMON; + v->vclass = CLVAR; + v->tag = TNAME; + v->vdim = t = ALLOC(Dimblock); + t->ndim = 1; + t->dims[0].dimsize = ICON(L / typesize[type]); + v->fvarname = v->cvarname = "eqv_pad"; + if (type == TYCHAR) + v->vleng = ICON(1); + c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp); + } + + +/* wr_common_decls -- outputs the common declarations in one of three + formats. If all references to a common block look the same (field + names and types agree), only one actual declaration will appear. + Otherwise, the same block will require many structs. If there is no + block data, these structs will be union'ed together (so the linker + knows the size of the largest one). If there IS a block data, only + that version will be associated with the variable, others will only be + defined as types, so the pointer can be cast to it. e.g. + + FORTRAN C +---------------------------------------------------------------------- + common /com1/ a, b, c struct { real a, b, c; } com1_; + + common /com1/ a, b, c union { + common /com1/ i, j, k struct { real a, b, c; } _1; + struct { integer i, j, k; } _2; + } com1_; + + common /com1/ a, b, c struct com1_1_ { real a, b, c; }; + block data struct { integer i, j, k; } com1_ = + common /com1/ i, j, k { 1, 2, 3 }; + data i/1/, j/2/, k/3/ + + + All of these versions will be followed by #defines, since the code in + the function bodies can't know ahead of time which of these options + will be taken */ + +/* Macros for deciding the output type */ + +#define ONE_STRUCT 1 +#define UNION_STRUCT 2 +#define INIT_STRUCT 3 + + void +#ifdef KR_headers +wr_common_decls(outfile) + FILE *outfile; +#else +wr_common_decls(FILE *outfile) +#endif +{ + Extsym *ext; + extern int extcomm; + static char *Extern[4] = {"", "Extern ", "extern "}; + char *E, *E0 = Extern[extcomm]; + int did_one = 0; + + for (ext = extsymtab; ext < nextext; ext++) { + if (ext -> extstg == STGCOMMON && ext->allextp) { + chainp comm; + int count = 1; + int which; /* which display to use; + ONE_STRUCT, UNION or INIT */ + + if (!did_one) + nice_printf (outfile, "/* Common Block Declarations */\n\n"); + + pad_common(ext); + +/* Construct the proper, condensed list of structs; eliminate duplicates + from the initial list ext -> allextp */ + + comm = ext->allextp = revchain(ext->allextp); + + if (ext -> extinit) + which = INIT_STRUCT; + else if (comm->nextp) { + which = UNION_STRUCT; + nice_printf (outfile, "%sunion {\n", E0); + next_tab (outfile); + E = ""; + } + else { + which = ONE_STRUCT; + E = E0; + } + + for (; comm; comm = comm -> nextp, count++) { + + if (which == INIT_STRUCT) + nice_printf (outfile, "struct %s%d_ {\n", + ext->cextname, count); + else + nice_printf (outfile, "%sstruct {\n", E); + + next_tab (c_file); + + wr_struct (outfile, (chainp) comm -> datap); + + prev_tab (c_file); + if (which == UNION_STRUCT) + nice_printf (outfile, "} _%d;\n", count); + else if (which == ONE_STRUCT) + nice_printf (outfile, "} %s;\n", ext->cextname); + else + nice_printf (outfile, "};\n"); + } /* for */ + + if (which == UNION_STRUCT) { + prev_tab (c_file); + nice_printf (outfile, "} %s;\n", ext->cextname); + } /* if */ + did_one = 1; + nice_printf (outfile, "\n"); + + for (count = 1, comm = ext -> allextp; comm; + comm = comm -> nextp, count++) { + def_start(outfile, ext->cextname, + comm_union_name(count), ""); + switch (which) { + case ONE_STRUCT: + extern_out (outfile, ext); + break; + case UNION_STRUCT: + nice_printf (outfile, "("); + extern_out (outfile, ext); + nice_printf(outfile, "._%d)", count); + break; + case INIT_STRUCT: + nice_printf (outfile, "(*(struct "); + extern_out (outfile, ext); + nice_printf (outfile, "%d_ *) &", count); + extern_out (outfile, ext); + nice_printf (outfile, ")"); + break; + } /* switch */ + nice_printf (outfile, "\n"); + } /* for count = 1, comm = ext -> allextp */ + nice_printf (outfile, "\n"); + } /* if ext -> extstg == STGCOMMON */ + } /* for ext = extsymtab */ +} /* wr_common_decls */ + + void +#ifdef KR_headers +wr_struct(outfile, var_list) + FILE *outfile; + chainp var_list; +#else +wr_struct(FILE *outfile, chainp var_list) +#endif +{ + int last_type = -1; + int did_one = 0; + chainp this_var; + + for (this_var = var_list; this_var; this_var = this_var -> nextp) { + Namep var = (Namep) this_var -> datap; + int type; + char *comment = NULL; + + if (var == (Namep) NULL) + err ("wr_struct: null variable"); + else if (var -> tag != TNAME) + erri ("wr_struct: bad tag on variable '%d'", + var -> tag); + + type = var -> vtype; + + if (last_type == type && did_one) + nice_printf (outfile, ", "); + else { + if (did_one) + nice_printf (outfile, ";\n"); + nice_printf (outfile, "%s ", + c_type_decl (type, var -> vclass == CLPROC)); + } /* else */ + +/* Character type is really a string type. Put out a '*' for parameters + with unknown length and functions returning character */ + + if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng)) + || var -> vclass == CLPROC)) + nice_printf (outfile, "*"); + + var -> vstg = STGAUTO; + out_name (outfile, var); + if (var -> vclass == CLPROC) + nice_printf (outfile, "()"); + else if (var -> vdim) + comment = wr_ardecls(outfile, var->vdim, + var->vtype == TYCHAR && ISICON(var->vleng) + ? var->vleng->constblock.Const.ci : 1L); + else if (var -> vtype == TYCHAR && var -> vclass != CLPROC && + ISICON ((var -> vleng))) + nice_printf (outfile, "[%ld]", + var -> vleng -> constblock.Const.ci); + + if (comment) + nice_printf (outfile, "%s", comment); + did_one = 1; + last_type = type; + } /* for this_var */ + + if (did_one) + nice_printf (outfile, ";\n"); +} /* wr_struct */ + + + char * +#ifdef KR_headers +user_label(stateno) + ftnint stateno; +#else +user_label(ftnint stateno) +#endif +{ + static char buf[USER_LABEL_MAX + 1]; + static char *Lfmt[2] = { "L_%ld", "L%ld" }; + + if (stateno >= 0) + sprintf(buf, Lfmt[shiftcase], stateno); + else + sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname); + return buf; +} /* user_label */ + + + char * +#ifdef KR_headers +temp_name(starter, num, storage) + char *starter; + int num; + char *storage; +#else +temp_name(char *starter, int num, char *storage) +#endif +{ + static char buf[IDENT_LEN]; + char *pointer = buf; + char *prefix = "t"; + + if (storage) + pointer = storage; + + if (starter && *starter) + prefix = starter; + + sprintf (pointer, "%s__%d", prefix, num); + return pointer; +} /* temp_name */ + + + char * +#ifdef KR_headers +equiv_name(memno, store) + int memno; + char *store; +#else +equiv_name(int memno, char *store) +#endif +{ + static char buf[IDENT_LEN]; + char *pointer = buf; + + if (store) + pointer = store; + + sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno); + return pointer; +} /* equiv_name */ + + void +#ifdef KR_headers +def_commons(of) + FILE *of; +#else +def_commons(FILE *of) +#endif +{ + Extsym *ext; + int c, onefile, Union; + chainp comm; + extern int ext1comm; + FILE *c_filesave = c_file; + + if (ext1comm == 1) { + onefile = 1; + c_file = of; + fprintf(of, "/*>>>'/dev/null'<<<*/\n\ +#ifdef Define_COMMONs\n\ +/*<<>>*/\n"); + } + else + onefile = 0; + for(ext = extsymtab; ext < nextext; ext++) + if (ext->extstg == STGCOMMON + && !ext->extinit && (comm = ext->allextp)) { + sprintf(outbtail, "%scom.c", ext->cextname); + if (onefile) + fprintf(of, "/*>>>'%s'<<<*/\n", + outbtail); + else { + c_file = of = fopen(outbuf,textwrite); + if (!of) + fatalstr("can't open %s", outbuf); + } + fprintf(of, "#include \"f2c.h\"\n"); + if (Ansi == 2) + fprintf(of, + "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n"); + if (comm->nextp) { + Union = 1; + nice_printf(of, "union {\n"); + next_tab(of); + } + else + Union = 0; + for(c = 1; comm; comm = comm->nextp) { + nice_printf(of, "struct {\n"); + next_tab(of); + wr_struct(of, (chainp)comm->datap); + prev_tab(of); + if (Union) + nice_printf(of, "} _%d;\n", c++); + } + if (Union) + prev_tab(of); + nice_printf(of, "} %s;\n", ext->cextname); + if (Ansi == 2) + fprintf(of, + "\n#ifdef __cplusplus\n}\n#endif\n"); + if (onefile) + fprintf(of, "/*<<<%s>>>*/\n", outbtail); + else + fclose(of); + } + if (onefile) + fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\ +/*<<>>*/\n"); + c_file = c_filesave; + } + +/* C Language keywords. Needed to filter unwanted fortran identifiers like + * "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup. + * Also includes C++ keywords and types used for I/O in f2c.h . + * These keywords must be in alphabetical order (as defined by strcmp()). + */ + +char *c_keywords[] = { + "Long", "Multitype", "Namelist", "Vardesc", "abs", "acos", + "addr", "address", "aerr", "alist", "asin", "asm", "atan", + "atan2", "aunit", "auto", "break", "c", "case", "catch", "cdecl", + "cerr", "char", "ciend", "cierr", "cifmt", "cilist", "cirec", + "ciunit", "class", "cllist", "complex", "const", "continue", "cos", + "cosh", "csta", "cunit", "d", "dabs", "default", "defined", + "delete", "dims", "dmax", "dmin", "do", "double", + "doublecomplex", "doublereal", "else", "entry", "enum", "exp", + "extern", "false", "far", "flag", "float", "for", "friend", + "ftnint", "ftnlen", "goto", "h", "huge", "i", "iciend", "icierr", + "icifmt", "icilist", "icirlen", "icirnum", "iciunit", "if", + "inacc", "inacclen", "inblank", "inblanklen", "include", + "indir", "indirlen", "inerr", "inex", "infile", "infilen", + "infmt", "infmtlen", "inform", "informlen", "inline", "inlist", + "inname", "innamed", "innamlen", "innrec", "innum", "inopen", + "inrecl", "inseq", "inseqlen", "int", "integer", "integer1", + "inunf", "inunflen", "inunit", "log", "logical", "logical1", + "long", "longint", "max", "min", "name", "near", "new", "nvars", + "oacc", "oblnk", "oerr", "ofm", "ofnm", "ofnmlen", "olist", + "operator", "orl", "osta", "ounit", "overload", "private", + "protected", "public", "r", "real", "register", "return", + "short", "shortint", "shortlogical", "signed", "sin", "sinh", + "sizeof", "sqrt", "static", "struct", "switch", "tan", "tanh", + "template", "this", "true", "try", "type", "typedef", "uinteger", + "ulongint", "union", "unsigned", "vars", "virtual", "void", + "volatile", "while", "z" + }; /* c_keywords */ + +int n_keywords = sizeof(c_keywords)/sizeof(char *); diff --git a/unix/f2c/src/names.h b/unix/f2c/src/names.h new file mode 100644 index 00000000..16bcc0b4 --- /dev/null +++ b/unix/f2c/src/names.h @@ -0,0 +1,19 @@ +#define CONST_IDENT_MAX 30 +#define IO_IDENT_MAX 30 +#define ARGUMENT_MAX 30 +#define USER_LABEL_MAX 30 + +#define EQUIV_INIT_NAME "equiv" + +#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a)) +#define nv_type(x) nv_type_help ((struct Addrblock *) x) + +extern char *c_keywords[]; + +char* c_type_decl Argdcl((int, int)); +void declare_new_addr Argdcl((Addrp)); +char* new_arg_length Argdcl((Namep)); +char* new_func_length Argdcl((void)); +int nv_type_help Argdcl((Addrp)); +char* temp_name Argdcl((char*, int, char*)); +char* user_label Argdcl((long int)); diff --git a/unix/f2c/src/niceprintf.c b/unix/f2c/src/niceprintf.c new file mode 100644 index 00000000..a32411c4 --- /dev/null +++ b/unix/f2c/src/niceprintf.c @@ -0,0 +1,445 @@ +/**************************************************************** +Copyright 1990, 1991, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "names.h" +#include "output.h" +#ifndef KR_headers +#include "stdarg.h" +#endif + +#define TOO_LONG_INDENT (2 * tab_size) +#define MAX_INDENT 44 +#define MIN_INDENT 22 +static int last_was_newline = 0; +int sharp_line = 0; +int indent = 0; +int in_comment = 0; +int in_define = 0; + extern int gflag1; + extern char filename[]; + + static void ind_printf Argdcl((int, FILE*, const char*, va_list)); + + static void +#ifdef KR_headers +write_indent(fp, use_indent, extra_indent, start, end) + FILE *fp; + int use_indent; + int extra_indent; + char *start; + char *end; +#else +write_indent(FILE *fp, int use_indent, int extra_indent, char *start, char *end) +#endif +{ + int ind, tab; + + if (sharp_line) { + fprintf(fp, "#line %ld \"%s\"\n", lineno, filename); + sharp_line = 0; + } + if (in_define == 1) { + in_define = 2; + use_indent = 0; + } + if (last_was_newline && use_indent) { + if (*start == '\n') do { + putc('\n', fp); + if (++start > end) + return; + } + while(*start == '\n'); + + ind = indent <= MAX_INDENT + ? indent + : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT); + + tab = ind + extra_indent; + + while (tab > 7) { + putc ('\t', fp); + tab -= 8; + } /* while */ + + while (tab-- > 0) + putc (' ', fp); + } /* if last_was_newline */ + + while (start <= end) + putc (*start++, fp); +} /* write_indent */ + +#ifdef KR_headers +/*VARARGS2*/ + void + margin_printf (fp, a, b, c, d, e, f, g) + FILE *fp; + char *a; + long b, c, d, e, f, g; +{ + ind_printf (0, fp, a, b, c, d, e, f, g); +} /* margin_printf */ + +/*VARARGS2*/ + void + nice_printf (fp, a, b, c, d, e, f, g) + FILE *fp; + char *a; + long b, c, d, e, f, g; +{ + ind_printf (1, fp, a, b, c, d, e, f, g); +} /* nice_printf */ +#define SPRINTF(x,a,b,c,d,e,f,g) sprintf(x,a,b,c,d,e,f,g) + +#else /* if (!defined(KR_HEADERS)) */ + +#define SPRINTF(x,a,b,c,d,e,f,g) vsprintf(x,a,ap) + + void + margin_printf(FILE *fp, const char *fmt, ...) +{ + va_list ap; + va_start(ap,fmt); + ind_printf(0, fp, fmt, ap); + va_end(ap); + } + + void + nice_printf(FILE *fp, const char *fmt, ...) +{ + va_list ap; + va_start(ap,fmt); + ind_printf(1, fp, fmt, ap); + va_end(ap); + } +#endif + +#define max_line_len c_output_line_length + /* 74Number of characters allowed on an output + line. This assumes newlines are handled + nicely, i.e. a newline after a full text + line on a terminal is ignored */ + +/* output_buf holds the text of the next line to be printed. It gets + flushed when a newline is printed. next_slot points to the next + available location in the output buffer, i.e. where the next call to + nice_printf will have its output stored */ + +static char *output_buf; +static char *next_slot; +static char *string_start; + +static char *word_start = NULL; +static int cursor_pos = 0; +static int In_string = 0; + + void +np_init(Void) +{ + next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE); + memset(output_buf, 0, MAX_OUTPUT_SIZE); + } + + static char * +#ifdef KR_headers +adjust_pointer_in_string(pointer) + register char *pointer; +#else +adjust_pointer_in_string(register char *pointer) +#endif +{ + register char *s, *s1, *se, *s0; + + /* arrange not to break \002 */ + s1 = string_start ? string_start : output_buf; + for(s = s1; s < pointer; s++) { + s0 = s1; + s1 = s; + if (*s == '\\') { + se = s++ + 4; + if (se > pointer) + break; + if (*s < '0' || *s > '7') + continue; + while(++s < se) + if (*s < '0' || *s > '7') + break; + --s; + } + } + return s0 - 1; + } + +/* ANSI says strcpy's behavior is undefined for overlapping args, + * so we roll our own fwd_strcpy: */ + + static void +#ifdef KR_headers +fwd_strcpy(t, s) + register char *t; + register char *s; +#else +fwd_strcpy(register char *t, register char *s) +#endif +{ while(*t++ = *s++); } + +/* isident -- true iff character could belong to a unit. C allows + letters, numbers and underscores in identifiers. This also doubles as + a check for numeric constants, since we include the decimal point and + minus sign. The minus has to be here, since the constant "10e-2" + cannot be broken up. The '.' also prevents structure references from + being broken, which is a quite acceptable side effect */ + +#define isident(x) (Tr[x] & 1) +#define isntident(x) (!Tr[x]) + + static void +#ifdef KR_headers + ind_printf (use_indent, fp, a, b, c, d, e, f, g) + int use_indent; + FILE *fp; + char *a; + long b, c, d, e, f, g; +#else + ind_printf (int use_indent, FILE *fp, const char *a, va_list ap) +#endif +{ + extern int max_line_len; + extern FILEP c_file; + extern char tr_tab[]; /* in output.c */ + register char *Tr = tr_tab; + int ch, cmax, inc, ind; + static int extra_indent, last_indent, set_cursor = 1; + + cursor_pos += indent - last_indent; + last_indent = indent; + SPRINTF (next_slot, a, b, c, d, e, f, g); + + if (fp != c_file) { + fprintf (fp,"%s", next_slot); + return; + } /* if fp != c_file */ + + do { + char *pointer; + +/* The for loop will parse one output line */ + + if (set_cursor) { + ind = indent <= MAX_INDENT + ? indent + : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT); + cursor_pos = extra_indent; + if (use_indent) + cursor_pos += ind; + set_cursor = 0; + } + if (in_comment) { + cmax = max_line_len + 32; /* let comments be wider */ + for (pointer = next_slot; *pointer && *pointer != '\n' && + cursor_pos <= cmax; pointer++) + cursor_pos++; + } + else + for (pointer = next_slot; *pointer && *pointer != '\n' && + cursor_pos <= max_line_len; pointer++) { + + /* Update state variables here */ + + if (In_string) { + switch(*pointer) { + case '\\': + if (++cursor_pos > max_line_len) { + cursor_pos -= 2; + --pointer; + goto overflow; + } + ++pointer; + break; + case '"': + In_string = 0; + word_start = 0; + } + } + else switch (*pointer) { + case '"': + if (cursor_pos + 5 > max_line_len) { + word_start = 0; + --pointer; + goto overflow; + } + In_string = 1; + string_start = word_start = pointer; + break; + case '\'': + if (pointer[1] == '\\') + if ((ch = pointer[2]) >= '0' && ch <= '7') + for(inc = 3; pointer[inc] != '\'' + && ++inc < 5;); + else + inc = 3; + else + inc = 2; + /*debug*/ if (pointer[inc] != '\'') + /*debug*/ fatalstr("Bad character constant %.10s", + pointer); + if ((cursor_pos += inc) > max_line_len) { + cursor_pos -= inc; + word_start = 0; + --pointer; + goto overflow; + } + word_start = pointer; + pointer += inc; + break; + case '\t': + cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1; + break; + default: { + +/* HACK Assumes that all characters in an atomic C token will be written + at the same time. Must check for tokens first, since '-' is considered + part of an identifier; checking isident first would mean breaking up "->" */ + + if (word_start) { + if (isntident(*(unsigned char *)pointer)) + word_start = NULL; + } + else if (isident(*(unsigned char *)pointer)) + word_start = pointer; + break; + } /* default */ + } /* switch */ + cursor_pos++; + } /* for pointer = next_slot */ + overflow: + if (*pointer == '\0') { + +/* The output line is not complete, so break out and don't output + anything. The current line fragment will be stored in the buffer */ + + next_slot = pointer; + break; + } else { + char last_char; + int in_string0 = In_string; + +/* If the line was too long, move pointer back to the character before + the current word. This allows line breaking on word boundaries. Make + sure that 80 character comment lines get broken up somehow. We assume + that any non-string 80 character identifier must be in a comment. +*/ + + if (*pointer == '\n') + in_define = 0; + else if (word_start && word_start > output_buf) + if (In_string) + if (string_start && pointer - string_start < 5) + pointer = string_start - 1; + else { + pointer = adjust_pointer_in_string(pointer); + string_start = 0; + } + else if (word_start == string_start + && pointer - string_start >= 5) { + pointer = adjust_pointer_in_string(next_slot); + In_string = 1; + string_start = 0; + } + else + pointer = word_start - 1; + else if (cursor_pos > max_line_len) { +#ifndef ANSI_Libraries + extern char *strchr(); +#endif + if (In_string) { + pointer = adjust_pointer_in_string(pointer); + if (string_start && pointer > string_start) + string_start = 0; + } + else if (strchr("&*+-/<=>|", *pointer) + && strchr("!%&*+-/<=>^|", pointer[-1])) { + pointer -= 2; + if (strchr("<>", *pointer)) /* <<=, >>= */ + pointer--; + } + else { + if (word_start) + while(isident(*(unsigned char *)pointer)) + pointer++; + pointer--; + } + } + last_char = *pointer; + write_indent(fp, use_indent, extra_indent, output_buf, pointer); + next_slot = output_buf; + if (In_string && !string_start && Ansi == 1 && last_char != '\n') + *next_slot++ = '"'; + fwd_strcpy(next_slot, pointer + 1); + +/* insert a line break */ + + if (last_char == '\n') { + if (In_string) + last_was_newline = 0; + else { + last_was_newline = 1; + extra_indent = 0; + sharp_line = gflag1; + } + } + else { + extra_indent = TOO_LONG_INDENT; + if (In_string && !string_start) { + if (Ansi == 1) { + fprintf(fp, gflag1 ? "\"\\\n" : "\"\n"); + use_indent = 1; + last_was_newline = 1; + } + else { + fprintf(fp, "\\\n"); + last_was_newline = 0; + } + In_string = in_string0; + } + else { + if (in_define/* | gflag1*/) + putc('\\', fp); + putc ('\n', fp); + last_was_newline = 1; + } + } /* if *pointer != '\n' */ + + if (In_string && Ansi != 1 && !string_start) + cursor_pos = 0; + else + set_cursor = 1; + + string_start = word_start = NULL; + + } /* else */ + + } while (*next_slot); + +} /* ind_printf */ diff --git a/unix/f2c/src/niceprintf.h b/unix/f2c/src/niceprintf.h new file mode 100644 index 00000000..24c65d4d --- /dev/null +++ b/unix/f2c/src/niceprintf.h @@ -0,0 +1,16 @@ +/* niceprintf.h -- contains constants and macros from the output filter + for the generated C code. We use macros for increased speed, less + function overhead. */ + +#define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS + the length of the longest string + printed using nice_printf */ + + + +#define next_tab(fp) (indent += tab_size) + +#define prev_tab(fp) (indent -= tab_size) + + + diff --git a/unix/f2c/src/notice b/unix/f2c/src/notice new file mode 100644 index 00000000..261b719b --- /dev/null +++ b/unix/f2c/src/notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/unix/f2c/src/output.c b/unix/f2c/src/output.c new file mode 100644 index 00000000..c734ca94 --- /dev/null +++ b/unix/f2c/src/output.c @@ -0,0 +1,1753 @@ +/**************************************************************** +Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "names.h" +#include "output.h" + +#ifndef TRUE +#define TRUE 1 +#endif +#ifndef FALSE +#define FALSE 0 +#endif + +char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 }; + +/* Opcode table -- This array is indexed by the OP_____ macros defined in + defines.h; these macros are expected to be adjacent integers, so that + this table is as small as possible. */ + +table_entry opcode_table[] = { + { 0, 0, NULL }, + /* OPPLUS 1 */ { BINARY_OP, 12, "%l + %r" }, + /* OPMINUS 2 */ { BINARY_OP, 12, "%l - %r" }, + /* OPSTAR 3 */ { BINARY_OP, 13, "%l * %r" }, + /* OPSLASH 4 */ { BINARY_OP, 13, "%l / %r" }, + /* OPPOWER 5 */ { BINARY_OP, 0, "power (%l, %r)" }, + /* OPNEG 6 */ { UNARY_OP, 14, "-%l" }, + /* OPOR 7 */ { BINARY_OP, 4, "%l || %r" }, + /* OPAND 8 */ { BINARY_OP, 5, "%l && %r" }, + /* OPEQV 9 */ { BINARY_OP, 9, "%l == %r" }, + /* OPNEQV 10 */ { BINARY_OP, 9, "%l != %r" }, + /* OPNOT 11 */ { UNARY_OP, 14, "! %l" }, + /* OPCONCAT 12 */ { BINARY_OP, 0, "concat (%l, %r)" }, + /* OPLT 13 */ { BINARY_OP, 10, "%l < %r" }, + /* OPEQ 14 */ { BINARY_OP, 9, "%l == %r" }, + /* OPGT 15 */ { BINARY_OP, 10, "%l > %r" }, + /* OPLE 16 */ { BINARY_OP, 10, "%l <= %r" }, + /* OPNE 17 */ { BINARY_OP, 9, "%l != %r" }, + /* OPGE 18 */ { BINARY_OP, 10, "%l >= %r" }, + /* OPCALL 19 */ { BINARY_OP, 15, SPECIAL_FMT }, + /* OPCCALL 20 */ { BINARY_OP, 15, SPECIAL_FMT }, + +/* Left hand side of an assignment cannot have outermost parens */ + + /* OPASSIGN 21 */ { BINARY_OP, 2, "%l = %r" }, + /* OPPLUSEQ 22 */ { BINARY_OP, 2, "%l += %r" }, + /* OPSTAREQ 23 */ { BINARY_OP, 2, "%l *= %r" }, + /* OPCONV 24 */ { BINARY_OP, 14, "%l" }, + /* OPLSHIFT 25 */ { BINARY_OP, 11, "%l << %r" }, + /* OPMOD 26 */ { BINARY_OP, 13, "%l %% %r" }, + /* OPCOMMA 27 */ { BINARY_OP, 1, "%l, %r" }, + +/* Don't want to nest the colon operator in parens */ + + /* OPQUEST 28 */ { BINARY_OP, 3, "%l ? %r" }, + /* OPCOLON 29 */ { BINARY_OP, 3, "%l : %r" }, + /* OPABS 30 */ { UNARY_OP, 0, "abs(%l)" }, + /* OPMIN 31 */ { BINARY_OP, 0, SPECIAL_FMT }, + /* OPMAX 32 */ { BINARY_OP, 0, SPECIAL_FMT }, + /* OPADDR 33 */ { UNARY_OP, 14, "&%l" }, + + /* OPCOMMA_ARG 34 */ { BINARY_OP, 15, SPECIAL_FMT }, + /* OPBITOR 35 */ { BINARY_OP, 6, "%l | %r" }, + /* OPBITAND 36 */ { BINARY_OP, 8, "%l & %r" }, + /* OPBITXOR 37 */ { BINARY_OP, 7, "%l ^ %r" }, + /* OPBITNOT 38 */ { UNARY_OP, 14, "~ %l" }, + /* OPRSHIFT 39 */ { BINARY_OP, 11, "%l >> %r" }, + +/* This isn't quite right -- it doesn't handle arrays, for instance */ + + /* OPWHATSIN 40 */ { UNARY_OP, 14, "*%l" }, + /* OPMINUSEQ 41 */ { BINARY_OP, 2, "%l -= %r" }, + /* OPSLASHEQ 42 */ { BINARY_OP, 2, "%l /= %r" }, + /* OPMODEQ 43 */ { BINARY_OP, 2, "%l %%= %r" }, + /* OPLSHIFTEQ 44 */ { BINARY_OP, 2, "%l <<= %r" }, + /* OPRSHIFTEQ 45 */ { BINARY_OP, 2, "%l >>= %r" }, + /* OPBITANDEQ 46 */ { BINARY_OP, 2, "%l &= %r" }, + /* OPBITXOREQ 47 */ { BINARY_OP, 2, "%l ^= %r" }, + /* OPBITOREQ 48 */ { BINARY_OP, 2, "%l |= %r" }, + /* OPPREINC 49 */ { UNARY_OP, 14, "++%l" }, + /* OPPREDEC 50 */ { UNARY_OP, 14, "--%l" }, + /* OPDOT 51 */ { BINARY_OP, 15, "%l.%r" }, + /* OPARROW 52 */ { BINARY_OP, 15, "%l -> %r"}, + /* OPNEG1 53 */ { UNARY_OP, 14, "-%l" }, + /* OPDMIN 54 */ { BINARY_OP, 0, "dmin(%l,%r)" }, + /* OPDMAX 55 */ { BINARY_OP, 0, "dmax(%l,%r)" }, + /* OPASSIGNI 56 */ { BINARY_OP, 2, "%l = &%r" }, + /* OPIDENTITY 57 */ { UNARY_OP, 15, "%l" }, + /* OPCHARCAST 58 */ { UNARY_OP, 14, "(char *)&%l" }, + /* OPDABS 59 */ { UNARY_OP, 0, "dabs(%l)" }, + /* OPMIN2 60 */ { BINARY_OP, 0, "min(%l,%r)" }, + /* OPMAX2 61 */ { BINARY_OP, 0, "max(%l,%r)" }, + /* OPBITTEST 62 */ { BINARY_OP, 0, "bit_test(%l,%r)" }, + /* OPBITCLR 63 */ { BINARY_OP, 0, "bit_clear(%l,%r)" }, + /* OPBITSET 64 */ { BINARY_OP, 0, "bit_set(%l,%r)" }, +#ifdef TYQUAD + /* OPQBITCLR 65 */ { BINARY_OP, 0, "qbit_clear(%l,%r)" }, + /* OPQBITSET 66 */ { BINARY_OP, 0, "qbit_set(%l,%r)" }, +#endif + +/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */ + + /* OPNEG KLUDGE */ { UNARY_OP, 14, "-(doublereal)%l" } +}; /* opcode_table */ + +#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1) + +extern int dneg, trapuv; +static char opeqable[sizeof(opcode_table)/sizeof(table_entry)]; + + +static void output_arg_list Argdcl((FILEP, struct Listblock*)); +static void output_binary Argdcl((FILEP, Exprp)); +static void output_list Argdcl((FILEP, struct Listblock*)); +static void output_literal Argdcl((FILEP, long, Constp)); +static void output_prim Argdcl((FILEP, struct Primblock*)); +static void output_unary Argdcl((FILEP, Exprp)); + + + void +#ifdef KR_headers +expr_out(fp, e) + FILE *fp; + expptr e; +#else +expr_out(FILE *fp, expptr e) +#endif +{ + Namep var; + expptr leftp, rightp; + int opcode; + + if (e == (expptr) NULL) + return; + + switch (e -> tag) { + case TNAME: out_name (fp, (struct Nameblock *) e); + return; + + case TCONST: out_const(fp, &e->constblock); + goto end_out; + case TEXPR: + break; + + case TADDR: out_addr (fp, &(e -> addrblock)); + goto end_out; + + case TPRIM: if (!nerr) + warn ("expr_out: got TPRIM"); + output_prim (fp, &(e -> primblock)); + return; + + case TLIST: output_list (fp, &(e -> listblock)); + end_out: frexpr(e); + return; + + case TIMPLDO: err ("expr_out: got TIMPLDO"); + return; + + case TERROR: + default: + erri ("expr_out: bad tag '%d'", e -> tag); + } /* switch */ + +/* Now we know that the tag is TEXPR */ + +/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */ + + if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp) + switch(e->exprblock.rightp->tag) { + case TEXPR: + opcode = e -> exprblock.rightp -> exprblock.opcode; + + if (opeqable[opcode]) { + if ((leftp = e -> exprblock.leftp) && + (rightp = e -> exprblock.rightp -> exprblock.leftp)) { + + if (same_ident (leftp, rightp)) { + expptr temp = e -> exprblock.rightp; + + e -> exprblock.opcode = op_assign(opcode); + + e -> exprblock.rightp = temp -> exprblock.rightp; + temp->exprblock.rightp = 0; + frexpr(temp); + } /* if same_ident (leftp, rightp) */ + } /* if leftp && rightp */ + } /* if opcode == OPPLUS || */ + break; + + case TNAME: + if (trapuv) { + var = &e->exprblock.rightp->nameblock; + if (ISREAL(var->vtype) + && var->vclass == CLVAR + && ONEOF(var->vstg, M(STGAUTO)|M(STGBSS)) + && !var->vsave) { + expr_out(fp, e -> exprblock.leftp); + nice_printf(fp, " = _0 + "); + expr_out(fp, e->exprblock.rightp); + goto done; + } + } + } /* if e -> exprblock.opcode == OPASSIGN */ + + +/* Optimize on increment or decrement by 1 */ + + { + opcode = e -> exprblock.opcode; + leftp = e -> exprblock.leftp; + rightp = e -> exprblock.rightp; + + if (leftp && rightp && (leftp -> headblock.vstg == STGARG || + ISINT (leftp -> headblock.vtype)) && + (opcode == OPPLUSEQ || opcode == OPMINUSEQ) && + ISINT (rightp -> headblock.vtype) && + ISICON (e -> exprblock.rightp) && + (ISONE (e -> exprblock.rightp) || + e -> exprblock.rightp -> constblock.Const.ci == -1)) { + +/* Allow for the '-1' constant value */ + + if (!ISONE (e -> exprblock.rightp)) + opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ; + +/* replace the existing opcode */ + + if (opcode == OPPLUSEQ) + e -> exprblock.opcode = OPPREINC; + else + e -> exprblock.opcode = OPPREDEC; + +/* Free up storage used by the right hand side */ + + frexpr (e -> exprblock.rightp); + e->exprblock.rightp = 0; + } /* if opcode == OPPLUS */ + } /* block */ + + + if (is_unary_op (e -> exprblock.opcode)) + output_unary (fp, &(e -> exprblock)); + else if (is_binary_op (e -> exprblock.opcode)) + output_binary (fp, &(e -> exprblock)); + else + erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode); + + done: + free((char *)e); + +} /* expr_out */ + + + void +#ifdef KR_headers +out_and_free_statement(outfile, expr) + FILE *outfile; + expptr expr; +#else +out_and_free_statement(FILE *outfile, expptr expr) +#endif +{ + if (expr) + expr_out (outfile, expr); + + nice_printf (outfile, ";\n"); +} /* out_and_free_statement */ + + + + int +#ifdef KR_headers +same_ident(left, right) + expptr left; + expptr right; +#else +same_ident(expptr left, expptr right) +#endif +{ + if (!left || !right) + return 0; + + if (left -> tag == TNAME && right -> tag == TNAME && left == right) + return 1; + + if (left -> tag == TADDR && right -> tag == TADDR && + left -> addrblock.uname_tag == right -> addrblock.uname_tag) + switch (left -> addrblock.uname_tag) { + case UNAM_REF: + case UNAM_NAME: + +/* Check for array subscripts */ + + if (left -> addrblock.user.name -> vdim || + right -> addrblock.user.name -> vdim) + if (left -> addrblock.user.name != + right -> addrblock.user.name || + !same_expr (left -> addrblock.memoffset, + right -> addrblock.memoffset)) + return 0; + + return same_ident ((expptr) (left -> addrblock.user.name), + (expptr) right -> addrblock.user.name); + case UNAM_IDENT: + return strcmp(left->addrblock.user.ident, + right->addrblock.user.ident) == 0; + case UNAM_CHARP: + return strcmp(left->addrblock.user.Charp, + right->addrblock.user.Charp) == 0; + default: + return 0; + } /* switch */ + + if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN + && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN) + return same_ident(left->exprblock.leftp, + right->exprblock.leftp); + + return 0; +} /* same_ident */ + + static int +#ifdef KR_headers +samefpconst(c1, c2, n) + register Constp c1; + register Constp c2; + register int n; +#else +samefpconst(register Constp c1, register Constp c2, register int n) +#endif +{ + char *s1, *s2; + if (!c1->vstg && !c2->vstg) + return c1->Const.cd[n] == c2->Const.cd[n]; + s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]); + s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]); + return !strcmp(s1, s2); + } + + static int +#ifdef KR_headers +sameconst(c1, c2) + register Constp c1; + register Constp c2; +#else +sameconst(register Constp c1, register Constp c2) +#endif +{ + switch(c1->vtype) { + case TYCOMPLEX: + case TYDCOMPLEX: + if (!samefpconst(c1,c2,1)) + return 0; + case TYREAL: + case TYDREAL: + return samefpconst(c1,c2,0); + case TYCHAR: + return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks + && c1->vleng->constblock.Const.ci + == c2->vleng->constblock.Const.ci + && !memcmp(c1->Const.ccp, c2->Const.ccp, + (int)c1->vleng->constblock.Const.ci); + case TYSHORT: + case TYINT: + case TYLOGICAL: + return c1->Const.ci == c2->Const.ci; + } + err("unexpected type in sameconst"); + return 0; + } + +/* same_expr -- Returns true only if e1 and e2 match. This is + somewhat pessimistic, but can afford to be because it's just used to + optimize on the assignment operators (+=, -=, etc). */ + + int +#ifdef KR_headers +same_expr(e1, e2) + expptr e1; + expptr e2; +#else +same_expr(expptr e1, expptr e2) +#endif +{ + if (!e1 || !e2) + return !e1 && !e2; + + if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype) + return 0; + + switch (e1 -> tag) { + case TEXPR: + if (e1 -> exprblock.opcode != e2 -> exprblock.opcode) + return 0; + + return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) && + same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp); + case TNAME: + case TADDR: + return same_ident (e1, e2); + case TCONST: + return sameconst(&e1->constblock, &e2->constblock); + default: + return 0; + } /* switch */ +} /* same_expr */ + + + + void +#ifdef KR_headers +out_name(fp, namep) + FILE *fp; + Namep namep; +#else +out_name(FILE *fp, Namep namep) +#endif +{ + extern int usedefsforcommon; + Extsym *comm; + + if (namep == NULL) + return; + +/* DON'T want to use oneof_stg() here; need to find the right common name + */ + + if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) { + comm = &extsymtab[namep->vardesc.varno]; + extern_out(fp, comm); + nice_printf(fp, "%d.", comm->curno); + } /* if namep -> vstg == STGCOMMON */ + + if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR) + nice_printf(fp, xretslot[namep->vtype]->user.ident); + else + nice_printf (fp, "%s", namep->cvarname); +} /* out_name */ + + +#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n]) + + void +#ifdef KR_headers +out_const(fp, cp) + FILE *fp; + register Constp cp; +#else +out_const(FILE *fp, register Constp cp) +#endif +{ + static char real_buf[50], imag_buf[50]; + ftnint j; + unsigned int k; + int type = cp->vtype; + + switch (type) { + case TYINT1: + case TYSHORT: + nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */ + break; + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */ + break; +#ifndef NO_LONG_LONG + case TYQUAD: + if (cp->Const.cd[1] == 123.456) + nice_printf (fp, "%s", cp->Const.cds[0]); + else + nice_printf (fp, "%lld", cp->Const.cq); + break; +#endif + case TYREAL: + nice_printf(fp, "%s", flconst(real_buf, cpd(0))); + break; + case TYDREAL: + nice_printf(fp, "%s", cpd(0)); + break; + case TYCOMPLEX: + nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)), + flconst(imag_buf, cpd(1))); + break; + case TYDCOMPLEX: + nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1)); + break; + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_"); + break; + case TYCHAR: { + char *c = cp->Const.ccp, *ce; + + if (c == NULL) { + nice_printf (fp, "\"\""); + break; + } /* if c == NULL */ + + nice_printf (fp, "\""); + ce = c + cp->vleng->constblock.Const.ci; + while(c < ce) { + k = *(unsigned char *)c++; + nice_printf(fp, str_fmt[k]); + } + for(j = cp->Const.ccp1.blanks; j > 0; j--) + nice_printf(fp, " "); + nice_printf (fp, "\""); + break; + } /* case TYCHAR */ + default: + erri ("out_const: bad type '%d'", (int) type); + break; + } /* switch */ + +} /* out_const */ +#undef cpd + + static void +#ifdef KR_headers +out_args(fp, ep) + FILE *fp; + expptr ep; +#else +out_args(FILE *fp, expptr ep) +#endif +{ + chainp arglist; + + if(ep->tag != TLIST) + badtag("out_args", ep->tag); + for(arglist = ep->listblock.listp;;) { + expr_out(fp, (expptr)arglist->datap); + arglist->datap = 0; + if (!(arglist = arglist->nextp)) + break; + nice_printf(fp, ", "); + } + } + + +/* out_addr -- this routine isn't local because it is called by the + system-generated identifier printing routines */ + + void +#ifdef KR_headers +out_addr(fp, addrp) + FILE *fp; + struct Addrblock *addrp; +#else +out_addr(FILE *fp, struct Addrblock *addrp) +#endif +{ + extern Extsym *extsymtab; + int was_array = 0; + char *s; + + + if (addrp == NULL) + return; + if (doin_setbound + && addrp->vstg == STGARG + && addrp->vtype != TYCHAR + && ISICON(addrp->memoffset) + && !addrp->memoffset->constblock.Const.ci) + nice_printf(fp, "*"); + + switch (addrp -> uname_tag) { + case UNAM_REF: + nice_printf(fp, "%s_%s(", addrp->user.name->cvarname, + addrp->cmplx_sub ? "subscr" : "ref"); + out_args(fp, addrp->memoffset); + nice_printf(fp, ")"); + return; + case UNAM_NAME: + out_name (fp, addrp -> user.name); + break; + case UNAM_IDENT: + if (*(s = addrp->user.ident) == ' ') { + if (multitype) + nice_printf(fp, "%s", + xretslot[addrp->vtype]->user.ident); + else + nice_printf(fp, "%s", s+1); + } + else { + nice_printf(fp, "%s", s); + } + break; + case UNAM_CHARP: + nice_printf(fp, "%s", addrp->user.Charp); + break; + case UNAM_EXTERN: + extern_out (fp, &extsymtab[addrp -> memno]); + break; + case UNAM_CONST: + switch(addrp->vstg) { + case STGCONST: + out_const(fp, (Constp)addrp); + break; + case STGMEMNO: + output_literal (fp, addrp->memno, + (Constp)addrp); + break; + default: + Fatal("unexpected vstg in out_addr"); + } + break; + case UNAM_UNKNOWN: + default: + nice_printf (fp, "Unknown Addrp"); + break; + } /* switch */ + +/* It's okay to just throw in the brackets here because they have a + precedence level of 15, the highest value. */ + + if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim + || addrp->ntempelt > 1 || addrp->isarray) + && addrp->vtype != TYCHAR) { + expptr offset; + + was_array = 1; + + offset = addrp -> memoffset; + addrp->memoffset = 0; + if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) + && addrp -> uname_tag == UNAM_NAME + && !addrp->skip_offset) + offset = mkexpr (OPMINUS, offset, mkintcon ( + addrp -> user.name -> voffset)); + + nice_printf (fp, "["); + + offset = mkexpr (OPSLASH, offset, + ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1))); + expr_out (fp, offset); + nice_printf (fp, "]"); + } + +/* Check for structure field reference */ + + if (addrp -> Field && addrp -> uname_tag != UNAM_CONST && + addrp -> uname_tag != UNAM_UNKNOWN) { + if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : + (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV)) + && !was_array && (addrp->vclass != CLPROC || !multitype)) + nice_printf (fp, "->%s", addrp -> Field); + else + nice_printf (fp, ".%s", addrp -> Field); + } /* if */ + +/* Check for character subscripting */ + + if (addrp->vtype == TYCHAR && + (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME + && addrp->user.name->vprocclass == PTHISPROC) && + addrp -> memoffset && + (addrp -> uname_tag != UNAM_NAME || + addrp -> user.name -> vtype == TYCHAR) && + (!ISICON (addrp -> memoffset) || + (addrp -> memoffset -> constblock.Const.ci))) { + + int use_paren = 0; + expptr e = addrp -> memoffset; + + if (!e) + return; + addrp->memoffset = 0; + + if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) + && addrp -> uname_tag == UNAM_NAME) { + e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset)); + +/* mkexpr will simplify it to zero if possible */ + if (e->tag == TCONST && e->constblock.Const.ci == 0) + return; + } /* if addrp -> vstg == STGCOMMON */ + +/* In the worst case, parentheses might be needed OUTSIDE the expression, + too. But since I think this subscripting can only appear as a + parameter in a procedure call, I don't think outside parens will ever + be needed. INSIDE parens are handled below */ + + nice_printf (fp, " + "); + if (e -> tag == TEXPR) { + int arg_prec = op_precedence (e -> exprblock.opcode); + int prec = op_precedence (OPPLUS); + use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec && + is_left_assoc (OPPLUS))); + } /* if e -> tag == TEXPR */ + if (use_paren) nice_printf (fp, "("); + expr_out (fp, e); + if (use_paren) nice_printf (fp, ")"); + } /* if */ +} /* out_addr */ + + + static void +#ifdef KR_headers +output_literal(fp, memno, cp) + FILE *fp; + long memno; + Constp cp; +#else +output_literal(FILE *fp, long memno, Constp cp) +#endif +{ + struct Literal *litp, *lastlit; + + lastlit = litpool + nliterals; + + for (litp = litpool; litp < lastlit; litp++) { + if (litp -> litnum == memno) + break; + } /* for litp */ + + if (litp >= lastlit) + out_const (fp, cp); + else { + nice_printf (fp, "%s", lit_name (litp)); + litp->lituse++; + } +} /* output_literal */ + + + static void +#ifdef KR_headers +output_prim(fp, primp) + FILE *fp; + struct Primblock *primp; +#else +output_prim(FILE *fp, struct Primblock *primp) +#endif +{ + if (primp == NULL) + return; + + out_name (fp, primp -> namep); + if (primp -> argsp) + output_arg_list (fp, primp -> argsp); + + if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL) + nice_printf (fp, "Sorry, no substrings yet"); +} + + + + static void +#ifdef KR_headers +output_arg_list(fp, listp) + FILE *fp; + struct Listblock *listp; +#else +output_arg_list(FILE *fp, struct Listblock *listp) +#endif +{ + chainp arg_list; + + if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL) + return; + + nice_printf (fp, "("); + + for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) { + expr_out (fp, (expptr) arg_list -> datap); + if (arg_list -> nextp != (chainp) NULL) + +/* Might want to add a hook in here to accomodate the style setting which + wants spaces after commas */ + + nice_printf (fp, ","); + } /* for arg_list */ + + nice_printf (fp, ")"); +} /* output_arg_list */ + + + + static void +#ifdef KR_headers +output_unary(fp, e) + FILE *fp; + struct Exprblock *e; +#else +output_unary(FILE *fp, struct Exprblock *e) +#endif +{ + if (e == NULL) + return; + + switch (e -> opcode) { + case OPNEG: + if (e->vtype == TYREAL && dneg) { + e->opcode = OPNEG_KLUDGE; + output_binary(fp,e); + e->opcode = OPNEG; + break; + } + case OPNEG1: + case OPNOT: + case OPABS: + case OPBITNOT: + case OPWHATSIN: + case OPPREINC: + case OPPREDEC: + case OPADDR: + case OPIDENTITY: + case OPCHARCAST: + case OPDABS: + output_binary (fp, e); + break; + case OPCALL: + case OPCCALL: + nice_printf (fp, "Sorry, no OPCALL yet"); + break; + default: + erri ("output_unary: bad opcode", (int) e -> opcode); + break; + } /* switch */ +} /* output_unary */ + + + static char * +#ifdef KR_headers +findconst(m) + register long m; +#else +findconst(register long m) +#endif +{ + register struct Literal *litp, *litpe; + + litp = litpool; + for(litpe = litp + nliterals; litp < litpe; litp++) + if (litp->litnum == m) + return litp->cds[0]; + Fatal("findconst failure!"); + return 0; + } + + static int +#ifdef KR_headers +opconv_fudge(fp, e) + FILE *fp; + struct Exprblock *e; +#else +opconv_fudge(FILE *fp, struct Exprblock *e) +#endif +{ + /* special handling for conversions, ichar and character*1 */ + register expptr lp; + register union Expression *Offset; + register char *cp; + int lt; + char buf[8], *s; + unsigned int k; + Namep np; + Addrp ap; + + if (!(lp = e->leftp)) /* possible with erroneous Fortran */ + return 1; + lt = lp->headblock.vtype; + if (lt == TYCHAR) { + switch(lp->tag) { + case TNAME: + nice_printf(fp, "*(unsigned char *)"); + out_name(fp, (Namep)lp); + return 1; + case TCONST: + tconst: + cp = lp->constblock.Const.ccp; + tconst1: + k = *(unsigned char *)cp; + if (k < 128) { /* ASCII character */ + sprintf(buf, chr_fmt[k], k); + nice_printf(fp, "'%s'", buf); + } + else + nice_printf(fp, "%d", k); + return 1; + case TADDR: + switch(lp->addrblock.vstg) { + case STGMEMNO: + if (halign && e->vtype != TYCHAR) { + nice_printf(fp, "*(%s *)", + c_type_decl(e->vtype,0)); + expr_out(fp, lp); + return 1; + } + cp = findconst(lp->addrblock.memno); + goto tconst1; + case STGCONST: + goto tconst; + } + lp->addrblock.vtype = tyint; + Offset = lp->addrblock.memoffset; + switch(lp->addrblock.uname_tag) { + case UNAM_REF: + nice_printf(fp, "*(unsigned char *)"); + return 0; + case UNAM_NAME: + np = lp->addrblock.user.name; + if (ONEOF(np->vstg, + M(STGCOMMON)|M(STGEQUIV))) + Offset = mkexpr(OPMINUS, Offset, + ICON(np->voffset)); + } + lp->addrblock.memoffset = Offset ? + mkexpr(OPSTAR, Offset, + ICON(typesize[tyint])) + : ICON(0); + lp->addrblock.isarray = 1; + /* STGCOMMON or STGEQUIV would cause */ + /* voffset to be added in a second time */ + lp->addrblock.vstg = STGUNKNOWN; + nice_printf(fp, "*(unsigned char *)&"); + return 0; + default: + badtag("opconv_fudge", lp->tag); + } + } + if (lt != e->vtype) { + s = c_type_decl(e->vtype, 0); + if (ISCOMPLEX(lt)) { + tryagain: + np = (Namep)e->leftp; + switch(np->tag) { + case TNAME: + nice_printf(fp, "(%s) %s%sr", s, + np->cvarname, + np->vstg == STGARG ? "->" : "."); + return 1; + case TADDR: + ap = (Addrp)np; + switch(ap->uname_tag) { + case UNAM_IDENT: + nice_printf(fp, "(%s) %s.r", s, + ap->user.ident); + return 1; + case UNAM_NAME: + nice_printf(fp, "(%s) ", s); + out_addr(fp, ap); + nice_printf(fp, ".r"); + return 1; + case UNAM_REF: + nice_printf(fp, "(%s) %s_%s(", + s, ap->user.name->cvarname, + ap->cmplx_sub ? "subscr" : "ref"); + out_args(fp, ap->memoffset); + nice_printf(fp, ").r"); + return 1; + default: + fatali( + "Bad uname_tag %d in opconv_fudge", + ap->uname_tag); + } + case TEXPR: + e = (Exprp)np; + if (e->opcode == OPWHATSIN) + goto tryagain; + default: + fatali("Unexpected tag %d in opconv_fudge", + np->tag); + } + } + nice_printf(fp, "(%s) ", s); + } + return 0; + } + + + static void +#ifdef KR_headers +output_binary(fp, e) + FILE *fp; + struct Exprblock *e; +#else +output_binary(FILE *fp, struct Exprblock *e) +#endif +{ + char *format; + int prec; + + if (e == NULL || e -> tag != TEXPR) + return; + +/* Instead of writing a huge switch, I've incorporated the output format + into a table. Things like "%l" and "%r" stand for the left and + right subexpressions. This should allow both prefix and infix + functions to be specified (e.g. "(%l * %r", "z_div (%l, %r"). Of + course, I should REALLY think out the ramifications of writing out + straight text, as opposed to some intermediate format, which could + figure out and optimize on the the number of required blanks (we don't + want "x - (-y)" to become "x --y", for example). Special cases (such as + incomplete implementations) could still be implemented as part of the + switch, they will just have some dummy value instead of the string + pattern. Another difficulty is the fact that the complex functions + will differ from the integer and real ones */ + +/* Handle a special case. We don't want to output "x + - 4", or "y - - 3" +*/ + if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) && + e -> rightp && e -> rightp -> tag == TCONST && + isnegative_const (&(e -> rightp -> constblock)) && + is_negatable (&(e -> rightp -> constblock))) { + + e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS; + negate_const (&(e -> rightp -> constblock)); + } /* if e -> opcode == PLUS or MINUS */ + + prec = op_precedence (e -> opcode); + format = op_format (e -> opcode); + + if (format != SPECIAL_FMT) { + while (*format) { + if (*format == '%') { + int arg_prec, use_paren = 0; + expptr lp, rp; + + switch (*(format + 1)) { + case 'l': + lp = e->leftp; + if (lp && lp->tag == TEXPR) { + arg_prec = op_precedence(lp->exprblock.opcode); + + use_paren = arg_prec && + (arg_prec < prec || (arg_prec == prec && + is_right_assoc (prec))); + } /* if e -> leftp */ + if (e->opcode == OPCONV && opconv_fudge(fp,e)) + break; + if (use_paren) + nice_printf (fp, "("); + expr_out(fp, lp); + if (use_paren) + nice_printf (fp, ")"); + break; + case 'r': + rp = e->rightp; + if (rp && rp->tag == TEXPR) { + arg_prec = op_precedence(rp->exprblock.opcode); + + use_paren = arg_prec && + (arg_prec < prec || (arg_prec == prec && + is_left_assoc (prec))); + use_paren = use_paren || + (rp->exprblock.opcode == OPNEG + && prec >= op_precedence(OPMINUS)); + } /* if e -> rightp */ + if (use_paren) + nice_printf (fp, "("); + expr_out(fp, rp); + if (use_paren) + nice_printf (fp, ")"); + break; + case '\0': + case '%': + nice_printf (fp, "%%"); + break; + default: + erri ("output_binary: format err: '%%%c' illegal", + (int) *(format + 1)); + break; + } /* switch */ + format += 2; + } else + nice_printf (fp, "%c", *format++); + } /* while *format */ + } else { + +/* Handle Special cases of formatting */ + + switch (e -> opcode) { + case OPCCALL: + case OPCALL: + out_call (fp, (int) e -> opcode, e -> vtype, + e -> vleng, e -> leftp, e -> rightp); + break; + + case OPCOMMA_ARG: + doin_setbound = 1; + nice_printf(fp, "("); + expr_out(fp, e->leftp); + nice_printf(fp, ", &"); + doin_setbound = 0; + expr_out(fp, e->rightp); + nice_printf(fp, ")"); + break; + + case OPADDR: + default: + nice_printf (fp, "Sorry, can't format OPCODE '%d'", + e -> opcode); + break; + } + + } /* else */ +} /* output_binary */ + + void +#ifdef KR_headers +out_call(outfile, op, ftype, len, name, args) + FILE *outfile; + int op; + int ftype; + expptr len; + expptr name; + expptr args; +#else +out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args) +#endif +{ + chainp arglist; /* Pointer to any actual arguments */ + chainp cp; /* Iterator over argument lists */ + Addrp ret_val = (Addrp) NULL; + /* Function return value buffer, if any is + required */ + int byvalue; /* True iff we're calling a C library + routine */ + int done_once; /* Used for writing commas to outfile */ + int narg, t; + register expptr q; + long L; + Argtypes *at; + Atype *A, *Ac; + Namep np; + extern int forcereal; + +/* Don't use addresses if we're calling a C function */ + + byvalue = op == OPCCALL; + + if (args) + arglist = args -> listblock.listp; + else + arglist = CHNULL; + +/* If this is a CHARACTER function, the first argument is the result */ + + if (ftype == TYCHAR) + if (ISICON (len)) { + ret_val = (Addrp) (arglist -> datap); + arglist = arglist -> nextp; + } else { + err ("adjustable character function"); + return; + } /* else */ + +/* If this is a COMPLEX function, the first argument is the result */ + + else if (ISCOMPLEX (ftype)) { + ret_val = (Addrp) (arglist -> datap); + arglist = arglist -> nextp; + } /* if ISCOMPLEX */ + + /* prepare to cast procedure parameters -- set A if we know how */ + np = name->tag == TEXPR && name->exprblock.opcode == OPWHATSIN + ? (Namep)name->exprblock.leftp : (Namep)name; + + A = Ac = 0; + if (np->tag == TNAME && (at = np->arginfo)) { + if (at->nargs > 0) + A = at->atypes; + if (Ansi && (at->defined || at->nargs > 0)) + Ac = at->atypes; + } + +/* Now we can actually start to write out the function invocation */ + + if (ftype == TYREAL && forcereal) + nice_printf(outfile, "(real)"); + if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) { + nice_printf (outfile, "("); + expr_out (outfile, name); + nice_printf (outfile, ")"); + } + else + expr_out(outfile, name); + + nice_printf(outfile, "("); + + if (ret_val) { + if (ISCOMPLEX (ftype)) + nice_printf (outfile, "&"); + expr_out (outfile, (expptr) ret_val); + if (Ac) + Ac++; + +/* The length of the result of a character function is the second argument */ +/* It should be in place from putcall(), so we won't touch it explicitly */ + + } /* if ret_val */ + done_once = ret_val ? TRUE : FALSE; + +/* Now run through the named arguments */ + + narg = -1; + for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) { + + if (done_once) + nice_printf (outfile, ", "); + narg++; + + if (!( q = (expptr)cp->datap) ) + continue; + + if (q->tag == TADDR) { + if (q->addrblock.vtype > TYERROR) { + /* I/O block */ + nice_printf(outfile, "&%s", q->addrblock.user.ident); + continue; + } + if (!byvalue && q->addrblock.isarray + && q->addrblock.vtype != TYCHAR + && q->addrblock.memoffset->tag == TCONST) { + + /* check for 0 offset -- after */ + /* correcting for equivalence. */ + L = q->addrblock.memoffset->constblock.Const.ci; + if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV)) + && q->addrblock.uname_tag == UNAM_NAME) + L -= q->addrblock.user.name->voffset; + if (L) + goto skip_deref; + + if (Ac && narg < at->dnargs + && q->headblock.vtype != (t = Ac[narg].type) + && t > TYADDR && t < TYSUBR) + nice_printf(outfile, "(%s*)", Typename[t]); + + /* &x[0] == x */ + /* This also prevents &sizeof(doublereal)[0] */ + + switch(q->addrblock.uname_tag) { + case UNAM_NAME: + out_name(outfile, q->addrblock.user.name); + continue; + case UNAM_IDENT: + nice_printf(outfile, "%s", + q->addrblock.user.ident); + continue; + case UNAM_CHARP: + nice_printf(outfile, "%s", + q->addrblock.user.Charp); + continue; + case UNAM_EXTERN: + extern_out(outfile, + &extsymtab[q->addrblock.memno]); + continue; + } + } + } + +/* Skip over the dereferencing operator generated only for the + intermediate file */ + skip_deref: + if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN) + q = q -> exprblock.leftp; + + if (q->headblock.vclass == CLPROC) { + if (Castargs && (q->tag != TNAME + || q->nameblock.vprocclass != PTHISPROC) + && (q->tag != TADDR + || q->addrblock.uname_tag != UNAM_NAME + || q->addrblock.user.name->vprocclass + != PTHISPROC)) + { + if (A && (t = A[narg].type) >= 200) + t %= 100; + else { + t = q->headblock.vtype; + if (q->tag == TNAME && q->nameblock.vimpltype) + t = TYUNKNOWN; + } + nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]); + } + } + else if (Ac && narg < at->dnargs + && q->headblock.vtype != (t = Ac[narg].type) + && t > TYADDR && t < TYSUBR) + nice_printf(outfile, "(%s*)", Typename[t]); + + if ((q -> tag == TADDR || q-> tag == TNAME) && + (byvalue || q -> headblock.vstg != STGREG)) { + if (q -> headblock.vtype != TYCHAR) + if (byvalue) { + + if (q -> tag == TADDR && + q -> addrblock.uname_tag == UNAM_NAME && + ! q -> addrblock.user.name -> vdim && + oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg, + M(STGARG)|M(STGEQUIV)) && + ! ISCOMPLEX(q->addrblock.user.name->vtype)) + nice_printf (outfile, "*"); + else if (q -> tag == TNAME + && oneof_stg(&q->nameblock, q -> nameblock.vstg, + M(STGARG)|M(STGEQUIV)) + && !(q -> nameblock.vdim)) + nice_printf (outfile, "*"); + + } else { + expptr memoffset; + + if (q->tag == TADDR && ( + !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG)) + && (ONEOF(q->addrblock.vstg, + M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO)) + || ((memoffset = q->addrblock.memoffset) + && (!ISICON(memoffset) + || memoffset->constblock.Const.ci))) + || ONEOF(q->addrblock.vstg, + M(STGINIT)|M(STGAUTO)|M(STGBSS)) + && !q->addrblock.isarray)) + nice_printf (outfile, "&"); + else if (q -> tag == TNAME + && !oneof_stg(&q->nameblock, q -> nameblock.vstg, + M(STGARG)|M(STGEXT)|M(STGEQUIV))) + nice_printf (outfile, "&"); + } /* else */ + + expr_out (outfile, q); + } /* if q -> tag == TADDR || q -> tag == TNAME */ + +/* Might be a Constant expression, e.g. string length, character constants */ + + else if (q -> tag == TCONST) { + if (q->constblock.vtype == TYLONG) + nice_printf(outfile, "(ftnlen)%ld", + q->constblock.Const.ci); + else + out_const(outfile, &q->constblock); + } + +/* Must be some other kind of expression, or register var, or constant. + In particular, this is likely to be a temporary variable assignment + which was generated in p1put_call */ + + else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){ + int use_paren = q -> tag == TEXPR && + op_precedence (q -> exprblock.opcode) <= + op_precedence (OPCOMMA); + if (q->headblock.vtype == TYREAL) { + if (forcereal) { + nice_printf(outfile, "(real)"); + use_paren = 1; + } + } + else if (!Ansi && ISINT(q->headblock.vtype)) { + nice_printf(outfile, "(ftnlen)"); + use_paren = 1; + } + if (use_paren) nice_printf (outfile, "("); + expr_out (outfile, q); + if (use_paren) nice_printf (outfile, ")"); + } /* if !ISCOMPLEX */ + else + err ("out_call: unknown parameter"); + + } /* for (cp = arglist */ + + if (arglist) + frchain (&arglist); + + nice_printf (outfile, ")"); + +} /* out_call */ + + + char * +#ifdef KR_headers +flconst(buf, x) + char *buf; + char *x; +#else +flconst(char *buf, char *x) +#endif +{ + sprintf(buf, fl_fmt_string, x); + return buf; + } + + char * +#ifdef KR_headers +dtos(x) + double x; +#else +dtos(double x) +#endif +{ + static char buf[64]; +#ifdef USE_DTOA + g_fmt(buf, x); +#else + sprintf(buf, db_fmt_string, x); +#endif + return strcpy(mem(strlen(buf)+1,0), buf); + } + +char tr_tab[Table_size]; + +/* out_init -- Initialize the data structures used by the routines in + output.c. These structures include the output format to be used for + Float, Double, Complex, and Double Complex constants. */ + + void +out_init(Void) +{ + extern int tab_size; + register char *s; + + s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-."; + while(*s) + tr_tab[*s++] = 3; + tr_tab['>'] = 1; + + opeqable[OPPLUS] = 1; + opeqable[OPMINUS] = 1; + opeqable[OPSTAR] = 1; + opeqable[OPSLASH] = 1; + opeqable[OPMOD] = 1; + opeqable[OPLSHIFT] = 1; + opeqable[OPBITAND] = 1; + opeqable[OPBITXOR] = 1; + opeqable[OPBITOR ] = 1; + + +/* Set the output format for both types of floating point constants */ + + if (fl_fmt_string == NULL || *fl_fmt_string == '\0') + fl_fmt_string = (char*)(Ansi == 1 ? "%sf" : "(float)%s"); + + if (db_fmt_string == NULL || *db_fmt_string == '\0') + db_fmt_string = "%.17g"; + +/* Set the output format for both types of complex constants. They will + have string parameters rather than float or double so that the decimal + point may be added to the strings generated by the {db,fl}_fmt_string + formats above */ + + if (cm_fmt_string == NULL || *cm_fmt_string == '\0') { + cm_fmt_string = "{%s,%s}"; + } /* if cm_fmt_string == NULL */ + + if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') { + dcm_fmt_string = "{%s,%s}"; + } /* if dcm_fmt_string == NULL */ + + tab_size = 4; +} /* out_init */ + + + void +#ifdef KR_headers +extern_out(fp, extsym) + FILE *fp; + Extsym *extsym; +#else +extern_out(FILE *fp, Extsym *extsym) +#endif +{ + if (extsym == (Extsym *) NULL) + return; + + nice_printf (fp, "%s", extsym->cextname); + +} /* extern_out */ + + + + static void +#ifdef KR_headers +output_list(fp, listp) + FILE *fp; + struct Listblock *listp; +#else +output_list(FILE *fp, struct Listblock *listp) +#endif +{ + int did_one = 0; + chainp elts; + + nice_printf (fp, "("); + if (listp) + for (elts = listp -> listp; elts; elts = elts -> nextp) { + if (elts -> datap) { + if (did_one) + nice_printf (fp, ", "); + expr_out (fp, (expptr) elts -> datap); + did_one = 1; + } /* if elts -> datap */ + } /* for elts */ + nice_printf (fp, ")"); +} /* output_list */ + + + void +#ifdef KR_headers +out_asgoto(outfile, expr) + FILE *outfile; + expptr expr; +#else +out_asgoto(FILE *outfile, expptr expr) +#endif +{ + chainp value; + Namep namep; + int k; + + if (expr == (expptr) NULL) { + err ("out_asgoto: NULL variable expr"); + return; + } /* if expr */ + + nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/ + expr_out (outfile, expr); + nice_printf (outfile, ") {\n"); + next_tab (outfile); + +/* The initial addrp value will be stored as a namep pointer */ + + switch(expr->tag) { + case TNAME: + /* local variable */ + namep = &expr->nameblock; + break; + case TEXPR: + if (expr->exprblock.opcode == OPWHATSIN + && expr->exprblock.leftp->tag == TNAME) + /* argument */ + namep = &expr->exprblock.leftp->nameblock; + else + goto bad; + break; + case TADDR: + if (expr->addrblock.uname_tag == UNAM_NAME) { + /* initialized local variable */ + namep = expr->addrblock.user.name; + break; + } + default: + bad: + err("out_asgoto: bad expr"); + return; + } + + for(k = 0, value = namep -> varxptr.assigned_values; value; + value = value->nextp, k++) { + nice_printf (outfile, "case %d: goto %s;\n", k, + user_label((long)value->datap)); + } /* for value */ + prev_tab (outfile); + + nice_printf (outfile, "}\n"); +} /* out_asgoto */ + + void +#ifdef KR_headers +out_if(outfile, expr) + FILE *outfile; + expptr expr; +#else +out_if(FILE *outfile, expptr expr) +#endif +{ + nice_printf (outfile, "if ("); + expr_out (outfile, expr); + nice_printf (outfile, ") {\n"); + next_tab (outfile); +} /* out_if */ + + static void +#ifdef KR_headers +output_rbrace(outfile, s) + FILE *outfile; + char *s; +#else +output_rbrace(FILE *outfile, char *s) +#endif +{ + extern int last_was_label; + register char *fmt; + + if (last_was_label) { + last_was_label = 0; + fmt = ";%s"; + } + else + fmt = "%s"; + nice_printf(outfile, fmt, s); + } + + void +#ifdef KR_headers +out_else(outfile) + FILE *outfile; +#else +out_else(FILE *outfile) +#endif +{ + prev_tab (outfile); + output_rbrace(outfile, "} else {\n"); + next_tab (outfile); +} /* out_else */ + + void +#ifdef KR_headers +elif_out(outfile, expr) + FILE *outfile; + expptr expr; +#else +elif_out(FILE *outfile, expptr expr) +#endif +{ + prev_tab (outfile); + output_rbrace(outfile, "} else "); + out_if (outfile, expr); +} /* elif_out */ + + void +#ifdef KR_headers +endif_out(outfile) + FILE *outfile; +#else +endif_out(FILE *outfile) +#endif +{ + prev_tab (outfile); + output_rbrace(outfile, "}\n"); +} /* endif_out */ + + void +#ifdef KR_headers +end_else_out(outfile) + FILE *outfile; +#else +end_else_out(FILE *outfile) +#endif +{ + prev_tab (outfile); + output_rbrace(outfile, "}\n"); +} /* end_else_out */ + + + + void +#ifdef KR_headers +compgoto_out(outfile, index, labels) + FILE *outfile; + expptr index; + expptr labels; +#else +compgoto_out(FILE *outfile, expptr index, expptr labels) +#endif +{ + char *s1, *s2; + + if (index == ENULL) + err ("compgoto_out: null index for computed goto"); + else if (labels && labels -> tag != TLIST) + erri ("compgoto_out: expected label list, got tag '%d'", + labels -> tag); + else { + chainp elts; + int i = 1; + + s2 = /*(*/ ") {\n"; /*}*/ + if (Ansi) + s1 = "switch ("; /*)*/ + else if (index->tag == TNAME || index->tag == TEXPR + && index->exprblock.opcode == OPWHATSIN) + s1 = "switch ((int)"; /*)*/ + else { + s1 = "switch ((int)("; + s2 = ")) {\n"; /*}*/ + } + nice_printf(outfile, s1); + expr_out (outfile, index); + nice_printf (outfile, s2); + next_tab (outfile); + + for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) { + if (elts -> datap) { + if (ISICON(((expptr) (elts -> datap)))) + nice_printf (outfile, "case %d: goto %s;\n", i, + user_label(((expptr)(elts->datap))->constblock.Const.ci)); + else + err ("compgoto_out: bad label in label list"); + } /* if (elts -> datap) */ + } /* for elts */ + prev_tab (outfile); + nice_printf (outfile, /*{*/ "}\n"); + } /* else */ +} /* compgoto_out */ + + + void +#ifdef KR_headers +out_for(outfile, init, test, inc) + FILE *outfile; + expptr init; + expptr test; + expptr inc; +#else +out_for(FILE *outfile, expptr init, expptr test, expptr inc) +#endif +{ + nice_printf (outfile, "for ("); + expr_out (outfile, init); + nice_printf (outfile, "; "); + expr_out (outfile, test); + nice_printf (outfile, "; "); + expr_out (outfile, inc); + nice_printf (outfile, ") {\n"); + next_tab (outfile); +} /* out_for */ + + + void +#ifdef KR_headers +out_end_for(outfile) + FILE *outfile; +#else +out_end_for(FILE *outfile) +#endif +{ + prev_tab (outfile); + nice_printf (outfile, "}\n"); +} /* out_end_for */ diff --git a/unix/f2c/src/output.h b/unix/f2c/src/output.h new file mode 100644 index 00000000..97e3a0ad --- /dev/null +++ b/unix/f2c/src/output.h @@ -0,0 +1,64 @@ +/* nice_printf -- same arguments as fprintf. + + All output which is to become C code must be directed through this + function. For now, no buffering is done. Later on, every line of + output will be filtered to accomodate the style definitions (e.g. one + statement per line, spaces between function names and argument lists, + etc.) +*/ +#include "niceprintf.h" + + +/* Definitions for the opcode table. The table is indexed by the macros + which are #defined in defines.h */ + +#define UNARY_OP 01 +#define BINARY_OP 02 + +#define SPECIAL_FMT NULL + +#define is_unary_op(x) (opcode_table[x].type == UNARY_OP) +#define is_binary_op(x) (opcode_table[x].type == BINARY_OP) +#define op_precedence(x) (opcode_table[x].prec) +#define op_format(x) (opcode_table[x].format) + +/* _assoc_table -- encodes left-associativity and right-associativity + information; indexed by precedence level. Only 2, 3, 14 are + right-associative. Source: Kernighan & Ritchie, p. 49 */ + +extern char _assoc_table[]; + +#define is_right_assoc(x) (_assoc_table [x]) +#define is_left_assoc(x) (! _assoc_table [x]) + + +typedef struct { + int type; /* UNARY_OP or BINARY_OP */ + int prec; /* Precedence level, useful for adjusting + number of parens to insert. Zero is a + special level, and 2, 3, 14 are + right-associative */ + char *format; +} table_entry; + + +extern char *fl_fmt_string; /* Float constant format string */ +extern char *db_fmt_string; /* Double constant format string */ +extern char *cm_fmt_string; /* Complex constant format string */ +extern char *dcm_fmt_string; /* Double Complex constant format string */ + +extern int indent; /* Number of spaces to indent; this is a + temporary fix */ +extern int tab_size; /* Number of spaces in each tab */ +extern int in_string; + +extern table_entry opcode_table[]; + + +void compgoto_out Argdcl((FILEP, tagptr, tagptr)); +void endif_out Argdcl((FILEP)); +void expr_out Argdcl((FILEP, tagptr)); +void out_and_free_statement Argdcl((FILEP, tagptr)); +void out_end_for Argdcl((FILEP)); +void out_if Argdcl((FILEP, tagptr)); +void out_name Argdcl((FILEP, Namep)); diff --git a/unix/f2c/src/p1defs.h b/unix/f2c/src/p1defs.h new file mode 100644 index 00000000..c76af229 --- /dev/null +++ b/unix/f2c/src/p1defs.h @@ -0,0 +1,158 @@ +#define P1_UNKNOWN 0 +#define P1_COMMENT 1 /* Fortan comment string */ +#define P1_EOF 2 /* End of file dummy token */ +#define P1_SET_LINE 3 /* Reset the line counter */ +#define P1_FILENAME 4 /* Name of current input file */ +#define P1_NAME_POINTER 5 /* Pointer to hash table entry */ +#define P1_CONST 6 /* Some constant value */ +#define P1_EXPR 7 /* Followed by opcode */ + +/* The next two tokens could be grouped together, since they always come + from an Addr structure */ + +#define P1_IDENT 8 /* Char string identifier in addrp->user + field */ +#define P1_EXTERN 9 /* Pointer to external symbol entry */ + +#define P1_HEAD 10 /* Function header info */ +#define P1_LIST 11 /* A list of data (e.g. arguments) will + follow the tag, type, and count */ +#define P1_LITERAL 12 /* Hold the index into the literal pool */ +#define P1_LABEL 13 /* label value */ +#define P1_ASGOTO 14 /* Store the hash table pointer of + variable used in assigned goto */ +#define P1_GOTO 15 /* Store the statement number */ +#define P1_IF 16 /* store the condition as an expression */ +#define P1_ELSE 17 /* No data */ +#define P1_ELIF 18 /* store the condition as an expression */ +#define P1_ENDIF 19 /* Marks the end of a block IF */ +#define P1_ENDELSE 20 /* Marks the end of a block ELSE */ +#define P1_ADDR 21 /* Addr data; used for arrays, common and + equiv addressing, NOT for names, idents + or externs */ +#define P1_SUBR_RET 22 /* Subroutine return; the return expression + follows */ +#define P1_COMP_GOTO 23 /* Computed goto; has expr, label list */ +#define P1_FOR 24 /* C FOR loop; three expressions follow */ +#define P1_ENDFOR 25 /* End of C FOR loop */ +#define P1_FORTRAN 26 /* original Fortran source */ +#define P1_CHARP 27 /* user.Charp field -- for long names */ +#define P1_WHILE1START 28 /* start of DO WHILE */ +#define P1_WHILE2START 29 /* rest of DO WHILE */ +#define P1_PROCODE 30 /* invoke procode() -- to adjust params */ +#define P1_ELSEIFSTART 31 /* handle extra code for abs, min, max + in else if() */ + +#define P1_FILENAME_MAX 256 /* max filename length to retain (for -g) */ +#define P1_STMTBUFSIZE 1400 + + + +#define COMMENT_BUFFER_SIZE 255 /* max number of chars in each comment */ +#define CONSTANT_STR_MAX 1000 /* max number of chars in string constant */ + +void p1_asgoto Argdcl((Addrp)); +void p1_comment Argdcl((char*)); +void p1_elif Argdcl((tagptr)); +void p1_else Argdcl((void)); +void p1_endif Argdcl((void)); +void p1_expr Argdcl((tagptr)); +void p1_for Argdcl((tagptr, tagptr, tagptr)); +void p1_goto Argdcl((long int)); +void p1_head Argdcl((int, char*)); +void p1_if Argdcl((tagptr)); +void p1_label Argdcl((long int)); +void p1_line_number Argdcl((long int)); +void p1_subr_ret Argdcl((tagptr)); +void p1comp_goto Argdcl((tagptr, int, struct Labelblock**)); +void p1else_end Argdcl((void)); +void p1for_end Argdcl((void)); +void p1put Argdcl((int)); +void p1puts Argdcl((int, char*)); + +/* The pass 1 intermediate file has the following format: + + [ : [ [ ]]] \n + + e.g. 1: This is a comment + + This format is destined to change in the future, but for now a readable + form is more desirable than a compact form. + + NOTES ABOUT THE P1 FORMAT + ---------------------------------------------------------------------- + + P1_COMMENT: The comment string (in ) may be at most + COMMENT_BUFFER_SIZE bytes long. It must contain no newlines + or null characters. A side effect of the way comments are + read in lex.c is that no '\377' chars may be in a + comment either. + + P1_SET_LINE: holds the line number in the current source file. + + P1_INC_LINE: Increment the source line number; is empty. + + P1_NAME_POINTER: holds the integer representation of a + pointer into a hash table entry. + + P1_CONST: the first field in is a type tag (one of the + TYxxxx macros), the next field holds the constant + value + + P1_EXPR: holds the opcode number of the expression, + followed by the type of the expression (required for + OPCONV). Next is the value of vleng. + The type of operation represented by the + opcode determines how many of the following data items + are part of this expression. + + P1_IDENT: holds the type, then storage, then the + char string identifier in the addrp->user field. + + P1_EXTERN: holds an offset into the external symbol + table entry + + P1_HEAD: the first field in is the procedure class, the + second is the name of the procedure + + P1_LIST: the first field in is the tag, the second the + type of the list, the third the number of elements in + the list + + P1_LITERAL: holds the litnum of a value in the + literal pool. + + P1_LABEL: holds the statement number of the current + line + + P1_ASGOTO: holds the hash table pointer of the variable + + P1_GOTO: holds the statement number to jump to + + P1_IF: is empty, the following expression is the IF + condition. + + P1_ELSE: is empty. + + P1_ELIF: is empty, the following expression is the IF + condition. + + P1_ENDIF: is empty. + + P1_ENDELSE: is empty. + + P1_ADDR: holds a direct copy of the structure. The + next expression is a copy of vleng, and the next a + copy of memoffset. + + P1_SUBR_RET: The next token is an expression for the return value. + + P1_COMP_GOTO: The next token is an integer expression, the + following one a list of labels. + + P1_FOR: The next three expressions are the Init, Test, and + Increment expressions of a C FOR loop. + + P1_ENDFOR: Marks the end of the body of a FOR loop + +*/ diff --git a/unix/f2c/src/p1output.c b/unix/f2c/src/p1output.c new file mode 100644 index 00000000..5afc7473 --- /dev/null +++ b/unix/f2c/src/p1output.c @@ -0,0 +1,728 @@ +/**************************************************************** +Copyright 1990, 1991, 1993, 1994, 1999-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "p1defs.h" +#include "output.h" +#include "names.h" + + +static void p1_addr Argdcl((Addrp)); +static void p1_big_addr Argdcl((Addrp)); +static void p1_binary Argdcl((Exprp)); +static void p1_const Argdcl((Constp)); +static void p1_list Argdcl((struct Listblock*)); +static void p1_literal Argdcl((long int)); +static void p1_name Argdcl((Namep)); +static void p1_unary Argdcl((Exprp)); +static void p1putd Argdcl((int, long int)); +static void p1putdd Argdcl((int, int, int)); +static void p1putddd Argdcl((int, int, int, int)); +static void p1putdds Argdcl((int, int, int, char*)); +static void p1putds Argdcl((int, int, char*)); +static void p1putn Argdcl((int, int, char*)); + + +/* p1_comment -- save the text of a Fortran comment in the intermediate + file. Make sure that there are no spurious "/ *" or "* /" characters by + mapping them onto "/+" and "+/". str is assumed to hold no newlines and be + null terminated; it may be modified by this function. */ + + void +#ifdef KR_headers +p1_comment(str) + char *str; +#else +p1_comment(char *str) +#endif +{ + register unsigned char *pointer, *ustr; + + if (!str) + return; + +/* Get rid of any open or close comment combinations that may be in the + Fortran input */ + + ustr = (unsigned char *)str; + for(pointer = ustr; *pointer; pointer++) + if (*pointer == '*' && (pointer[1] == '/' + || pointer > ustr && pointer[-1] == '/')) + *pointer = '+'; + /* trim trailing white space */ +#ifdef isascii + while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer))); +#else + while(--pointer >= ustr && isspace(*pointer)); +#endif + pointer[1] = 0; + p1puts (P1_COMMENT, str); +} /* p1_comment */ + +/* p1_name -- Writes the address of a hash table entry into the + intermediate file */ + + static void +#ifdef KR_headers +p1_name(namep) + Namep namep; +#else +p1_name(Namep namep) +#endif +{ + p1putd (P1_NAME_POINTER, (long) namep); + namep->visused = 1; +} /* p1_name */ + + + + void +#ifdef KR_headers +p1_expr(expr) + expptr expr; +#else +p1_expr(expptr expr) +#endif +{ +/* An opcode of 0 means a null entry */ + + if (expr == ENULL) { + p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */ + return; + } /* if (expr == ENULL) */ + + switch (expr -> tag) { + case TNAME: + p1_name ((Namep) expr); + return; + case TCONST: + p1_const(&expr->constblock); + return; + case TEXPR: + /* Fall through the switch */ + break; + case TADDR: + p1_addr (&(expr -> addrblock)); + goto freeup; + case TPRIM: + warn ("p1_expr: got TPRIM"); + return; + case TLIST: + p1_list (&(expr->listblock)); + frchain( &(expr->listblock.listp) ); + return; + case TERROR: + return; + default: + erri ("p1_expr: bad tag '%d'", (int) (expr -> tag)); + return; + } + +/* Now we know that the tag is TEXPR */ + + if (is_unary_op (expr -> exprblock.opcode)) + p1_unary (&(expr -> exprblock)); + else if (is_binary_op (expr -> exprblock.opcode)) + p1_binary (&(expr -> exprblock)); + else + erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode); + freeup: + free((char *)expr); + +} /* p1_expr */ + + + + static void +#ifdef KR_headers +p1_const(cp) + register Constp cp; +#else +p1_const(register Constp cp) +#endif +{ + int type = cp->vtype; + expptr vleng = cp->vleng; + union Constant *c = &cp->Const; + char cdsbuf0[64], cdsbuf1[64]; + char *cds0, *cds1; + + switch (type) { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD0 + case TYQUAD: +#endif + case TYLOGICAL: + case TYLOGICAL1: + case TYLOGICAL2: + fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci); + break; +#ifndef NO_LONG_LONG + case TYQUAD: + fprintf(pass1_file, "%d: %d %llx\n", P1_CONST, type, c->cq); + break; +#endif + case TYREAL: + case TYDREAL: + fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type, + cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0)); + break; + case TYCOMPLEX: + case TYDCOMPLEX: + if (cp->vstg) { + cds0 = c->cds[0]; + cds1 = c->cds[1]; + } + else { + cds0 = cds(dtos(c->cd[0]), cdsbuf0); + cds1 = cds(dtos(c->cd[1]), cdsbuf1); + } + fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type, + cds0, cds1); + break; + case TYCHAR: + if (vleng && !ISICON (vleng)) + err("p1_const: bad vleng\n"); + else + fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type, + (unsigned long)cpexpr((expptr)cp)); + break; + default: + erri ("p1_const: bad constant type '%d'", type); + break; + } /* switch */ +} /* p1_const */ + + + void +#ifdef KR_headers +p1_asgoto(addrp) + Addrp addrp; +#else +p1_asgoto(Addrp addrp) +#endif +{ + p1put (P1_ASGOTO); + p1_addr (addrp); +} /* p1_asgoto */ + + + void +#ifdef KR_headers +p1_goto(stateno) + ftnint stateno; +#else +p1_goto(ftnint stateno) +#endif +{ + p1putd (P1_GOTO, stateno); +} /* p1_goto */ + + + static void +#ifdef KR_headers +p1_addr(addrp) + register struct Addrblock *addrp; +#else +p1_addr(register struct Addrblock *addrp) +#endif +{ + int stg; + + if (addrp == (struct Addrblock *) NULL) + return; + + stg = addrp -> vstg; + + if (ONEOF(stg, M(STGINIT)|M(STGREG)) + || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) && + (!ISICON(addrp->memoffset) + || (addrp->uname_tag == UNAM_NAME + ? addrp->memoffset->constblock.Const.ci + != addrp->user.name->voffset + : addrp->memoffset->constblock.Const.ci)) + || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) && + (!ISICON(addrp->memoffset) + || addrp->memoffset->constblock.Const.ci) + || addrp->Field || addrp->isarray || addrp->vstg == STGLENG) + { + p1_big_addr (addrp); + return; + } + +/* Write out a level of indirection for non-array arguments, which have + addrp -> memoffset set and are handled by p1_big_addr(). + Lengths are passed by value, so don't check STGLENG + 28-Jun-89 (dmg) Added the check for != TYCHAR + */ + + if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL, + stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) { + p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype); + p1_expr (ENULL); /* Put dummy vleng */ + } /* if stg == STGARG */ + + switch (addrp -> uname_tag) { + case UNAM_NAME: + p1_name (addrp -> user.name); + break; + case UNAM_IDENT: + p1putdds(P1_IDENT, addrp->vtype, addrp->vstg, + addrp->user.ident); + break; + case UNAM_CHARP: + p1putdds(P1_CHARP, addrp->vtype, addrp->vstg, + addrp->user.Charp); + break; + case UNAM_EXTERN: + p1putd (P1_EXTERN, (long) addrp -> memno); + if (addrp->vclass == CLPROC) + extsymtab[addrp->memno].extype = addrp->vtype; + break; + case UNAM_CONST: + if (addrp -> memno != BAD_MEMNO) + p1_literal (addrp -> memno); + else + p1_const((struct Constblock *)addrp); + break; + case UNAM_UNKNOWN: + default: + erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag); + break; + } /* switch */ +} /* p1_addr */ + + + static void +#ifdef KR_headers +p1_list(listp) + struct Listblock *listp; +#else +p1_list(struct Listblock *listp) +#endif +{ + chainp lis; + int count = 0; + + if (listp == (struct Listblock *) NULL) + return; + +/* Count the number of parameters in the list */ + + for (lis = listp -> listp; lis; lis = lis -> nextp) + count++; + + p1putddd (P1_LIST, listp -> tag, listp -> vtype, count); + + for (lis = listp -> listp; lis; lis = lis -> nextp) + p1_expr ((expptr) lis -> datap); + +} /* p1_list */ + + + void +#ifdef KR_headers +p1_label(lab) + long lab; +#else +p1_label(long lab) +#endif +{ + if (parstate < INDATA) + earlylabs = mkchain((char *)lab, earlylabs); + else + p1putd (P1_LABEL, lab); + } + + + + static void +#ifdef KR_headers +p1_literal(memno) + long memno; +#else +p1_literal(long memno) +#endif +{ + p1putd (P1_LITERAL, memno); +} /* p1_literal */ + + + void +#ifdef KR_headers +p1_if(expr) + expptr expr; +#else +p1_if(expptr expr) +#endif +{ + p1put (P1_IF); + p1_expr (expr); +} /* p1_if */ + + + + + void +#ifdef KR_headers +p1_elif(expr) + expptr expr; +#else +p1_elif(expptr expr) +#endif +{ + p1put (P1_ELIF); + p1_expr (expr); +} /* p1_elif */ + + + + + void +p1_else(Void) +{ + p1put (P1_ELSE); +} /* p1_else */ + + + + + void +p1_endif(Void) +{ + p1put (P1_ENDIF); +} /* p1_endif */ + + + + + void +p1else_end(Void) +{ + p1put (P1_ENDELSE); +} /* p1else_end */ + + + static void +#ifdef KR_headers +p1_big_addr(addrp) + Addrp addrp; +#else +p1_big_addr(Addrp addrp) +#endif +{ + if (addrp == (Addrp) NULL) + return; + + p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp); + p1_expr (addrp -> vleng); + p1_expr (addrp -> memoffset); + if (addrp->uname_tag == UNAM_NAME) + addrp->user.name->visused = 1; +} /* p1_big_addr */ + + + + static void +#ifdef KR_headers +p1_unary(e) + struct Exprblock *e; +#else +p1_unary(struct Exprblock *e) +#endif +{ + if (e == (struct Exprblock *) NULL) + return; + + p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype); + p1_expr (e -> vleng); + + switch (e -> opcode) { + case OPNEG: + case OPNEG1: + case OPNOT: + case OPABS: + case OPBITNOT: + case OPPREINC: + case OPPREDEC: + case OPADDR: + case OPIDENTITY: + case OPCHARCAST: + case OPDABS: + p1_expr(e -> leftp); + break; + default: + erri ("p1_unary: bad opcode '%d'", (int) e -> opcode); + break; + } /* switch */ + +} /* p1_unary */ + + + static void +#ifdef KR_headers +p1_binary(e) + struct Exprblock *e; +#else +p1_binary(struct Exprblock *e) +#endif +{ + if (e == (struct Exprblock *) NULL) + return; + + p1putdd (P1_EXPR, e -> opcode, e -> vtype); + p1_expr (e -> vleng); + p1_expr (e -> leftp); + p1_expr (e -> rightp); +} /* p1_binary */ + + + void +#ifdef KR_headers +p1_head(Class, name) + int Class; + char *name; +#else +p1_head(int Class, char *name) +#endif +{ + p1putds (P1_HEAD, Class, (char*)(name ? name : "")); +} /* p1_head */ + + + void +#ifdef KR_headers +p1_subr_ret(retexp) + expptr retexp; +#else +p1_subr_ret(expptr retexp) +#endif +{ + + p1put (P1_SUBR_RET); + p1_expr (cpexpr(retexp)); +} /* p1_subr_ret */ + + + + void +#ifdef KR_headers +p1comp_goto(index, count, labels) + expptr index; + int count; + struct Labelblock **labels; +#else +p1comp_goto(expptr index, int count, struct Labelblock **labels) +#endif +{ + struct Constblock c; + int i; + register struct Labelblock *L; + + p1put (P1_COMP_GOTO); + p1_expr (index); + +/* Write out a P1_LIST directly, to avoid the overhead of allocating a + list before it's needed HACK HACK HACK */ + + p1putddd (P1_LIST, TLIST, TYUNKNOWN, count); + c.vtype = TYLONG; + c.vleng = 0; + + for (i = 0; i < count; i++) { + L = labels[i]; + L->labused = 1; + c.Const.ci = L->stateno; + p1_const(&c); + } /* for i = 0 */ +} /* p1comp_goto */ + + + + void +#ifdef KR_headers +p1_for(init, test, inc) + expptr init; + expptr test; + expptr inc; +#else +p1_for(expptr init, expptr test, expptr inc) +#endif +{ + p1put (P1_FOR); + p1_expr (init); + p1_expr (test); + p1_expr (inc); +} /* p1_for */ + + + void +p1for_end(Void) +{ + p1put (P1_ENDFOR); +} /* p1for_end */ + + + + +/* ---------------------------------------------------------------------- + The intermediate file actually gets written ONLY by the routines below. + To change the format of the file, you need only change these routines. + ---------------------------------------------------------------------- +*/ + + +/* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that + str contains no newlines and is null-terminated. */ + + void +#ifdef KR_headers +p1puts(type, str) + int type; + char *str; +#else +p1puts(int type, char *str) +#endif +{ + fprintf (pass1_file, "%d: %s\n", type, str); +} /* p1puts */ + + +/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */ + + static void +#ifdef KR_headers +p1putd(type, value) + int type; + long value; +#else +p1putd(int type, long value) +#endif +{ + fprintf (pass1_file, "%d: %ld\n", type, value); +} /* p1_putd */ + + +/* p1putdd -- Put a typed pair of integers into the intermediate file. */ + + static void +#ifdef KR_headers +p1putdd(type, v1, v2) + int type; + int v1; + int v2; +#else +p1putdd(int type, int v1, int v2) +#endif +{ + fprintf (pass1_file, "%d: %d %d\n", type, v1, v2); +} /* p1putdd */ + + +/* p1putddd -- Put a typed triple of integers into the intermediate file. */ + + static void +#ifdef KR_headers +p1putddd(type, v1, v2, v3) + int type; + int v1; + int v2; + int v3; +#else +p1putddd(int type, int v1, int v2, int v3) +#endif +{ + fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3); +} /* p1putddd */ + + union dL { + double d; + long L[2]; + }; + + static void +#ifdef KR_headers +p1putn(type, count, str) + int type; + int count; + char *str; +#else +p1putn(int type, int count, char *str) +#endif +{ + int i; + + fprintf (pass1_file, "%d: ", type); + + for (i = 0; i < count; i++) + putc (str[i], pass1_file); + + putc ('\n', pass1_file); +} /* p1putn */ + + + +/* p1put -- Put a type marker into the intermediate file. */ + + void +#ifdef KR_headers +p1put(type) + int type; +#else +p1put(int type) +#endif +{ + fprintf (pass1_file, "%d:\n", type); +} /* p1put */ + + + + static void +#ifdef KR_headers +p1putds(type, i, str) + int type; + int i; + char *str; +#else +p1putds(int type, int i, char *str) +#endif +{ + fprintf (pass1_file, "%d: %d %s\n", type, i, str); +} /* p1putds */ + + + static void +#ifdef KR_headers +p1putdds(token, type, stg, str) + int token; + int type; + int stg; + char *str; +#else +p1putdds(int token, int type, int stg, char *str) +#endif +{ + fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str); +} /* p1putdds */ diff --git a/unix/f2c/src/parse.h b/unix/f2c/src/parse.h new file mode 100644 index 00000000..6de23994 --- /dev/null +++ b/unix/f2c/src/parse.h @@ -0,0 +1,47 @@ +#ifndef PARSE_INCLUDE +#define PARSE_INCLUDE + +/* macros for the parse_args routine */ + +#define P_STRING 1 /* Macros for the result_type attribute */ +#define P_CHAR 2 +#define P_SHORT 3 +#define P_INT 4 +#define P_LONG 5 +#define P_FILE 6 +#define P_OLD_FILE 7 +#define P_NEW_FILE 8 +#define P_FLOAT 9 +#define P_DOUBLE 10 + +#define P_CASE_INSENSITIVE 01 /* Macros for the flags attribute */ +#define P_REQUIRED_PREFIX 02 + +#define P_NO_ARGS 0 /* Macros for the arg_count attribute */ +#define P_ONE_ARG 1 +#define P_INFINITE_ARGS 2 + +#define p_entry(pref,swit,flag,count,type,store,size) \ + { (pref), (swit), (flag), (count), (type), (int *) (store), (size) } + +typedef struct { + char *prefix; + char *string; + int flags; + int count; + int result_type; + int *result_ptr; + int table_size; +} arg_info; + +#ifdef KR_headers +#define Argdcl(x) () +#else +#define Argdcl(x) x +#endif +int arg_verify Argdcl((char**, arg_info*, int)); +void init_store Argdcl((arg_info*, int)); +int match_table Argdcl((char*, arg_info*, int, int, int*)); +int parse_args Argdcl((int, char**, arg_info*, int, char**, int)); + +#endif diff --git a/unix/f2c/src/parse_args.c b/unix/f2c/src/parse_args.c new file mode 100644 index 00000000..dd7b7810 --- /dev/null +++ b/unix/f2c/src/parse_args.c @@ -0,0 +1,558 @@ +/**************************************************************** +Copyright 1990, 1994-5, 2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* parse_args + + This function will parse command line input into appropriate data + structures, output error messages when appropriate and provide some + minimal type conversion. + + Input to the function consists of the standard argc,argv + values, and a table which directs the parser. Each table entry has the + following components: + + prefix -- the (optional) switch character string, e.g. "-" "/" "=" + switch -- the command string, e.g. "o" "data" "file" "F" + flags -- control flags, e.g. CASE_INSENSITIVE, REQUIRED_PREFIX + arg_count -- number of arguments this command requires, e.g. 0 for + booleans, 1 for filenames, INFINITY for input files + result_type -- how to interpret the switch arguments, e.g. STRING, + CHAR, FILE, OLD_FILE, NEW_FILE + result_ptr -- pointer to storage for the result, be it a table or + a string or whatever + table_size -- if the arguments fill a table, the maximum number of + entries; if there are no arguments, the value to + load into the result storage + + Although the table can be used to hold a list of filenames, only + scalar values (e.g. pointers) can be stored in the table. No vector + processing will be done, only pointers to string storage will be moved. + + An example entry, which could be used to parse input filenames, is: + + "-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE + +*/ + +#include +#ifndef NULL +/* ANSI C */ +#include +#endif +#ifdef KR_headers +extern double atof(); +#else +#include "stdlib.h" +#include "string.h" +#endif +#include "parse.h" +#include /* For atof */ +#include + +#define MAX_INPUT_SIZE 1000 + +#define arg_prefix(x) ((x).prefix) +#define arg_string(x) ((x).string) +#define arg_flags(x) ((x).flags) +#define arg_count(x) ((x).count) +#define arg_result_type(x) ((x).result_type) +#define arg_result_ptr(x) ((x).result_ptr) +#define arg_table_size(x) ((x).table_size) + +#ifndef TRUE +#define TRUE 1 +#endif +#ifndef FALSE +#define FALSE 0 +#endif +typedef int boolean; + + +static char *this_program = ""; + +static int arg_parse Argdcl((char*, arg_info*)); +static char *lower_string Argdcl((char*, char*)); +static int match Argdcl((char*, char*, arg_info*, boolean)); +static int put_one_arg Argdcl((int, char*, char**, char*, char*)); +extern int badargs; + + + boolean +#ifdef KR_headers +parse_args(argc, argv, table, entries, others, other_count) + int argc; + char **argv; + arg_info *table; + int entries; + char **others; + int other_count; +#else +parse_args(int argc, char **argv, arg_info *table, int entries, char **others, int other_count) +#endif +{ + boolean result; + + if (argv) + this_program = argv[0]; + +/* Check the validity of the table and its parameters */ + + result = arg_verify (argv, table, entries); + +/* Initialize the storage values */ + + init_store (table, entries); + + if (result) { + boolean use_prefix = TRUE; + char *argv0; + + argc--; + argv0 = *++argv; + while (argc) { + int index, length; + + index = match_table (*argv, table, entries, use_prefix, &length); + if (index < 0) { + +/* The argument doesn't match anything in the table */ + + if (others) { + + if (*argv > argv0) + *--*argv = '-'; /* complain at invalid flag */ + + if (other_count > 0) { + *others++ = *argv; + other_count--; + } else { + fprintf (stderr, "%s: too many parameters: ", + this_program); + fprintf (stderr, "'%s' ignored\n", *argv); + badargs++; + } /* else */ + } /* if (others) */ + argv0 = *++argv; + argc--; + use_prefix = TRUE; + } else { + +/* A match was found */ + + if (length >= strlen (*argv)) { + argc--; + argv0 = *++argv; + use_prefix = TRUE; + } else { + (*argv) += length; + use_prefix = FALSE; + } /* else */ + +/* Parse any necessary arguments */ + + if (arg_count (table[index]) != P_NO_ARGS) { + +/* Now length will be used to store the number of parsed characters */ + + length = arg_parse(*argv, &table[index]); + if (*argv == NULL) + argc = 0; + else if (length >= strlen (*argv)) { + argc--; + argv0 = *++argv; + use_prefix = TRUE; + } else { + (*argv) += length; + use_prefix = FALSE; + } /* else */ + } /* if (argv_count != P_NO_ARGS) */ + else + *arg_result_ptr(table[index]) = + arg_table_size(table[index]); + } /* else */ + } /* while (argc) */ + } /* if (result) */ + + return result; +} /* parse_args */ + + + boolean +#ifdef KR_headers +arg_verify(argv, table, entries) + char **argv; + arg_info *table; + int entries; +#else +arg_verify(char **argv, arg_info *table, int entries) +#endif +{ + int i; + char *this_program = ""; + + if (argv) + this_program = argv[0]; + + for (i = 0; i < entries; i++) { + arg_info *arg = &table[i]; + +/* Check the argument flags */ + + if (arg_flags (*arg) & ~(P_CASE_INSENSITIVE | P_REQUIRED_PREFIX)) { + fprintf (stderr, "%s [arg_verify]: too many ", this_program); + fprintf (stderr, "flags in entry %d: '%x' (hex)\n", i, + arg_flags (*arg)); + badargs++; + } /* if */ + +/* Check the argument count */ + + { int count = arg_count (*arg); + + if (count != P_NO_ARGS && count != P_ONE_ARG && count != + P_INFINITE_ARGS) { + fprintf (stderr, "%s [arg_verify]: invalid ", this_program); + fprintf (stderr, "argument count in entry %d: '%d'\n", i, + count); + badargs++; + } /* if count != P_NO_ARGS ... */ + +/* Check the result field; want to be able to store results */ + + else + if (arg_result_ptr (*arg) == (int *) NULL) { + fprintf (stderr, "%s [arg_verify]: ", this_program); + fprintf (stderr, "no argument storage given for "); + fprintf (stderr, "entry %d\n", i); + badargs++; + } /* if arg_result_ptr */ + } + +/* Check the argument type */ + + { int type = arg_result_type (*arg); + + if (type < P_STRING || type > P_DOUBLE) { + fprintf(stderr, + "%s [arg_verify]: bad arg type in entry %d: '%d'\n", + this_program, i, type); + badargs++; + } + } + +/* Check table size */ + + { int size = arg_table_size (*arg); + + if (arg_count (*arg) == P_INFINITE_ARGS && size < 1) { + fprintf (stderr, "%s [arg_verify]: bad ", this_program); + fprintf (stderr, "table size in entry %d: '%d'\n", i, + size); + badargs++; + } /* if (arg_count == P_INFINITE_ARGS && size < 1) */ + } + + } /* for i = 0 */ + + return TRUE; +} /* arg_verify */ + + +/* match_table -- returns the index of the best entry matching the input, + -1 if no match. The best match is the one of longest length which + appears lowest in the table. The length of the match will be returned + in length ONLY IF a match was found. */ + + int +#ifdef KR_headers +match_table(norm_input, table, entries, use_prefix, length) + register char *norm_input; + arg_info *table; + int entries; + boolean use_prefix; + int *length; +#else +match_table(register char *norm_input, arg_info *table, int entries, boolean use_prefix, int *length) +#endif +{ + char low_input[MAX_INPUT_SIZE]; + register int i; + int best_index = -1, best_length = 0; + +/* FUNCTION BODY */ + + (void) lower_string (low_input, norm_input); + + for (i = 0; i < entries; i++) { + int this_length = match(norm_input, low_input, &table[i], use_prefix); + + if (this_length > best_length) { + best_index = i; + best_length = this_length; + } /* if (this_length > best_length) */ + } /* for (i = 0) */ + + if (best_index > -1 && length != (int *) NULL) + *length = best_length; + + return best_index; +} /* match_table */ + + +/* match -- takes an input string and table entry, and returns the length + of the longer match. + + 0 ==> input doesn't match + + For example: + + INPUT PREFIX STRING RESULT +---------------------------------------------------------------------- + "abcd" "-" "d" 0 + "-d" "-" "d" 2 (i.e. "-d") + "dout" "-" "d" 1 (i.e. "d") + "-d" "" "-d" 2 (i.e. "-d") + "dd" "d" "d" 2 <= here's the weird one +*/ + + static int +#ifdef KR_headers +match(norm_input, low_input, entry, use_prefix) + char *norm_input; + char *low_input; + arg_info *entry; + boolean use_prefix; +#else +match(char *norm_input, char *low_input, arg_info *entry, boolean use_prefix) +#endif +{ + char *norm_prefix = arg_prefix (*entry); + char *norm_string = arg_string (*entry); + boolean prefix_match = FALSE, string_match = FALSE; + int result = 0; + +/* Buffers for the lowercased versions of the strings being compared. + These are used when the switch is to be case insensitive */ + + static char low_prefix[MAX_INPUT_SIZE]; + static char low_string[MAX_INPUT_SIZE]; + int prefix_length = strlen (norm_prefix); + int string_length = strlen (norm_string); + +/* Pointers for the required strings (lowered or nonlowered) */ + + register char *input, *prefix, *string; + +/* FUNCTION BODY */ + +/* Use the appropriate strings to handle case sensitivity */ + + if (arg_flags (*entry) & P_CASE_INSENSITIVE) { + input = low_input; + prefix = lower_string (low_prefix, norm_prefix); + string = lower_string (low_string, norm_string); + } else { + input = norm_input; + prefix = norm_prefix; + string = norm_string; + } /* else */ + +/* First, check the string formed by concatenating the prefix onto the + switch string, but only when the prefix is not being ignored */ + + if (use_prefix && prefix != NULL && *prefix != '\0') + prefix_match = (strncmp (input, prefix, prefix_length) == 0) && + (strncmp (input + prefix_length, string, string_length) == 0); + +/* Next, check just the switch string, if that's allowed */ + + if (!use_prefix && (arg_flags (*entry) & P_REQUIRED_PREFIX) == 0) + string_match = strncmp (input, string, string_length) == 0; + + if (prefix_match) + result = prefix_length + string_length; + else if (string_match) + result = string_length; + + return result; +} /* match */ + + + static char * +#ifdef KR_headers +lower_string(dest, src) + char *dest; + char *src; +#else +lower_string(char *dest, char *src) +#endif +{ + char *result = dest; + register int c; + + if (dest == NULL || src == NULL) + result = NULL; + else + while (*dest++ = (c = *src++) >= 'A' && c <= 'Z' ? tolower(c) : c); + + return result; +} /* lower_string */ + + +/* arg_parse -- returns the number of characters parsed for this entry */ + + static int +#ifdef KR_headers +arg_parse(str, entry) + char *str; + arg_info *entry; +#else +arg_parse(char *str, arg_info *entry) +#endif +{ + int length = 0; + + if (arg_count (*entry) == P_ONE_ARG) { + char **store = (char **) arg_result_ptr (*entry); + + length = put_one_arg (arg_result_type (*entry), str, store, + arg_prefix (*entry), arg_string (*entry)); + + } /* if (arg_count == P_ONE_ARG) */ + else { /* Must be a table of arguments */ + char **store = (char **) arg_result_ptr (*entry); + + if (store) { + while (*store) + store++; + + length = put_one_arg(arg_result_type (*entry), str, store++, + arg_prefix (*entry), arg_string (*entry)); + + *store = (char *) NULL; + } /* if (store) */ + } /* else */ + + return length; +} /* arg_parse */ + + + static int +#ifdef KR_headers +put_one_arg(type, str, store, prefix, string) + int type; + char *str; + char **store; + char *prefix; + char *string; +#else +put_one_arg(int type, char *str, char **store, char *prefix, char *string) +#endif +{ + int length = 0; + long L; + + if (store) { + switch (type) { + case P_STRING: + case P_FILE: + case P_OLD_FILE: + case P_NEW_FILE: + if (str == NULL) { + fprintf(stderr, "%s: Missing argument after '%s%s'\n", + this_program, prefix, string); + length = 0; + badargs++; + } + else + length = strlen(*store = str); + break; + case P_CHAR: + *((char *) store) = *str; + length = 1; + break; + case P_SHORT: + L = atol(str); + *(short *)store = (short) L; + if (L != *(short *)store) { + fprintf(stderr, + "%s%s parameter '%ld' is not a SHORT INT (truncating to %d)\n", + prefix, string, L, *(short *)store); + badargs++; + } + length = strlen (str); + break; + case P_INT: + L = atol(str); + *(int *)store = (int)L; + if (L != *(int *)store) { + fprintf(stderr, + "%s%s parameter '%ld' is not an INT (truncating to %d)\n", + prefix, string, L, *(int *)store); + badargs++; + } + length = strlen (str); + break; + case P_LONG: + *(long *)store = atol(str); + length = strlen (str); + break; + case P_FLOAT: + *((float *) store) = (float) atof(str); + length = strlen (str); + break; + case P_DOUBLE: + *((double *) store) = (double) atof(str); + length = strlen (str); + break; + default: + fprintf (stderr, "put_one_arg: bad type '%d'\n", type); + badargs++; + break; + } /* switch */ + } /* if (store) */ + + return length; +} /* put_one_arg */ + + + void +#ifdef KR_headers +init_store(table, entries) + arg_info *table; + int entries; +#else +init_store(arg_info *table, int entries) +#endif +{ + int index; + + for (index = 0; index < entries; index++) + if (arg_count (table[index]) == P_INFINITE_ARGS) { + char **place = (char **) arg_result_ptr (table[index]); + + if (place) + *place = (char *) NULL; + } /* if arg_count == P_INFINITE_ARGS */ + +} /* init_store */ diff --git a/unix/f2c/src/pccdefs.h b/unix/f2c/src/pccdefs.h new file mode 100644 index 00000000..bde81177 --- /dev/null +++ b/unix/f2c/src/pccdefs.h @@ -0,0 +1,64 @@ +/* The following numbers are strange, and implementation-dependent */ + +#define P2BAD -1 +#define P2NAME 2 +#define P2ICON 4 /* Integer constant */ +#define P2PLUS 6 +#define P2PLUSEQ 7 +#define P2MINUS 8 +#define P2NEG 10 +#define P2STAR 11 +#define P2STAREQ 12 +#define P2INDIRECT 13 +#define P2BITAND 14 +#define P2BITOR 17 +#define P2BITXOR 19 +#define P2QUEST 21 +#define P2COLON 22 +#define P2ANDAND 23 +#define P2OROR 24 +#define P2GOTO 37 +#define P2LISTOP 56 +#define P2ASSIGN 58 +#define P2COMOP 59 +#define P2SLASH 60 +#define P2MOD 62 +#define P2LSHIFT 64 +#define P2RSHIFT 66 +#define P2CALL 70 +#define P2CALL0 72 + +#define P2NOT 76 +#define P2BITNOT 77 +#define P2EQ 80 +#define P2NE 81 +#define P2LE 82 +#define P2LT 83 +#define P2GE 84 +#define P2GT 85 +#define P2REG 94 +#define P2OREG 95 +#define P2CONV 104 +#define P2FORCE 108 +#define P2CBRANCH 109 + +/* special operators included only for fortran's use */ + +#define P2PASS 200 +#define P2STMT 201 +#define P2SWITCH 202 +#define P2LBRACKET 203 +#define P2RBRACKET 204 +#define P2EOF 205 +#define P2ARIF 206 +#define P2LABEL 207 + +#define P2SHORT 3 +#define P2INT 4 +#define P2LONG 4 + +#define P2CHAR 2 +#define P2REAL 6 +#define P2DREAL 7 +#define P2PTR 020 +#define P2FUNCT 040 diff --git a/unix/f2c/src/pread.c b/unix/f2c/src/pread.c new file mode 100644 index 00000000..40152182 --- /dev/null +++ b/unix/f2c/src/pread.c @@ -0,0 +1,990 @@ +/**************************************************************** +Copyright 1990, 1992, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" + + static char Ptok[128], Pct[Table_size]; + static char *Pfname; + static long Plineno; + static int Pbad; + static int *tfirst, *tlast, *tnext, tmax; + +#define P_space 1 +#define P_anum 2 +#define P_delim 3 +#define P_slash 4 + +#define TGULP 100 + + static void +trealloc(Void) +{ + int k = tmax; + tfirst = (int *)realloc((char *)tfirst, + (tmax += TGULP)*sizeof(int)); + if (!tfirst) { + fprintf(stderr, + "Pfile: realloc failure!\n"); + exit(2); + } + tlast = tfirst + tmax; + tnext = tfirst + k; + } + + static void +#ifdef KR_headers +badchar(c) + int c; +#else +badchar(int c) +#endif +{ + fprintf(stderr, + "unexpected character 0x%.2x = '%c' on line %ld of %s\n", + c, c, Plineno, Pfname); + exit(2); + } + + static void +bad_type(Void) +{ + fprintf(stderr, + "unexpected type \"%s\" on line %ld of %s\n", + Ptok, Plineno, Pfname); + exit(2); + } + + static void +#ifdef KR_headers +badflag(tname, option) + char *tname; + char *option; +#else +badflag(char *tname, char *option) +#endif +{ + fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n", + tname, option, Plineno, Pfname); + Pbad++; + } + + static void +#ifdef KR_headers +detected(msg) + char *msg; +#else +detected(char *msg) +#endif +{ + fprintf(stderr, + "%sdetected on line %ld of %s\n", msg, Plineno, Pfname); + Pbad++; + } + +#if 0 + static void +#ifdef KR_headers +checklogical(k) + int k; +#else +checklogical(int k) +#endif +{ + static int lastmsg = 0; + static int seen[2] = {0,0}; + + seen[k] = 1; + if (seen[1-k]) { + if (lastmsg < 3) { + lastmsg = 3; + detected( + "Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t"); + } + return; + } + if (k) { + if (tylogical == TYLONG || lastmsg >= 2) + return; + if (!lastmsg) { + lastmsg = 2; + badflag("LOGICAL", "I4"); + } + } + else { + if (tylogical == TYSHORT || lastmsg & 1) + return; + if (!lastmsg) { + lastmsg = 1; + badflag("LOGICAL", "i2` or `f2c -I2"); + } + } + } +#else +#define checklogical(n) /* */ +#endif + + static void +#ifdef KR_headers +checkreal(k) + int k; +#else +checkreal(int k) +#endif +{ + static int warned = 0; + static int seen[2] = {0,0}; + + seen[k] = 1; + if (seen[1-k]) { + if (warned < 2) + detected("Illegal mixture of -R and -!R "); + warned = 2; + return; + } + if (k == forcedouble || warned) + return; + warned = 1; + badflag("REAL return", (char*)(k ? "!R" : "R")); + } + + static void +#ifdef KR_headers +Pnotboth(e) + Extsym *e; +#else +Pnotboth(Extsym *e) +#endif +{ + if (e->curno) + return; + Pbad++; + e->curno = 1; + fprintf(stderr, + "%s cannot be both a procedure and a common block (line %ld of %s)\n", + e->fextname, Plineno, Pfname); + } + + static int +#ifdef KR_headers +numread(pf, n) + register FILE *pf; + int *n; +#else +numread(register FILE *pf, int *n) +#endif +{ + register int c, k; + + if ((c = getc(pf)) < '0' || c > '9') + return c; + k = c - '0'; + for(;;) { + if ((c = getc(pf)) == ' ') { + *n = k; + return c; + } + if (c < '0' || c > '9') + break; + k = 10*k + c - '0'; + } + return c; + } + + static void argverify Argdcl((int, Extsym*)); + static void Pbadret Argdcl((int ftype, Extsym *p)); + + static int +#ifdef KR_headers +readref(pf, e, ftype) + register FILE *pf; + Extsym *e; + int ftype; +#else +readref(register FILE *pf, Extsym *e, int ftype) +#endif +{ + register int c, *t; + int i, nargs, type; + Argtypes *at; + Atype *a, *ae; + + if (ftype > TYSUBR) + return 0; + if ((c = numread(pf, &nargs)) != ' ') { + if (c != ':') + return c == EOF; + /* just a typed external */ + if (e->extstg == STGUNKNOWN) { + at = 0; + goto justsym; + } + if (e->extstg == STGEXT) { + if (e->extype != ftype) + Pbadret(ftype, e); + } + else + Pnotboth(e); + return 0; + } + + tnext = tfirst; + for(i = 0; i < nargs; i++) { + if ((c = numread(pf, &type)) != ' ' + || type >= 500 + || type != TYFTNLEN + 100 && type % 100 > TYSUBR) + return c == EOF; + if (tnext >= tlast) + trealloc(); + *tnext++ = type; + } + + if (e->extstg == STGUNKNOWN) { + save_at: + at = (Argtypes *) + gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1); + at->dnargs = at->nargs = nargs; + at->changes = 0; + t = tfirst; + a = at->atypes; + for(ae = a + nargs; a < ae; a++) { + a->type = *t++; + a->cp = 0; + } + justsym: + e->extstg = STGEXT; + e->extype = ftype; + e->arginfo = at; + } + else if (e->extstg != STGEXT) { + Pnotboth(e); + } + else if (!e->arginfo) { + if (e->extype != ftype) + Pbadret(ftype, e); + else + goto save_at; + } + else + argverify(ftype, e); + return 0; + } + + static int +#ifdef KR_headers +comlen(pf) + register FILE *pf; +#else +comlen(register FILE *pf) +#endif +{ + register int c; + register char *s, *se; + char buf[128], cbuf[128]; + int refread; + long L; + Extsym *e; + + if ((c = getc(pf)) == EOF) + return 1; + if (c == ' ') { + refread = 0; + s = "comlen "; + } + else if (c == ':') { + refread = 1; + s = "ref: "; + } + else { + ret0: + if (c == '*') + ungetc(c,pf); + return 0; + } + while(*s) { + if ((c = getc(pf)) == EOF) + return 1; + if (c != *s++) + goto ret0; + } + s = buf; + se = buf + sizeof(buf) - 1; + for(;;) { + if ((c = getc(pf)) == EOF) + return 1; + if (c == ' ') + break; + if (s >= se || Pct[c] != P_anum) + goto ret0; + *s++ = c; + } + *s-- = 0; + if (s <= buf || *s != '_') + return 0; + strcpy(cbuf,buf); + *s-- = 0; + if (*s == '_') { + *s-- = 0; + if (s <= buf) + return 0; + } + for(L = 0;;) { + if ((c = getc(pf)) == EOF) + return 1; + if (c == ' ') + break; + if (c < '0' && c > '9') + goto ret0; + L = 10*L + c - '0'; + } + if (!L && !refread) + return 0; + e = mkext1(buf, cbuf); + if (refread) + return readref(pf, e, (int)L); + if (e->extstg == STGUNKNOWN) { + e->extstg = STGCOMMON; + e->maxleng = L; + } + else if (e->extstg != STGCOMMON) + Pnotboth(e); + else if (e->maxleng != L) { + fprintf(stderr, + "incompatible lengths for common block %s (line %ld of %s)\n", + buf, Plineno, Pfname); + if (e->maxleng < L) + e->maxleng = L; + } + return 0; + } + + static int +#ifdef KR_headers +Ptoken(pf, canend) + FILE *pf; + int canend; +#else +Ptoken(FILE *pf, int canend) +#endif +{ + register int c; + register char *s, *se; + + top: + for(;;) { + c = getc(pf); + if (c == EOF) { + if (canend) + return 0; + goto badeof; + } + if (Pct[c] != P_space) + break; + if (c == '\n') + Plineno++; + } + switch(Pct[c]) { + case P_anum: + if (c == '_') + badchar(c); + s = Ptok; + se = s + sizeof(Ptok) - 1; + do { + if (s < se) + *s++ = c; + if ((c = getc(pf)) == EOF) { + badeof: + fprintf(stderr, + "unexpected end of file in %s\n", + Pfname); + exit(2); + } + } + while(Pct[c] == P_anum); + ungetc(c,pf); + *s = 0; + return P_anum; + + case P_delim: + return c; + + case P_slash: + if ((c = getc(pf)) != '*') { + if (c == EOF) + goto badeof; + badchar('/'); + } + if (canend && comlen(pf)) + goto badeof; + for(;;) { + while((c = getc(pf)) != '*') { + if (c == EOF) + goto badeof; + if (c == '\n') + Plineno++; + } + slashseek: + switch(getc(pf)) { + case '/': + goto top; + case EOF: + goto badeof; + case '*': + goto slashseek; + } + } + default: + badchar(c); + } + /* NOT REACHED */ + return 0; + } + + static int +Pftype(Void) +{ + switch(Ptok[0]) { + case 'C': + if (!strcmp(Ptok+1, "_f")) + return TYCOMPLEX; + break; + case 'E': + if (!strcmp(Ptok+1, "_f")) { + /* TYREAL under forcedouble */ + checkreal(1); + return TYREAL; + } + break; + case 'H': + if (!strcmp(Ptok+1, "_f")) + return TYCHAR; + break; + case 'Z': + if (!strcmp(Ptok+1, "_f")) + return TYDCOMPLEX; + break; + case 'd': + if (!strcmp(Ptok+1, "oublereal")) + return TYDREAL; + break; + case 'i': + if (!strcmp(Ptok+1, "nt")) + return TYSUBR; + if (!strcmp(Ptok+1, "nteger")) + return TYLONG; + if (!strcmp(Ptok+1, "nteger1")) + return TYINT1; + break; + case 'l': + if (!strcmp(Ptok+1, "ogical")) { + checklogical(1); + return TYLOGICAL; + } + if (!strcmp(Ptok+1, "ogical1")) + return TYLOGICAL1; +#ifdef TYQUAD + if (!strcmp(Ptok+1, "ongint")) + return TYQUAD; +#endif + break; + case 'r': + if (!strcmp(Ptok+1, "eal")) { + checkreal(0); + return TYREAL; + } + break; + case 's': + if (!strcmp(Ptok+1, "hortint")) + return TYSHORT; + if (!strcmp(Ptok+1, "hortlogical")) { + checklogical(0); + return TYLOGICAL2; + } + break; + } + bad_type(); + /* NOT REACHED */ + return 0; + } + + static void +#ifdef KR_headers +wanted(i, what) + int i; + char *what; +#else +wanted(int i, char *what) +#endif +{ + if (i != P_anum) { + Ptok[0] = i; + Ptok[1] = 0; + } + fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n", + what, Ptok, Plineno, Pfname); + exit(2); + } + + static int +#ifdef KR_headers +Ptype(pf) + FILE *pf; +#else +Ptype(FILE *pf) +#endif +{ + int i, rv; + + i = Ptoken(pf,0); + if (i == ')') + return 0; + if (i != P_anum) + badchar(i); + + rv = 0; + switch(Ptok[0]) { + case 'C': + if (!strcmp(Ptok+1, "_fp")) + rv = TYCOMPLEX+200; + break; + case 'D': + if (!strcmp(Ptok+1, "_fp")) + rv = TYDREAL+200; + break; + case 'E': + case 'R': + if (!strcmp(Ptok+1, "_fp")) + rv = TYREAL+200; + break; + case 'H': + if (!strcmp(Ptok+1, "_fp")) + rv = TYCHAR+200; + break; + case 'I': + if (!strcmp(Ptok+1, "_fp")) + rv = TYLONG+200; + else if (!strcmp(Ptok+1, "1_fp")) + rv = TYINT1+200; +#ifdef TYQUAD + else if (!strcmp(Ptok+1, "8_fp")) + rv = TYQUAD+200; +#endif + break; + case 'J': + if (!strcmp(Ptok+1, "_fp")) + rv = TYSHORT+200; + break; + case 'K': + checklogical(0); + goto Logical; + case 'L': + checklogical(1); + Logical: + if (!strcmp(Ptok+1, "_fp")) + rv = TYLOGICAL+200; + else if (!strcmp(Ptok+1, "1_fp")) + rv = TYLOGICAL1+200; + else if (!strcmp(Ptok+1, "2_fp")) + rv = TYLOGICAL2+200; + break; + case 'S': + if (!strcmp(Ptok+1, "_fp")) + rv = TYSUBR+200; + break; + case 'U': + if (!strcmp(Ptok+1, "_fp")) + rv = TYUNKNOWN+300; + break; + case 'Z': + if (!strcmp(Ptok+1, "_fp")) + rv = TYDCOMPLEX+200; + break; + case 'c': + if (!strcmp(Ptok+1, "har")) + rv = TYCHAR; + else if (!strcmp(Ptok+1, "omplex")) + rv = TYCOMPLEX; + break; + case 'd': + if (!strcmp(Ptok+1, "oublereal")) + rv = TYDREAL; + else if (!strcmp(Ptok+1, "oublecomplex")) + rv = TYDCOMPLEX; + break; + case 'f': + if (!strcmp(Ptok+1, "tnlen")) + rv = TYFTNLEN+100; + break; + case 'i': + if (!strncmp(Ptok+1, "nteger", 6)) { + if (!Ptok[7]) + rv = TYLONG; + else if (Ptok[7] == '1' && !Ptok[8]) + rv = TYINT1; + } + break; + case 'l': + if (!strncmp(Ptok+1, "ogical", 6)) { + if (!Ptok[7]) { + checklogical(1); + rv = TYLOGICAL; + } + else if (Ptok[7] == '1' && !Ptok[8]) + rv = TYLOGICAL1; + } +#ifdef TYQUAD + else if (!strcmp(Ptok+1,"ongint")) + rv = TYQUAD; +#endif + break; + case 'r': + if (!strcmp(Ptok+1, "eal")) + rv = TYREAL; + break; + case 's': + if (!strcmp(Ptok+1, "hortint")) + rv = TYSHORT; + else if (!strcmp(Ptok+1, "hortlogical")) { + checklogical(0); + rv = TYLOGICAL2; + } + break; + case 'v': + if (tnext == tfirst && !strcmp(Ptok+1, "oid")) { + if ((i = Ptoken(pf,0)) != /*(*/ ')') + wanted(i, /*(*/ "\")\""); + return 0; + } + } + if (!rv) + bad_type(); + if (rv < 100 && (i = Ptoken(pf,0)) != '*') + wanted(i, "\"*\""); + if ((i = Ptoken(pf,0)) == P_anum) + i = Ptoken(pf,0); /* skip variable name */ + switch(i) { + case ')': + ungetc(i,pf); + break; + case ',': + break; + default: + wanted(i, "\",\" or \")\""); + } + return rv; + } + + static char * +trimunder(Void) +{ + register char *s; + register int n; + static char buf[128]; + + s = Ptok + strlen(Ptok) - 1; + if (*s != '_') { + fprintf(stderr, + "warning: %s does not end in _ (line %ld of %s)\n", + Ptok, Plineno, Pfname); + return Ptok; + } + if (s[-1] == '_') + s--; + strncpy(buf, Ptok, n = s - Ptok); + buf[n] = 0; + return buf; + } + + static void +#ifdef KR_headers +Pbadmsg(msg, p) + char *msg; + Extsym *p; +#else +Pbadmsg(char *msg, Extsym *p) +#endif +{ + Pbad++; + fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg, + p->fextname, Plineno, Pfname); + p->arginfo->nargs = -1; + } + + static void +#ifdef KR_headers +Pbadret(ftype, p) + int ftype; + Extsym *p; +#else +Pbadret(int ftype, Extsym *p) +#endif +{ + char buf1[32], buf2[32]; + + Pbadmsg("inconsistent types",p); + fprintf(stderr, "here %s, previously %s\n", + Argtype(ftype+200,buf1), + Argtype(p->extype+200,buf2)); + } + + static void +#ifdef KR_headers +argverify(ftype, p) + int ftype; + Extsym *p; +#else +argverify(int ftype, Extsym *p) +#endif +{ + Argtypes *at; + register Atype *aty; + int i, j, k; + register int *t, *te; + char buf1[32], buf2[32]; + + at = p->arginfo; + if (at->nargs < 0) + return; + if (p->extype != ftype) { + Pbadret(ftype, p); + return; + } + t = tfirst; + te = tnext; + i = te - t; + if (at->nargs != i) { + j = at->nargs; + Pbadmsg("differing numbers of arguments",p); + fprintf(stderr, "here %d, previously %d\n", + i, j); + return; + } + for(aty = at->atypes; t < te; t++, aty++) { + if (*t == aty->type) + continue; + j = aty->type; + k = *t; + if (k >= 300 || k == j) + continue; + if (j >= 300) { + if (k >= 200) { + if (k == TYUNKNOWN + 200) + continue; + if (j % 100 != k - 200 + && k != TYSUBR + 200 + && j != TYUNKNOWN + 300 + && !type_fixup(at,aty,k)) + goto badtypes; + } + else if (j % 100 % TYSUBR != k % TYSUBR + && !type_fixup(at,aty,k)) + goto badtypes; + } + else if (k < 200 || j < 200) + goto badtypes; + else if (k == TYUNKNOWN+200) + continue; + else if (j != TYUNKNOWN+200) + { + badtypes: + Pbadmsg("differing calling sequences",p); + i = t - tfirst + 1; + fprintf(stderr, + "arg %d: here %s, prevously %s\n", + i, Argtype(k,buf1), Argtype(j,buf2)); + return; + } + /* We've subsequently learned the right type, + as in the call on zoo below... + + subroutine foo(x, zap) + external zap + call goo(zap) + x = zap(3) + call zoo(zap) + end + */ + aty->type = k; + at->changes = 1; + } + } + + static void +#ifdef KR_headers +newarg(ftype, p) + int ftype; + Extsym *p; +#else +newarg(int ftype, Extsym *p) +#endif +{ + Argtypes *at; + register Atype *aty; + register int *t, *te; + int i, k; + + if (p->extstg == STGCOMMON) { + Pnotboth(p); + return; + } + p->extstg = STGEXT; + p->extype = ftype; + p->exproto = 1; + t = tfirst; + te = tnext; + i = te - t; + k = sizeof(Argtypes) + (i-1)*sizeof(Atype); + at = p->arginfo = (Argtypes *)gmem(k,1); + at->dnargs = at->nargs = i; + at->defined = at->changes = 0; + for(aty = at->atypes; t < te; aty++) { + aty->type = *t++; + aty->cp = 0; + } + } + + static int +#ifdef KR_headers +Pfile(fname) + char *fname; +#else +Pfile(char *fname) +#endif +{ + char *s; + int ftype, i; + FILE *pf; + Extsym *p; + + for(s = fname; *s; s++); + if (s - fname < 2 + || s[-2] != '.' + || (s[-1] != 'P' && s[-1] != 'p')) + return 0; + + if (!(pf = fopen(fname, textread))) { + fprintf(stderr, "can't open %s\n", fname); + exit(2); + } + Pfname = fname; + Plineno = 1; + if (!Pct[' ']) { + for(s = " \t\n\r\v\f"; *s; s++) + Pct[*s] = P_space; + for(s = "*,();"; *s; s++) + Pct[*s] = P_delim; + for(i = '0'; i <= '9'; i++) + Pct[i] = P_anum; + for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++) + Pct[i] = Pct[i+'A'-'a'] = P_anum; + Pct['_'] = P_anum; + Pct['/'] = P_slash; + } + + for(;;) { + if (!(i = Ptoken(pf,1))) + break; + if (i != P_anum + || !strcmp(Ptok, "extern") && (i = Ptoken(pf,0)) != P_anum) + badchar(i); + ftype = Pftype(); + getname: + if ((i = Ptoken(pf,0)) != P_anum) + badchar(i); + p = mkext1(trimunder(), Ptok); + + if ((i = Ptoken(pf,0)) != '(') + badchar(i); + tnext = tfirst; + while(i = Ptype(pf)) { + if (tnext >= tlast) + trealloc(); + *tnext++ = i; + } + if (p->arginfo) { + argverify(ftype, p); + if (p->arginfo->nargs < 0) + newarg(ftype, p); + } + else + newarg(ftype, p); + p->arginfo->defined = 1; + i = Ptoken(pf,0); + switch(i) { + case ';': + break; + case ',': + goto getname; + default: + wanted(i, "\";\" or \",\""); + } + } + fclose(pf); + return 1; + } + + void +#ifdef KR_headers +read_Pfiles(ffiles) + char **ffiles; +#else +read_Pfiles(char **ffiles) +#endif +{ + char **f1files, **f1files0, *s; + int k; + register Extsym *e, *ee; + register Argtypes *at; + extern int retcode; + + f1files0 = f1files = ffiles; + while(s = *ffiles++) + if (!Pfile(s)) + *f1files++ = s; + if (Pbad) + retcode = 8; + if (tfirst) { + free((char *)tfirst); + /* following should be unnecessary, as we won't be back here */ + tfirst = tnext = tlast = 0; + tmax = 0; + } + *f1files = 0; + if (f1files == f1files0) + f1files[1] = 0; + + k = 0; + ee = nextext; + for (e = extsymtab; e < ee; e++) + if (e->extstg == STGEXT + && (at = e->arginfo)) { + if (at->nargs < 0 || at->changes) + k++; + at->changes = 2; + } + if (k) { + fprintf(diagfile, + "%d prototype%s updated while reading prototypes.\n", k, + k > 1 ? "s" : ""); + } + fflush(diagfile); + } diff --git a/unix/f2c/src/proc.c b/unix/f2c/src/proc.c new file mode 100644 index 00000000..955d4646 --- /dev/null +++ b/unix/f2c/src/proc.c @@ -0,0 +1,1834 @@ +/**************************************************************** +Copyright 1990, 1994-6, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "names.h" +#include "output.h" +#include "p1defs.h" + +/* round a up to the nearest multiple of b: + + a = b * floor ( (a + (b - 1)) / b )*/ + +#undef roundup +#define roundup(a,b) ( b * ( (a+b-1)/b) ) + +#define EXNULL (union Expression *)0 + +static void dobss Argdcl((void)); +static void docomleng Argdcl((void)); +static void docommon Argdcl((void)); +static void doentry Argdcl((struct Entrypoint*)); +static void epicode Argdcl((void)); +static int nextarg Argdcl((int)); +static void retval Argdcl((int)); + +static char Blank[] = BLANKCOMMON; + + static char *postfix[] = { "g", "h", "i", +#ifdef TYQUAD + "j", +#endif + "r", "d", "c", "z", "g", "h", "i" }; + + chainp new_procs; + int prev_proc, proc_argchanges, proc_protochanges; + + void +#ifdef KR_headers +changedtype(q) + Namep q; +#else +changedtype(Namep q) +#endif +{ + char buf[200]; + int qtype, type1; + register Extsym *e; + Argtypes *at; + + if (q->vtypewarned) + return; + q->vtypewarned = 1; + qtype = q->vtype; + e = &extsymtab[q->vardesc.varno]; + if (!(at = e->arginfo)) { + if (!e->exused) + return; + } + else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined) + proc_protochanges++; + type1 = e->extype; + if (type1 == TYUNKNOWN) + return; + if (qtype == TYUNKNOWN) + /* e.g., + subroutine foo + end + external foo + call goo(foo) + end + */ + return; + sprintf(buf, "%.90s: inconsistent declarations:\n\ + here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype], + qtype == TYSUBR ? "" : " function", + ftn_types[type1], type1 == TYSUBR ? "" : " function"); + warn(buf); + } + + void +#ifdef KR_headers +unamstring(q, s) + register Addrp q; + register char *s; +#else +unamstring(register Addrp q, register char *s) +#endif +{ + register int k; + register char *t; + + k = strlen(s); + if (k < IDENT_LEN) { + q->uname_tag = UNAM_IDENT; + t = q->user.ident; + } + else { + q->uname_tag = UNAM_CHARP; + q->user.Charp = t = mem(k+1, 0); + } + strcpy(t, s); + } + + static void +fix_entry_returns(Void) /* for multiple entry points */ +{ + Addrp a; + int i; + struct Entrypoint *e; + Namep np; + + e = entries = (struct Entrypoint *)revchain((chainp)entries); + allargs = revchain(allargs); + if (!multitype) + return; + + /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */ + + for(i = TYINT1; i <= TYLOGICAL; i++) + if (a = xretslot[i]) + sprintf(a->user.ident, "(*ret_val).%s", + postfix[i-TYINT1]); + + do { + np = e->enamep; + switch(np->vtype) { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + case TYREAL: + case TYDREAL: + case TYCOMPLEX: + case TYDCOMPLEX: + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + np->vstg = STGARG; + } + } + while(e = e->entnextp); + } + + static void +#ifdef KR_headers +putentries(outfile) + FILE *outfile; +#else +putentries(FILE *outfile) +#endif + /* put out wrappers for multiple entries */ +{ + char base[MAXNAMELEN+4]; + struct Entrypoint *e; + Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np; + chainp args, lengths; + int i, k, mt, nL, t, type; + extern char *dfltarg[], **dfltproc; + + e = entries; + if (!e->enamep) /* only possible with erroneous input */ + return; + nL = (nallargs + nallchargs) * sizeof(Namep *); + if (!nL) + nL = 8; + A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **)); + Ae = A + nallargs; + Alp = (Namep **)(Ae1 = Ae + nallchargs); + i = k = 0; + for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) { + np = (Namep)args->datap; + if (np->vtype == TYCHAR && np->vclass != CLPROC) + *a1 = &Ae[i++]; + } + + mt = multitype; + multitype = 0; + sprintf(base, "%s0_", e->enamep->cvarname); + do { + np = e->enamep; + lengths = length_comp(e, 0); + proctype = type = np->vtype; + if (protofile) + protowrite(protofile, type, np->cvarname, e, lengths); + nice_printf(outfile, "\n%s ", c_type_decl(type, 1)); + nice_printf(outfile, "%s", np->cvarname); + if (!Ansi) { + listargs(outfile, e, 0, lengths); + nice_printf(outfile, "\n"); + } + list_arg_types(outfile, e, lengths, 0, "\n"); + nice_printf(outfile, "{\n"); + frchain(&lengths); + next_tab(outfile); + if (mt) + nice_printf(outfile, + "Multitype ret_val;\n%s(%d, &ret_val", + base, k); /*)*/ + else if (ISCOMPLEX(type)) + nice_printf(outfile, "%s(%d,%s", base, k, + xretslot[type]->user.ident); /*)*/ + else if (type == TYCHAR) + nice_printf(outfile, + "%s(%d, ret_val, ret_val_len", base, k); /*)*/ + else + nice_printf(outfile, "return %s(%d", base, k); /*)*/ + k++; + memset((char *)A, 0, nL); + for(args = e->arglist; args; args = args->nextp) { + np = (Namep)args->datap; + A[np->argno] = np; + if (np->vtype == TYCHAR && np->vclass != CLPROC) + *Alp[np->argno] = np; + } + args = allargs; + for(a = A; a < Ae; a++, args = args->nextp) { + t = ((Namep)args->datap)->vtype; + nice_printf(outfile, ", %s", (np = *a) + ? np->cvarname + : ((Namep)args->datap)->vclass == CLPROC + ? dfltproc[((Namep)args->datap)->vimpltype + ? (Castargs ? TYUNKNOWN : TYSUBR) + : t == TYREAL && forcedouble && !Castargs + ? TYDREAL : t] + : dfltarg[((Namep)args->datap)->vtype]); + } + for(; a < Ae1; a++) + if (np = *a) + nice_printf(outfile, ", %s", + new_arg_length(np)); + else + nice_printf(outfile, ", (ftnint)0"); + nice_printf(outfile, /*(*/ ");\n"); + if (mt) { + if (type == TYCOMPLEX) + nice_printf(outfile, + "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n"); + else if (type == TYDCOMPLEX) + nice_printf(outfile, + "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n"); + else if (type <= TYLOGICAL) + nice_printf(outfile, "return ret_val.%s;\n", + postfix[type-TYINT1]); + } + nice_printf(outfile, "}\n"); + prev_tab(outfile); + } + while(e = e->entnextp); + free((char *)A); + } + + static void +#ifdef KR_headers +entry_goto(outfile) + FILE *outfile; +#else +entry_goto(FILE *outfile) +#endif +{ + struct Entrypoint *e = entries; + int k = 0; + + nice_printf(outfile, "switch(n__) {\n"); + next_tab(outfile); + while(e = e->entnextp) + nice_printf(outfile, "case %d: goto %s;\n", ++k, + user_label((long)(extsymtab - e->entryname - 1))); + nice_printf(outfile, "}\n\n"); + prev_tab(outfile); + } + +/* start a new procedure */ + + void +newproc(Void) +{ + if(parstate != OUTSIDE) + { + execerr("missing end statement", CNULL); + endproc(); + } + + parstate = INSIDE; + procclass = CLMAIN; /* default */ +} + + static void +zap_changes(Void) +{ + register chainp cp; + register Argtypes *at; + + /* arrange to get correct count of prototypes that would + change by running f2c again */ + + if (prev_proc && proc_argchanges) + proc_protochanges++; + prev_proc = proc_argchanges = 0; + for(cp = new_procs; cp; cp = cp->nextp) + if (at = ((Namep)cp->datap)->arginfo) + at->changes &= ~1; + frchain(&new_procs); + } + +/* end of procedure. generate variables, epilogs, and prologs */ + + void +endproc(Void) +{ + struct Labelblock *lp; + Extsym *ext; + + if(parstate < INDATA) + enddcl(); + if(ctlstack >= ctls) + err("DO loop or BLOCK IF not closed"); + for(lp = labeltab ; lp < labtabend ; ++lp) + if(lp->stateno!=0 && lp->labdefined==NO) + errstr("missing statement label %s", + convic(lp->stateno) ); + +/* Save copies of the common variables in extptr -> allextp */ + + for (ext = extsymtab; ext < nextext; ext++) + if (ext -> extstg == STGCOMMON && ext -> extp) { + extern int usedefsforcommon; + +/* Write out the abbreviations for common block reference */ + + copy_data (ext -> extp); + if (usedefsforcommon) { + wr_abbrevs (c_file, 1, ext -> extp); + ext -> used_here = 1; + } + else + ext -> extp = CHNULL; + + } + + if (nentry > 1) + fix_entry_returns(); + epicode(); + donmlist(); + dobss(); + start_formatting (); + if (nentry > 1) + putentries(c_file); + + zap_changes(); + procinit(); /* clean up for next procedure */ +} + + + +/* End of declaration section of procedure. Allocate storage. */ + + void +enddcl(Void) +{ + register struct Entrypoint *ep; + struct Entrypoint *ep0; + chainp cp; + extern char *err_proc; + static char comblks[] = "common blocks"; + + err_proc = comblks; + docommon(); + +/* Now the hash table entries for fields of common blocks have STGCOMMON, + vdcldone, voffset, and varno. And the common blocks themselves have + their full sizes in extleng. */ + + err_proc = "equivalences"; + doequiv(); + + err_proc = comblks; + docomleng(); + +/* This implies that entry points in the declarations are buffered in + entries but not written out */ + + err_proc = "entries"; + if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) { + /* entries could be 0 in case of an error */ + do doentry(ep); + while(ep = ep->entnextp); + entries = (struct Entrypoint *)revchain((chainp)ep0); + } + + err_proc = 0; + parstate = INEXEC; + p1put(P1_PROCODE); + freetemps(); + if (earlylabs) { + for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp) + p1_label((long)cp->datap); + frchain(&earlylabs); + } + p1_line_number(lineno); /* for files that start with a MAIN program */ + /* that starts with an executable statement */ +} + +/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ + +/* Main program or Block data */ + + void +#ifdef KR_headers +startproc(progname, Class) + Extsym *progname; + int Class; +#else +startproc(Extsym *progname, int Class) +#endif +{ + register struct Entrypoint *p; + + p = ALLOC(Entrypoint); + if(Class == CLMAIN) { + puthead(CNULL, CLMAIN); + if (progname) + strcpy (main_alias, progname->cextname); + } else { + if (progname) { + /* Construct an empty subroutine with this name */ + /* in case the name is needed to force loading */ + /* of this block-data subprogram: the name can */ + /* appear elsewhere in an external statement. */ + entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0); + endproc(); + newproc(); + } + puthead(CNULL, CLBLOCK); + } + if(Class == CLMAIN) + newentry( mkname(" MAIN"), 0 )->extinit = 1; + p->entryname = progname; + entries = p; + + procclass = Class; + fprintf(diagfile, " %s", (Class==CLMAIN ? "MAIN" : "BLOCK DATA") ); + if(progname) { + fprintf(diagfile, " %s", progname->fextname); + procname = progname->cextname; + } + fprintf(diagfile, ":\n"); + fflush(diagfile); +} + +/* subroutine or function statement */ + + Extsym * +#ifdef KR_headers +newentry(v, substmsg) + register Namep v; + int substmsg; +#else +newentry(register Namep v, int substmsg) +#endif +{ + register Extsym *p; + char buf[128], badname[64]; + static int nbad = 0; + static char already[] = "external name already used"; + + p = mkext(v->fvarname, addunder(v->cvarname)); + + if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) + { + sprintf(badname, "%s_bad%d", v->fvarname, ++nbad); + if (substmsg) { + sprintf(buf,"%s\n\tsubstituting \"%s\"", + already, badname); + dclerr(buf, v); + } + else + dclerr(already, v); + p = mkext(v->fvarname, badname); + } + v->vstg = STGAUTO; + v->vprocclass = PTHISPROC; + v->vclass = CLPROC; + if (p->extstg == STGEXT) + prev_proc = 1; + else + p->extstg = STGEXT; + p->extinit = YES; + v->vardesc.varno = p - extsymtab; + return(p); +} + + void +#ifdef KR_headers +entrypt(Class, type, length, entry, args) + int Class; + int type; + ftnint length; + Extsym *entry; + chainp args; +#else +entrypt(int Class, int type, ftnint length, Extsym *entry, chainp args) +#endif +{ + register Namep q; + register struct Entrypoint *p; + + if(Class != CLENTRY) + puthead( procname = entry->cextname, Class); + else + fprintf(diagfile, " entry "); + fprintf(diagfile, " %s:\n", entry->fextname); + fflush(diagfile); + q = mkname(entry->fextname); + if (type == TYSUBR) + q->vstg = STGEXT; + + type = lengtype(type, length); + if(Class == CLPROC) + { + procclass = CLPROC; + proctype = type; + procleng = type == TYCHAR ? length : 0; + } + + p = ALLOC(Entrypoint); + + p->entnextp = entries; + entries = p; + + p->entryname = entry; + p->arglist = revchain(args); + p->enamep = q; + + if(Class == CLENTRY) + { + Class = CLPROC; + if(proctype == TYSUBR) + type = TYSUBR; + } + + q->vclass = Class; + q->vprocclass = 0; + settype(q, type, length); + q->vprocclass = PTHISPROC; + /* hold all initial entry points till end of declarations */ + if(parstate >= INDATA) + doentry(p); +} + +/* generate epilogs */ + +/* epicode -- write out the proper function return mechanism at the end of + the procedure declaration. Handles multiple return value types, as + well as cooercion into the proper value */ + + LOCAL void +epicode(Void) +{ + extern int lastwasbranch; + + if(procclass==CLPROC) + { + if(proctype==TYSUBR) + { + +/* Return a zero only when the alternate return mechanism has been + specified in the function header */ + + if ((substars || Ansi) && lastwasbranch != YES) + p1_subr_ret (ICON(0)); + } + else if (!multitype && lastwasbranch != YES) + retval(proctype); + } + else if (procclass == CLMAIN && Ansi && lastwasbranch != YES) + p1_subr_ret (ICON(0)); + lastwasbranch = NO; +} + + +/* generate code to return value of type t */ + + LOCAL void +#ifdef KR_headers +retval(t) + register int t; +#else +retval(register int t) +#endif +{ + register Addrp p; + + switch(t) + { + case TYCHAR: + case TYCOMPLEX: + case TYDCOMPLEX: + break; + + case TYLOGICAL: + t = tylogical; + case TYINT1: + case TYADDR: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + case TYREAL: + case TYDREAL: + case TYLOGICAL1: + case TYLOGICAL2: + p = (Addrp) cpexpr((expptr)retslot); + p->vtype = t; + p1_subr_ret (mkconv (t, fixtype((expptr)p))); + break; + + default: + badtype("retval", t); + } +} + + +/* Do parameter adjustments */ + + void +#ifdef KR_headers +procode(outfile) + FILE *outfile; +#else +procode(FILE *outfile) +#endif +{ + prolog(outfile, allargs); + + if (nentry > 1) + entry_goto(outfile); + } + + static void +#ifdef KR_headers +bad_dimtype(q) Namep q; +#else +bad_dimtype(Namep q) +#endif +{ + errstr("bad dimension type for %.70s", q->fvarname); + } + +/* Finish bound computations now that all variables are declared. + * This used to be in setbound(), but under -u the following incurred + * an erroneous error message: + * subroutine foo(x,n) + * real x(n) + * integer n + */ + + static void +#ifdef KR_headers +dim_finish(v) + Namep v; +#else +dim_finish(Namep v) +#endif +{ + register struct Dimblock *p; + register expptr q; + register int i, nd; + + p = v->vdim; + v->vdimfinish = 0; + nd = p->ndim; + doin_setbound = 1; + for(i = 0; i < nd; i++) + if (q = p->dims[i].dimexpr) { + q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q))); + if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL)) + bad_dimtype(v); + } + if (q = p->basexpr) + p->basexpr = make_int_expr(putx(fixtype(q))); + doin_setbound = 0; + } + + static void +#ifdef KR_headers +duparg(q) + Namep q; +#else +duparg(Namep q) +#endif +{ errstr("duplicate argument %.80s", q->fvarname); } + +/* + manipulate argument lists (allocate argument slot positions) + * keep track of return types and labels + */ + + LOCAL void +#ifdef KR_headers +doentry(ep) + struct Entrypoint *ep; +#else +doentry(struct Entrypoint *ep) +#endif +{ + register int type; + register Namep np; + chainp p, p1; + register Namep q; + Addrp rs; + int it, k; + extern char dflttype[26]; + Extsym *entryname = ep->entryname; + + if (++nentry > 1) + p1_label((long)(extsymtab - entryname - 1)); + +/* The main program isn't allowed to have parameters, so any given + parameters are ignored */ + + if(procclass == CLMAIN && !ep->arglist || procclass == CLBLOCK) + return; + + /* Entry points in MAIN are an error, but we process them here */ + /* to prevent faults elsewhere. */ + +/* So now we're working with something other than CLMAIN or CLBLOCK. + Determine the type of its return value. */ + + impldcl( np = mkname(entryname->fextname) ); + type = np->vtype; + proc_argchanges = prev_proc && type != entryname->extype; + entryname->extseen = 1; + if(proctype == TYUNKNOWN) + if( (proctype = type) == TYCHAR) + procleng = np->vleng ? np->vleng->constblock.Const.ci + : (ftnint) (-1); + + if(proctype == TYCHAR) + { + if(type != TYCHAR) + err("noncharacter entry of character function"); + +/* Functions returning type char can only have multiple entries if all + entries return the same length */ + + else if( (np->vleng ? np->vleng->constblock.Const.ci : + (ftnint) (-1)) != procleng) + err("mismatched character entry lengths"); + } + else if(type == TYCHAR) + err("character entry of noncharacter function"); + else if(type != proctype) + multitype = YES; + if(rtvlabel[type] == 0) + rtvlabel[type] = (int)newlabel(); + ep->typelabel = rtvlabel[type]; + + if(type == TYCHAR) + { + if(chslot < 0) + { + chslot = nextarg(TYADDR); + chlgslot = nextarg(TYLENG); + } + np->vstg = STGARG; + +/* Put a new argument in the function, one which will hold the result of + a character function. This will have to be named sometime, probably in + mkarg(). */ + + if(procleng < 0) { + np->vleng = (expptr) mkarg(TYLENG, chlgslot); + np->vleng->addrblock.uname_tag = UNAM_IDENT; + strcpy (np -> vleng -> addrblock.user.ident, + new_func_length()); + } + if (!xretslot[TYCHAR]) { + xretslot[TYCHAR] = rs = + autovar(0, type, ISCONST(np->vleng) + ? np->vleng : ICON(0), ""); + strcpy(rs->user.ident, "ret_val"); + } + } + +/* Handle a complex return type -- declare a new parameter (pointer to + a complex value) */ + + else if( ISCOMPLEX(type) ) { + if (!xretslot[type]) + xretslot[type] = + autovar(0, type, EXNULL, " ret_val"); + /* the blank is for use in out_addr */ + np->vstg = STGARG; + if(cxslot < 0) + cxslot = nextarg(TYADDR); + } + else if (type != TYSUBR) { + if (type == TYUNKNOWN) { + dclerr("untyped function", np); + proctype = type = np->vtype = + dflttype[letter(np->fvarname[0])]; + } + if (!xretslot[type]) + xretslot[type] = retslot = + autovar(1, type, EXNULL, " ret_val"); + /* the blank is for use in out_addr */ + np->vstg = STGAUTO; + } + + for(p = ep->arglist ; p ; p = p->nextp) + if(! (( q = (Namep) (p->datap) )->vknownarg) ) { + q->vknownarg = 1; + q->vardesc.varno = nextarg(TYADDR); + allargs = mkchain((char *)q, allargs); + q->argno = nallargs++; + } + else if (nentry == 1) + duparg(q); + else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp) + if ((Namep)p1->datap == q) + duparg(q); + + k = 0; + for(p = ep->arglist ; p ; p = p->nextp) { + if(! (( q = (Namep) (p->datap) )->vdcldone) ) + { + impldcl(q); + q->vdcldone = YES; + if(q->vtype == TYCHAR) + { + +/* If we don't know the length of a char*(*) (i.e. a string), we must add + in this additional length argument. */ + + ++nallchargs; + if (q->vclass == CLPROC) + nallchargs--; + else if (q->vleng == NULL) { + /* character*(*) */ + q->vleng = (expptr) + mkarg(TYLENG, nextarg(TYLENG) ); + unamstring((Addrp)q->vleng, + new_arg_length(q)); + } + } + } + if (q->vdimfinish) + dim_finish(q); + if (q->vtype == TYCHAR && q->vclass != CLPROC) + k++; + } + + if (entryname->extype != type) + changedtype(np); + + /* save information for checking consistency of arg lists */ + + it = infertypes; + if (entryname->exproto) + infertypes = 1; + save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo, + 0, np->fvarname, STGEXT, k, np->vtype, 2); + infertypes = it; +} + + + + LOCAL int +#ifdef KR_headers +nextarg(type) + int type; +#else +nextarg(int type) +#endif +{ + type = type; /* shut up warning */ + return(lastargslot++); + } + + LOCAL void +#ifdef KR_headers +dim_check(q) + Namep q; +#else +dim_check(Namep q) +#endif +{ + register struct Dimblock *vdim = q->vdim; + register expptr nelt; + + if(!(nelt = vdim->nelt) || !ISCONST(nelt)) + dclerr("adjustable dimension on non-argument", q); + else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL)) + bad_dimtype(q); + else if (ISINT(nelt->headblock.vtype) + ? nelt->constblock.Const.ci <= 0 + : nelt->constblock.Const.cd[0] <= 0.) + dclerr("nonpositive dimension", q); + } + + LOCAL void +dobss(Void) +{ + register struct Hashentry *p; + register Namep q; + int qstg, qclass, qtype; + Extsym *e; + + for(p = hashtab ; pvarp) + { + qstg = q->vstg; + qtype = q->vtype; + qclass = q->vclass; + + if( (qclass==CLUNKNOWN && qstg!=STGARG) || + (qclass==CLVAR && qstg==STGUNKNOWN) ) { + if (!(q->vis_assigned | q->vimpldovar)) + warn1("local variable %s never used", + q->fvarname); + } + else if(qclass==CLVAR && qstg==STGBSS) + { ; } + +/* Give external procedures the proper storage class */ + + else if(qclass==CLPROC && q->vprocclass==PEXTERNAL + && qstg!=STGARG) { + e = mkext(q->fvarname,addunder(q->cvarname)); + e->extstg = STGEXT; + q->vardesc.varno = e - extsymtab; + if (e->extype != qtype) + changedtype(q); + } + if(qclass==CLVAR) { + if (qstg != STGARG && q->vdim) + dim_check(q); + } /* if qclass == CLVAR */ + } + +} + + + void +donmlist(Void) +{ + register struct Hashentry *p; + register Namep q; + + for(p=hashtab; pvarp) && q->vclass==CLNAMELIST) + namelist(q); +} + + +/* iarrlen -- Returns the size of the array in bytes, or -1 */ + + ftnint +#ifdef KR_headers +iarrlen(q) + register Namep q; +#else +iarrlen(register Namep q) +#endif +{ + ftnint leng; + + leng = typesize[q->vtype]; + if(leng <= 0) + return(-1); + if(q->vdim) + if( ISICON(q->vdim->nelt) ) + leng *= q->vdim->nelt->constblock.Const.ci; + else return(-1); + if(q->vleng) + if( ISICON(q->vleng) ) + leng *= q->vleng->constblock.Const.ci; + else return(-1); + return(leng); +} + + void +#ifdef KR_headers +namelist(np) + Namep np; +#else +namelist(Namep np) +#endif +{ + register chainp q; + register Namep v; + int y; + + if (!np->visused) + return; + y = 0; + + for(q = np->varxptr.namelist ; q ; q = q->nextp) + { + vardcl( v = (Namep) (q->datap) ); + if( !ONEOF(v->vstg, MSKSTATIC) ) + dclerr("may not appear in namelist", v); + else { + v->vnamelist = 1; + v->visused = 1; + v->vsave = 1; + y = 1; + } + np->visused = y; + } +} + +/* docommon -- called at the end of procedure declarations, before + equivalences and the procedure body */ + + LOCAL void +docommon(Void) +{ + register Extsym *extptr; + register chainp q, q1; + struct Dimblock *t; + expptr neltp; + register Namep comvar; + ftnint size; + int i, k, pref, type; + extern int type_pref[]; + + for(extptr = extsymtab ; extptrextstg == STGCOMMON && (q = extptr->extp)) { + +/* If a common declaration also had a list of variables ... */ + + q = extptr->extp = revchain(q); + pref = 1; + for(k = TYCHAR; q ; q = q->nextp) + { + comvar = (Namep) (q->datap); + + if(comvar->vdcldone == NO) + vardcl(comvar); + type = comvar->vtype; + if (pref < type_pref[type]) + pref = type_pref[k = type]; + if(extptr->extleng % typealign[type] != 0) { + dclerr("common alignment", comvar); + --nerr; /* don't give bad return code for this */ +#if 0 + extptr->extleng = roundup(extptr->extleng, typealign[type]); +#endif + } /* if extptr -> extleng % */ + +/* Set the offset into the common block */ + + comvar->voffset = extptr->extleng; + comvar->vardesc.varno = extptr - extsymtab; + if(type == TYCHAR) + if (comvar->vleng) + size = comvar->vleng->constblock.Const.ci; + else { + dclerr("character*(*) in common", comvar); + size = 1; + } + else + size = typesize[type]; + if(t = comvar->vdim) + if( (neltp = t->nelt) && ISCONST(neltp) ) + size *= neltp->constblock.Const.ci; + else + dclerr("adjustable array in common", comvar); + +/* Adjust the length of the common block so far */ + + extptr->extleng += size; + } /* for */ + + extptr->extype = k; + +/* Determine curno and, if new, save this identifier chain */ + + q1 = extptr->extp; + for (q = extptr->allextp, i = 0; q; i++, q = q->nextp) + if (struct_eq((chainp)q->datap, q1)) + break; + if (q) + extptr->curno = extptr->maxno - i; + else { + extptr->curno = ++extptr->maxno; + extptr->allextp = mkchain((char *)extptr->extp, + extptr->allextp); + } + } /* if extptr -> extstg == STGCOMMON */ + +/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and + varno. And the common block itself has its full size in extleng. */ + +} /* docommon */ + + +/* copy_data -- copy the Namep entries so they are available even after + the hash table is empty */ + + void +#ifdef KR_headers +copy_data(list) + chainp list; +#else +copy_data(chainp list) +#endif +{ + for (; list; list = list -> nextp) { + Namep namep = ALLOC (Nameblock); + int size, nd, i; + struct Dimblock *dp; + + cpn(sizeof(struct Nameblock), list->datap, (char *)namep); + namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0), + namep->fvarname); + namep->cvarname = strcmp(namep->fvarname, namep->cvarname) + ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname) + : namep->fvarname; + if (namep -> vleng) + namep -> vleng = (expptr) cpexpr (namep -> vleng); + if (namep -> vdim) { + nd = namep -> vdim -> ndim; + size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr); + dp = (struct Dimblock *) ckalloc (size); + cpn(size, (char *)namep->vdim, (char *)dp); + namep -> vdim = dp; + dp->nelt = (expptr)cpexpr(dp->nelt); + for (i = 0; i < nd; i++) { + dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize); + } /* for */ + } /* if */ + list -> datap = (char *) namep; + } /* for */ +} /* copy_data */ + + + + LOCAL void +docomleng(Void) +{ + register Extsym *p; + + for(p = extsymtab ; p < nextext ; ++p) + if(p->extstg == STGCOMMON) + { + if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng + && strcmp(Blank, p->cextname) ) + warn1("incompatible lengths for common block %.60s", + p->fextname); + if(p->maxleng < p->extleng) + p->maxleng = p->extleng; + p->extleng = 0; + } +} + + +/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ + + void +#ifdef KR_headers +frtemp(p) + Addrp p; +#else +frtemp(Addrp p) +#endif +{ + /* put block on chain of temps to be reclaimed */ + holdtemps = mkchain((char *)p, holdtemps); +} + + void +freetemps(Void) +{ + register chainp p, p1; + register Addrp q; + register int t; + + p1 = holdtemps; + while(p = p1) { + q = (Addrp)p->datap; + t = q->vtype; + if (t == TYCHAR && q->varleng != 0) { + /* restore clobbered character string lengths */ + frexpr(q->vleng); + q->vleng = ICON(q->varleng); + } + p1 = p->nextp; + p->nextp = templist[t]; + templist[t] = p; + } + holdtemps = 0; + } + +/* allocate an automatic variable slot for each of nelt variables */ + + Addrp +#ifdef KR_headers +autovar(nelt0, t, lengp, name) + register int nelt0; + register int t; + expptr lengp; + char *name; +#else +autovar(register int nelt0, register int t, expptr lengp, char *name) +#endif +{ + ftnint leng; + register Addrp q; + register int nelt = nelt0 > 0 ? nelt0 : 1; + extern char *av_pfix[]; + + if(t == TYCHAR) + if( ISICON(lengp) ) + leng = lengp->constblock.Const.ci; + else { + Fatal("automatic variable of nonconstant length"); + } + else + leng = typesize[t]; + + q = ALLOC(Addrblock); + q->tag = TADDR; + q->vtype = t; + if(t == TYCHAR) + { + q->vleng = ICON(leng); + q->varleng = leng; + } + q->vstg = STGAUTO; + q->ntempelt = nelt; + q->isarray = (nelt > 1); + q->memoffset = ICON(0); + + /* kludge for nls so we can have ret_val rather than ret_val_4 */ + if (*name == ' ') + unamstring(q, name); + else { + q->uname_tag = UNAM_IDENT; + temp_name(av_pfix[t], ++autonum[t], q->user.ident); + } + if (nelt0 > 0) + declare_new_addr (q); + return(q); +} + + +/* Returns a temporary of the appropriate type. Will reuse existing + temporaries when possible */ + + Addrp +#ifdef KR_headers +mktmpn(nelt, type, lengp) + int nelt; + register int type; + expptr lengp; +#else +mktmpn(int nelt, register int type, expptr lengp) +#endif +{ + ftnint leng; + chainp p, oldp; + register Addrp q; + extern int krparens; + + if(type==TYUNKNOWN || type==TYERROR) + badtype("mktmpn", type); + + if(type==TYCHAR) + if(lengp && ISICON(lengp) ) + leng = lengp->constblock.Const.ci; + else { + err("adjustable length"); + return( (Addrp) errnode() ); + } + else if (type > TYCHAR || type < TYADDR) { + erri("mktmpn: unexpected type %d", type); + exit(1); + } +/* + * if a temporary of appropriate shape is on the templist, + * remove it from the list and return it + */ + if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX))) + type++; + for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp) + { + q = (Addrp) (p->datap); + if(q->ntempelt==nelt && + (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) ) + { + if(oldp) + oldp->nextp = p->nextp; + else + templist[type] = p->nextp; + free( (charptr) p); + return(q); + } + } + q = autovar(nelt, type, lengp, ""); + return(q); +} + + + + +/* mktmp -- create new local variable; call it something like name + lengp is taken directly, not copied */ + + Addrp +#ifdef KR_headers +mktmp(type, lengp) + int type; + expptr lengp; +#else +mktmp(int type, expptr lengp) +#endif +{ + Addrp rv; + /* arrange for temporaries to be recycled */ + /* at the end of this statement... */ + rv = mktmpn(1,type,lengp); + frtemp((Addrp)cpexpr((expptr)rv)); + return rv; +} + +/* mktmp0 omits frtemp() */ + Addrp +#ifdef KR_headers +mktmp0(type, lengp) + int type; + expptr lengp; +#else +mktmp0(int type, expptr lengp) +#endif +{ + Addrp rv; + /* arrange for temporaries to be recycled */ + /* when this Addrp is freed */ + rv = mktmpn(1,type,lengp); + rv->istemp = YES; + return rv; +} + +/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ + +/* comblock -- Declare a new common block. Input parameters name the block; + s will be NULL if the block is unnamed */ + + Extsym * +#ifdef KR_headers +comblock(s) + register char *s; +#else +comblock(register char *s) +#endif +{ + Extsym *p; + register char *t; + register int c, i; + char cbuf[256], *s0; + +/* Give the unnamed common block a unique name */ + + if(*s == 0) + p = mkext1(s0 = Blank, Blank); + else { + s0 = s; + t = cbuf; + for(i = 0; c = *t = *s++; t++) + if (c == '_') + i = 1; + if (i) + *t++ = '_'; + t[0] = '_'; + t[1] = 0; + p = mkext1(s0,cbuf); + } + if(p->extstg == STGUNKNOWN) + p->extstg = STGCOMMON; + else if(p->extstg != STGCOMMON) + { + errstr("%.52s cannot be a common block: it is a subprogram.", + s0); + return(0); + } + + return( p ); +} + + +/* incomm -- add a new variable to a common declaration */ + + void +#ifdef KR_headers +incomm(c, v) + Extsym *c; + Namep v; +#else +incomm(Extsym *c, Namep v) +#endif +{ + if (!c) + return; + if(v->vstg != STGUNKNOWN && !v->vimplstg) + dclerr(v->vstg == STGARG + ? "dummy arguments cannot be in common" + : "incompatible common declaration", v); + else + { + v->vstg = STGCOMMON; + c->extp = mkchain((char *)v, c->extp); + } +} + + + + +/* settype -- set the type or storage class of a Namep object. If + v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be + -type. This function will not change any earlier definitions in v, + in will only attempt to fill out more information give the other params */ + + void +#ifdef KR_headers +settype(v, type, length) + register Namep v; + register int type; + register ftnint length; +#else +settype(register Namep v, register int type, register ftnint length) +#endif +{ + int type1; + + if(type == TYUNKNOWN) + return; + + if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) + { + v->vtype = TYSUBR; + frexpr(v->vleng); + v->vleng = 0; + v->vimpltype = 0; + } + else if(type < 0) /* storage class set */ + { + if(v->vstg == STGUNKNOWN) + v->vstg = - type; + else if(v->vstg != -type) + dclerr("incompatible storage declarations", v); + } + else if(v->vtype == TYUNKNOWN + || v->vtype != type + && (v->vimpltype || v->vinftype || v->vinfproc)) + { + if( (v->vtype = lengtype(type, length))==TYCHAR ) + if (length>=0) + v->vleng = ICON(length); + else if (parstate >= INDATA) + v->vleng = ICON(1); /* avoid a memory fault */ + v->vimpltype = 0; + v->vinftype = 0; /* 19960709 */ + v->vinfproc = 0; /* 19960709 */ + + if (v->vclass == CLPROC) { + if (v->vstg == STGEXT + && (type1 = extsymtab[v->vardesc.varno].extype) + && type1 != v->vtype) + changedtype(v); + else if (v->vprocclass == PTHISPROC + && (parstate >= INDATA + || procclass == CLMAIN) + && !xretslot[type]) { + xretslot[type] = autovar(ONEOF(type, + MSKCOMPLEX|MSKCHAR) ? 0 : 1, type, + v->vleng, " ret_val"); + if (procclass == CLMAIN) + errstr( + "illegal use of %.60s (main program name)", + v->fvarname); + /* not completely right, but enough to */ + /* avoid memory faults; we won't */ + /* emit any C as we have illegal Fortran */ + } + } + } + else if(v->vtype != type && v->vtype != lengtype(type, length)) { + incompat: + dclerr("incompatible type declarations", v); + } + else if (type==TYCHAR) + if (v->vleng && v->vleng->constblock.Const.ci != length) + goto incompat; + else if (parstate >= INDATA) + v->vleng = ICON(1); /* avoid a memory fault */ +} + + + + + +/* lengtype -- returns the proper compiler type, given input of Fortran + type and length specifier */ + + int +#ifdef KR_headers +lengtype(type, len) + register int type; + ftnint len; +#else +lengtype(register int type, ftnint len) +#endif +{ + register int length = (int)len; + switch(type) + { + case TYREAL: + if(length == typesize[TYDREAL]) + return(TYDREAL); + if(length == typesize[TYREAL]) + goto ret; + break; + + case TYCOMPLEX: + if(length == typesize[TYDCOMPLEX]) + return(TYDCOMPLEX); + if(length == typesize[TYCOMPLEX]) + goto ret; + break; + + case TYINT1: + case TYSHORT: + case TYDREAL: + case TYDCOMPLEX: + case TYCHAR: + case TYLOGICAL1: + case TYLOGICAL2: + case TYUNKNOWN: + case TYSUBR: + case TYERROR: +#ifdef TYQUAD + case TYQUAD: +#endif + goto ret; + + case TYLOGICAL: + switch(length) { + case 0: return tylog; + case 1: return TYLOGICAL1; + case 2: return TYLOGICAL2; + case 4: goto ret; + } + break; + + case TYLONG: + if(length == 0) + return(tyint); + if (length == 1) + return TYINT1; + if(length == typesize[TYSHORT]) + return(TYSHORT); +#ifdef TYQUAD + if(length == typesize[TYQUAD] && use_tyquad) + return(TYQUAD); +#endif + if(length == typesize[TYLONG]) + goto ret; + break; + default: + badtype("lengtype", type); + } + + if(len != 0) + err("incompatible type-length combination"); + +ret: + return(type); +} + + + + + +/* setintr -- Set Intrinsic function */ + + void +#ifdef KR_headers +setintr(v) + register Namep v; +#else +setintr(register Namep v) +#endif +{ + int k; + + if(k = intrfunct(v->fvarname)) { + if ((*(struct Intrpacked *)&k).f4) + if (noextflag) + goto unknown; + else + dcomplex_seen++; + v->vardesc.varno = k; + } + else { + unknown: + dclerr("unknown intrinsic function", v); + return; + } + if(v->vstg == STGUNKNOWN) + v->vstg = STGINTR; + else if(v->vstg!=STGINTR) + dclerr("incompatible use of intrinsic function", v); + if(v->vclass==CLUNKNOWN) + v->vclass = CLPROC; + if(v->vprocclass == PUNKNOWN) + v->vprocclass = PINTRINSIC; + else if(v->vprocclass != PINTRINSIC) + dclerr("invalid intrinsic declaration", v); +} + + + +/* setext -- Set External declaration -- assume that unknowns will become + procedures */ + + void +#ifdef KR_headers +setext(v) + register Namep v; +#else +setext(register Namep v) +#endif +{ + if(v->vclass == CLUNKNOWN) + v->vclass = CLPROC; + else if(v->vclass != CLPROC) + dclerr("invalid external declaration", v); + + if(v->vprocclass == PUNKNOWN) + v->vprocclass = PEXTERNAL; + else if(v->vprocclass != PEXTERNAL) + dclerr("invalid external declaration", v); +} /* setext */ + + + + +/* create dimensions block for array variable */ + + void +#ifdef KR_headers +setbound(v, nd, dims) + register Namep v; + int nd; + struct Dims *dims; +#else +setbound(Namep v, int nd, struct Dims *dims) +#endif +{ + expptr q, q0, t; + struct Dimblock *p; + int i; + extern chainp new_vars; + char buf[256]; + + if(v->vclass == CLUNKNOWN) + v->vclass = CLVAR; + else if(v->vclass != CLVAR) + { + dclerr("only variables may be arrays", v); + return; + } + + v->vdim = p = (struct Dimblock *) + ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); + p->ndim = nd--; + p->nelt = ICON(1); + doin_setbound = 1; + + if (noextflag) + for(i = 0; i <= nd; i++) + if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)) + || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) { + sprintf(buf, "dimension %d of %s is not an integer.", + i+1, v->fvarname); + errext(buf); + break; + } + + for(i = 0; i <= nd; i++) { + if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))) + dims[i].lb = mkconv(TYINT, q); + if (((q = dims[i].ub) && !ISINT(q->headblock.vtype))) + dims[i].ub = mkconv(TYINT, q); + } + + for(i = 0; i <= nd; ++i) + { + if( (q = dims[i].ub) == NULL) + { + if(i == nd) + { + frexpr(p->nelt); + p->nelt = NULL; + } + else + err("only last bound may be asterisk"); + p->dims[i].dimsize = ICON(1); + p->dims[i].dimexpr = NULL; + } + else + { + + if(dims[i].lb) + { + q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); + q = mkexpr(OPPLUS, q, ICON(1) ); + } + if( ISCONST(q) ) + { + p->dims[i].dimsize = q; + p->dims[i].dimexpr = (expptr) PNULL; + } + else { + sprintf(buf, " %s_dim%d", v->fvarname, i+1); + p->dims[i].dimsize = (expptr) + autovar(1, tyint, EXNULL, buf); + p->dims[i].dimexpr = q; + if (i == nd) + v->vlastdim = new_vars; + v->vdimfinish = 1; + } + if(p->nelt) + p->nelt = mkexpr(OPSTAR, p->nelt, + cpexpr(p->dims[i].dimsize) ); + } + } + + q = dims[nd].lb; + q0 = 0; + if(q == NULL) + q = q0 = ICON(1); + + for(i = nd-1 ; i>=0 ; --i) + { + t = dims[i].lb; + if(t == NULL) + t = ICON(1); + if(p->dims[i].dimsize) { + if (q == q0) { + q0 = 0; + frexpr(q); + q = cpexpr(p->dims[i].dimsize); + } + else + q = mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q); + q = mkexpr(OPPLUS, t, q); + } + } + + if( ISCONST(q) ) + { + p->baseoffset = q; + p->basexpr = NULL; + } + else + { + sprintf(buf, " %s_offset", v->fvarname); + p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf); + p->basexpr = q; + v->vdimfinish = 1; + } + doin_setbound = 0; +} + + + void +#ifdef KR_headers +wr_abbrevs(outfile, function_head, vars) + FILE *outfile; + int function_head; + chainp vars; +#else +wr_abbrevs(FILE *outfile, int function_head, chainp vars) +#endif +{ + for (; vars; vars = vars -> nextp) { + Namep name = (Namep) vars -> datap; + if (!name->visused) + continue; + + if (function_head) + nice_printf (outfile, "#define "); + else + nice_printf (outfile, "#undef "); + out_name (outfile, name); + + if (function_head) { + Extsym *comm = &extsymtab[name -> vardesc.varno]; + + nice_printf (outfile, " ("); + extern_out (outfile, comm); + nice_printf (outfile, "%d.", comm->curno); + nice_printf (outfile, "%s)", name->cvarname); + } /* if function_head */ + nice_printf (outfile, "\n"); + } /* for */ +} /* wr_abbrevs */ diff --git a/unix/f2c/src/put.c b/unix/f2c/src/put.c new file mode 100644 index 00000000..15c70cd8 --- /dev/null +++ b/unix/f2c/src/put.c @@ -0,0 +1,458 @@ +/**************************************************************** +Copyright 1990-1991, 1993-1994, 1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* + * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH + * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES +*/ + +#include "defs.h" +#include "names.h" /* For LOCAL_CONST_NAME */ +#include "pccdefs.h" +#include "p1defs.h" + +/* Definitions for putconst() */ + +#define LIT_CHAR 1 +#define LIT_FLOAT 2 +#define LIT_INT 3 +#define LIT_INTQ 4 + + +/* +char *ops [ ] = + { + "??", "+", "-", "*", "/", "**", "-", + "OR", "AND", "EQV", "NEQV", "NOT", + "CONCAT", + "<", "==", ">", "<=", "!=", ">=", + " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ", + " , ", " ? ", " : " + " abs ", " min ", " max ", " addr ", " indirect ", + " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ", + }; +*/ + +/* Each of these values is defined in pccdefs */ + +int ops2 [ ] = +{ + P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG, + P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT, + P2BAD, + P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE, + P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD, + P2COMOP, P2QUEST, P2COLON, + 1, P2BAD, P2BAD, P2BAD, P2BAD, + P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT, + P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, + P2BAD, P2BAD, P2BAD, P2BAD, + 1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */ + 1,1,1,1, /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */ + 1,1,1,1,1 /* OPBITTEST, OPBITCLR, OPBITSET, OPQBIT{CLR,SET} */ +}; + + + void +#ifdef KR_headers +putexpr(p) + expptr p; +#else +putexpr(expptr p) +#endif +{ +/* Write the expression to the p1 file */ + + p = (expptr) putx (fixtype (p)); + p1_expr (p); +} + + + + + + expptr +#ifdef KR_headers +putassign(lp, rp) + expptr lp; + expptr rp; +#else +putassign(expptr lp, expptr rp) +#endif +{ + return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp))); +} + + + + + void +#ifdef KR_headers +puteq(lp, rp) + expptr lp; + expptr rp; +#else +puteq(expptr lp, expptr rp) +#endif +{ + putexpr(mkexpr(OPASSIGN, lp, rp) ); +} + + + + +/* put code for a *= b */ + + expptr +#ifdef KR_headers +putsteq(a, b) + Addrp a; + Addrp b; +#else +putsteq(Addrp a, Addrp b) +#endif +{ + return putx( fixexpr((Exprp) + mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b)))); +} + + + + + Addrp +#ifdef KR_headers +mkfield(res, f, ty) + register Addrp res; + char *f; + int ty; +#else +mkfield(register Addrp res, char *f, int ty) +#endif +{ + res -> vtype = ty; + res -> Field = f; + return res; +} /* mkfield */ + + + Addrp +#ifdef KR_headers +realpart(p) + register Addrp p; +#else +realpart(register Addrp p) +#endif +{ + register Addrp q; + + if (p->tag == TADDR + && p->uname_tag == UNAM_CONST + && ISCOMPLEX (p->vtype)) + return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX, + p->user.kludge.vstg1 ? p->user.Const.cds[0] + : cds(dtos(p->user.Const.cd[0]),CNULL)); + + q = (Addrp) cpexpr((expptr) p); + if( ISCOMPLEX(p->vtype) ) + q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX); + + return(q); +} + + + + + expptr +#ifdef KR_headers +imagpart(p) + register Addrp p; +#else +imagpart(register Addrp p) +#endif +{ + register Addrp q; + + if( ISCOMPLEX(p->vtype) ) + { + if (p->tag == TADDR && p->uname_tag == UNAM_CONST) + return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX, + p->user.kludge.vstg1 ? p->user.Const.cds[1] + : cds(dtos(p->user.Const.cd[1]),CNULL)); + q = (Addrp) cpexpr((expptr) p); + q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX); + return( (expptr) q ); + } + else + +/* Cast an integer type onto a Double Real type */ + + return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0")); +} + + + + + +/* ncat -- computes the number of adjacent concatenation operations */ + + int +#ifdef KR_headers +ncat(p) + register expptr p; +#else +ncat(register expptr p) +#endif +{ + if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT) + return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) ); + else return(1); +} + + + + +/* lencat -- returns the length of the concatenated string. Each + substring must have a static (i.e. compile-time) fixed length */ + + ftnint +#ifdef KR_headers +lencat(p) + register expptr p; +#else +lencat(register expptr p) +#endif +{ + if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT) + return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) ); + else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) ) + return(p->headblock.vleng->constblock.Const.ci); + else if(p->tag==TADDR && p->addrblock.varleng!=0) + return(p->addrblock.varleng); + else + { + err("impossible element in concatenation"); + return(0); + } +} + +/* putconst -- Creates a new Addrp value which maps onto the input + constant value. The Addrp doesn't retain the value of the constant, + instead that value is copied into a table of constants (called + litpool, for pool of literal values). The only way to retrieve the + actual value of the constant is to look at the memno field of the + Addrp result. You know that the associated literal is the one referred + to by q when (q -> memno == litp -> litnum). +*/ + + Addrp +#ifdef KR_headers +putconst(p) + register Constp p; +#else +putconst(register Constp p) +#endif +{ + register Addrp q; + struct Literal *litp, *lastlit; + int k, len, type; + int litflavor; + double cd[2]; + ftnint nblanks; + char *strp; + char cdsbuf0[64], cdsbuf1[64], *ds[2]; + + if (p->tag != TCONST) + badtag("putconst", p->tag); + + q = ALLOC(Addrblock); + q->tag = TADDR; + type = p->vtype; + q->vtype = ( type==TYADDR ? tyint : type ); + q->vleng = (expptr) cpexpr(p->vleng); + q->vstg = STGCONST; + +/* Create the new label for the constant. This is wasteful of labels + because when the constant value already exists in the literal pool, + this label gets thrown away and is never reclaimed. It might be + cleaner to move this down past the first switch() statement below */ + + q->memno = newlabel(); + q->memoffset = ICON(0); + q -> uname_tag = UNAM_CONST; + +/* Copy the constant info into the Addrblock; do this by copying the + largest storage elts */ + + q -> user.Const = p -> Const; + q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */ + + /* check for value in literal pool, and update pool if necessary */ + + k = 1; + switch(type) + { + case TYCHAR: + if (halign) { + strp = p->Const.ccp; + nblanks = p->Const.ccp1.blanks; + len = (int)p->vleng->constblock.Const.ci; + litflavor = LIT_CHAR; + goto loop; + } + else + q->memno = BAD_MEMNO; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + k = 2; + if (p->vstg) + cd[1] = atof(ds[1] = p->Const.cds[1]); + else + ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1); + case TYREAL: + case TYDREAL: + litflavor = LIT_FLOAT; + if (p->vstg) + cd[0] = atof(ds[0] = p->Const.cds[0]); + else + ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0); + goto loop; + +#ifndef NO_LONG_LONG + case TYQUAD: + litflavor = LIT_INTQ; + goto loop; +#endif + + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + case TYLONG: + case TYSHORT: + case TYINT1: +#ifdef TYQUAD0 + case TYQUAD: +#endif + litflavor = LIT_INT; + +/* Scan the literal pool for this constant value. If this same constant + has been assigned before, use the same label. Note that this routine + does NOT consider two differently-typed constants with the same bit + pattern to be the same constant */ + + loop: + lastlit = litpool + nliterals; + for(litp = litpool ; litplittype) switch(litflavor) + { + case LIT_CHAR: + if (len == (int)litp->litval.litival2[0] + && nblanks == litp->litval.litival2[1] + && !memcmp(strp, litp->cds[0], len)) { + q->memno = litp->litnum; + frexpr((expptr)p); + q->user.Const.ccp1.ccp0 = litp->cds[0]; + return(q); + } + break; + case LIT_FLOAT: + if(cd[0] == litp->litval.litdval[0] + && !strcmp(ds[0], litp->cds[0]) + && (k == 1 || + cd[1] == litp->litval.litdval[1] + && !strcmp(ds[1], litp->cds[1]))) { +ret: + q->memno = litp->litnum; + frexpr((expptr)p); + return(q); + } + break; + + case LIT_INT: + if(p->Const.ci == litp->litval.litival) + goto ret; + break; +#ifndef NO_LONG_LONG + case LIT_INTQ: + if(p->Const.cq == litp->litval.litqval) + goto ret; + break; +#endif + } + +/* If there's room in the literal pool, add this new value to the pool */ + + if(nliterals < maxliterals) + { + ++nliterals; + + /* litp now points to the next free elt */ + + litp->littype = type; + litp->litnum = q->memno; + switch(litflavor) + { + case LIT_CHAR: + litp->litval.litival2[0] = len; + litp->litval.litival2[1] = nblanks; + q->user.Const.ccp = litp->cds[0] = (char*) + memcpy(gmem(len,0), strp, len); + break; + + case LIT_FLOAT: + litp->litval.litdval[0] = cd[0]; + litp->cds[0] = copys(ds[0]); + if (k == 2) { + litp->litval.litdval[1] = cd[1]; + litp->cds[1] = copys(ds[1]); + } + break; + + case LIT_INT: + litp->litval.litival = p->Const.ci; + break; +#ifndef NO_LONG_LONG + case LIT_INTQ: + litp->litval.litqval = p->Const.cq; + break; +#endif + } /* switch (litflavor) */ + } + else + many("literal constants", 'L', maxliterals); + + break; + case TYADDR: + break; + default: + badtype ("putconst", p -> vtype); + break; + } /* switch */ + + if (type != TYCHAR || halign) + frexpr((expptr)p); + return( q ); +} diff --git a/unix/f2c/src/putpcc.c b/unix/f2c/src/putpcc.c new file mode 100644 index 00000000..18a9df66 --- /dev/null +++ b/unix/f2c/src/putpcc.c @@ -0,0 +1,2169 @@ +/**************************************************************** +Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */ +/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */ + +#include "defs.h" +#include "pccdefs.h" +#include "output.h" /* for nice_printf */ +#include "names.h" +#include "p1defs.h" + +static Addrp intdouble Argdcl((Addrp)); +static Addrp putcx1 Argdcl((tagptr)); +static tagptr putaddr Argdcl((tagptr)); +static tagptr putcall Argdcl((tagptr, Addrp*)); +static tagptr putcat Argdcl((tagptr, tagptr)); +static Addrp putch1 Argdcl((tagptr)); +static tagptr putchcmp Argdcl((tagptr)); +static tagptr putcheq Argdcl((tagptr)); +static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr)); +static tagptr putcxcmp Argdcl((tagptr)); +static Addrp putcxeq Argdcl((tagptr)); +static tagptr putmnmx Argdcl((tagptr)); +static tagptr putop Argdcl((tagptr)); +static tagptr putpower Argdcl((tagptr)); +static long p1_where; + +extern int init_ac[TYSUBR+1]; +extern int ops2[]; +extern int proc_argchanges, proc_protochanges; +extern int krparens; + +#define P2BUFFMAX 128 + +/* Puthead -- output the header information about subroutines, functions + and entry points */ + + void +#ifdef KR_headers +puthead(s, Class) + char *s; + int Class; +#else +puthead(char *s, int Class) +#endif +{ + if (headerdone == NO) { + if (Class == CLMAIN) + s = "MAIN__"; + p1_head (Class, s); + headerdone = YES; + } +} + + void +#ifdef KR_headers +putif(p, else_if_p) + register expptr p; + int else_if_p; +#else +putif(register expptr p, int else_if_p) +#endif +{ + int k, n; + + if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) ) + { + if(k != TYERROR) + err("non-logical expression in IF statement"); + } + else { + if (else_if_p) { + if (ei_next >= ei_last) + { + k = ei_last - ei_first; + n = k + 100; + ei_next = mem(n,0); + ei_last = ei_first + n; + if (k) + memcpy(ei_next, ei_first, k); + ei_first = ei_next; + ei_next += k; + ei_last = ei_first + n; + } + p = putx(p); + if (*ei_next++ = ftell(pass1_file) > p1_where) { + p1_if(p); + new_endif(); + } + else + p1_elif(p); + } + else { + p = putx(p); + p1_if(p); + } + } + } + + void +#ifdef KR_headers +putout(p) + expptr p; +#else +putout(expptr p) +#endif +{ + p1_expr (p); + +/* Used to make temporaries in holdtemps available here, but they */ +/* may be reused too soon (e.g. when multiple **'s are involved). */ +} + + + void +#ifdef KR_headers +putcmgo(index, nlab, labs) + expptr index; + int nlab; + struct Labelblock **labs; +#else +putcmgo(expptr index, int nlab, struct Labelblock **labs) +#endif +{ + if(! ISINT(index->headblock.vtype) ) + { + execerr("computed goto index must be integer", CNULL); + return; + } + + p1comp_goto (index, nlab, labs); +} + + static expptr +#ifdef KR_headers +krput(p) + register expptr p; +#else +krput(register expptr p) +#endif +{ + register expptr e, e1; + register unsigned op; + int t = krparens == 2 ? TYDREAL : p->exprblock.vtype; + + op = p->exprblock.opcode; + e = p->exprblock.leftp; + if (e->tag == TEXPR && e->exprblock.opcode == op) { + e1 = (expptr)mktmp(t, ENULL); + putout(putassign(cpexpr(e1), e)); + p->exprblock.leftp = e1; + } + else + p->exprblock.leftp = putx(e); + + e = p->exprblock.rightp; + if (e->tag == TEXPR && e->exprblock.opcode == op) { + e1 = (expptr)mktmp(t, ENULL); + putout(putassign(cpexpr(e1), e)); + p->exprblock.rightp = e1; + } + else + p->exprblock.rightp = putx(e); + return p; + } + + expptr +#ifdef KR_headers +putx(p) + register expptr p; +#else +putx(register expptr p) +#endif +{ + int opc; + int k; + + if (p) + switch(p->tag) + { + case TERROR: + break; + + case TCONST: + switch(p->constblock.vtype) + { + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: +#ifdef TYQUAD + case TYQUAD: +#endif + case TYLONG: + case TYSHORT: + case TYINT1: + break; + + case TYADDR: + break; + case TYREAL: + case TYDREAL: + +/* Don't write it out to the p2 file, since you'd need to call putconst, + which is just what we need to avoid in the translator */ + + break; + default: + p = putx( (expptr)putconst((Constp)p) ); + break; + } + break; + + case TEXPR: + switch(opc = p->exprblock.opcode) + { + case OPCALL: + case OPCCALL: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else p = putcall(p, (Addrp *)NULL); + break; + + case OPMIN: + case OPMAX: + p = putmnmx(p); + break; + + + case OPASSIGN: + if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype) + || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) { + (void) putcxeq(p); + p = ENULL; + } else if( ISCHAR(p) ) + p = putcheq(p); + else + goto putopp; + break; + + case OPEQ: + case OPNE: + if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) || + ISCOMPLEX(p->exprblock.rightp->headblock.vtype) ) + { + p = putcxcmp(p); + break; + } + case OPLT: + case OPLE: + case OPGT: + case OPGE: + if(ISCHAR(p->exprblock.leftp)) + { + p = putchcmp(p); + break; + } + goto putopp; + + case OPPOWER: + p = putpower(p); + break; + + case OPSTAR: + /* m * (2**k) -> m<exprblock.leftp->headblock.vtype) && + ISICON(p->exprblock.rightp) && + ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) ) + { + p->exprblock.opcode = OPLSHIFT; + frexpr(p->exprblock.rightp); + p->exprblock.rightp = ICON(k); + goto putopp; + } + if (krparens && ISREAL(p->exprblock.vtype)) + return krput(p); + + case OPMOD: + goto putopp; + case OPPLUS: + if (krparens && ISREAL(p->exprblock.vtype)) + return krput(p); + case OPMINUS: + case OPSLASH: + case OPNEG: + case OPNEG1: + case OPABS: + case OPDABS: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else goto putopp; + break; + + case OPCONV: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ) + { + p = putx( mkconv(p->exprblock.vtype, + (expptr)realpart(putcx1(p->exprblock.leftp)))); + } + else goto putopp; + break; + + case OPNOT: + case OPOR: + case OPAND: + case OPEQV: + case OPNEQV: + case OPADDR: + case OPPLUSEQ: + case OPSTAREQ: + case OPCOMMA: + case OPQUEST: + case OPCOLON: + case OPBITOR: + case OPBITAND: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + case OPASSIGNI: + case OPIDENTITY: + case OPCHARCAST: + case OPMIN2: + case OPMAX2: + case OPDMIN: + case OPDMAX: + case OPBITTEST: + case OPBITCLR: + case OPBITSET: +#ifdef TYQUAD + case OPQBITSET: + case OPQBITCLR: +#endif +putopp: + p = putop(p); + break; + + case OPCONCAT: + /* weird things like ichar(a//a) */ + p = (expptr)putch1(p); + break; + + default: + badop("putx", opc); + p = errnode (); + } + break; + + case TADDR: + p = putaddr(p); + break; + + default: + badtag("putx", p->tag); + p = errnode (); + } + + return p; +} + + + + LOCAL expptr +#ifdef KR_headers +putop(p) + expptr p; +#else +putop(expptr p) +#endif +{ + expptr lp, tp; + int pt, lt, lt1; + int comma; + char *hsave; + + switch(p->exprblock.opcode) /* check for special cases and rewrite */ + { + case OPCONV: + pt = p->exprblock.vtype; + lp = p->exprblock.leftp; + lt = lp->headblock.vtype; + +/* Simplify nested type casts */ + + while(p->tag==TEXPR && p->exprblock.opcode==OPCONV && + ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) || + (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) )) + { + if(pt==TYDREAL && lt==TYREAL) + { + if(lp->tag==TEXPR + && lp->exprblock.opcode == OPCONV) { + lt1 = lp->exprblock.leftp->headblock.vtype; + if (lt1 == TYDREAL) { + lp->exprblock.leftp = + putx(lp->exprblock.leftp); + return p; + } + if (lt1 == TYDCOMPLEX) { + lp->exprblock.leftp = putx( + (expptr)realpart( + putcx1(lp->exprblock.leftp))); + return p; + } + } + break; + } + else if (ISREAL(pt) && ISCOMPLEX(lt)) { + p->exprblock.leftp = putx(mkconv(pt, + (expptr)realpart( + putcx1(p->exprblock.leftp)))); + break; + } + if(lt==TYCHAR && lp->tag==TEXPR && + lp->exprblock.opcode==OPCALL) + { + +/* May want to make a comma expression here instead. I had one, but took + it out for my convenience, not for the convenience of the end user */ + + putout (putcall (lp, (Addrp *) &(p -> + exprblock.leftp))); + return putop (p); + } + if (lt == TYCHAR) { + if (ISCONST(p->exprblock.leftp) + && ISNUMERIC(p->exprblock.vtype)) { + hsave = halign; + halign = 0; + p->exprblock.leftp = putx((expptr) + putconst((Constp) + p->exprblock.leftp)); + halign = hsave; + } + else + p->exprblock.leftp = + putx(p->exprblock.leftp); + return p; + } + if (pt < lt && ONEOF(lt,MSKINT|MSKREAL)) + break; + frexpr(p->exprblock.vleng); + free( (charptr) p ); + p = lp; + if (p->tag != TEXPR) + goto retputx; + pt = lt; + lp = p->exprblock.leftp; + lt = lp->headblock.vtype; + } /* while */ + if(p->tag==TEXPR && p->exprblock.opcode==OPCONV) + break; + retputx: + return putx(p); + + case OPADDR: + comma = NO; + lp = p->exprblock.leftp; + free( (charptr) p ); + if(lp->tag != TADDR) + { + tp = (expptr) + mktmp(lp->headblock.vtype,lp->headblock.vleng); + p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) ); + lp = tp; + comma = YES; + } + if(comma) + p = mkexpr(OPCOMMA, p, putaddr(lp)); + else + p = (expptr)putaddr(lp); + return p; + + case OPASSIGN: + case OPASSIGNI: + case OPLT: + case OPLE: + case OPGT: + case OPGE: + case OPEQ: + case OPNE: + ; + } + + if( ops2[p->exprblock.opcode] <= 0) + badop("putop", p->exprblock.opcode); + lp = p->exprblock.leftp = putx(p->exprblock.leftp); + if (p -> exprblock.rightp) { + tp = p->exprblock.rightp = putx(p->exprblock.rightp); + if (tp && ISCONST(tp) && ISCONST(lp)) + p = fold(p); + } + return p; +} + + LOCAL expptr +#ifdef KR_headers +putpower(p) + expptr p; +#else +putpower(expptr p) +#endif +{ + expptr base; + Addrp t1, t2; + ftnint k; + int type; + char buf[80]; /* buffer for text of comment */ + + if(!ISICON(p->exprblock.rightp) || + (k = p->exprblock.rightp->constblock.Const.ci)<2) + Fatal("putpower: bad call"); + base = p->exprblock.leftp; + type = base->headblock.vtype; + t1 = mktmp(type, ENULL); + t2 = NULL; + + free ((charptr) p); + p = putassign (cpexpr((expptr) t1), base); + + sprintf (buf, "Computing %ld%s power", k, + k == 2 ? "nd" : k == 3 ? "rd" : "th"); + p1_comment (buf); + + for( ; (k&1)==0 && k>2 ; k>>=1 ) + { + p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); + } + + if(k == 2) { + +/* Write the power computation out immediately */ + putout (p); + p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))); + } else if (k == 3) { + putout(p); + p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), + mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)))); + } else { + t2 = mktmp(type, ENULL); + p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2), + cpexpr((expptr)t1))); + + for(k>>=1 ; k>1 ; k>>=1) + { + p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); + if(k & 1) + { + p = mkexpr (OPCOMMA, p, putsteq(t2, t1)); + } + } +/* Write the power computation out immediately */ + putout (p); + p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2), + mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)))); + } + frexpr((expptr)t1); + if(t2) + frexpr((expptr)t2); + return p; +} + + + + + LOCAL Addrp +#ifdef KR_headers +intdouble(p) + Addrp p; +#else +intdouble(Addrp p) +#endif +{ + register Addrp t; + + t = mktmp(TYDREAL, ENULL); + putout (putassign(cpexpr((expptr)t), (expptr)p)); + return(t); +} + + + + + +/* Complex-type variable assignment */ + + LOCAL Addrp +#ifdef KR_headers +putcxeq(p) + register expptr p; +#else +putcxeq(register expptr p) +#endif +{ + register Addrp lp, rp; + expptr code; + + if(p->tag != TEXPR) + badtag("putcxeq", p->tag); + + lp = putcx1(p->exprblock.leftp); + rp = putcx1(p->exprblock.rightp); + code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp)); + + if( ISCOMPLEX(p->exprblock.vtype) ) + { + code = mkexpr (OPCOMMA, code, putassign + (imagpart(lp), imagpart(rp))); + } + putout (code); + frexpr((expptr)rp); + free ((charptr) p); + return lp; +} + + + +/* putcxop -- used to write out embedded calls to complex functions, and + complex arguments to procedures */ + + expptr +#ifdef KR_headers +putcxop(p) + expptr p; +#else +putcxop(expptr p) +#endif +{ + return (expptr)putaddr((expptr)putcx1(p)); +} + +#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y)) + + LOCAL Addrp +#ifdef KR_headers +putcx1(p) + register expptr p; +#else +putcx1(register expptr p) +#endif +{ + expptr q; + Addrp lp, rp; + register Addrp resp; + int opcode; + int ltype, rtype; + long ts, tskludge; + + if(p == NULL) + return(NULL); + + switch(p->tag) + { + case TCONST: + if( ISCOMPLEX(p->constblock.vtype) ) + p = (expptr) putconst((Constp)p); + return( (Addrp) p ); + + case TADDR: + resp = &p->addrblock; + if (addressable(p)) + return (Addrp) p; + ts = tskludge = 0; + if (q = resp->memoffset) { + if (resp->uname_tag == UNAM_REF) { + q = cpexpr((tagptr)resp); + q->addrblock.vtype = tyint; + q->addrblock.cmplx_sub = 1; + p->addrblock.skip_offset = 1; + resp->user.name->vsubscrused = 1; + resp->uname_tag = UNAM_NAME; + tskludge = typesize[resp->vtype] + * (resp->Field ? 2 : 1); + } + else if (resp->isarray + && resp->vtype != TYCHAR) { + if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) + && resp->uname_tag == UNAM_NAME) + q = mkexpr(OPMINUS, q, + mkintcon(resp->user.name->voffset)); + ts = typesize[resp->vtype] + * (resp->Field ? 2 : 1); + q = resp->memoffset = mkexpr(OPSLASH, q, + ICON(ts)); + } + } +#ifdef TYQUAD + resp = mktmp(q->headblock.vtype == TYQUAD ? TYQUAD : tyint, ENULL); +#else + resp = mktmp(tyint, ENULL); +#endif + putout(putassign(cpexpr((expptr)resp), q)); + p->addrblock.memoffset = tskludge + ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge)) + : (expptr)resp; + if (ts) { + resp = &p->addrblock; + q = mkexpr(OPSTAR, resp->memoffset, ICON(ts)); + if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) + && resp->uname_tag == UNAM_NAME) + q = mkexpr(OPPLUS, q, + mkintcon(resp->user.name->voffset)); + resp->memoffset = q; + } + return (Addrp) p; + + case TEXPR: + if( ISCOMPLEX(p->exprblock.vtype) ) + break; + resp = mktmp(p->exprblock.vtype, ENULL); + /*first arg of above mktmp call was TYDREAL before 19950102 */ + putout (putassign( cpexpr((expptr)resp), p)); + return(resp); + + case TERROR: + return NULL; + + default: + badtag("putcx1", p->tag); + } + + opcode = p->exprblock.opcode; + if(opcode==OPCALL || opcode==OPCCALL) + { + Addrp t; + p = putcall(p, &t); + putout(p); + return t; + } + else if(opcode == OPASSIGN) + { + return putcxeq (p); + } + +/* BUG (inefficient) Generates too many temporary variables */ + + resp = mktmp(p->exprblock.vtype, ENULL); + if(lp = putcx1(p->exprblock.leftp) ) + ltype = lp->vtype; + if(rp = putcx1(p->exprblock.rightp) ) + rtype = rp->vtype; + + switch(opcode) + { + case OPCOMMA: + frexpr((expptr)resp); + resp = rp; + rp = NULL; + break; + + case OPNEG: + case OPNEG1: + putout (PAIR ( + putassign( (expptr)realpart(resp), + mkexpr(OPNEG, (expptr)realpart(lp), ENULL)), + putassign( imagpart(resp), + mkexpr(OPNEG, imagpart(lp), ENULL)))); + break; + + case OPPLUS: + case OPMINUS: { expptr r; + r = putassign( (expptr)realpart(resp), + mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) )); + if(rtype < TYCOMPLEX) + q = putassign( imagpart(resp), imagpart(lp) ); + else if(ltype < TYCOMPLEX) + { + if(opcode == OPPLUS) + q = putassign( imagpart(resp), imagpart(rp) ); + else + q = putassign( imagpart(resp), + mkexpr(OPNEG, imagpart(rp), ENULL) ); + } + else + q = putassign( imagpart(resp), + mkexpr(opcode, imagpart(lp), imagpart(rp) )); + r = PAIR (r, q); + putout (r); + break; + } /* case OPPLUS, OPMINUS: */ + case OPSTAR: + if(ltype < TYCOMPLEX) + { + if( ISINT(ltype) ) + lp = intdouble(lp); + putout (PAIR ( + putassign( (expptr)realpart(resp), + mkexpr(OPSTAR, cpexpr((expptr)lp), + (expptr)realpart(rp))), + putassign( imagpart(resp), + mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp))))); + } + else if(rtype < TYCOMPLEX) + { + if( ISINT(rtype) ) + rp = intdouble(rp); + putout (PAIR ( + putassign( (expptr)realpart(resp), + mkexpr(OPSTAR, cpexpr((expptr)rp), + (expptr)realpart(lp))), + putassign( imagpart(resp), + mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp))))); + } + else { + putout (PAIR ( + putassign( (expptr)realpart(resp), mkexpr(OPMINUS, + mkexpr(OPSTAR, (expptr)realpart(lp), + (expptr)realpart(rp)), + mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))), + putassign( imagpart(resp), mkexpr(OPPLUS, + mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)), + mkexpr(OPSTAR, imagpart(lp), + (expptr)realpart(rp)))))); + } + break; + + case OPSLASH: + /* fixexpr has already replaced all divisions + * by a complex by a function call + */ + if( ISINT(rtype) ) + rp = intdouble(rp); + putout (PAIR ( + putassign( (expptr)realpart(resp), + mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))), + putassign( imagpart(resp), + mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp))))); + break; + + case OPCONV: + if (!lp) + break; + if(ISCOMPLEX(lp->vtype) ) + q = imagpart(lp); + else if(rp != NULL) + q = (expptr) realpart(rp); + else + q = mkrealcon(TYDREAL, "0"); + putout (PAIR ( + putassign( (expptr)realpart(resp), (expptr)realpart(lp)), + putassign( imagpart(resp), q))); + break; + + default: + badop("putcx1", opcode); + } + + frexpr((expptr)lp); + frexpr((expptr)rp); + free( (charptr) p ); + return(resp); +} + + + + +/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations + are not defined */ + + LOCAL expptr +#ifdef KR_headers +putcxcmp(p) + register expptr p; +#else +putcxcmp(register expptr p) +#endif +{ + int opcode; + register Addrp lp, rp; + expptr q; + + if(p->tag != TEXPR) + badtag("putcxcmp", p->tag); + + opcode = p->exprblock.opcode; + lp = putcx1(p->exprblock.leftp); + rp = putcx1(p->exprblock.rightp); + + q = mkexpr( opcode==OPEQ ? OPAND : OPOR , + mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)), + mkexpr(opcode, imagpart(lp), imagpart(rp)) ); + + free( (charptr) lp); + free( (charptr) rp); + free( (charptr) p ); + if (ISCONST(q)) + return q; + return putx( fixexpr((Exprp)q) ); +} + +/* putch1 -- Forces constants into the literal pool, among other things */ + + LOCAL Addrp +#ifdef KR_headers +putch1(p) + register expptr p; +#else +putch1(register expptr p) +#endif +{ + Addrp t; + expptr e; + + switch(p->tag) + { + case TCONST: + return( putconst((Constp)p) ); + + case TADDR: + return( (Addrp) p ); + + case TEXPR: + switch(p->exprblock.opcode) + { + expptr q; + + case OPCALL: + case OPCCALL: + + p = putcall(p, &t); + putout (p); + break; + + case OPCONCAT: + t = mktmp(TYCHAR, ICON(lencat(p))); + q = (expptr) cpexpr(p->headblock.vleng); + p = putcat( cpexpr((expptr)t), p ); + /* put the correct length on the block */ + frexpr(t->vleng); + t->vleng = q; + putout (p); + break; + + case OPCONV: + if(!ISICON(p->exprblock.vleng) + || p->exprblock.vleng->constblock.Const.ci!=1 + || ! INT(p->exprblock.leftp->headblock.vtype) ) + Fatal("putch1: bad character conversion"); + t = mktmp(TYCHAR, ICON(1)); + e = mkexpr(OPCONV, (expptr)t, ENULL); + e->headblock.vtype = TYCHAR; + p = putop( mkexpr(OPASSIGN, cpexpr(e), p)); + putout (p); + break; + default: + badop("putch1", p->exprblock.opcode); + } + return(t); + + default: + badtag("putch1", p->tag); + } + /* NOT REACHED */ return 0; +} + + +/* putchop -- Write out a character actual parameter; that is, this is + part of a procedure invocation */ + + Addrp +#ifdef KR_headers +putchop(p) + expptr p; +#else +putchop(expptr p) +#endif +{ + p = putaddr((expptr)putch1(p)); + return (Addrp)p; +} + + + + + LOCAL expptr +#ifdef KR_headers +putcheq(p) + register expptr p; +#else +putcheq(register expptr p) +#endif +{ + expptr lp, rp; + int nbad; + + if(p->tag != TEXPR) + badtag("putcheq", p->tag); + + lp = p->exprblock.leftp; + rp = p->exprblock.rightp; + frexpr(p->exprblock.vleng); + free( (charptr) p ); + +/* If s = t // u, don't bother copying the result, write it directly into + this buffer */ + + nbad = badchleng(lp) + badchleng(rp); + if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT ) + p = putcat(lp, rp); + else if( !nbad + && ISONE(lp->headblock.vleng) + && ISONE(rp->headblock.vleng) ) { + lp = mkexpr(OPCONV, lp, ENULL); + rp = mkexpr(OPCONV, rp, ENULL); + lp->headblock.vtype = rp->headblock.vtype = TYCHAR; + p = putop(mkexpr(OPASSIGN, lp, rp)); + } + else + p = putx( call2(TYSUBR, "s_copy", lp, rp) ); + return p; +} + + + + + LOCAL expptr +#ifdef KR_headers +putchcmp(p) + register expptr p; +#else +putchcmp(register expptr p) +#endif +{ + expptr lp, rp; + + if(p->tag != TEXPR) + badtag("putchcmp", p->tag); + + lp = p->exprblock.leftp; + rp = p->exprblock.rightp; + + if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) { + lp = mkexpr(OPCONV, lp, ENULL); + rp = mkexpr(OPCONV, rp, ENULL); + lp->headblock.vtype = rp->headblock.vtype = TYCHAR; + } + else { + lp = call2(TYINT,"s_cmp", lp, rp); + rp = ICON(0); + } + p->exprblock.leftp = lp; + p->exprblock.rightp = rp; + p = putop(p); + return p; +} + + + + + +/* putcat -- Writes out a concatenation operation. Two temporary arrays + are allocated, putct1() is called to initialize them, and then a + call to runtime library routine s_cat() is inserted. + + This routine generates code which will perform an (nconc lhs rhs) + at runtime. The runtime funciton does not return a value, the routine + that calls this putcat must remember the name of lhs. +*/ + + + LOCAL expptr +#ifdef KR_headers +putcat(lhs0, rhs) + expptr lhs0; + register expptr rhs; +#else +putcat(expptr lhs0, register expptr rhs) +#endif +{ + register Addrp lhs = (Addrp)lhs0; + int n, tyi; + Addrp length_var, string_var; + expptr p; + static char Writing_concatenation[] = "Writing concatenation"; + +/* Create the temporary arrays */ + + n = ncat(rhs); + length_var = mktmpn(n, tyioint, ENULL); + string_var = mktmpn(n, TYADDR, ENULL); + frtemp((Addrp)cpexpr((expptr)length_var)); + frtemp((Addrp)cpexpr((expptr)string_var)); + +/* Initialize the arrays */ + + n = 0; + /* p1_comment scribbles on its argument, so we + * cannot safely pass a string literal here. */ + p1_comment(Writing_concatenation); + putct1(rhs, length_var, string_var, &n); + +/* Create the invocation */ + + tyi = tyint; + tyint = tyioint; /* for -I2 */ + p = putx (call4 (TYSUBR, "s_cat", + (expptr)lhs, + (expptr)string_var, + (expptr)length_var, + (expptr)putconst((Constp)ICON(n)))); + tyint = tyi; + + return p; +} + + + + + + LOCAL void +#ifdef KR_headers +putct1(q, length_var, string_var, ip) + register expptr q; + register Addrp length_var; + register Addrp string_var; + int *ip; +#else +putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip) +#endif +{ + int i; + Addrp length_copy, string_copy; + expptr e; + extern int szleng; + + if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT) + { + putct1(q->exprblock.leftp, length_var, string_var, + ip); + putct1(q->exprblock.rightp, length_var, string_var, + ip); + frexpr (q -> exprblock.vleng); + free ((charptr) q); + } + else + { + i = (*ip)++; + e = cpexpr(q->headblock.vleng); + if (!e) + return; /* error -- character*(*) */ + length_copy = (Addrp) cpexpr((expptr)length_var); + length_copy->memoffset = + mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng)); + string_copy = (Addrp) cpexpr((expptr)string_var); + string_copy->memoffset = + mkexpr(OPPLUS, string_copy->memoffset, + ICON(i*typesize[TYADDR])); + putout (PAIR (putassign((expptr)length_copy, e), + putassign((expptr)string_copy, addrof((expptr)putch1(q))))); + } +} + +/* putaddr -- seems to write out function invocation actual parameters */ + + LOCAL expptr +#ifdef KR_headers +putaddr(p0) + expptr p0; +#else +putaddr(expptr p0) +#endif +{ + register Addrp p; + chainp cp; + + if (!(p = (Addrp)p0)) + return ENULL; + + if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) ) + { + frexpr((expptr)p); + return ENULL; + } + if (p->isarray && p->memoffset) + if (p->uname_tag == UNAM_REF) { + cp = p->memoffset->listblock.listp; + for(; cp; cp = cp->nextp) + cp->datap = (char *)fixtype((tagptr)cp->datap); + } + else + p->memoffset = putx(p->memoffset); + return (expptr) p; +} + + LOCAL expptr +#ifdef KR_headers +addrfix(e) + expptr e; +#else +addrfix(expptr e) +#endif + /* fudge character string length if it's a TADDR */ +{ + return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e; + } + + LOCAL int +#ifdef KR_headers +typekludge(ccall, q, at, j) + int ccall; + register expptr q; + Atype *at; + int j; +#else +typekludge(int ccall, register expptr q, Atype *at, int j) +#endif + /* j = alternate type */ +{ + register int i, k; + extern int iocalladdr; + register Namep np; + + /* Return value classes: + * < 100 ==> Fortran arg (pointer to type) + * < 200 ==> C arg + * < 300 ==> procedure arg + * < 400 ==> external, no explicit type + * < 500 ==> arg that may turn out to be + * either a variable or a procedure + */ + + k = q->headblock.vtype; + if (ccall) { + if (k == TYREAL) + k = TYDREAL; /* force double for library routines */ + return k + 100; + } + if (k == TYADDR) + return iocalladdr; + i = q->tag; + if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG) + || (i == TADDR && q->addrblock.charleng) + || i == TCONST) + k = TYFTNLEN + 100; + else if (i == TADDR) + switch(q->addrblock.vclass) { + case CLPROC: + if (q->addrblock.uname_tag != UNAM_NAME) + k += 200; + else if ((np = q->addrblock.user.name)->vprocclass + != PTHISPROC) { + if (k && !np->vimpltype) + k += 200; + else { + if (j > 200 && infertypes && j < 300) { + k = j; + inferdcl(np, j-200); + } + else k = (np->vstg == STGEXT + ? extsymtab[np->vardesc.varno].extype + : 0) + 200; + at->cp = mkchain((char *)np, at->cp); + } + } + else if (k == TYSUBR) + k += 200; + break; + + case CLUNKNOWN: + if (q->addrblock.vstg == STGARG + && q->addrblock.uname_tag == UNAM_NAME) { + k += 400; + at->cp = mkchain((char *)q->addrblock.user.name, + at->cp); + } + } + else if (i == TNAME && q->nameblock.vstg == STGARG) { + np = &q->nameblock; + switch(np->vclass) { + case CLPROC: + if (!np->vimpltype) + k += 200; + else if (j <= 200 || !infertypes || j >= 300) + k += 300; + else { + k = j; + inferdcl(np, j-200); + } + goto add2chain; + + case CLUNKNOWN: + /* argument may be a scalar variable or a function */ + if (np->vimpltype && j && infertypes + && j < 300) { + inferdcl(np, j % 100); + k = j; + } + else + k += 400; + + /* to handle procedure args only so far known to be + * external, save a pointer to the symbol table entry... + */ + add2chain: + at->cp = mkchain((char *)np, at->cp); + } + } + return k; + } + + char * +#ifdef KR_headers +Argtype(k, buf) + int k; + char *buf; +#else +Argtype(int k, char *buf) +#endif +{ + if (k < 100) { + sprintf(buf, "%s variable", ftn_types[k]); + return buf; + } + if (k < 200) { + k -= 100; + return ftn_types[k]; + } + if (k < 300) { + k -= 200; + if (k == TYSUBR) + return ftn_types[TYSUBR]; + sprintf(buf, "%s function", ftn_types[k]); + return buf; + } + if (k < 400) + return "external argument"; + k -= 400; + sprintf(buf, "%s argument", ftn_types[k]); + return buf; + } + + static void +#ifdef KR_headers +atype_squawk(at, msg) + Argtypes *at; + char *msg; +#else +atype_squawk(Argtypes *at, char *msg) +#endif +{ + register Atype *a, *ae; + warn(msg); + for(a = at->atypes, ae = a + at->nargs; a < ae; a++) + frchain(&a->cp); + at->nargs = -1; + if (at->changes & 2 && !at->defined) + proc_protochanges++; + } + + static char inconsist[] = "inconsistent calling sequences for "; + + void +#ifdef KR_headers +bad_atypes(at, fname, i, j, k, here, prev) + Argtypes *at; + char *fname; + int i; + int j; + int k; + char *here; + char *prev; +#else +bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev) +#endif +{ + char buf[208], buf1[32], buf2[32]; + + sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.", + inconsist, fname, i, here, Argtype(k, buf1), + prev, Argtype(j, buf2)); + atype_squawk(at, buf); + } + + int +#ifdef KR_headers +type_fixup(at, a, k) + Argtypes *at; + Atype *a; + int k; +#else +type_fixup(Argtypes *at, Atype *a, int k) +#endif +{ + register struct Entrypoint *ep; + if (!infertypes) + return 0; + for(ep = entries; ep; ep = ep->entnextp) + if (ep->entryname && at == ep->entryname->arginfo) { + a->type = k % 100; + return proc_argchanges = 1; + } + return 0; + } + + + void +#ifdef KR_headers +save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap) + chainp arglist; + Argtypes **at0; + Argtypes **at1; + int ccall; + char *fname; + int stg; + int nchargs; + int type; + int zap; +#else +save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap) +#endif +{ + Argtypes *at; + chainp cp; + int i, i0, j, k, nargs, nbad, *t, *te; + Atype *atypes; + expptr q; + char buf[208], buf1[32], buf2[32]; + static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100}; + static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0, +#ifdef TYQUAD + 0, +#endif + initargs, initargs+1,0,0,0,initargs+2}; + + i0 = init_ac[type]; + t = init_ap[type]; + te = t + i0; + if (at = *at0) { + *at1 = at; + nargs = at->nargs; + if (nargs < 0 && type && at->changes & 2 && !at->defined) + --proc_protochanges; + if (at->dnargs >= 0 && zap != 2) + type = 0; + if (nargs < 0) { /* inconsistent usage seen */ + if (type) + goto newlist; + return; + } + atypes = at->atypes; + i = nchargs; + for(nbad = 0; t < te; atypes++) { + if (++i > nargs) { + toomany: + i = nchargs + i0; + for(cp = arglist; cp; cp = cp->nextp) + i++; + toofew: + switch(zap) { + case 2: zap = 6; break; + case 1: if (at->defined & 4) + return; + } + sprintf(buf, + "%s%.90s:\n\there %d, previously %d args and string lengths.", + inconsist, fname, i, nargs); + atype_squawk(at, buf); + if (type) { + t = init_ap[type]; + goto newlist; + } + return; + } + j = atypes->type; + k = *t++; + if (j != k && j-400 != k) { + cp = 0; + goto badtypes; + } + } + for(cp = arglist; cp; atypes++, cp = cp->nextp) { + if (++i > nargs) + goto toomany; + j = atypes->type; + if (!(q = (expptr)cp->datap)) + continue; + k = typekludge(ccall, q, atypes, j); + if (k >= 300 || k == j) + continue; + if (j >= 300) { + if (k >= 200) { + if (k == TYUNKNOWN + 200) + continue; + if (j % 100 != k - 200 + && k != TYSUBR + 200 + && j != TYUNKNOWN + 300 + && !type_fixup(at,atypes,k)) + goto badtypes; + } + else if (j % 100 % TYSUBR != k % TYSUBR + && !type_fixup(at,atypes,k)) + goto badtypes; + } + else if (k < 200 || j < 200) + if (j) { + if (k == TYUNKNOWN + && q->tag == TNAME + && q->nameblock.vinfproc) { + q->nameblock.vdcldone = 0; + impldcl((Namep)q); + } + goto badtypes; + } + else ; /* fall through to update */ + else if (k == TYUNKNOWN+200) + continue; + else if (j != TYUNKNOWN+200) + { + badtypes: + if (++nbad == 1) + bad_atypes(at, fname, i - nchargs, + j, k, "here ", ", previously"); + else + fprintf(stderr, + "\targ %d: here %s, previously %s.\n", + i - nchargs, Argtype(k,buf1), + Argtype(j,buf2)); + if (!cp) + break; + continue; + } + /* We've subsequently learned the right type, + as in the call on zoo below... + + subroutine foo(x, zap) + external zap + call goo(zap) + x = zap(3) + call zoo(zap) + end + */ + if (!nbad) { + atypes->type = k; + at->changes |= 1; + } + } + if (i < nargs) + goto toofew; + if (nbad) { + if (type) { + /* we're defining the procedure */ + t = init_ap[type]; + te = t + i0; + proc_argchanges = 1; + goto newlist; + } + return; + } + if (zap == 1 && (at->changes & 5) != 5) + at->changes = 0; + return; + } + newlist: + i = i0 + nchargs; + for(cp = arglist; cp; cp = cp->nextp) + i++; + k = sizeof(Argtypes) + (i-1)*sizeof(Atype); + *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1) + : (Argtypes *) mem(k,1); + at->dnargs = at->nargs = i; + at->defined = zap & 6; + at->changes = type ? 0 : 4; + atypes = at->atypes; + for(; t < te; atypes++) { + atypes->type = *t++; + atypes->cp = 0; + } + for(cp = arglist; cp; atypes++, cp = cp->nextp) { + atypes->cp = 0; + atypes->type = (q = (expptr)cp->datap) + ? typekludge(ccall, q, atypes, 0) + : 0; + } + for(; --nchargs >= 0; atypes++) { + atypes->type = TYFTNLEN + 100; + atypes->cp = 0; + } + } + + static char* +#ifdef KR_headers +get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1; +#else +get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1) +#endif +{ + Addrp a; + Argtypes **at0, **at1; + Namep np; + Extsym *e; + char *fname; + + a = (Addrp)p->leftp; + switch(a->vstg) { + case STGEXT: + switch(a->uname_tag) { + case UNAM_EXTERN: /* e.g., sqrt() */ + e = extsymtab + a->memno; + at0 = at1 = &e->arginfo; + fname = e->fextname; + break; + case UNAM_NAME: + np = a->user.name; + at0 = &extsymtab[np->vardesc.varno].arginfo; + at1 = &np->arginfo; + fname = np->fvarname; + break; + default: + goto bug; + } + break; + case STGARG: + if (a->uname_tag != UNAM_NAME) + goto bug; + np = a->user.name; + at0 = at1 = &np->arginfo; + fname = np->fvarname; + break; + default: + bug: + Fatal("Confusion in saveargtypes"); + } + *pat0 = at0; + *pat1 = at1; + return fname; + } + + void +#ifdef KR_headers +saveargtypes(p) + register Exprp p; +#else +saveargtypes(register Exprp p) +#endif + /* for writing prototypes */ +{ + Argtypes **at0, **at1; + chainp arglist; + expptr rp; + char *fname; + + fname = get_argtypes(p, &at0, &at1); + rp = p->rightp; + arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0; + save_argtypes(arglist, at0, at1, p->opcode == OPCCALL, + fname, p->leftp->addrblock.vstg, 0, 0, 0); + } + +/* putcall - fix up the argument list, and write out the invocation. p + is expected to be initialized and point to an OPCALL or OPCCALL + expression. The return value is a pointer to a temporary holding the + result of a COMPLEX or CHARACTER operation, or NULL. */ + + LOCAL expptr +#ifdef KR_headers +putcall(p0, temp) + expptr p0; + Addrp *temp; +#else +putcall(expptr p0, Addrp *temp) +#endif +{ + register Exprp p = (Exprp)p0; + chainp arglist; /* Pointer to actual arguments, if any */ + chainp charsp; /* List of copies of the variables which + hold the lengths of character + parameters (other than procedure + parameters) */ + chainp cp; /* Iterator over argument lists */ + register expptr q; /* Pointer to the current argument */ + Addrp fval; /* Function return value */ + int type; /* type of the call - presumably this was + set elsewhere */ + int byvalue; /* True iff we don't want to massage the + parameter list, since we're calling a C + library routine */ + char *s; + Argtypes *at, **at0, **at1; + Atype *At, *Ate; + + type = p -> vtype; + charsp = NULL; + byvalue = (p->opcode == OPCCALL); + +/* Verify the actual parameters */ + + if (p == (Exprp) NULL) + err ("putcall: NULL call expression"); + else if (p -> tag != TEXPR) + erri ("putcall: expected TEXPR, got '%d'", p -> tag); + +/* Find the argument list */ + + if(p->rightp && p -> rightp -> tag == TLIST) + arglist = p->rightp->listblock.listp; + else + arglist = NULL; + +/* Count the number of explicit arguments, including lengths of character + variables */ + + if (!byvalue) { + get_argtypes(p, &at0, &at1); + At = Ate = 0; + if ((at = *at0) && at->nargs >= 0) { + At = at->atypes; + Ate = At + at->nargs; + At += init_ac[type]; + } + for(cp = arglist ; cp ; cp = cp->nextp) { + q = (expptr) cp->datap; + if( ISCONST(q) ) { + +/* Even constants are passed by reference, so we need to put them in the + literal table */ + + q = (expptr) putconst((Constp)q); + cp->datap = (char *) q; + } + +/* Save the length expression of character variables (NOT character + procedures) for the end of the argument list */ + + if( ISCHAR(q) && + (q->headblock.vclass != CLPROC + || q->headblock.vstg == STGARG + && q->tag == TADDR + && q->addrblock.uname_tag == UNAM_NAME + && q->addrblock.user.name->vprocclass == PTHISPROC) + && (!At || At->type % 100 % TYSUBR == TYCHAR)) + { + p0 = cpexpr(q->headblock.vleng); + charsp = mkchain((char *)p0, charsp); + if (q->headblock.vclass == CLUNKNOWN + && q->headblock.vstg == STGARG) + q->addrblock.user.name->vpassed = 1; + else if (q->tag == TADDR + && q->addrblock.uname_tag == UNAM_CONST) + p0->constblock.Const.ci + += q->addrblock.user.Const.ccp1.blanks; + } + if (At && ++At == Ate) + At = 0; + } + } + charsp = revchain(charsp); + +/* If the routine is a CHARACTER function ... */ + + if(type == TYCHAR) + { + if( ISICON(p->vleng) ) + { + +/* Allocate a temporary to hold the return value of the function */ + + fval = mktmp(TYCHAR, p->vleng); + } + else { + err("adjustable character function"); + if (temp) + *temp = 0; + return 0; + } + } + +/* If the routine is a COMPLEX function ... */ + + else if( ISCOMPLEX(type) ) + fval = mktmp(type, ENULL); + else + fval = NULL; + +/* Write the function name, without taking its address */ + + p -> leftp = putx(fixtype(putaddr(p->leftp))); + + if(fval) + { + chainp prepend; + +/* Prepend a copy of the function return value buffer out as the first + argument. */ + + prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist); + +/* If it's a character function, also prepend the length of the result */ + + if(type==TYCHAR) + { + + prepend->nextp = mkchain((char *)putx(mkconv(TYLENG, + p->vleng)), arglist); + } + if (!(q = p->rightp)) + p->rightp = q = (expptr)mklist(CHNULL); + q->listblock.listp = prepend; + } + +/* Scan through the fortran argument list */ + + for(cp = arglist ; cp ; cp = cp->nextp) + { + q = (expptr) (cp->datap); + if (q == ENULL) + err ("putcall: NULL argument"); + +/* call putaddr only when we've got a parameter for a C routine or a + memory resident parameter */ + + if (q -> tag == TCONST && !byvalue) + q = (expptr) putconst ((Constp)q); + + if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) { + if (q->addrblock.parenused + && !byvalue && q->headblock.vtype != TYCHAR) + goto make_copy; + cp->datap = (char *)putaddr(q); + } + else if( ISCOMPLEX(q->headblock.vtype) ) + cp -> datap = (char *) putx (fixtype(putcxop(q))); + else if (ISCHAR(q) ) + cp -> datap = (char *) putx (fixtype((expptr)putchop(q))); + else if( ! ISERROR(q) ) + { + if(byvalue) { + if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) { + if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype) + && q->exprblock.leftp->tag == TEXPR) + q->exprblock.leftp = putcxop(q->exprblock.leftp); + else + q->exprblock.leftp = putx(q->exprblock.leftp); + } + else + cp -> datap = (char *) putx(q); + } + else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST) + cp -> datap = (char *) putx(q); + else { + expptr t, t1; + +/* If we've got a register parameter, or (maybe?) a constant, save it in a + temporary first */ + make_copy: + t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng); + +/* Assign to temporary variables before invoking the subroutine or + function */ + + t1 = putassign( cpexpr(t), q ); + if (doin_setbound) + t = mkexpr(OPCOMMA_ARG, t1, t); + else + putout(t1); + cp -> datap = (char *) t; + } /* else */ + } /* if !ISERROR(q) */ + } + +/* Now adjust the lengths of the CHARACTER parameters */ + + for(cp = charsp ; cp ; cp = cp->nextp) + cp->datap = (char *)addrfix(putx( + /* in case MAIN has a character*(*)... */ + (s = cp->datap) ? mkconv(TYLENG,(expptr)s) + : ICON(0))); + +/* ... and add them to the end of the argument list */ + + hookup (arglist, charsp); + +/* Return the name of the temporary used to hold the results, if any was + necessary. */ + + if (temp) *temp = fval; + else frexpr ((expptr)fval); + + saveargtypes(p); + + return (expptr) p; +} + + static expptr +#ifdef KR_headers +foldminmax(op, type, p) int op; int type; chainp p; +#else +foldminmax(int op, int type, chainp p) +#endif +{ + Constp c, c1; + ftnint i, i1; + double d, d1; + int dstg, d1stg; + char *s, *s1; + + c = ALLOC(Constblock); + c->tag = TCONST; + c->vtype = type; + s = s1 = 0; + + switch(type) { + case TYREAL: + case TYDREAL: + c1 = (Constp)p->datap; + d = ISINT(c1->vtype) ? (double)c1->Const.ci + : c1->vstg ? atof(c1->Const.cds[0]) : c1->Const.cd[0]; + dstg = 0; + if (ISINT(c1->vtype)) + d = (double)c1->Const.ci; + else if (dstg = c1->vstg) + d = atof(s = c1->Const.cds[0]); + else + d = c1->Const.cd[0]; + while(p = p->nextp) { + c1 = (Constp)p->datap; + d1stg = 0; + if (ISINT(c1->vtype)) + d1 = (double)c1->Const.ci; + else if (d1stg = c1->vstg) + d1 = atof(s1 = c1->Const.cds[0]); + else + d1 = c1->Const.cd[0]; + if (op == OPMIN) { + if (d > d1) + goto d1copy; + } + else if (d < d1) { + d1copy: + d = d1; + dstg = d1stg; + s = s1; + } + } + if (c->vstg = dstg) + c->Const.cds[0] = s; + else + c->Const.cd[0] = d; + break; + default: + i = ((Constp)p->datap)->Const.ci; + while(p = p->nextp) { + i1 = ((Constp)p->datap)->Const.ci; + if (op == OPMIN) { + if (i > i1) + i = i1; + } + else if (i < i1) + i = i1; + } + c->Const.ci = i; + } + return (expptr)c; + } + +/* putmnmx -- Put min or max. p must point to an EXPR, not just a + CONST */ + + LOCAL expptr +#ifdef KR_headers +putmnmx(p) + register expptr p; +#else +putmnmx(register expptr p) +#endif +{ + int op, op2, type; + expptr arg, qp, temp; + chainp p0, p1; + Addrp sp, tp; + char comment_buf[80]; + char *what; + + if(p->tag != TEXPR) + badtag("putmnmx", p->tag); + + type = p->exprblock.vtype; + op = p->exprblock.opcode; + op2 = op == OPMIN ? OPMIN2 : OPMAX2; + p0 = p->exprblock.leftp->listblock.listp; + free( (charptr) (p->exprblock.leftp) ); + free( (charptr) p ); + + /* for param statements, deal with constant expressions now */ + + for(p1 = p0;; p1 = p1->nextp) { + if (!p1) { + /* all constants */ + p = foldminmax(op, type, p0); + frchain(&p0); + return p; + } + else if (!ISCONST(((expptr)p1->datap))) + break; + } + + /* special case for two addressable operands */ + + if (addressable((expptr)p0->datap) + && (p1 = p0->nextp) + && addressable((expptr)p1->datap) + && !p1->nextp) { + if (type == TYREAL && forcedouble) + op2 = op == OPMIN ? OPDMIN : OPDMAX; + p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)), + mkconv(type, cpexpr((expptr)p1->datap))); + frchain(&p0); + return p; + } + + /* general case */ + + sp = mktmp(type, ENULL); + +/* We only need a second temporary if the arg list has an unaddressable + value */ + + tp = (Addrp) NULL; + qp = ENULL; + for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp) + if (!addressable ((expptr) p1 -> datap)) { + tp = mktmp(type, ENULL); + qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp)); + qp = fixexpr((Exprp)qp); + break; + } /* if */ + +/* Now output the appropriate number of assignments and comparisons. Min + and max are implemented by the simple O(n) algorithm: + + min (a, b, c, d) ==> + { t1, t2; + + t1 = a; + t2 = b; t1 = (t1 < t2) ? t1 : t2; + t2 = c; t1 = (t1 < t2) ? t1 : t2; + t2 = d; t1 = (t1 < t2) ? t1 : t2; + } +*/ + + if (!doin_setbound) { + switch(op) { + case OPLT: + case OPMIN: + case OPDMIN: + case OPMIN2: + what = "IN"; + break; + default: + what = "AX"; + } + sprintf (comment_buf, "Computing M%s", what); + p1_comment (comment_buf); + } + + p1 = p0->nextp; + temp = (expptr)p0->datap; + if (addressable(temp) && addressable((expptr)p1->datap)) { + p = mkconv(type, cpexpr(temp)); + arg = mkconv(type, cpexpr((expptr)p1->datap)); + temp = mkexpr(op2, p, arg); + if (!ISCONST(temp)) + temp = fixexpr((Exprp)temp); + p1 = p1->nextp; + } + p = putassign (cpexpr((expptr)sp), temp); + + for(; p1 ; p1 = p1->nextp) + { + if (addressable ((expptr) p1 -> datap)) { + arg = mkconv(type, cpexpr((expptr)p1->datap)); + temp = mkexpr(op2, cpexpr((expptr)sp), arg); + temp = fixexpr((Exprp)temp); + } else { + temp = (expptr) cpexpr (qp); + p = mkexpr(OPCOMMA, p, + putassign(cpexpr((expptr)tp), (expptr)p1->datap)); + } /* else */ + + if(p1->nextp) + p = mkexpr(OPCOMMA, p, + putassign(cpexpr((expptr)sp), temp)); + else { + if (type == TYREAL && forcedouble) + temp->exprblock.opcode = + op == OPMIN ? OPDMIN : OPDMAX; + if (doin_setbound) + p = mkexpr(OPCOMMA, p, temp); + else { + putout (p); + p = putx(temp); + } + if (qp) + frexpr (qp); + } /* else */ + } /* for */ + + frchain( &p0 ); + return p; +} + + + void +#ifdef KR_headers +putwhile(p) + expptr p; +#else +putwhile(expptr p) +#endif +{ + int k, n; + + if (wh_next >= wh_last) + { + k = wh_last - wh_first; + n = k + 100; + wh_next = mem(n,0); + wh_last = wh_first + n; + if (k) + memcpy(wh_next, wh_first, k); + wh_first = wh_next; + wh_next += k; + wh_last = wh_first + n; + } + if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype))) + { + if(k != TYERROR) + err("non-logical expression in DO WHILE statement"); + } + else { + p = putx(p); + *wh_next++ = ftell(pass1_file) > p1_where; + p1put(P1_WHILE2START); + p1_expr(p); + } + } + + void +#ifdef KR_headers +westart(elseif) int elseif; +#else +westart(int elseif) +#endif +{ + static int we[2] = { P1_WHILE1START, P1_ELSEIFSTART }; + p1put(we[elseif]); + p1_where = ftell(pass1_file); + } diff --git a/unix/f2c/src/sysdep.c b/unix/f2c/src/sysdep.c new file mode 100644 index 00000000..ab5b04ee --- /dev/null +++ b/unix/f2c/src/sysdep.c @@ -0,0 +1,699 @@ +/**************************************************************** +Copyright 1990 - 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ +#include "defs.h" +#include "usignal.h" + +char binread[] = "rb", textread[] = "r"; +char binwrite[] = "wb", textwrite[] = "w"; +char *c_functions = "c_functions"; +char *coutput = "c_output"; +char *initfname = "raw_data"; +char *initbname = "raw_data.b"; +char *blkdfname = "block_data"; +char *p1_file = "p1_file"; +char *p1_bakfile = "p1_file.BAK"; +char *sortfname = "init_file"; +char *proto_fname = "proto_file"; + +char link_msg[] = "on Microsoft Windows system, link with libf2c.lib;\n\ + on Linux or Unix systems, link with .../path/to/libf2c.a -lm\n\ + or, if you install libf2c.a in a standard place, with -lf2c -lm\n\ + -- in that order, at the end of the command line, as in\n\ + cc *.o -lf2c -lm\n\ + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,\n\n\ + http://www.netlib.org/f2c/libf2c.zip"; + +char *outbuf = "", *outbtail; + +#undef WANT_spawnvp +#ifdef MSDOS +#ifndef NO_spawnvp +#define WANT_spawnvp +#endif +#endif + +#ifdef _WIN32 +#include /* for GetVolumeInformation */ +#undef WANT_spawnvp +#define WANT_spawnvp +#undef MSDOS +#define MSDOS +#endif + +#ifdef WANT_spawnvp +#include +#ifndef _P_WAIT +#define _P_WAIT P_WAIT /* Symantec C/C++ */ +#endif +static char **spargv, **pfname; +#endif + +char *tmpdir = ""; + +#ifdef __cplusplus +#define Cextern extern "C" +extern "C" { + static void flovflo(int), killed(int); + static int compare(const void *a, const void *b); +} +#else +#define Cextern extern +#endif + +Cextern int unlink Argdcl((const char *)); +Cextern int fork Argdcl((void)), getpid Argdcl((void)), wait Argdcl((int*)); + + void +#ifdef KR_headers +Un_link_all(cdelete) + int cdelete; +#else +Un_link_all(int cdelete) +#endif +{ + if (!debugflag) { + unlink(c_functions); + unlink(initfname); + unlink(p1_file); + unlink(sortfname); + unlink(blkdfname); + if (cdelete && coutput) + unlink(coutput); + } + } + +#ifndef NO_TEMPDIR + static void +rmtdir(Void) +{ + char *s; + if (*(s = tmpdir)) { + tmpdir = ""; + rmdir(s); + } + } +#endif /*NO_TEMPDIR*/ + +#ifndef MSDOS +#include "sysdep.hd" +#ifndef NO_MKDTEMP +#include /* for mkdtemp */ +#endif +#endif + + static void +alloc_names(Void) +{ + int k = strlen(tmpdir) + 24; + c_functions = (char *)ckalloc(7*k); + initfname = c_functions + k; + initbname = initfname + k; + blkdfname = initbname + k; + p1_file = blkdfname + k; + p1_bakfile = p1_file + k; + sortfname = p1_bakfile + k; + } + + void +set_tmp_names(Void) +{ +#ifdef MSDOS + char buf[64], *s, *t; +#ifdef _WIN32 + DWORD flags, maxlen, volser; + char volname[512], f2c[24], fsname[512], *name1; + int i; + + if (debugflag == 1) + return; + i = sprintf(f2c, "%x", _getpid()); + if (!GetVolumeInformation(NULL, volname, sizeof(volname), &volser, &maxlen, + &flags, fsname, sizeof(fsname)) + || maxlen < i+8) /* FAT16 */ + strcpy(f2c, "f2c_"); +#else + static char f2c[] = "f2c_"; + if (debugflag == 1) + return; +#endif + + if (!*tmpdir || *tmpdir == '.' && !tmpdir[1]) + t = ""; + else { + /* substitute \ for / to avoid confusion with a + * switch indicator in the system("sort ...") + * call in formatdata.c + */ + for(s = tmpdir, t = buf; *s; s++, t++) + if ((*t = *s) == '/') + *t = '\\'; + if (t[-1] != '\\') + *t++ = '\\'; + *t = 0; + t = buf; + } + alloc_names(); + sprintf(c_functions, "%s%sfunc", t, f2c); + sprintf(initfname, "%s%srd", t, f2c); + sprintf(blkdfname, "%s%sblkd", t, f2c); + sprintf(p1_file, "%s%sp1f", t, f2c); + sprintf(p1_bakfile, "%s%sp1fb", t, f2c); + sprintf(sortfname, "%s%ssort", t, f2c); +#else /*!MSDOS*/ + long pid; + +#define L_TDNAME 20 +#ifdef NO_MKDTEMP +#ifdef NO_MKSTEMP +#undef L_TDNAME +#define L_TDNAME L_tmpnam +#endif +#endif + static char tdbuf[L_TDNAME]; + + if (debugflag == 1) + return; + pid = getpid(); + if (!*tmpdir) { +#ifdef NO_TEMPDIR + tmpdir = "/tmp"; +#else +#ifdef NO_MKDTEMP +#ifdef NO_MKSTEMP + if (!(tmpdir = tmpnam(tdbuf))) { + fprintf(stderr, "tmpnam failed (for -T)\n"); + exit(1); + } +#else + int f; + strcpy(tdbuf, "/tmp/f2ctd_XXXXXX"); + f = mkstemp(tdbuf); + if (f >= 0) { + close(f); + remove(tmpdir = tdbuf); + } + else { + fprintf(stderr, "mkstemp failed (for -T)\n"); + exit(1); + } +#endif /*NO_MKSTEMP*/ + if (mkdir(tdbuf,0700)) { + fprintf(stderr, "mkdir failed (for -T)\n"); + exit(1); + } +#else /*!NO_MKDTEMP*/ + strcpy(tdbuf, "/tmp/f2ctd_XXXXXX"); + if (!(tmpdir = mkdtemp(tdbuf))) { + fprintf(stderr, "mkdtemp failed (for -T)\n"); + exit(1); + } +#endif /*NO_MKDTEMP*/ + if (!debugflag) + atexit(rmtdir); +#endif /*NO_TEMPDIR*/ + } + alloc_names(); + sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid); + sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid); + sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid); + sprintf(p1_file, "%s/f2c%ld_p1f", tmpdir, pid); + sprintf(p1_bakfile, "%s/f2c%ld_p1fb", tmpdir, pid); + sprintf(sortfname, "%s/f2c%ld_sort", tmpdir, pid); +#endif /*MSDOS*/ + sprintf(initbname, "%s.b", initfname); + if (debugflag) + fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions, + initfname, blkdfname, p1_file, p1_bakfile, sortfname); + } + + char * +#ifdef KR_headers +c_name(s, ft) + char *s; + int ft; +#else +c_name(char *s, int ft) +#endif +{ + char *b, *s0; + int c; + + b = s0 = s; + while(c = *s++) + if (c == '/') + b = s; + if (--s < s0 + 3 || s[-2] != '.' + || ((c = *--s) != 'f' && c != 'F')) { + infname = s0; + Fatal("file name must end in .f or .F"); + } + strcpy(outbtail, b); + outbtail[s-b] = ft; + b = copys(outbuf); + return b; + } + + static void +#ifdef KR_headers +killed(sig) + int sig; +#else +killed(int sig) +#endif +{ + sig = sig; /* shut up warning */ + signal(SIGINT, SIG_IGN); +#ifdef SIGQUIT + signal(SIGQUIT, SIG_IGN); +#endif +#ifdef SIGHUP + signal(SIGHUP, SIG_IGN); +#endif + signal(SIGTERM, SIG_IGN); + Un_link_all(1); + exit(126); + } + + static void +#ifdef KR_headers +sig1catch(sig) + int sig; +#else +sig1catch(int sig) +#endif +{ + sig = sig; /* shut up warning */ + if (signal(sig, SIG_IGN) != SIG_IGN) + signal(sig, killed); + } + + static void +#ifdef KR_headers +flovflo(sig) + int sig; +#else +flovflo(int sig) +#endif +{ + sig = sig; /* shut up warning */ + Fatal("floating exception during constant evaluation; cannot recover"); + /* vax returns a reserved operand that generates + an illegal operand fault on next instruction, + which if ignored causes an infinite loop. + */ + signal(SIGFPE, flovflo); +} + + void +#ifdef KR_headers +sigcatch(sig) + int sig; +#else +sigcatch(int sig) +#endif +{ + sig = sig; /* shut up warning */ + sig1catch(SIGINT); +#ifdef SIGQUIT + sig1catch(SIGQUIT); +#endif +#ifdef SIGHUP + sig1catch(SIGHUP); +#endif + sig1catch(SIGTERM); + signal(SIGFPE, flovflo); /* catch overflows */ + } + +/* argkludge permits wild-card expansion and caching of the original or expanded */ +/* argv to kludge around the lack of fork() and exec() when necessary. */ + + void +#ifdef KR_headers +argkludge(pargc, pargv) int *pargc; char ***pargv; +#else +argkludge(int *pargc, char ***pargv) +#endif +{ +#ifdef WANT_spawnvp + size_t L, L1; + int argc, i, nf; + char **a, **argv, *s, *t, *t0; + + /* Assume wild-card expansion has been done by Microsoft's setargv.obj */ + + /* Count Fortran input files. */ + + L = argc = *pargc; + argv = *pargv; + for(i = nf = 0; i < argc; i++) { + L += L1 = strlen(s = argv[i]); + if (L1 > 2 && s[L1-2] == '.') + switch(s[L1-1]) { + case 'f': + case 'F': + nf++; + } + } + if (nf <= 1) + return; + + /* Cache inputs */ + + i = argc - nf + 2; + a = spargv = (char**)Alloc(i*sizeof(char*) + L); + t = (char*)(a + i); + for(i = 0; i < argc; i++) { + *a++ = t0 = t; + for(s = argv[i]; *t++ = *s; s++); + if (t-t0 > 3 && s[-2] == '.') + switch(s[-1]) { + case 'f': + case 'F': + --a; + t = t0; + } + } + pfname = a++; + *a = 0; +#endif + } + + int +#ifdef KR_headers +dofork(fname) char *fname; +#else +dofork(char *fname) +#endif +{ + extern int retcode; +#ifdef MSDOS +#ifdef WANT_spawnvp + *pfname = fname; + retcode |= _spawnvp(_P_WAIT, spargv[0], (char const*const*)spargv); +#else /*_WIN32*/ + Fatal("Only one Fortran input file allowed under MS-DOS"); +#endif /*_WIN32*/ +#else + int pid, status, w; + + if (!(pid = fork())) + return 1; + if (pid == -1) + Fatal("bad fork"); + while((w = wait(&status)) != pid) + if (w == -1) + Fatal("bad wait code"); + retcode |= status >> 8; +#endif + return 0; + } + +/* Initialization of tables that change with the character set... */ + +char escapes[Table_size]; + +#ifdef non_ASCII +char *str_fmt[Table_size]; +static char *str0fmt[127] = { /*}*/ +#else +char *str_fmt[Table_size] = { +#endif + "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007", + "\\b", "\\t", "\\n", "\\013", "\\f", "\\r", "\\016", "\\017", + "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027", + "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037", + " ", "!", "\\\"", "#", "$", "%%", "&", "'", + "(", ")", "*", "+", ",", "-", ".", "/", + "0", "1", "2", "3", "4", "5", "6", "7", + "8", "9", ":", ";", "<", "=", ">", "?", + "@", "A", "B", "C", "D", "E", "F", "G", + "H", "I", "J", "K", "L", "M", "N", "O", + "P", "Q", "R", "S", "T", "U", "V", "W", + "X", "Y", "Z", "[", "\\\\", "]", "^", "_", + "`", "a", "b", "c", "d", "e", "f", "g", + "h", "i", "j", "k", "l", "m", "n", "o", + "p", "q", "r", "s", "t", "u", "v", "w", + "x", "y", "z", "{", "|", "}", "~" + }; + +#ifdef non_ASCII +char *chr_fmt[Table_size]; +static char *chr0fmt[127] = { /*}*/ +#else +char *chr_fmt[Table_size] = { +#endif + "\\0", "\\1", "\\2", "\\3", "\\4", "\\5", "\\6", "\\7", + "\\b", "\\t", "\\n", "\\13", "\\f", "\\r", "\\16", "\\17", + "\\20", "\\21", "\\22", "\\23", "\\24", "\\25", "\\26", "\\27", + "\\30", "\\31", "\\32", "\\33", "\\34", "\\35", "\\36", "\\37", + " ", "!", "\"", "#", "$", "%%", "&", "\\'", + "(", ")", "*", "+", ",", "-", ".", "/", + "0", "1", "2", "3", "4", "5", "6", "7", + "8", "9", ":", ";", "<", "=", ">", "?", + "@", "A", "B", "C", "D", "E", "F", "G", + "H", "I", "J", "K", "L", "M", "N", "O", + "P", "Q", "R", "S", "T", "U", "V", "W", + "X", "Y", "Z", "[", "\\\\", "]", "^", "_", + "`", "a", "b", "c", "d", "e", "f", "g", + "h", "i", "j", "k", "l", "m", "n", "o", + "p", "q", "r", "s", "t", "u", "v", "w", + "x", "y", "z", "{", "|", "}", "~" + }; + + void +fmt_init(Void) +{ + static char *str1fmt[6] = + { "\\b", "\\t", "\\n", "\\f", "\\r", "\\013" }; + register int i, j; + register char *s; + + /* str_fmt */ + +#ifdef non_ASCII + i = 0; +#else + i = 127; +#endif + s = Alloc(5*(Table_size - i)); + for(; i < Table_size; i++) { + sprintf(str_fmt[i] = s, "\\%03o", i); + s += 5; + } +#ifdef non_ASCII + for(i = 32; i < 127; i++) { + s = str0fmt[i]; + str_fmt[*(unsigned char *)s] = s; + } + str_fmt['"'] = "\\\""; +#else + if (Ansi == 1) + str_fmt[7] = chr_fmt[7] = "\\a"; +#endif + + /* chr_fmt */ + +#ifdef non_ASCII + for(i = 0; i < 32; i++) + chr_fmt[i] = chr0fmt[i]; +#else + i = 127; +#endif + for(; i < Table_size; i++) + chr_fmt[i] = "\\%o"; +#ifdef non_ASCII + for(i = 32; i < 127; i++) { + s = chr0fmt[i]; + j = *(unsigned char *)s; + if (j == '\\') + j = *(unsigned char *)(s+1); + chr_fmt[j] = s; + } +#endif + + /* escapes (used in lex.c) */ + + for(i = 0; i < Table_size; i++) + escapes[i] = i; + for(s = "btnfr0", i = 0; i < 6; i++) + escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i]; + /* finish str_fmt and chr_fmt */ + + if (Ansi) + str1fmt[5] = "\\v"; + if ('\v' == 'v') { /* ancient C compiler */ + str1fmt[5] = "v"; +#ifndef non_ASCII + escapes['v'] = 11; +#endif + } + else + escapes['v'] = '\v'; + for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;) + str_fmt[j] = chr_fmt[j] = str1fmt[i++]; + /* '\v' = 11 for both EBCDIC and ASCII... */ + chr_fmt[11] = (char*)(Ansi ? "\\v" : "\\13"); + } + + void +outbuf_adjust(Void) +{ + int n, n1; + char *s; + + n = n1 = strlen(outbuf); + if (*outbuf && outbuf[n-1] != '/') + n1++; + s = Alloc(n+64); + outbtail = s + n1; + strcpy(s, outbuf); + if (n != n1) + strcpy(s+n, "/"); + outbuf = s; + } + + +/* Unless SYSTEM_SORT is defined, the following gives a simple + * in-core version of dsort(). On Fortran source with huge DATA + * statements, the in-core version may exhaust the available memory, + * in which case you might either recompile this source file with + * SYSTEM_SORT defined (if that's reasonable on your system), or + * replace the dsort below with a more elaborate version that + * does a merging sort with the help of auxiliary files. + */ + +#ifdef SYSTEM_SORT + + int +#ifdef KR_headers +dsort(from, to) + char *from; + char *to; +#else +dsort(char *from, char *to) +#endif +{ + char buf[200]; + sprintf(buf, "sort <%s >%s", from, to); + return system(buf) >> 8; + } +#else + + static int +#ifdef KR_headers + compare(a,b) + char *a, *b; +#else + compare(const void *a, const void *b) +#endif +{ return strcmp(*(char **)a, *(char **)b); } + + int +#ifdef KR_headers +dsort(from, to) + char *from; + char *to; +#else +dsort(char *from, char *to) +#endif +{ + struct Memb { + struct Memb *next; + int n; + char buf[32000]; + }; + typedef struct Memb memb; + memb *mb, *mb1; + register char *x, *x0, *xe; + register int c, n; + FILE *f; + char **z, **z0; + int nn = 0; + + f = opf(from, textread); + mb = (memb *)Alloc(sizeof(memb)); + mb->next = 0; + x0 = x = mb->buf; + xe = x + sizeof(mb->buf); + n = 0; + for(;;) { + c = getc(f); + if (x >= xe && (c != EOF || x != x0)) { + if (!n) + return 126; + nn += n; + mb->n = n; + mb1 = (memb *)Alloc(sizeof(memb)); + mb1->next = mb; + mb = mb1; + memcpy(mb->buf, x0, n = x-x0); + x0 = mb->buf; + x = x0 + n; + xe = x0 + sizeof(mb->buf); + n = 0; + } + if (c == EOF) + break; + if (c == '\n') { + ++n; + *x++ = 0; + x0 = x; + } + else + *x++ = c; + } + clf(&f, from, 1); + f = opf(to, textwrite); + if (x > x0) { /* shouldn't happen */ + *x = 0; + ++n; + } + mb->n = n; + nn += n; + if (!nn) /* shouldn't happen */ + goto done; + z = z0 = (char **)Alloc(nn*sizeof(char *)); + for(mb1 = mb; mb1; mb1 = mb1->next) { + x = mb1->buf; + n = mb1->n; + for(;;) { + *z++ = x; + if (--n <= 0) + break; + while(*x++); + } + } + qsort((char *)z0, nn, sizeof(char *), compare); + for(n = nn, z = z0; n > 0; n--) + fprintf(f, "%s\n", *z++); + free((char *)z0); + done: + clf(&f, to, 1); + do { + mb1 = mb->next; + free((char *)mb); + } + while(mb = mb1); + return 0; + } +#endif diff --git a/unix/f2c/src/sysdep.h b/unix/f2c/src/sysdep.h new file mode 100644 index 00000000..f9b7cbce --- /dev/null +++ b/unix/f2c/src/sysdep.h @@ -0,0 +1,101 @@ +/**************************************************************** +Copyright 1990, 1991, 1994 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* This file is included at the start of defs.h; this file + * is an initial attempt to gather in one place some declarations + * that may need to be tweaked on some systems. + */ + +#ifdef __STDC__ +#undef KR_headers +#endif + +#ifndef KR_headers +#ifndef ANSI_Libraries +#define ANSI_Libraries +#endif +#ifndef ANSI_Prototypes +#define ANSI_Prototypes +#endif +#endif + +#ifdef __BORLANDC__ +#define MSDOS +#endif + +#ifdef __ZTC__ /* Zortech */ +#define MSDOS +#endif + +#ifdef MSDOS +#define ANSI_Libraries +#define ANSI_Prototypes +#define LONG_CAST (long) +#else +#define LONG_CAST +#endif + +#include + +#ifdef ANSI_Libraries +#include +#include +#else +char *calloc(), *malloc(), *realloc(); +void *memcpy(), *memset(); +#ifndef _SIZE_T +typedef unsigned int size_t; +#endif +#ifndef atol + long atol(); +#endif + +#ifdef ANSI_Prototypes +extern double atof(const char *); +extern double strtod(const char*, char**); +#else +extern double atof(), strtod(); +#endif +#endif + +/* On systems like VMS where fopen might otherwise create + * multiple versions of intermediate files, you may wish to + * #define scrub(x) unlink(x) + */ +#ifndef scrub +#define scrub(x) /* do nothing */ +#endif + +/* On systems that severely limit the total size of statically + * allocated arrays, you may need to change the following to + * extern char **chr_fmt, *escapes, **str_fmt; + * and to modify sysdep.c appropriately + */ +extern char *chr_fmt[], escapes[], *str_fmt[]; + +#include + +#include "ctype.h" + +#define Bits_per_Byte 8 +#define Table_size (1 << Bits_per_Byte) diff --git a/unix/f2c/src/sysdep.hd b/unix/f2c/src/sysdep.hd new file mode 100644 index 00000000..e15e92f3 --- /dev/null +++ b/unix/f2c/src/sysdep.hd @@ -0,0 +1 @@ +/*OK*/ diff --git a/unix/f2c/src/sysdeptest.c b/unix/f2c/src/sysdeptest.c new file mode 100644 index 00000000..3c470522 --- /dev/null +++ b/unix/f2c/src/sysdeptest.c @@ -0,0 +1,23 @@ +/* This is never meant to be executed; we just want to check for the */ +/* presence of mkdtemp and mkstemp by whether this links without error. */ + +#include +#include + + int +#ifdef KR_headers +main(argc, argv) int argc; char **argv; +#else +main(int argc, char **argv) +#endif +{ + char buf[16]; + if (argc < 0) { +#ifndef NO_MKDTEMP + mkdtemp(buf); +#else + mkstemp(buf); +#endif + } + return 0; + } diff --git a/unix/f2c/src/tokdefs.h b/unix/f2c/src/tokdefs.h new file mode 100644 index 00000000..35e3d72b --- /dev/null +++ b/unix/f2c/src/tokdefs.h @@ -0,0 +1,100 @@ +#define SEOS 1 +#define SCOMMENT 2 +#define SLABEL 3 +#define SUNKNOWN 4 +#define SHOLLERITH 5 +#define SICON 6 +#define SRCON 7 +#define SDCON 8 +#define SBITCON 9 +#define SOCTCON 10 +#define SHEXCON 11 +#define STRUE 12 +#define SFALSE 13 +#define SNAME 14 +#define SNAMEEQ 15 +#define SFIELD 16 +#define SSCALE 17 +#define SINCLUDE 18 +#define SLET 19 +#define SASSIGN 20 +#define SAUTOMATIC 21 +#define SBACKSPACE 22 +#define SBLOCK 23 +#define SCALL 24 +#define SCHARACTER 25 +#define SCLOSE 26 +#define SCOMMON 27 +#define SCOMPLEX 28 +#define SCONTINUE 29 +#define SDATA 30 +#define SDCOMPLEX 31 +#define SDIMENSION 32 +#define SDO 33 +#define SDOUBLE 34 +#define SELSE 35 +#define SELSEIF 36 +#define SEND 37 +#define SENDFILE 38 +#define SENDIF 39 +#define SENTRY 40 +#define SEQUIV 41 +#define SEXTERNAL 42 +#define SFORMAT 43 +#define SFUNCTION 44 +#define SGOTO 45 +#define SASGOTO 46 +#define SCOMPGOTO 47 +#define SARITHIF 48 +#define SLOGIF 49 +#define SIMPLICIT 50 +#define SINQUIRE 51 +#define SINTEGER 52 +#define SINTRINSIC 53 +#define SLOGICAL 54 +#define SNAMELIST 55 +#define SOPEN 56 +#define SPARAM 57 +#define SPAUSE 58 +#define SPRINT 59 +#define SPROGRAM 60 +#define SPUNCH 61 +#define SREAD 62 +#define SREAL 63 +#define SRETURN 64 +#define SREWIND 65 +#define SSAVE 66 +#define SSTATIC 67 +#define SSTOP 68 +#define SSUBROUTINE 69 +#define STHEN 70 +#define STO 71 +#define SUNDEFINED 72 +#define SWRITE 73 +#define SLPAR 74 +#define SRPAR 75 +#define SEQUALS 76 +#define SCOLON 77 +#define SCOMMA 78 +#define SCURRENCY 79 +#define SPLUS 80 +#define SMINUS 81 +#define SSTAR 82 +#define SSLASH 83 +#define SPOWER 84 +#define SCONCAT 85 +#define SAND 86 +#define SOR 87 +#define SNEQV 88 +#define SEQV 89 +#define SNOT 90 +#define SEQ 91 +#define SLT 92 +#define SGT 93 +#define SLE 94 +#define SGE 95 +#define SNE 96 +#define SENDDO 97 +#define SWHILE 98 +#define SSLASHD 99 +#define SBYTE 100 diff --git a/unix/f2c/src/tokens b/unix/f2c/src/tokens new file mode 100644 index 00000000..07b18816 --- /dev/null +++ b/unix/f2c/src/tokens @@ -0,0 +1,100 @@ +SEOS +SCOMMENT +SLABEL +SUNKNOWN +SHOLLERITH +SICON +SRCON +SDCON +SBITCON +SOCTCON +SHEXCON +STRUE +SFALSE +SNAME +SNAMEEQ +SFIELD +SSCALE +SINCLUDE +SLET +SASSIGN +SAUTOMATIC +SBACKSPACE +SBLOCK +SCALL +SCHARACTER +SCLOSE +SCOMMON +SCOMPLEX +SCONTINUE +SDATA +SDCOMPLEX +SDIMENSION +SDO +SDOUBLE +SELSE +SELSEIF +SEND +SENDFILE +SENDIF +SENTRY +SEQUIV +SEXTERNAL +SFORMAT +SFUNCTION +SGOTO +SASGOTO +SCOMPGOTO +SARITHIF +SLOGIF +SIMPLICIT +SINQUIRE +SINTEGER +SINTRINSIC +SLOGICAL +SNAMELIST +SOPEN +SPARAM +SPAUSE +SPRINT +SPROGRAM +SPUNCH +SREAD +SREAL +SRETURN +SREWIND +SSAVE +SSTATIC +SSTOP +SSUBROUTINE +STHEN +STO +SUNDEFINED +SWRITE +SLPAR +SRPAR +SEQUALS +SCOLON +SCOMMA +SCURRENCY +SPLUS +SMINUS +SSTAR +SSLASH +SPOWER +SCONCAT +SAND +SOR +SNEQV +SEQV +SNOT +SEQ +SLT +SGT +SLE +SGE +SNE +SENDDO +SWHILE +SSLASHD +SBYTE diff --git a/unix/f2c/src/usignal.h b/unix/f2c/src/usignal.h new file mode 100644 index 00000000..ba4ee6ad --- /dev/null +++ b/unix/f2c/src/usignal.h @@ -0,0 +1,7 @@ +#include +#ifndef SIGHUP +#define SIGHUP 1 /* hangup */ +#endif +#ifndef SIGQUIT +#define SIGQUIT 3 /* quit */ +#endif diff --git a/unix/f2c/src/vax.c b/unix/f2c/src/vax.c new file mode 100644 index 00000000..63a7d8c8 --- /dev/null +++ b/unix/f2c/src/vax.c @@ -0,0 +1,585 @@ +/**************************************************************** +Copyright 1990, 1992-1994, 2001 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" +#include "pccdefs.h" +#include "output.h" + +int regnum[] = { + 11, 10, 9, 8, 7, 6 }; + +/* Put out a constant integer */ + + void +#ifdef KR_headers +prconi(fp, n) + FILEP fp; + ftnint n; +#else +prconi(FILEP fp, ftnint n) +#endif +{ + fprintf(fp, "\t%ld\n", n); +} + +#ifndef NO_LONG_LONG + void +#ifdef KR_headers +prconq(fp, n) FILEP fp; Llong n; +#else +prconq(FILEP fp, Llong n) +#endif +{ + fprintf(fp, "\t%lld\n", n); + } +#endif + + +/* Put out a constant address */ + + void +#ifdef KR_headers +prcona(fp, a) + FILEP fp; + ftnint a; +#else +prcona(FILEP fp, ftnint a) +#endif +{ + fprintf(fp, "\tL%ld\n", a); +} + + + void +#ifdef KR_headers +prconr(fp, x, k) + FILEP fp; + Constp x; + int k; +#else +prconr(FILEP fp, Constp x, int k) +#endif +{ + char *x0, *x1; + char cdsbuf0[64], cdsbuf1[64]; + + if (k > 1) { + if (x->vstg) { + x0 = x->Const.cds[0]; + x1 = x->Const.cds[1]; + } + else { + x0 = cds(dtos(x->Const.cd[0]), cdsbuf0); + x1 = cds(dtos(x->Const.cd[1]), cdsbuf1); + } + fprintf(fp, "\t%s %s\n", x0, x1); + } + else + fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0] + : cds(dtos(x->Const.cd[0]), cdsbuf0)); +} + + + char * +#ifdef KR_headers +memname(stg, mem) + int stg; + long mem; +#else +memname(int stg, long mem) +#endif +{ + static char s[20]; + + switch(stg) + { + case STGCOMMON: + case STGEXT: + sprintf(s, "_%s", extsymtab[mem].cextname); + break; + + case STGBSS: + case STGINIT: + sprintf(s, "v.%ld", mem); + break; + + case STGCONST: + sprintf(s, "L%ld", mem); + break; + + case STGEQUIV: + sprintf(s, "q.%ld", mem+eqvstart); + break; + + default: + badstg("memname", stg); + } + return(s); +} + +extern void addrlit Argdcl((Addrp)); + +/* make_int_expr -- takes an arbitrary expression, and replaces all + occurrences of arguments with indirection */ + + expptr +#ifdef KR_headers +make_int_expr(e) + expptr e; +#else +make_int_expr(expptr e) +#endif +{ + chainp listp; + Addrp ap; + expptr e1; + + if (e != ENULL) + switch (e -> tag) { + case TADDR: + if (e->addrblock.isarray) { + if (e1 = e->addrblock.memoffset) + e->addrblock.memoffset = make_int_expr(e1); + } + else if (e->addrblock.vstg == STGARG + || e->addrblock.vstg == STGCOMMON + && e->addrblock.uname_tag == UNAM_NAME + && e->addrblock.user.name->vcommequiv) + e = mkexpr(OPWHATSIN, e, ENULL); + break; + case TEXPR: + e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp); + e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp); + break; + case TLIST: + for(listp = e->listblock.listp; listp; listp = listp->nextp) + if ((ap = (Addrp)listp->datap) + && ap->tag == TADDR + && ap->uname_tag == UNAM_CONST) + addrlit(ap); + break; + default: + break; + } /* switch */ + + return e; +} /* make_int_expr */ + + + +/* prune_left_conv -- used in prolog() to strip type cast away from + left-hand side of parameter adjustments. This is necessary to avoid + error messages from cktype() */ + + expptr +#ifdef KR_headers +prune_left_conv(e) + expptr e; +#else +prune_left_conv(expptr e) +#endif +{ + struct Exprblock *leftp; + + if (e && e -> tag == TEXPR && e -> exprblock.leftp && + e -> exprblock.leftp -> tag == TEXPR) { + leftp = &(e -> exprblock.leftp -> exprblock); + if (leftp -> opcode == OPCONV) { + e -> exprblock.leftp = leftp -> leftp; + free ((charptr) leftp); + } + } + + return e; +} /* prune_left_conv */ + + + static int wrote_comment; + static FILE *comment_file; + + static void +write_comment(Void) +{ + if (!wrote_comment) { + wrote_comment = 1; + nice_printf (comment_file, "/* Parameter adjustments */\n"); + } + } + + static int * +count_args(Void) +{ + register int *ac; + register chainp cp; + register struct Entrypoint *ep; + register Namep q; + + ac = (int *)ckalloc(nallargs*sizeof(int)); + + for(ep = entries; ep; ep = ep->entnextp) + for(cp = ep->arglist; cp; cp = cp->nextp) + if (q = (Namep)cp->datap) + ac[q->argno]++; + return ac; + } + + static int nu, *refs, *used; + static void awalk Argdcl((expptr)); + + static void +#ifdef KR_headers +aawalk(P) + struct Primblock *P; +#else +aawalk(struct Primblock *P) +#endif +{ + chainp p; + expptr q; + + if (P->argsp) + for(p = P->argsp->listp; p; p = p->nextp) { + q = (expptr)p->datap; + if (q->tag != TCONST) + awalk(q); + } + if (P->namep->vtype == TYCHAR) { + if (q = P->fcharp) + awalk(q); + if (q = P->lcharp) + awalk(q); + } + } + + static void +#ifdef KR_headers +afwalk(P) + struct Primblock *P; +#else +afwalk(struct Primblock *P) +#endif +{ + chainp p; + expptr q; + Namep np; + + for(p = P->argsp->listp; p; p = p->nextp) { + q = (expptr)p->datap; + switch(q->tag) { + case TPRIM: + np = q->primblock.namep; + if (np->vknownarg) + if (!refs[np->argno]++) + used[nu++] = np->argno; + if (q->primblock.argsp == 0) { + if (q->primblock.namep->vclass == CLPROC + && q->primblock.namep->vprocclass + != PTHISPROC + || q->primblock.namep->vdim != NULL) + continue; + } + default: + awalk(q); + /* no break */ + case TCONST: + continue; + } + } + } + + static void +#ifdef KR_headers +awalk(e) + expptr e; +#else +awalk(expptr e) +#endif +{ + Namep np; + top: + if (!e) + return; + switch(e->tag) { + default: + badtag("awalk", e->tag); + case TCONST: + case TERROR: + case TLIST: + return; + case TADDR: + if (e->addrblock.uname_tag == UNAM_NAME) { + np = e->addrblock.user.name; + if (np->vknownarg && !refs[np->argno]++) + used[nu++] = np->argno; + } + e = e->addrblock.memoffset; + goto top; + case TPRIM: + np = e->primblock.namep; + if (np->vknownarg && !refs[np->argno]++) + used[nu++] = np->argno; + if (e->primblock.argsp && np->vclass != CLVAR) + afwalk((struct Primblock *)e); + else + aawalk((struct Primblock *)e); + return; + case TEXPR: + awalk(e->exprblock.rightp); + e = e->exprblock.leftp; + goto top; + } + } + + static chainp +#ifdef KR_headers +argsort(p0) + chainp p0; +#else +argsort(chainp p0) +#endif +{ + Namep *args, q, *stack; + int i, nargs, nout, nst; + chainp *d, *da, p, rv, *rvp; + struct Dimblock *dp; + + if (!p0) + return p0; + for(nargs = 0, p = p0; p; p = p->nextp) + nargs++; + args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp) + + 2*sizeof(int))); + memset((char *)args, 0, i); + stack = args + nargs; + d = (chainp *)(stack + nargs); + refs = (int *)(d + nargs); + used = refs + nargs; + + for(p = p0; p; p = p->nextp) { + q = (Namep) p->datap; + args[q->argno] = q; + } + for(p = p0; p; p = p->nextp) { + q = (Namep) p->datap; + if (!(dp = q->vdim)) + continue; + i = dp->ndim; + while(--i >= 0) + awalk(dp->dims[i].dimexpr); + awalk(dp->basexpr); + while(nu > 0) { + refs[i = used[--nu]] = 0; + d[i] = mkchain((char *)q, d[i]); + } + } + for(i = nst = 0; i < nargs; i++) + for(p = d[i]; p; p = p->nextp) + refs[((Namep)p->datap)->argno]++; + while(--i >= 0) + if (!refs[i]) + stack[nst++] = args[i]; + if (nst == nargs) { + rv = p0; + goto done; + } + nout = 0; + rv = 0; + rvp = &rv; + while(nst > 0) { + nout++; + q = stack[--nst]; + *rvp = p = mkchain((char *)q, CHNULL); + rvp = &p->nextp; + da = d + q->argno; + for(p = *da; p; p = p->nextp) + if (!--refs[(q = (Namep)p->datap)->argno]) + stack[nst++] = q; + frchain(da); + } + if (nout < nargs) + for(i = 0; i < nargs; i++) + if (refs[i]) { + q = args[i]; + errstr("Can't adjust %.38s correctly\n\ + due to dependencies among arguments.", + q->fvarname); + *rvp = p = mkchain((char *)q, CHNULL); + rvp = &p->nextp; + frchain(d+i); + } + done: + free((char *)args); + return rv; + } + + void +#ifdef KR_headers +prolog(outfile, p) + FILE *outfile; + register chainp p; +#else +prolog(FILE *outfile, register chainp p) +#endif +{ + int addif, addif0, i, nd; + ftnint size; + int *ac; + register Namep q; + register struct Dimblock *dp; + chainp p0, p1; + + if(procclass == CLBLOCK) + return; + p0 = p; + p1 = p = argsort(p); + wrote_comment = 0; + comment_file = outfile; + ac = 0; + +/* Compute the base addresses and offsets for the array parameters, and + assign these values to local variables */ + + addif = addif0 = nentry > 1; + for(; p ; p = p->nextp) + { + q = (Namep) p->datap; + if(dp = q->vdim) /* if this param is an array ... */ + { + expptr Q, expr; + + /* See whether to protect the following with an if. */ + /* This only happens when there are multiple entries. */ + + nd = dp->ndim - 1; + if (addif0) { + if (!ac) + ac = count_args(); + if (ac[q->argno] == nentry) + addif = 0; + else if (dp->basexpr + || dp->baseoffset->constblock.Const.ci) + addif = 1; + else for(addif = i = 0; i <= nd; i++) + if (dp->dims[i].dimexpr + && (i < nd || !q->vlastdim)) { + addif = 1; + break; + } + if (addif) { + write_comment(); + nice_printf(outfile, "if (%s) {\n", /*}*/ + q->cvarname); + next_tab(outfile); + } + } + for(i = 0 ; i <= nd; ++i) + +/* Store the variable length of each dimension (which is fixed upon + runtime procedure entry) into a local variable */ + + if ((Q = dp->dims[i].dimexpr) + && (i < nd || !q->vlastdim)) { + expr = (expptr)cpexpr(Q); + write_comment(); + out_and_free_statement (outfile, mkexpr (OPASSIGN, + fixtype(cpexpr(dp->dims[i].dimsize)), expr)); + } /* if dp -> dims[i].dimexpr */ + +/* size will equal the size of a single element, or -1 if the type is + variable length character type */ + + size = typesize[ q->vtype ]; + if(q->vtype == TYCHAR) + if( ISICON(q->vleng) ) + size *= q->vleng->constblock.Const.ci; + else + size = -1; + + /* Fudge the argument pointers for arrays so subscripts + * are 0-based. Not done if array bounds are being checked. + */ + if(dp->basexpr) { + +/* Compute the base offset for this procedure */ + + write_comment(); + out_and_free_statement (outfile, mkexpr (OPASSIGN, + cpexpr(fixtype(dp->baseoffset)), + cpexpr(fixtype(dp->basexpr)))); + } /* if dp -> basexpr */ + + if(! checksubs) { + if(dp->basexpr) { + expptr tp; + +/* If the base of this array has a variable adjustment ... */ + + tp = (expptr) cpexpr (dp -> baseoffset); + if(size < 0 || q -> vtype == TYCHAR) + tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng)); + + write_comment(); + tp = mkexpr (OPMINUSEQ, + mkconv (TYADDR, (expptr)p->datap), + mkconv(TYINT, fixtype + (fixtype (tp)))); +/* Avoid type clash by removing the type conversion */ + tp = prune_left_conv (tp); + out_and_free_statement (outfile, tp); + } else if(dp->baseoffset->constblock.Const.ci != 0) { + +/* if the base of this array has a nonzero constant adjustment ... */ + + expptr tp; + + write_comment(); + if(size > 0 && q -> vtype != TYCHAR) { + tp = prune_left_conv (mkexpr (OPMINUSEQ, + mkconv (TYADDR, (expptr)p->datap), + mkconv (TYINT, fixtype + (cpexpr (dp->baseoffset))))); + out_and_free_statement (outfile, tp); + } else { + tp = prune_left_conv (mkexpr (OPMINUSEQ, + mkconv (TYADDR, (expptr)p->datap), + mkconv (TYINT, fixtype + (mkexpr (OPSTAR, cpexpr (dp -> baseoffset), + cpexpr (q -> vleng)))))); + out_and_free_statement (outfile, tp); + } /* else */ + } /* if dp -> baseoffset -> const */ + } /* if !checksubs */ + + if (addif) { + nice_printf(outfile, /*{*/ "}\n"); + prev_tab(outfile); + } + } + } + if (wrote_comment) + nice_printf (outfile, "\n/* Function Body */\n"); + if (ac) + free((char *)ac); + if (p0 != p1) + frchain(&p1); +} /* prolog */ diff --git a/unix/f2c/src/version.c b/unix/f2c/src/version.c new file mode 100644 index 00000000..07013406 --- /dev/null +++ b/unix/f2c/src/version.c @@ -0,0 +1,2 @@ +char F2C_version[] = "20100827"; +char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 20100827\n"; diff --git a/unix/f2c/src/xsum.c b/unix/f2c/src/xsum.c new file mode 100644 index 00000000..a5d70e45 --- /dev/null +++ b/unix/f2c/src/xsum.c @@ -0,0 +1,239 @@ +/**************************************************************** +Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both that the copyright notice and this permission notice and warranty +disclaimer appear in supporting documentation, and that the names of +AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities +not be used in advertising or publicity pertaining to distribution of +the software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability and +fitness. In no event shall AT&T or Bellcore be liable for any +special, indirect or consequential damages or any damages whatsoever +resulting from loss of use, data or profits, whether in an action of +contract, negligence or other tortious action, arising out of or in +connection with the use or performance of this software. +****************************************************************/ + +#undef _POSIX_SOURCE +#define _POSIX_SOURCE +#include "stdio.h" +#ifndef KR_headers +#include "stdlib.h" +#include "sys/types.h" +#ifndef MSDOS +#include "unistd.h" /* for read, close */ +#endif +#include "fcntl.h" /* for declaration of open, O_RDONLY */ +#endif +#ifdef MSDOS +#include "io.h" +#endif +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif +#ifndef O_BINARY +#define O_BINARY O_RDONLY +#endif + + char *progname; + static int ignore_cr; + + void +#ifdef KR_headers +usage(rc) +#else +usage(int rc) +#endif +{ + fprintf(stderr, "usage: %s [-r] [file [file...]]\n\ + option -r ignores carriage return characters\n", progname); + exit(rc); + } + +typedef unsigned char Uchar; + + long +#ifdef KR_headers +sum32(sum, x, n) + register long sum; + register Uchar *x; + int n; +#else +sum32(register long sum, register Uchar *x, int n) +#endif +{ + register Uchar *xe; + static long crc_table[256] = { + 0, 151466134, 302932268, 453595578, + -9583591, -160762737, -312236747, -463170141, + -19167182, -136529756, -321525474, -439166584, + 28724267, 145849533, 330837255, 448732561, + -38334364, -189783822, -273059512, -423738914, + 47895677, 199091435, 282375505, 433292743, + 57448534, 174827712, 291699066, 409324012, + -67019697, -184128295, -300991133, -418902539, + -76668728, -227995554, -379567644, -530091662, + 67364049, 218420295, 369985021, 520795499, + 95791354, 213031020, 398182870, 515701056, + -86479645, -203465611, -388624945, -506380967, + 114897068, 266207290, 349655424, 500195606, + -105581387, -256654301, -340093543, -490887921, + -134039394, -251295736, -368256590, -485758684, + 124746887, 241716241, 358686123, 476458301, + -153337456, -2395898, -455991108, -304803798, + 162629001, 11973919, 465560741, 314102835, + 134728098, 16841012, 436840590, 319723544, + -144044613, -26395347, -446403433, -329032703, + 191582708, 40657250, 426062040, 274858062, + -200894995, -50223749, -435620671, -284179369, + -172959290, -55056048, -406931222, -289830788, + 182263263, 64630089, 416513267, 299125861, + 229794136, 78991822, 532414580, 381366498, + -220224191, -69691945, -523123603, -371788549, + -211162774, -93398532, -513308602, -396314416, + 201600371, 84090341, 503991391, 386759881, + -268078788, -117292630, -502591472, -351526778, + 258520357, 107972019, 493278217, 341959839, + 249493774, 131713432, 483432482, 366454964, + -239911657, -122417791, -474129349, -356881235, + -306674912, -457198666, -4791796, -156118374, + 315967289, 466778031, 14362133, 165418627, + 325258002, 442776452, 23947838, 141187752, + -334573813, -452329571, -33509849, -150495567, + 269456196, 419996626, 33682024, 184992510, + -278767779, -429561909, -43239823, -194312473, + -288089226, -405591072, -52790694, -170046772, + 297394031, 415166457, 62373443, 179343061, + 383165416, 533828478, 81314500, 232780370, + -373594127, -524527769, -72022307, -223201717, + -401789990, -519431348, -100447498, -217810336, + 392228803, 510123861, 91131631, 208256633, + -345918580, -496598246, -110112096, -261561802, + 336361365, 487278339, 100800185, 251995695, + 364526526, 482151208, 129260178, 246639108, + -354943065, -472854735, -119955829, -237064675, + 459588272, 308539942, 157983644, 7181066, + -469170519, -317835713, -167286907, -16754925, + -440448382, -323454444, -139383890, -21619912, + 450006683, 332774925, 148697015, 31186721, + -422325548, -271261118, -186797064, -36011154, + 431888077, 280569435, 196114401, 45565815, + 403200742, 286222960, 168180682, 50400092, + -412770561, -295522711, -177471533, -59977915, + -536157576, -384970002, -234585260, -83643454, + 526853729, 375396087, 225003341, 74348507, + 517040714, 399923932, 215944038, 98057200, + -507728301, -390357307, -206385281, -88735767, + 498987548, 347783818, 263426864, 112501670, + -489671163, -338229613, -253864151, -103192641, + -479823314, -362722632, -244835582, -126932076, + 470531639, 353144481, 235265819, 117632909 + }; + + xe = x + n; + while(x < xe) + sum = crc_table[(sum ^ *x++) & 0xff] ^ (sum >> 8 & 0xffffff); + return sum; + } + + int +#ifdef KR_headers +cr_purge(buf, n) + Uchar *buf; + int n; +#else +cr_purge(Uchar *buf, int n) +#endif +{ + register Uchar *b, *b1, *be; + b = buf; + be = b + n; + while(b < be) + if (*b++ == '\r') { + b1 = b - 1; + while(b < be) + if ((*b1 = *b++) != '\r') + b1++; + return b1 - buf; + } + return n; + } + +static Uchar Buf[16*1024]; + + void +#ifdef KR_headers +process(s, x) + char *s; + int x; +#else +process(char *s, int x) +#endif +{ + register int n; + long fsize, sum; + + sum = 0; + fsize = 0; + while((n = read(x, (char *)Buf, sizeof(Buf))) > 0) { + if (ignore_cr) + n = cr_purge(Buf, n); + fsize += n; + sum = sum32(sum, Buf, n); + } + sum &= 0xffffffff; + if (n==0) + printf("%s\t%lx\t%ld\n", s, sum & 0xffffffff, fsize); + else { perror(s); } + close(x); + } + + int +#ifdef KR_headers +main(argc, argv) + char **argv; +#else +main(int argc, char **argv) +#endif +{ + int x; + char *s; + static int rc; + + progname = *argv; + argc = argc; /* turn off "not used" warning */ + s = *++argv; + if (s && *s == '-') { + switch(s[1]) { + case '?': + usage(0); + case 'r': + ignore_cr = 1; + case '-': + break; + default: + fprintf(stderr, "invalid option %s\n", s); + usage(1); + } + s = *++argv; + } + if (s) do { + x = open(s, O_RDONLY|O_BINARY); + if (x < 0) { + fprintf(stderr, "%s: can't open %s\n", progname, s); + rc |= 1; + } + else + process(s, x); + } + while(s = *++argv); + else { + process("/dev/stdin", fileno(stdin)); + } + return rc; + } diff --git a/unix/f2c/src/xsum.out b/unix/f2c/src/xsum.out new file mode 100644 index 00000000..d880438b --- /dev/null +++ b/unix/f2c/src/xsum.out @@ -0,0 +1,59 @@ +Notice 76f23b4 1212 +README f11dd32a 7973 +cds.c 147aded1 4221 +data.c e53078ae 10697 +defines.h fd9fa7c5 8720 +defs.h e48cebb 34523 +equiv.c fdeff25 9340 +error.c ef1dd812 5015 +exec.c e169a868 21191 +expr.c 6bfe005 72276 +f2c.1 b0441b2 7532 +f2c.1t bf1f87 7574 +f2c.h e770b7d8 4688 +format.c f97004df 59746 +format.h b396862 458 +formatdata.c 11a95834 28870 +ftypes.h 9a0b38c 1616 +gram.c 3794117 64242 +gram.dcl e38579ff 8463 +gram.exec e20ca496 3033 +gram.expr eca86241 3193 +gram.head e6bbfeab 7362 +gram.io 101f7521 3350 +init.c fe1abab5 11833 +intr.c 1ebf37ee 25016 +io.c 1739e50 30664 +iob.h ece45655 548 +lex.c 1b0d5df9 34746 +machdefs.h 4950e5b 659 +main.c e2fad403 20921 +makefile.u e0dd1cab 3710 +makefile.vc eb8aae7c 2685 +malloc.c 40d2ad0 3975 +mem.c e54b227d 5437 +memset.c 12a1e1aa 2121 +misc.c 8d99c9 22945 +names.c fa887031 21553 +names.h 110806d6 569 +niceprintf.c 141fb644 10950 +niceprintf.h c31f08c 412 +output.c ee3a3cc5 43483 +output.h fa6797d9 2103 +p1defs.h 1b02743 5741 +p1output.c 6fd9954 14376 +parse.h 18d34e6b 1119 +parse_args.c eb2fd4ea 14145 +pccdefs.h 1b4fbbee 1195 +pread.c 1fbd30ab 17831 +proc.c 649db52 39174 +put.c af0be95 10345 +putpcc.c 7669b2f 46093 +sysdep.c fe71c52a 15893 +sysdep.h e7826434 2755 +sysdeptest.c c92b2d4 408 +tokens 188b7c5d 733 +usignal.h 1c4ce909 124 +vax.c 8b21b83 12436 +version.c f48eeae3 107 +xsum.c e05654a7 6653 diff --git a/unix/f2c/src/xsum0.out b/unix/f2c/src/xsum0.out new file mode 100644 index 00000000..d880438b --- /dev/null +++ b/unix/f2c/src/xsum0.out @@ -0,0 +1,59 @@ +Notice 76f23b4 1212 +README f11dd32a 7973 +cds.c 147aded1 4221 +data.c e53078ae 10697 +defines.h fd9fa7c5 8720 +defs.h e48cebb 34523 +equiv.c fdeff25 9340 +error.c ef1dd812 5015 +exec.c e169a868 21191 +expr.c 6bfe005 72276 +f2c.1 b0441b2 7532 +f2c.1t bf1f87 7574 +f2c.h e770b7d8 4688 +format.c f97004df 59746 +format.h b396862 458 +formatdata.c 11a95834 28870 +ftypes.h 9a0b38c 1616 +gram.c 3794117 64242 +gram.dcl e38579ff 8463 +gram.exec e20ca496 3033 +gram.expr eca86241 3193 +gram.head e6bbfeab 7362 +gram.io 101f7521 3350 +init.c fe1abab5 11833 +intr.c 1ebf37ee 25016 +io.c 1739e50 30664 +iob.h ece45655 548 +lex.c 1b0d5df9 34746 +machdefs.h 4950e5b 659 +main.c e2fad403 20921 +makefile.u e0dd1cab 3710 +makefile.vc eb8aae7c 2685 +malloc.c 40d2ad0 3975 +mem.c e54b227d 5437 +memset.c 12a1e1aa 2121 +misc.c 8d99c9 22945 +names.c fa887031 21553 +names.h 110806d6 569 +niceprintf.c 141fb644 10950 +niceprintf.h c31f08c 412 +output.c ee3a3cc5 43483 +output.h fa6797d9 2103 +p1defs.h 1b02743 5741 +p1output.c 6fd9954 14376 +parse.h 18d34e6b 1119 +parse_args.c eb2fd4ea 14145 +pccdefs.h 1b4fbbee 1195 +pread.c 1fbd30ab 17831 +proc.c 649db52 39174 +put.c af0be95 10345 +putpcc.c 7669b2f 46093 +sysdep.c fe71c52a 15893 +sysdep.h e7826434 2755 +sysdeptest.c c92b2d4 408 +tokens 188b7c5d 733 +usignal.h 1c4ce909 124 +vax.c 8b21b83 12436 +version.c f48eeae3 107 +xsum.c e05654a7 6653 diff --git a/unix/f2c/src/xsum1.out b/unix/f2c/src/xsum1.out new file mode 100644 index 00000000..44d962fc --- /dev/null +++ b/unix/f2c/src/xsum1.out @@ -0,0 +1,59 @@ +Notice 76f23b4 1212 +README f11dd32a 7973 +cds.c 147aded1 4221 +data.c e53078ae 10697 +defines.h fd9fa7c5 8720 +defs.h e48cebb 34523 +equiv.c fdeff25 9340 +error.c ef1dd812 5015 +exec.c e169a868 21191 +expr.c 6bfe005 72276 +f2c.1 b0441b2 7532 +f2c.1t bf1f87 7574 +f2c.h e770b7d8 4688 +format.c f97004df 59746 +format.h b396862 458 +formatdata.c 11a95834 28870 +ftypes.h 9a0b38c 1616 +gram.c 3794117 64242 +gram.dcl e38579ff 8463 +gram.exec e20ca496 3033 +gram.expr eca86241 3193 +gram.head e6bbfeab 7362 +gram.io 101f7521 3350 +init.c fe1abab5 11833 +intr.c 1ebf37ee 25016 +io.c 1739e50 30664 +iob.h ece45655 548 +lex.c 1b0d5df9 34746 +machdefs.h 4950e5b 659 +main.c e2fad403 20921 +makefile.u f11b7532 3713 +makefile.vc eb8aae7c 2685 +malloc.c 40d2ad0 3975 +mem.c e54b227d 5437 +memset.c 12a1e1aa 2121 +misc.c 8d99c9 22945 +names.c fa887031 21553 +names.h 110806d6 569 +niceprintf.c 141fb644 10950 +niceprintf.h c31f08c 412 +output.c ee3a3cc5 43483 +output.h fa6797d9 2103 +p1defs.h 1b02743 5741 +p1output.c 6fd9954 14376 +parse.h 18d34e6b 1119 +parse_args.c eb2fd4ea 14145 +pccdefs.h 1b4fbbee 1195 +pread.c 1fbd30ab 17831 +proc.c 649db52 39174 +put.c af0be95 10345 +putpcc.c 7669b2f 46093 +sysdep.c fe71c52a 15893 +sysdep.h e7826434 2755 +sysdeptest.c c92b2d4 408 +tokens 188b7c5d 733 +usignal.h 1c4ce909 124 +vax.c 8b21b83 12436 +version.c f48eeae3 107 +xsum.c e05654a7 6653 diff --git a/unix/gdev/README b/unix/gdev/README new file mode 100644 index 00000000..235194cb --- /dev/null +++ b/unix/gdev/README @@ -0,0 +1,126 @@ +ZFIOGD -- FIO device driver for binary graphics devices. + Note: this code is part of library LIBSYS. + +The purpose of this driver is to provide a low level i/o interface to the +interactive binary graphics devices supported on a particular system. This +includes devices such as image displays and bit mapped vector graphics devices +(e.g., the Versatec plotters). The ZFIOGD driver is not intended for graphics +devices with a text interface, e.g., the Tektronix compatible graphics +terminals. A third interface, i.e., the ZFIOPL driver, is used for devices +accessed via the NCAR system plot package. + +By using a ZFIO level driver to talk to the binary graphics devices we can +isolate the system dependencies of the interface to a small amount of code. +We gain the ability to access the device over the network, since the kernel +server can be used once the i/o interface to the device is part of the kernel. + +The ZFIOGD driver is implemented in LIBSYS rather than LIBOS since the +interface code, while system dependent, is generally written at least partially +in SPP to access header files shared with the GIO graphics kernel for the +device, as well as to gain access to the LIBSYS library functions for ease +of coding. ZFIOGD is used only by the graphics kernels hence is not needed +to bootstrap the system; it is added to LIBSYS after the system is up and +running. + +The code is made as follows: + + [1] In a bootstrap, the commands in the mkpkg.csh file are executed by + the root mkpkg.csh file in host$. + + [2] In a sysgen, the mkpkg file in this directory is called by an entry + in sys$mkpkg to to update the libsys.a library. + + +ARCHITECTURE + + The single FIO device driver ZFIOGD is used to access all binary graphics +devices. This simplifies the KI and VOS interfaces and maximally isolates +knowledge of the devices supported on a particular system. New devices can +be added to ZFIOGD without any changes to the kernel interface or the VOS. +When a device is opened via the ZFIOGD driver the name of the device is +specified as follows: + + node!device:hostdevname +e.g., + lyra!iis,/dev/iis + vela!iis,iia0 + +where + device identifies the bottom level driver to be used + + hostdevname is the host system name for the particular + device to be accessed (there may be + multiple copies of a device on a single + system) + +The task of ZOPNGD is to look up device name in an internal table and call +the appropriate lower level device open procedure to physically open the +device. If the device resides on a remote node the kernel interface will +have have spawned a remote kernel server which will call ZOPNGD on the host +which actually owns the device. + + + ZFIOGD + + + iism7X deanza peritek versatec (etc.) + + +The ZFIOGD interface is a data driven interface, i.e., all control and status +readback functions are performed by ZARDGD and ZAWRGD calls to read and write +binary packets of data. This is ideal for a device such as the IIS which is +also data driven, but is less convenient for devices which have a control +type interface (in a control type interface, a subroutine is called to do +something to the device, rather than writing to the device). Even when the +device is control driven at the host system level, a data driven interface is +desirable to isolate the system dependence of the OS device driver, as well +as to provide network access. + + +PROTOCOLS + + When building a ZFIOGD sub-driver for a control driven device, it is +suggested that a control packet be defined for the device which is capable +of encoding all control functions. The high level code (GIO graphics device +driver) will encode control functions in this packet (which should have a +machine independent external representation), and send it along via ZAWRGD +to the sub-kernel, which will decode the packet and poke the host system device +driver as necessary to perform the indicated function. + +There is no predefined protocol for encoding control packets for binary +graphics devices. Conceivably such an interface could be defined, but our +goal with the ZFIOGD interface is to isolate the host system dependence of +the interface and provide network access capabilities; we are NOT trying to +address the problems of device independence in this interface. That is the +function of the GIO device driver, which should be machine independent and +portable, but addresses the problems of providing a device independent +interface. + +A control packet and communications protocol should therefore be defined +separately for each device. One possibility is to use the OFFSET argument +in the ZAWRGD call as a function code, rather than placing the function code +in a generic packet header. This is possible since the OFFSET argument is not +used for streaming devices. The only disadvantage to using the OFFSET field +in this way is that doing so would prevent use of FIO to buffer i/o to the +device, since FIO always sets OFFSET to zero when calling ZAWRGD for a +streaming device. The alternative is the generic packet approach, wherein +each i/o or control operation is preceded by a packet defining the operation +to be performed (this can simplify the interface, since a single set of +subroutines can be used to encode/transmit and receive/decode packet headers). +Yet another possibilty is to combine the two approaches, using a generic +packet header for most operations, but a special "offset" or function code +for special operations such as master clear or device reset (as well as to +reset the communications protocol). + +See the send/receive procedures in the KI (kernel interface) for an example +of how to encode packets in a machine independent form for transmission over +the network. + + +ADDING NEW DEVICES + + To add a new device to ZFIOGD, create a subdirectory with the name of the +device and implement the six driver subroutines therein. Add an entry to the +mkpkg to compile the new subdirectory. Add a new entry to the device table +and to each switch-case statement in zfiogd.x. Relink all affected graphics +executables, and relink the kernel server executable. diff --git a/unix/gdev/iism70/README b/unix/gdev/iism70/README new file mode 100644 index 00000000..8023068b --- /dev/null +++ b/unix/gdev/iism70/README @@ -0,0 +1,18 @@ +UNIX IRAF/FIO device driver for the IIS Model 70 +(will probably also work for the model 75). 11/85 dct +---------------------------------------------------------------------- + +This directory contains the IRAF/FIO driver subroutines for the IIS Model 70 +image display on UNIX. On a UNIX system the ZIFOBF (binary file) driver is +used to access the display, hence the subroutines herein merely map the calls +into the corresponding BF procedures. + + +Driver Procedures: + + zopm70 -- open + allocate + zclm70 -- close + deallocate + zrdm70 -- asynchronous binary read + zwrm70 -- asynchronous binary write + zwtm70 -- wait for i/o completion, return status + zstm70 -- get device status diff --git a/unix/gdev/iism70/m70.h b/unix/gdev/iism70/m70.h new file mode 100644 index 00000000..6a1a7d28 --- /dev/null +++ b/unix/gdev/iism70/m70.h @@ -0,0 +1,27 @@ +# Definitions for the VMS/IIS device driver. + +define IIS_READ 1 # read function code +define IIS_WRITE 0 # write function code +define IIS_INACTIVE -1 # no i/o in progress + +define EFN EFN2 # EFN to use for i/o +define EFN1W 0 # efn #1, wait for completion +define EFN2 1 # efn #2, no wait for completion +define EFN3 2 # efn #3, no wait for completion + +# Function control block structure for IIS. The first part of the structure +# is filled in by VMS at open time; all we need to know is the offset of the +# device name. We use the latter part of the buffer + +define LEN_FCB 30 +define FCB_U_NAME (P2S($1)+16+($2)-1) +define FCB_STATUS Memi[$1+20] # channel status (r, w, err) +define FCB_NBYTES Memi[$1+21] # nbytes last transfer +define FCB_EFN Memi[$1+22] # event flag used for transfer + +# IIS device status words. + +define IIS_FILSIZE (512 * 512 * SZB_CHAR) +define IIS_BLKSIZE 1024 +define IIS_OPTBUFSIZE (512 * SZB_CHAR) +define IIS_MAXBUFSIZE 32768 diff --git a/unix/gdev/iism70/mkpkg b/unix/gdev/iism70/mkpkg new file mode 100644 index 00000000..57b920c5 --- /dev/null +++ b/unix/gdev/iism70/mkpkg @@ -0,0 +1,15 @@ +# Make the UNIX version of the IIS driver. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + zclm70.x + zopm70.x + zrdm70.x + zstm70.x m70.h + zwrm70.x + zwtm70.x + ; diff --git a/unix/gdev/iism70/zclm70.x b/unix/gdev/iism70/zclm70.x new file mode 100644 index 00000000..719bc727 --- /dev/null +++ b/unix/gdev/iism70/zclm70.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZCLM70 -- Close and deallocate the IIS. + +procedure zclm70 (chan, status) + +int chan +int status + +begin + call zclsbf (chan, status) +end diff --git a/unix/gdev/iism70/zopm70.x b/unix/gdev/iism70/zopm70.x new file mode 100644 index 00000000..5c49d506 --- /dev/null +++ b/unix/gdev/iism70/zopm70.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZOPM70 -- Open the IIS for binary file i/o. The device will be automatically +# allocated if necessary. + +procedure zopm70 (device, mode, chan) + +char device[ARB] # packed UNIX device name +int mode # access mode +int chan # receives device channel + +begin + call zopnbf (device, mode, chan) +end diff --git a/unix/gdev/iism70/zrdm70.x b/unix/gdev/iism70/zrdm70.x new file mode 100644 index 00000000..f3ef3f2a --- /dev/null +++ b/unix/gdev/iism70/zrdm70.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZRDM70 -- Initiate an asynchronous read from the IIS. + +procedure zrdm70 (chan, buf, nbytes, offset) + +int chan # FCB pointer for device +char buf[ARB] # output buffer +int nbytes # number of bytes to read +long offset # not used for this device + +begin + call zardbf (chan, buf, nbytes, offset) +end diff --git a/unix/gdev/iism70/zstm70.x b/unix/gdev/iism70/zstm70.x new file mode 100644 index 00000000..2b790dfa --- /dev/null +++ b/unix/gdev/iism70/zstm70.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m70.h" + +# ZSTM70 -- Return device status for the IIS. + +procedure zstm70 (chan, what, lvalue) + +int chan # FCB pointer for device +int what # status parameter +long lvalue + +begin + switch (what) { + case FSTT_FILSIZE: + lvalue = IIS_FILSIZE + case FSTT_BLKSIZE: + lvalue = IIS_BLKSIZE + case FSTT_OPTBUFSIZE: + lvalue = IIS_OPTBUFSIZE + case FSTT_MAXBUFSIZE: + lvalue = IIS_MAXBUFSIZE + default: + lvalue = ERR + } +end diff --git a/unix/gdev/iism70/zwrm70.x b/unix/gdev/iism70/zwrm70.x new file mode 100644 index 00000000..10545f99 --- /dev/null +++ b/unix/gdev/iism70/zwrm70.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZWRM70 -- Initiate an asynchronous write to the IIS. + +procedure zwrm70 (chan, buf, nbytes, offset) + +int chan # FCB pointer for device +char buf[ARB] # input buffer +int nbytes # number of bytes to write +long offset # not used for this device + +begin + call zawrbf (chan, buf, nbytes, offset) +end diff --git a/unix/gdev/iism70/zwtm70.x b/unix/gdev/iism70/zwtm70.x new file mode 100644 index 00000000..b2523c31 --- /dev/null +++ b/unix/gdev/iism70/zwtm70.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZWTM70 -- Wait for i/o completion and return the number of bytes read or +# written or ERR. Repetitive calls return the same value. + +procedure zwtm70 (chan, status) + +int chan # FCB pointer for device +int status # nbytes transferred or ERR + +begin + call zawtbf (chan, status) +end diff --git a/unix/gdev/iism75/README b/unix/gdev/iism75/README new file mode 100644 index 00000000..60433d4d --- /dev/null +++ b/unix/gdev/iism75/README @@ -0,0 +1,24 @@ +UNIX IRAF/FIO device driver for the IIS Model 75 +2 Feb 1896 Dct.; ported to UNIX from VMS 10 Mar 1987 SRo. +---------------------------------------------------------------------- + +This directory contains the IRAF/FIO driver subroutines for the IIS Model 75 +image display. This directory is self contained. + +The model 75 interface is implemented as a transformation on the data stream +for the model 70. The high level code thinks that it is talking to a model +70; we translate the headers as necessary for the model 75 before passing +them on to the device. This approach does not provide full access to the +capabilities of the model 75, however the existing high level code is all +written for the model 70 and we are not at present interested in the advanced +features of either display. + + +Driver Procedures: + + zopm75 -- open + allocate + zclm75 -- close + deallocate + zrdm75 -- asynchronous binary read + zwrm75 -- asynchronous binary write + zwtm75 -- wait for i/o completion, return status + zstm75 -- get device status diff --git a/unix/gdev/iism75/iis.h b/unix/gdev/iism75/iis.h new file mode 100644 index 00000000..515c0def --- /dev/null +++ b/unix/gdev/iism75/iis.h @@ -0,0 +1,106 @@ +# IIS.H -- Hardware definitions for the IIS models 70 and 75. + +# Define header +define LEN_IISHDR 8 # Length of IIS header + +define XFERID $1[1] # transfer id +define THINGCT $1[2] # thing count +define SUBUNIT $1[3] # subuint select +define CHECKSUM $1[4] # check sum +define XREG $1[5] # x register +define YREG $1[6] # y register +define ZREG $1[7] # z register +define TREG $1[8] # t register + +# Transfer ID definitions +define BYTEORDER 20B +define PMA 40B +define ACCELERATE 100B +define REPEAT 200B +define IREAD 100000B +define IWRITE 000000B +define PACKED 40000B +define BYPASSIFM 20000B +define PAGEMODE 10000B +define ADDWRITE 4000B +define ACCUM 2000B +define BLOCKXFER 1000B +define VRETRACE 400B + +define M70_BYTE 10000B +define M70_MUX32 200B + +# Subunits +define REFRESH 1 +define LUT 2 +define OFM 3 +define IFM 4 +define FEEDBACK 5 +define SCROLLZOOM 6 +define VIDEOM 7 +define SUMPROC 8 +define GRAPHICS 9 +define CURSOR 10 +define ALU 11 + +define M70_SCROLL 6 +define M70_ZOOM 12 + +# Command definitions +define COMMAND 100000B +define ERASE 100000B # Erase + +define SCROLL 1B +define ZOOM 10000B +define WRAP 1000B + +define M70_ADVXONTC 100000B # Advance x on thing count +define M70_ADVXONYOV 40000B # Advance x on y overflow +define M70_ADVYONXOV 100000B # Advance y on x overflow +define M70_ADVYONTC 40000B # Advance y on thing count + +define M75_ADVXONTC 400B # Advance x on thing count +define M75_ADVXONYOV 200B # Advance x on y overflow +define M75_ADVYONXOV 2000B # Advance y on x overflow +define M75_ADVYONTC 4000B # Advance y on thing count + +# 4 - Button Trackball +define PUSH 40000B +define BUTTONA 400B +define BUTTONB 1000B +define BUTTONC 2000B +define BUTTOND 4000B + +# Display channels +define CHAN1 1B +define CHAN2 2B +define CHAN3 4B +define CHAN4 10B +define GRCHAN 100000B + +define LEN_IISFRAMES 4 +define IISFRAMES CHAN1, CHAN2, CHAN3, CHAN4 + +# Colors +define BLUE 1B +define GREEN 2B +define RED 4B +define MONO 7B + +# Bit plane selections +define BITPL0 1B +define BITPL1 2B +define BITPL2 4B +define BITPL3 10B +define BITPL4 20B +define BITPL5 40B +define BITPL6 100B +define BITPL7 200B +define ALLBITPL 377B + +# IIS Sizes +define MCXSCALE 64 # Metacode x scale +define MCYSCALE 64 # Metacode y scale +define IIS_XDIM 512 +define IIS_YDIM 512 +define SZB_IISHDR 16 # Size of IIS header in bytes diff --git a/unix/gdev/iism75/m75.h b/unix/gdev/iism75/m75.h new file mode 100644 index 00000000..832aa423 --- /dev/null +++ b/unix/gdev/iism75/m75.h @@ -0,0 +1,28 @@ +# Definitions for the Model 75 UNIX/IIS device driver. + +define IIS_READ 1 # read function code +define IIS_WRITE 0 # write function code +define IIS_INACTIVE 2 # no i/o in progress + +# Function control block structure containing only our own internal variables. + +define LEN_FCB 20 +define FCB_CHAN Memi[($1)] # os channel +define FCB_STATUS Mems[P2S(($1)+1)] # channel status (r, w, err) +define FCB_NBYTES Mems[P2S(($1)+2)] # nbytes last transfer +define FCB_STATE Mems[P2S(($1)+3)] # instruction processing state +define FCB_IISHDR Mems[P2S(($1)+4)] # m70 header of current instr. + # (extra space) + +# Instruction processing states + +define READY 0 # ready for new instruction +define DATA_READ 1 # read data to complete instruction +define DATA_WRITE 2 # write data to complete instruction + +# IIS device status words. + +define IIS_FILSIZE (512 * 512 * SZB_CHAR) +define IIS_BLKSIZE 1024 +define IIS_OPTBUFSIZE (512 * SZB_CHAR) +define IIS_MAXBUFSIZE 16384 diff --git a/unix/gdev/iism75/m75put.x b/unix/gdev/iism75/m75put.x new file mode 100644 index 00000000..01ca6511 --- /dev/null +++ b/unix/gdev/iism75/m75put.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" +include "iis.h" + +# M75PUT -- Translate an M70 instruction+data into an M75 instruction+data and +# output it to the display device. We are called after both the instruction +# header and the data (if any) have been received. The M70 header has been +# saved in the the channel descriptor and the data, if any, is in BUF. + +procedure m75put (fcb, buf, nbytes_buf, offset) + +pointer fcb # pointer to channel descriptor +short buf[ARB] # data array +int nbytes_buf # nbytes of data in buffer +long offset # not used + +int ifcb +bool use_altbuf +short altbuf[128] +short m70[LEN_IISHDR] +short m75[LEN_IISHDR] +int nbytes, status, sum, i +int xferid, subunit, xreg, yreg +int and(), or(), not() + +begin + ifcb = fcb + use_altbuf = false + + # Retrieve the M70 header from the channel descriptor. + call amovs (FCB_IISHDR(fcb), m70, LEN_IISHDR) + + xferid = XFERID(m70) + subunit = SUBUNIT(m70) + xreg = XREG(m70) + yreg = YREG(m70) + + if (THINGCT(m70) == 0) + nbytes = 0 + else + nbytes = nbytes_buf + + # Start with a copy of the header for the M75, but turn off those bits + # in the transfer id which the M70 knows nothing about and hence could + # not have set. + + call amovs (m70, m75, LEN_IISHDR) + XFERID(m75) = and (xferid, + not (BYTEORDER+PMA+ACCELERATE+REPEAT+PAGEMODE)) + + # Translate the remaining fields of the header as necessary for each + # subunit. + + switch (and (subunit, 77B)) { + case REFRESH: + if (and (xreg, M70_ADVXONTC) != 0) + subunit = or (subunit, M75_ADVXONTC) + if (and (xreg, M70_ADVXONYOV) != 0) + subunit = or (subunit, M75_ADVXONYOV) + if (and (yreg, M70_ADVYONTC) != 0) + subunit = or (subunit, M75_ADVYONTC) + if (and (yreg, M70_ADVYONXOV) != 0) + subunit = or (subunit, M75_ADVYONXOV) + + SUBUNIT(m75) = subunit + XREG(m75) = and (xreg, IIS_XDIM-1) + YREG(m75) = and (yreg, IIS_YDIM-1) + + case LUT: + XREG(m75) = and (xreg, 1777B) + YREG(m75) = 0 + + case OFM: + XREG(m75) = and (xreg, 1777B) + YREG(m75) = 0 + + # The M70 feeds a 10 bit output DAC while the M75 DAC is 8 bits. + do i = 1, nbytes_buf / (SZB_CHAR * SZ_SHORT) + buf[i] = buf[i] / 4 + + case FEEDBACK: + subunit = COMMAND + FEEDBACK + SUBUNIT(m75) = subunit + XREG(m75) = 0 + YREG(m75) = 0 + + case GRAPHICS: + XREG(m75) = and (xreg, 777B) + + # In a command mode transfer, the status register value is passed + # as data for the M70, but in the T register for the M75. + + if (and (subunit, COMMAND) != 0) { + TREG(m75) = buf[1] + THINGCT(m75) = 0 + nbytes = 0 + } + + case CURSOR: + XREG(m75) = and (xreg, 7777B) + YREG(m75) = 0 + + case M70_SCROLL: + SUBUNIT(m75) = SCROLLZOOM + XREG(m75) = and (xreg, 3B) + YREG(m75) = 0 + ZREG(m75) = ALLBITPL + TREG(m75) = SCROLL + WRAP + + case M70_ZOOM: + SUBUNIT(m75) = SCROLLZOOM + THINGCT(m75) = 2 + XREG(m75) = and (xreg, 3B) + YREG(m75) = 0 + ZREG(m75) = ALLBITPL + TREG(m75) = ZOOM + SCROLL + WRAP + + # There are up to 3 words of data for the M70: zoom factor, + # x center, y center. For the M75 the zoom is specified + # separately for each axis in the high bits of the word which + # contains the axis center. For simplicity we require that + # all 3 words always be given. + + altbuf[1] = buf[1] * 10000B + buf[2] + altbuf[2] = buf[1] * 10000B + buf[3] + use_altbuf = true + nbytes = 2 * (SZ_SHORT * SZB_CHAR) + } + + # Compute the checksum for the new header. + + CHECKSUM(m75) = 1 + if (THINGCT(m75) > 0) + THINGCT(m75) = -THINGCT(m75) + + sum = 0 + do i = 1, LEN_IISHDR + sum = sum + m75[i] + + CHECKSUM(m75) = -sum + + # Output the header. + + call zzwrii (fcb, m75, SZB_IISHDR, offset) + call zwtm75 (ifcb, status) + if (status == ERR) { + FCB_STATUS(fcb) = ERR + return + } + + # Output the data block, if any. + + if (nbytes > 0) + if (use_altbuf) + call zzwrii (fcb, altbuf, nbytes, offset) + else + call zzwrii (fcb, buf, nbytes, offset) +end diff --git a/unix/gdev/iism75/mkpkg b/unix/gdev/iism75/mkpkg new file mode 100644 index 00000000..97387aec --- /dev/null +++ b/unix/gdev/iism75/mkpkg @@ -0,0 +1,18 @@ +# Mkpkg for the UNIX version of the IIS driver. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + m75put.x iis.h m75.h + zclm75.x m75.h + zopm75.x m75.h + zrdm75.x iis.h m75.h + zstm75.x m75.h + zwrm75.x iis.h m75.h + zwtm75.x m75.h + zzrdii.x m75.h + zzwrii.x m75.h + ; diff --git a/unix/gdev/iism75/zclm75.x b/unix/gdev/iism75/zclm75.x new file mode 100644 index 00000000..989358d9 --- /dev/null +++ b/unix/gdev/iism75/zclm75.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" + +# ZCLM75 -- Close and deallocate the IIS. + +procedure zclm75 (ifcb, status) + +int ifcb # pointer to channel descriptor passed as int +int status +pointer fcb + +begin + fcb = ifcb + call zclsbf (FCB_CHAN(fcb), status) + + call mfree (fcb, TY_STRUCT) +end diff --git a/unix/gdev/iism75/zopm75.x b/unix/gdev/iism75/zopm75.x new file mode 100644 index 00000000..33a9acf8 --- /dev/null +++ b/unix/gdev/iism75/zopm75.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" + +# ZOPM75 -- Open the IIS for binary file i/o. + +procedure zopm75 (device, mode, ifcb) + +char device[ARB] # packed UNIX device name +int mode # access mode +int ifcb # pointer to channel descriptor passed as int + +pointer fcb +int chan + +begin + call calloc (fcb, LEN_FCB, TY_STRUCT) + ifcb = fcb + + FCB_STATUS(fcb) = IIS_INACTIVE + FCB_NBYTES(fcb) = 0 + FCB_STATE(fcb) = READY + + call zopnbf (device, mode, chan) + + if (chan < 0) { + call mfree (fcb, TY_STRUCT) + ifcb = ERR + } else + FCB_CHAN(fcb) = chan +end diff --git a/unix/gdev/iism75/zrdm75.x b/unix/gdev/iism75/zrdm75.x new file mode 100644 index 00000000..9cc2498d --- /dev/null +++ b/unix/gdev/iism75/zrdm75.x @@ -0,0 +1,163 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" +include "iis.h" + +# ZRDM75 -- Initiate an asynchronous read of data from the IIS. Note that +# the zwrm75 procedure is called to write the header for data reads, as well +# as writes. Hence we should be called only after the header has been saved +# in the channel descriptor by ZWRM75, leaving the channel in state DATA_READ. +# Our task is to translate and output the header, read the M75 data block, and +# return the data block to the user after performing any transformations +# necessary to make it look like M70fdata. + +procedure zrdm75 (ifcb, buf, nbytes_buf, offset) + +int ifcb # pointer to channel descriptor passed as int +short buf[ARB] # data array +int nbytes_buf # nbytes of data in buffer +long offset # not used + +pointer fcb +short m70[LEN_IISHDR] +short m75[LEN_IISHDR] +int nbytes, status, sum, i +int xferid, subunit, xreg, yreg +int and(), or(), not() + +begin + fcb = ifcb + nbytes = nbytes_buf + + if (FCB_STATE(fcb) != DATA_READ) { + FCB_STATUS(fcb) = ERR + return + } + + # Retrieve the M70 header from the channel descriptor. + call amovs (FCB_IISHDR(fcb), m70, LEN_IISHDR) + + xferid = XFERID(m70) + subunit = SUBUNIT(m70) + xreg = XREG(m70) + yreg = YREG(m70) + + # Start with a copy of the header for the M75, but turn off those bits + # in the transfer id which the M70 knows nothing about and hence could + # not have set. + + call amovs (m70, m75, LEN_IISHDR) + XFERID(m75) = and (xferid, + not (BYTEORDER+PMA+ACCELERATE+REPEAT+PAGEMODE)) + + # Translate the remaining fields of the header as necessary for each + # subunit. + + switch (and (subunit, 77B)) { + case REFRESH: + if (and (xreg, M70_ADVXONTC) != 0) + subunit = or (subunit, M75_ADVXONTC) + if (and (xreg, M70_ADVXONYOV) != 0) + subunit = or (subunit, M75_ADVXONYOV) + if (and (yreg, M70_ADVYONTC) != 0) + subunit = or (subunit, M75_ADVYONTC) + if (and (yreg, M70_ADVYONXOV) != 0) + subunit = or (subunit, M75_ADVYONXOV) + + SUBUNIT(m75) = subunit + XREG(m75) = and (xreg, IIS_XDIM-1) + YREG(m75) = and (yreg, IIS_YDIM-1) + + case LUT: + XREG(m75) = and (xreg, 1777B) + YREG(m75) = 0 + + case OFM: + XREG(m75) = and (xreg, 1777B) + YREG(m75) = 0 + + # The M70 OFM lookup table is 10 bits deep, whereas the M75 table + # is only 8 bits deep, so scale the 8 bit M75 values up to 10 bits. + + do i = 1, nbytes_buf / (SZB_CHAR * SZ_SHORT) + buf[i] = buf[i] * 4 + + case FEEDBACK: + subunit = COMMAND + FEEDBACK + SUBUNIT(m75) = subunit + XREG(m75) = 0 + YREG(m75) = 0 + + case GRAPHICS: + XREG(m75) = and (xreg, 777B) + TREG(m75) = 0 # ?? + + case CURSOR: + XREG(m75) = and (xreg, 7777B) + YREG(m75) = 0 + + case M70_SCROLL: + SUBUNIT(m75) = SCROLLZOOM + XREG(m75) = and (xreg, 3B) + YREG(m75) = 0 + ZREG(m75) = ALLBITPL + TREG(m75) = SCROLL + WRAP + + case M70_ZOOM: + SUBUNIT(m75) = SCROLLZOOM + THINGCT(m75) = 2 + nbytes = 2 * (SZ_SHORT * SZB_CHAR) + XREG(m75) = and (xreg, 3B) + YREG(m75) = 0 + ZREG(m75) = ALLBITPL + TREG(m75) = ZOOM + } + + # Compute the checksum for the new header. + + CHECKSUM(m75) = 1 + if (THINGCT(m75) > 0) + THINGCT(m75) = -THINGCT(m75) + + sum = 0 + do i = 1, LEN_IISHDR + sum = sum + m75[i] + + CHECKSUM(m75) = -sum + + # Output the header. + + call zzwrii (fcb, m75, SZB_IISHDR, offset) + call zwtm75 (ifcb, status) + if (status == ERR) { + FCB_STATUS(fcb) = ERR + return + } + + # Read the data block. + + if (nbytes > 0) { + call zzrdii (fcb, buf, nbytes, offset) + call zwtm75 (ifcb, status) + if (status <= 0) { + FCB_STATUS(fcb) = ERR + return + } + } + + # Perform any transformations on the data just read necessary to + # convert it into M70 format. If the number of bytes read is + # different than that expected by the M70, be sure to set the + # expected count in the channel descriptor for the next ZWTM75. + + if (and (subunit, 77B) == ZOOM) { + FCB_NBYTES(fcb) = 3 * (SZ_SHORT * SZB_CHAR) + FCB_STATUS(fcb) = IIS_INACTIVE + buf[3] = mod (int(buf[2]), 10000B) + buf[2] = mod (int(buf[1]), 10000B) + buf[1] = buf[1] / 10000B + } + + FCB_STATE(fcb) = READY +end diff --git a/unix/gdev/iism75/zstm75.x b/unix/gdev/iism75/zstm75.x new file mode 100644 index 00000000..b1e9923c --- /dev/null +++ b/unix/gdev/iism75/zstm75.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m75.h" + +# ZSTM75 -- Return device status for the IIS. + +procedure zstm75 (ifcb, what, lvalue) + +int ifcb # pointer to channel descriptor passed as int +int what # status parameter +long lvalue + +begin + switch (what) { + case FSTT_FILSIZE: + lvalue = IIS_FILSIZE + case FSTT_BLKSIZE: + lvalue = IIS_BLKSIZE + case FSTT_OPTBUFSIZE: + lvalue = IIS_OPTBUFSIZE + case FSTT_MAXBUFSIZE: + lvalue = IIS_MAXBUFSIZE + default: + lvalue = ERR + } +end diff --git a/unix/gdev/iism75/zwrm75.x b/unix/gdev/iism75/zwrm75.x new file mode 100644 index 00000000..38bb0f3c --- /dev/null +++ b/unix/gdev/iism75/zwrm75.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" +include "iis.h" + +# ZWRM75 -- Initiate an asynchronous write to the IIS. We are called to +# output the header of all instructions sent to the IIS. There are 3 types +# of instructions; those which consist only of a header write, those which +# consist of a header write followed by a data write, and those which +# consist of a header write followed by a data read. Translation of an M70 +# instruction into an M75 instruction may involve moving information between +# the header and data block, hence we must save the headers of the read and +# write instructions until the data has been read or written. The STATE +# variable in the channel descriptor is used to keep track of the instruction +# processing state. + +procedure zwrm75 (ifcb, buf, nbytes, offset) + +int ifcb # pointer to channel descriptor passed as int +char buf[ARB] # input buffer +int nbytes # number of bytes to write +long offset # not used for this device + +pointer fcb +int xferid, and() + +begin + fcb = ifcb + + if (FCB_STATE(fcb) == READY) { + # Start a new instruction. + + if (nbytes != SZB_IISHDR) { + FCB_STATUS(fcb) = ERR + return + } + + # Save the M70 header in the descriptor. + call amovs (buf, FCB_IISHDR(fcb), LEN_IISHDR) + xferid = XFERID(buf) + + # Determine the state for the new instruction. + + if (THINGCT(buf) == 0) + FCB_STATE(fcb) = READY + else if (and (xferid, IREAD) != 0) + FCB_STATE(fcb) = DATA_READ + else + FCB_STATE(fcb) = DATA_WRITE + + # If the new state is READY, no data read or write is needed, + # so just translate and output the header. + + if (FCB_STATE(fcb) == READY) + call m75put (fcb, buf, nbytes, offset) + else { + # Set up a channel status as if we had just written the new + # header, so that the next ZWTM75 will not return an error. + + FCB_STATUS(fcb) = IIS_INACTIVE + FCB_NBYTES(fcb) = SZB_IISHDR + } + + } else if (FCB_STATE(fcb) == DATA_WRITE) { + # This is the second zwrm75 call for a hdr+data output + # instruction. + + call m75put (fcb, buf, nbytes, offset) + FCB_STATE(fcb) = READY + + } else { + # ZRDM75 should have been called, set error on the channel. + FCB_STATUS(fcb) = ERR + } +end diff --git a/unix/gdev/iism75/zwtm75.x b/unix/gdev/iism75/zwtm75.x new file mode 100644 index 00000000..491b0f50 --- /dev/null +++ b/unix/gdev/iism75/zwtm75.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" + +# ZWTM75 -- Wait for i/o completion and return the number of bytes read or +# written or ERR. Repetitive calls return the same value. + +procedure zwtm75 (ifcb, status) + +int ifcb # pointer to channel descriptor passed as int +int status # nbytes transferred or ERR + +pointer fcb + +begin + fcb = ifcb + + switch (FCB_STATUS(fcb)) { + case ERR: + status = ERR + case IIS_INACTIVE: + status = FCB_NBYTES(fcb) + + default: + call zawtbf (FCB_CHAN(fcb), status) + FCB_STATUS(fcb) = IIS_INACTIVE + } +end diff --git a/unix/gdev/iism75/zzrdii.x b/unix/gdev/iism75/zzrdii.x new file mode 100644 index 00000000..f72058c3 --- /dev/null +++ b/unix/gdev/iism75/zzrdii.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" + +# ZZRDII -- Initiate an asynchronous read from the IIS. + +procedure zzrdii (fcb, buf, nbytes, offset) + +pointer fcb # pointer to channel descriptor +char buf[ARB] # output buffer +int nbytes # number of bytes to read +long offset # not used for this device + +begin + call zardbf (FCB_CHAN(fcb), buf, nbytes, offset) +end diff --git a/unix/gdev/iism75/zzwrii.x b/unix/gdev/iism75/zzwrii.x new file mode 100644 index 00000000..8515cc64 --- /dev/null +++ b/unix/gdev/iism75/zzwrii.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "m75.h" + +# ZZWRII -- Initiate an asynchronous write to the IIS. + +procedure zzwrii (fcb, buf, nbytes, offset) + +pointer fcb # pointer to channel descriptor +char buf[ARB] # input buffer +int nbytes # number of bytes to write +long offset # not used for this device + +begin + call zawrbf (FCB_CHAN(fcb), buf, nbytes, offset) +end diff --git a/unix/gdev/m70vms/README b/unix/gdev/m70vms/README new file mode 100644 index 00000000..23a06824 --- /dev/null +++ b/unix/gdev/m70vms/README @@ -0,0 +1,68 @@ +VMS IRAF/FIO device driver for the IIS Model 70 +(will probably also work for the model 75). 11/85 dct +---------------------------------------------------------------------- + +This directory contains the IRAF/FIO driver subroutines for the IIS Model 70 +image display on VMS. This directory is self contained; no external code is +required other than the VMS/IIS device driver itself. The code should be +portable to any VMS system. + + +Driver Procedures: + + zopm70 -- open + allocate + zclm70 -- close + deallocate + zrdm70 -- asynchronous binary read + zwrm70 -- asynchronous binary write + zwtm70 -- wait for i/o completion, return status + zstm70 -- get device status + + +On a UNIX system the ordinary binary file driver (ZFIOBF) may be used for these +functions. This might work on VMS too, but the IRAF/VMS binary file driver is +complicated and uses RMS, so I did not bother to try. This driver uses a +modified version local KPNO IIS library, which I suppose came originally from +IIS corp. The interface procedures are written in VMS Fortran and make direct +calls to the VMS system services. The original library has been modified to +convert all the names to the prefix "m70", and to remove all Fortran i/o. + + +VMS/IIS Interface Procedures: + + m70get (fcb, error) # open+allocate+mclear + m70rel (fcb) # close+deallocate + m70opn (fcb, error) # open + m70cls (fcb) # close + m70mcl (fcb, error) # master clear + + m70io (fcb, data, count, read, opcd, iosb, error) + m70wt (fcb, bfnum, bfcnt, iosb, error) + m70wti (fcb, func, time, button, x, y) + + +M70IO: I/O between M70 and a VAX. + + fcb function communications block. + data input/output buffer. + count number of words to read/write. + read 0 -> write, 1 -> read. + opcd :: 0 -> qio with efn = 1 and wait for completion + 1 -> qio with efn = 2 + 2 -> qio with efn = 3 + iosb I/O status quadword + error :: -1 => display not available + 0 => success + 1 => time/out + 2 => invalid or non-responding device + 1000 > machine dependent error code + + +M70WT: Wait for i/o. + + fcb function communication block. + bfnum used to determine event flag to wait for + bfcnt number of words in buffer. should be -1 indicating + i/o pending. reset to zero when i/o completed. + iosb i/o status block + error 0 success, -1 not acquired, 1 timeout, + 2 invalid device, 1000+n system dep. error diff --git a/unix/gdev/m70vms/fcbu.inc b/unix/gdev/m70vms/fcbu.inc new file mode 100644 index 00000000..54f23244 --- /dev/null +++ b/unix/gdev/m70vms/fcbu.inc @@ -0,0 +1,6 @@ +c +c vax offsets for display.for and termio.for +c + parameter fcb_u_spool = 21 + parameter fcb_u_m70_chan = 19 + parameter fcb_u_m70_name = 17 diff --git a/unix/gdev/m70vms/m70.h b/unix/gdev/m70vms/m70.h new file mode 100644 index 00000000..16b4c938 --- /dev/null +++ b/unix/gdev/m70vms/m70.h @@ -0,0 +1,30 @@ +# Definitions for the VMS/IIS device driver. + +define IIS_READ 1 # read function code +define IIS_WRITE 0 # write function code +define IIS_INACTIVE 2 # no i/o in progress + +define EFN EFN2 # EFN to use for i/o +define EFN1W 0 # efn #1, wait for completion +define EFN2 1 # efn #2, no wait for completion +define EFN3 2 # efn #3, no wait for completion + +# Function control block structure for IIS. The first part of the structure +# is filled in by VMS at open time; all we need to know is the offset of the +# device name. We use the latter part of the buffer for our own internal +# variables. + +define LEN_FCB 28 +define FCB_U_NAME Mems[($1)+16+($2)-1] +define FCB_IOSB Mems[($1)+20+($2)-1] +define FCB_KCHAN Mems[($1)+24] # NULL if on local node, else remote +define FCB_STATUS Mems[($1)+25] # channel status (r, w, err) +define FCB_NBYTES Mems[($1)+26] # nbytes last transfer +define FCB_EFN Mems[($1)+27] # event flag used for transfer + +# IIS device status words. + +define IIS_FILSIZE (512 * 512 * SZB_CHAR) +define IIS_BLKSIZE 1024 +define IIS_OPTBUFSIZE (512 * SZB_CHAR) +define IIS_MAXBUFSIZE 32768 diff --git a/unix/gdev/m70vms/m70cls.f b/unix/gdev/m70vms/m70cls.f new file mode 100644 index 00000000..9eb2fcd3 --- /dev/null +++ b/unix/gdev/m70vms/m70cls.f @@ -0,0 +1,26 @@ + subroutine m70cls (fcb) +c +c Routine to close model 70 display +c + integer fcb(*) + include 'fcbu.inc' +c + integer*4 sys$dassgn, chan, junk + integer*2 chan2(2) + equivalence (chan, chan2) +c +c call wtexec (fcb) +c + chan2(1) = fcb(fcb_u_m70_chan) + chan2(2) = fcb(fcb_u_m70_chan+1) +c +c if (chan.ne.0) call lib$signal (%val(sys$dassgn (%val(chan)))) + if (chan.ne.0) then + junk = sys$dassgn (%val(chan)) + endif +c + fcb(fcb_u_m70_chan) = 0 + fcb(fcb_u_m70_chan+1) = 0 +c + return + end diff --git a/unix/gdev/m70vms/m70get.f b/unix/gdev/m70vms/m70get.f new file mode 100644 index 00000000..c9d0b1c2 --- /dev/null +++ b/unix/gdev/m70vms/m70get.f @@ -0,0 +1,43 @@ + subroutine m70get (fcb, error) +c +c Routine to get (allocate) the model 70 +c +c arguments: +c +c fcb function communications block +c +c error -2 => device already allocated +c -1 => m70 not acquired +c 0 => success +c 1 => timeout +c 2 => invalid device or powerfail +c >=1000 machine dependent error number +c + integer fcb(*), error +c + include 'fcbu.inc' + external ss$_normal, ss$_devalloc + integer*4 len,status, sys$alloc + integer*2 nam2(2), stat + byte nam(4) + character name*4, result*8 + equivalence (nam2, nam), (name, nam), (status, stat) +c + nam2(1) = fcb(fcb_u_m70_name) + nam2(2) = fcb(fcb_u_m70_name+1) +c + status = sys$alloc (name, len, result,) + if (status.ne.%loc(ss$_normal)) then + if (status .eq. %loc(ss$_devalloc)) then + error = -2 + else + error = 1000 + stat + endif + else + call m70opn (fcb, error) + if (error .ne. 0) return + call m70mcl (fcb, error) + endif +c + return + end diff --git a/unix/gdev/m70vms/m70io.f b/unix/gdev/m70vms/m70io.f new file mode 100644 index 00000000..cbe0418e --- /dev/null +++ b/unix/gdev/m70vms/m70io.f @@ -0,0 +1,75 @@ + subroutine m70io (fcb, data, count, read, opcd, iosb, error) +c +c Routine does io between M70 and a VAX +c +c Parameters: +c +c fcb function communications block. +c +c data input/output buffer. +c +c count number of words to read/write. +c +c read 0 -> write, 1 -> read. +c +c opcd 0 -> qio with efn = 1 and wait for completion +c 1 -> qio with efn = 2 +c 2 -> qio with efn = 3 +c +c iosb I/O status quadword +c +c error -1 => display not available +c 0 => success +c 1 => time/out +c 2 => invalid or non-responding device +c 1000 > machine dependent error code +c + integer fcb(*), data(1), count, read, opcd, error + integer*4 iosb(2) +c + include 'fcbu.inc' + external io$_writevblk, io$_readvblk, ss$_timeout, ss$_powerfail + integer*4 chan, sys$qio, sys$waitfr, func, status, l_iosb(2) + integer*2 chan2(2), stat(2) + equivalence (chan, chan2), (status, stat(1)) +c + chan2(1) = fcb(fcb_u_m70_chan) + chan2(2) = fcb(fcb_u_m70_chan+1) +c + if (read.eq.1) then + func = %loc(io$_readvblk) + else + func = %loc(io$_writevblk) + endif +c + if (opcd.eq.0) then + status = sys$qio (%val(opcd+1), %val(chan), %val(func), + 1 l_iosb,,, data, %val(2*count),,,,) + if (status) then + status = sys$waitfr (%val(1)) + if (l_iosb(1)) then + error = 0 + else + stat(1) = lib$match_cond + 1 (iosb, ss$_timeout, ss$_powerfail) + if (stat(1) .eq. 0) then + error = 1000 + iosb(1) + else + error = stat(1) + endif + endif + else + error = 1000 + stat(1) + endif + else + status = sys$qio (%val(opcd+1), %val(chan), %val(func), + 1 iosb,,, data, %val(2*count),,,,) + if (status) then + error = 0 + else + error = 1000 + stat(1) + endif + endif +c + return + end diff --git a/unix/gdev/m70vms/m70mcl.f b/unix/gdev/m70vms/m70mcl.f new file mode 100644 index 00000000..c9fb5c98 --- /dev/null +++ b/unix/gdev/m70vms/m70mcl.f @@ -0,0 +1,35 @@ + subroutine m70mcl (fcb, error) +c +c master clear model 70 +c + integer fcb(*), error +c + include 'fcbu.inc' + external io$_rewind, ss$_normal + integer*4 status, iosb(2), chan, sys$qiow + integer*2 chan2(2), iostat, stat + equivalence (chan, chan2), (iosb, iostat) + equivalence (status, stat) + external ss$_timeout, ss$_powerfail +c + chan2(1) = fcb(fcb_u_m70_chan) + chan2(2) = fcb(fcb_u_m70_chan+1) +c + status = sys$qiow (, %val(chan), io$_rewind, iosb,,,,,,,,) + if (status) then + if (iosb(1)) then + error = 0 + else + status = lib$match_cond (iosb, ss$_timeout, ss$_powerfail) + if (status .eq. 0) then + error = 1000 + iostat + else + error = status + endif + endif + else + error = 1000 + stat + endif +c + return + end diff --git a/unix/gdev/m70vms/m70opn.f b/unix/gdev/m70vms/m70opn.f new file mode 100644 index 00000000..4bb91b3a --- /dev/null +++ b/unix/gdev/m70vms/m70opn.f @@ -0,0 +1,41 @@ + subroutine m70opn (FCB, error) +C +c Routine to open model 70 +c +c Error is returned as: +c -1 = display open +c 0 = OK +c 1 = timeout +c 2 = invalid or non-responding device +c >= 1000 : machine dependent error number +c + integer fcb(*), error + include 'fcbu.inc' +C + integer*4 sys$assign, chan, status + integer*2 chan2(2), name2(2), stat(2) + byte name1(4) + character*4 m70 + equivalence (chan, chan2), (status, stat(1)) + equivalence (name1, name2), (name1, m70) +C + name2(1) = fcb(fcb_u_m70_name) + name2(2) = fcb(fcb_u_m70_name+1) + chan2(1) = fcb(fcb_u_m70_chan) + chan2(2) = fcb(fcb_u_m70_chan+1) +c + if (chan.eq.0) then + status = sys$assign ('_'//m70//':', chan,,) + if (status) then + fcb(fcb_u_m70_chan) = chan2(1) + fcb(fcb_u_m70_chan+1) = chan2(2) + error = 0 + else + error = 1000 + stat(1) + endif + else + error = -1 + endif +c + return + end diff --git a/unix/gdev/m70vms/m70rel.f b/unix/gdev/m70vms/m70rel.f new file mode 100644 index 00000000..7b686d10 --- /dev/null +++ b/unix/gdev/m70vms/m70rel.f @@ -0,0 +1,19 @@ + subroutine m70rel (fcb) +c +c routine to release(DEALLOCATE) the model 70 +c + integer fcb(*) +c + include 'fcbu.inc' + integer*2 dev2(2) + byte dev(4) + character*4 m70 + equivalence (dev2,dev), (m70,dev) +c + call m70cls (fcb) + dev2(1) = fcb(fcb_u_m70_name) + dev2(2) = fcb(fcb_u_m70_name+1) + call sys$dalloc ('_'//m70//':',) +c + return + end diff --git a/unix/gdev/m70vms/m70wt.f b/unix/gdev/m70vms/m70wt.f new file mode 100644 index 00000000..715a1c68 --- /dev/null +++ b/unix/gdev/m70vms/m70wt.f @@ -0,0 +1,44 @@ + subroutine m70wt (fcb, bfnum, bfcnt, iosb, error) +c +c routine to wait for completion of buffer write on pdp-11's +c +c fcb function communication block. +c bfnum used to determine event flag to wait for +c bfcnt number of words in buffer. should be -1 indicating +c i/o pending. reset to zero when i/o completed. +c iosb i/o status block +c error 0 success, -1 not acquired, 1 timeout, +c 2 invalid device, 1000+n system dep. error +c + integer fcb(*) + integer bfnum, bfcnt, error + integer*4 iosb(2), status + integer*2 stat(2) +c + integer*4 sys$waitfr + equivalence (status, stat(1)) + external ss$_timeout, ss$_powerfail +c +c is this wait required? +c + error = 0 + if (bfcnt .ge. 0) return +c + status = sys$waitfr (%val(bfnum+1)) + if (status) then + bfcnt = 0 + if (.not. iosb(1)) then + stat(1) = lib$match_cond + 1 (iosb, ss$_timeout, ss$_powerfail) + if (stat(1) .eq. 0) then + error = 1000 + iosb(1) + else + error = stat(1) + endif + endif + else + error = 1000 + stat(1) + endif +c + return + end diff --git a/unix/gdev/m70vms/m70wti.f b/unix/gdev/m70vms/m70wti.f new file mode 100644 index 00000000..0aabd1fd --- /dev/null +++ b/unix/gdev/m70vms/m70wti.f @@ -0,0 +1,46 @@ + subroutine m70wti (fcb, func, time, button, x, y) +c +c This routine waits for the appropriate interupt from the +c Unibus M70 interface card, then returns button and cursor +c information. +c +c +c parameter descriptions: +c +c fcb is a system info. array. +c +c func is interpreted: +c 0 ==> wait for button push. +c 1 ==> wait for cursor move. +c 2 ==> wait for button push or cursor move. +c + integer fcb(*), func, time, button, x, y +c + include 'fcbu.inc' + external io$_rewindoff + integer*4 sys$qiow, mask, chan, iosb(2) + integer*2 chan2(2) + equivalence (chan, chan2) +c + chan2(1) = fcb(fcb_u_m70_chan) ! get M70 channel + chan2(2) = fcb(fcb_u_m70_chan+1) +c + if (func.eq.0) then + mask = '0400'x ! wait for button + elseif (func.eq.1) then + mask = '0800'x ! wait for trackball + elseif (func.eq.2) then + mask = '0C00'x ! wait for button or trackball + else + mask = '0C00'x + endif +c + status = sys$qiow (, %val(chan), io$_rewindoff, + 1 iosb,,,%val(mask),,,,,) +c +c Get button word and X-Y position of cursor +c + call rbutn (fcb, button, x, y) +c + return + end diff --git a/unix/gdev/m70vms/mkpkg b/unix/gdev/m70vms/mkpkg new file mode 100644 index 00000000..976cc1e4 --- /dev/null +++ b/unix/gdev/m70vms/mkpkg @@ -0,0 +1,29 @@ +# Makelib for the VMS version of the IIS driver. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + @(i2) + zclm70.x m70.h + zopm70.x m70.h + zrdm70.x m70.h + zstm70.x m70.h + zwrm70.x m70.h + zwtm70.x m70.h + ; + +i2: # Compile the VMS/Fortran IIS i/o routines with the VMS /NOI4 option. + $set XFLAGS = "-c -O -i2" + + m70cls.f fcbu.inc + m70get.f fcbu.inc + m70io.f fcbu.inc + m70mcl.f fcbu.inc + m70opn.f fcbu.inc + m70rel.f fcbu.inc + m70wt.f + m70wti.f fcbu.inc + ; diff --git a/unix/gdev/m70vms/zclm70.x b/unix/gdev/m70vms/zclm70.x new file mode 100644 index 00000000..a7ebb8f7 --- /dev/null +++ b/unix/gdev/m70vms/zclm70.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m70.h" + +# ZCLM70 -- Close and deallocate the IIS. + +procedure zclm70 (chan, status) + +int chan # FCB pointer for device +int status +pointer fcb + +begin + fcb = chan + if (FCB_KCHAN(fcb) == NULL) { + call zwtm70 (chan, status) + call m70rel (Mems[fcb]) + } else + call zclsbf (FCB_KCHAN(fcb), status) + + call mfree (fcb, TY_SHORT) +end diff --git a/unix/gdev/m70vms/zopm70.x b/unix/gdev/m70vms/zopm70.x new file mode 100644 index 00000000..f338dbe7 --- /dev/null +++ b/unix/gdev/m70vms/zopm70.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m70.h" + +# ZOPM70 -- Open the IIS for binary file i/o. The device will be automatically +# allocated if necessary. + +procedure zopm70 (device, mode, chan) + +char device[ARB] # packed VMS device name +int mode # access mode +int chan # receives device channel + +pointer fcb +int kchan +char upkdev[SZ_FNAME] +int ki_connect() + +short ier +% character m70*4 +% integer*2 namw(2) +% equivalence (m70, namw) + +begin + call calloc (fcb, LEN_FCB, TY_SHORT) + + # Use the binary file driver if the device resides on a remote node. + # This precludes remote access to a VMS hosted IIS at present. + + if (ki_connect (device) != NULL) { + call zopnbf (device, mode, kchan) + if (kchan != ERR) + FCB_KCHAN(fcb) = kchan + } else { + # Load string descriptor for device name into FCB. + call strupk (device, upkdev, SZ_FNAME) +% call f77pak (upkdev, m70, 4) + + FCB_U_NAME(fcb,1) = namw[1] + FCB_U_NAME(fcb,2) = namw[2] + FCB_KCHAN(fcb) = NULL + FCB_STATUS(fcb) = IIS_INACTIVE + FCB_NBYTES(fcb) = 0 + + # Allocate and open the device. + call m70get (Mems[fcb], ier) + kchan = ier + if (kchan != 0) + kchan = ERR + } + + if (kchan < 0) { + call mfree (fcb, TY_SHORT) + chan = ERR + } else + chan = fcb +end diff --git a/unix/gdev/m70vms/zrdm70.x b/unix/gdev/m70vms/zrdm70.x new file mode 100644 index 00000000..2bf726ab --- /dev/null +++ b/unix/gdev/m70vms/zrdm70.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m70.h" + +# ZRDM70 -- Initiate an asynchronous read from the IIS. + +procedure zrdm70 (chan, buf, nbytes, offset) + +int chan # FCB pointer for device +char buf[ARB] # output buffer +int nbytes # number of bytes to read +long offset # not used for this device + +pointer fcb +short rwflag, opcd, nwords, ier +data rwflag /IIS_READ/, opcd /EFN/ + +begin + fcb = chan + if (FCB_KCHAN(fcb) == NULL) { + nwords = nbytes / (SZ_SHORT * SZB_CHAR) + call m70io (Mems[fcb], buf, nwords, rwflag, opcd, FCB_IOSB(fcb,1), + ier) + + FCB_NBYTES(fcb) = nbytes + FCB_EFN(fcb) = opcd + + if (ier != 0) + FCB_STATUS(fcb) = ERR + else + FCB_STATUS(fcb) = IIS_READ + } else + call zardbf (FCB_KCHAN(fcb), buf, nbytes, offset) +end diff --git a/unix/gdev/m70vms/zstm70.x b/unix/gdev/m70vms/zstm70.x new file mode 100644 index 00000000..2b790dfa --- /dev/null +++ b/unix/gdev/m70vms/zstm70.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m70.h" + +# ZSTM70 -- Return device status for the IIS. + +procedure zstm70 (chan, what, lvalue) + +int chan # FCB pointer for device +int what # status parameter +long lvalue + +begin + switch (what) { + case FSTT_FILSIZE: + lvalue = IIS_FILSIZE + case FSTT_BLKSIZE: + lvalue = IIS_BLKSIZE + case FSTT_OPTBUFSIZE: + lvalue = IIS_OPTBUFSIZE + case FSTT_MAXBUFSIZE: + lvalue = IIS_MAXBUFSIZE + default: + lvalue = ERR + } +end diff --git a/unix/gdev/m70vms/zwrm70.x b/unix/gdev/m70vms/zwrm70.x new file mode 100644 index 00000000..7cc1ef8a --- /dev/null +++ b/unix/gdev/m70vms/zwrm70.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m70.h" + +# ZWRM70 -- Initiate an asynchronous write to the IIS. + +procedure zwrm70 (chan, buf, nbytes, offset) + +int chan # FCB pointer for device +char buf[ARB] # input buffer +int nbytes # number of bytes to write +long offset # not used for this device + +pointer fcb +short rwflag, opcd, nwords, ier +data rwflag /IIS_WRITE/, opcd /EFN/ + +begin + fcb = chan + if (FCB_KCHAN(fcb) == NULL) { + nwords = nbytes / (SZ_SHORT * SZB_CHAR) + call m70io (Mems[fcb], buf, nwords, rwflag, opcd, FCB_IOSB(fcb,1), + ier) + + FCB_NBYTES(fcb) = nbytes + FCB_EFN(fcb) = opcd + + if (ier != 0) + FCB_STATUS(fcb) = ERR + else + FCB_STATUS(fcb) = IIS_WRITE + } else + call zawrbf (FCB_KCHAN(fcb), buf, nbytes, offset) +end diff --git a/unix/gdev/m70vms/zwtm70.x b/unix/gdev/m70vms/zwtm70.x new file mode 100644 index 00000000..69ab39da --- /dev/null +++ b/unix/gdev/m70vms/zwtm70.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "m70.h" + +# ZWTM70 -- Wait for i/o completion and return the number of bytes read or +# written or ERR. Repetitive calls return the same value. + +procedure zwtm70 (chan, status) + +int chan # FCB pointer for device +int status # nbytes transferred or ERR + +pointer fcb +short bfnum, bufcnt, ier + +begin + fcb = chan + + if (FCB_KCHAN(fcb) == NULL) { + switch (FCB_STATUS(fcb)) { + case ERR: + status = ERR + case IIS_INACTIVE: + status = FCB_NBYTES(fcb) + + default: + bfcnt = -1 # m70wt is a nop if we don't do this + bfnum = FCB_EFN(fcb) + + call m70wt (Mems[fcb], bfnum, bfcnt, FCB_IOSB(fcb,1), ier) + + if (ier != 0) + status = ERR + else + status = FCB_NBYTES(fcb) + + FCB_STATUS(fcb) = IIS_INACTIVE + } + + } else + call zawtbf (FCB_KCHAN(fcb), status) +end diff --git a/unix/gdev/mkpkg b/unix/gdev/mkpkg new file mode 100644 index 00000000..800c7e9c --- /dev/null +++ b/unix/gdev/mkpkg @@ -0,0 +1,12 @@ +# Make the ZFIOGD (binary graphics) device driver and install it in libsys. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + zfiogd.x + @iism70 + @iism75 + ; diff --git a/unix/gdev/mkpkg.sh b/unix/gdev/mkpkg.sh new file mode 100644 index 00000000..3984d71f --- /dev/null +++ b/unix/gdev/mkpkg.sh @@ -0,0 +1,3 @@ +# GDEV -- Host dependent graphics device drivers. + +(cd sgidev; sh -x mkpkg.sh) diff --git a/unix/gdev/sgidev/README b/unix/gdev/sgidev/README new file mode 100644 index 00000000..363b490f --- /dev/null +++ b/unix/gdev/sgidev/README @@ -0,0 +1,24 @@ +SGIDEV -- This directory contains the UNIX dependent sources for the metacode +or bitmap translation programs for all devices supported by the SGI graphics +kernel. See gio$sgikern or `help sgikern' for further information on SGI. + +To add a new SGI device: + + [1] Add source file for translator to this directory. + [2] Add references to mkpkg.csh and mkpkg. + [3] Run `mkpkg update' in this directory to install new translator. + + [4] Add entry to graphcap file, including DD command string + containing host command to dispose of the output. + + [5] Test new device interface. + +Alternatively, you might wish to install the source for the translator in +local somewhere, to avoid a merge operation when a new version of the VMS +host system interface is installed. + +Note that some example graphcap entries for SGI devices might require non- +standard tasks residing outside of IRAF, for example the `impress300' +command to ship Impress output from a UNIX node to a VMS node running +Eunice in order to execute the VMS IMPRINT command. These are considered +so unusual that support is not included in the standard system. diff --git a/unix/gdev/sgidev/README.gif b/unix/gdev/sgidev/README.gif new file mode 100644 index 00000000..85833d3f --- /dev/null +++ b/unix/gdev/sgidev/README.gif @@ -0,0 +1,438 @@ + +Announcement for adass.iraf.system: + + An SGI translator which converts IRAF graphics directly to GIF +images is now available from our anonymous ftp archive as + + ftp://iraf.noao.edu/pub/sgi2gif.c + ftp://iraf.noao.edu/pub/sgi2gif.readme + +The associated readme file describes how to install the translator and +configure a variety of graphcap entries for it. + SGI translators are used to convert IRAF graphics to some other +format, usually Postscript, for disposal to a printer or some other +hardcopy device. The SGI2GIF translator now allows users to generate +GIF images (suitable for web page presentation) directly from IRAF using +the familiar ":.snap" command or non-interactively. See the readme file +for a full discussion of the capabilities and configuration options, or +contact site support (iraf@noao.edu) with questions or problems. + +-------------------------------------------------------------------------------- + +README: + +1. Introduction +--------------- + + IRAF hardcopy graphics are generated by converting the graphics +metacode through the SGI (Simple Graphics Interface) kernel which +translates the numerous graphics commands to a minimal set of move/draw +instructions or a bitmap raster of the plot. In the case of +hardcopy/output graphics (i.e. the SGI kernel), the dev$graphcap file +defines parameters for this conversion which include the plot size, SGI +kernel options, and most especially a "device dispose" (DD) string which +specifies the SGI translator to be used and what to do with the resulting +translator output. The SGI kernel is not a full graphics kernel so +information such as line color and fill areas are lost, below we will +discuss how to retain this when producing a GIF images using other +translators and graphcap file trickery. + + For most printer devices the "sgi2uapl" Postscript translator is +used to convert the SGI kernel metacode from a series of move/draw +instructions to equivalent postscript commands, other translators are +available to convert to other printer languages. The SGI kernel can also +be used, with the proper graphcap entries, to generate a bitmap raster of +the plot which can be easily converted to various image formats. The SGI2GIF +translator takes advantage of this latter feature to produce GIF images +directly from the IRAF graphics metacode. + + The translator has options for specifying the image size, +foreground and background colors, GIF transparency, and can be used to +convert multiple input bitmap files or a single file containing multiple +graphics frames. It allows users to easily generate images suitable for +presentation on the web, either manually or automatically. + + +2. Installation +--------------- + + The SGI translator is distributed in source form and to be used +must be compiled and installed in the system hbin$ directory. To install +the new SGI translator follow these steps while logged in through the iraf +user account: + + [1] Download the translator from the IRAF anonymous FTP archive or + one of it's mirror sites using: + + % ftp iraf.noao.edu (140.252.1.1) + login: anonymous + password: [your email address] + ftp> cd /pub + ftp> mget sgi2gif.c + ftp> quit + + [2] Compile the source using + + % cc -o sgi2gif.e sgi2gif.c # compile the source + % mv sgi2gif.e $hbin # move to the $hbin + + "$hbin" is defined in the iraf environment to be something like + $iraf/unix/bin., where would be 'ssol' for Solaris, + 'sparc' for SunOS and so on. + + [3] Optionally place the source in the directory $iraf/unix/gdev/sgidev. + + [4] Edit the dev$graphcap file and add the following default entries + for the device near the top of the file: + + g-gif|UNIX generic interface to multi-frame GIF file generator:\ + :DD=ugif,tmp$sgk,!{ sgidispatch sgi2gif -w $(PX) -h $(PY) \ + -bg 0 0 0 -fg 255 255 255 -root sgigif $F.[1-8] ; \ + rm $F.[1-8]; }&:MF#8:NF:tc=sgi_image_format: + + sgi_image_format|Generic raster file format specification:\ + :kf=bin$x_sgikern.e:tn=sgikern:ar#.75:\ + :xr#640:yr#480 :PX#640:PY#480 :XW#640:YW#480:\ + :BI:MF#1:YF:NB#8:LO#1:LS#0:XO#0:YO#0: + + The 'g-gif' entry takes one or more graphics file input and converts + each input frame to a redirected file on output called 'sgigifXXX.gif' + where the 'XXX' is frame number. See below for details one + configuring other graphcap entries. + + +2. Translator Options +--------------------- + The SGI2GIF translator allows the following options: + + -w N Set the width of input bitmap and output image. The + argument must be derived from the graphcap value since + that is what the SGI kernel will use when generating the + bitmap, e.g. "-w $(PX)" instead of "-w 640". + + -h N Set the height of input bitmap and output image. The + argument must be derived from the graphcap value since + that is what the SGI kernel will use when generating the + bitmap, e.g. "-h $(PY)" instead of "-h 640". + + -i Invert the bitmap before conversion. By default the + graphics are drawn using the foreground color, this + option inverts the bitmap before conversion meaning the + graphics are drawn using the background color. + + -t Set background color as transparent. If enabled the + translator will produce a GIF89 format image with the + background color set as "transparent". When this image + is used with an HTML document the background color is + the HTML page color. + + -root Set the root rame for output file. If defined this + root name will be combined with the frame number and + a ".gif" extension to form the output name. If not + defined and only one input image is present the default + action is to send the output to STDOUT. + + -fg R G B Specify foreground color (default 'black'). Set the + foreground color as a triplet of RGB values in the + range 0-255. The -fg flag must have three arguments. + + -bg R G B Specify background color (default 'white'). Set the + foreground color as a triplet of RGB values in the + range 0-255. The -bg flag must have three arguments. + + +3. Configuring Alternate Graphcap Entries +----------------------------------------- + + Most of the work in a graphcap entry is done by the 'device +dispose' (i.e. "DD") string. This string is composed of three comma +delimited parts: a node/device name (which is normally ignored), a +temporary filename, and a host dispose command. To configure a new entry +it is only this last field that normally needs to be modified, perhaps in +conjunction with another graphcap parameter. As an example let's look at +the DD string used in the example graphcap above: + + :DD=ugif,tmp$sgk,!{ sgidispatch sgi2gif -w $(PX) -h $(PY) \ + -bg 0 0 0 -fg 255 255 255 -root sgigif $F.[1-8] ; rm $F.[1-8]; }&: + +where 'ugif' is the unused node/device name, 'tmp$sgk' is the temporary +filename, and the remainder is a host dispose command. The 'sgidispatch' +command is an iraf binary that launches the specified translator +('sgi2gif' here) with any required arguments. Note that everything within +the "!{...}&" curly braces is executed (as a background Bourne shell +command) so any string of valid unix command separate by a semicolon will +be executed. In this case the sgidispatch command launches the sgi2gif +translator with all of it's arguments, it then deletes the input metacode +file symbolized by the "$F". + You may notice that some arguments are specified as e.g. "-w +$(PX)". When the DD string is executed any macro values beginning with a +'$' such as '$(PX)' are replaced with values from the rest of the graphcap +entry. In this case '$(PX)' is replaced by the value contained in the +graphcap :PX (physical X size) field, the "$F.[1-8]" is expanded to +include the unique root filename along with any extension 1 thru 8 which may +be generated because of multiple plots in the input. In +most cases all you may need to change in the DD string itself is the +output file, or e.g. whether it gets piped to some other command. + + +3.1 Changing Image Size +----------------------- + + Changing the image size is simply a matter of changing the graphcap +parameters + + :xr#640:yr#480: sets X,Y device resolution + :PX#640:PY#480: sets X,Y physical size of bitmap + :XW#640:YW#480: sets X,Y width of plotting window + +These are defined in the 'sgi_image_format' entry given above. Graphics +are drawn using Normalized Device Coordinates ('NDC', values in the range +0.0 to 1.0) and will be scaled appropriately for any specified output +dimensions allowing users to configure graphcap entries for images which are +larger/smaller than the default, or have square or elongated aspect ratios. + +3.2 Preserving Color Information +-------------------------------- + + Colors such as those used for the axis labels and frame, and colors +used in the plot itself for different line/marker types cannot be preserved +by the SGI kernel directly. To do this you must use a full graphics kernel +such as the PSIKERN postscript kernel found in STSDAS. The V2.11 +distribution contains graphcap entries suitable for this kernel but assumes +you have STSDAS available. See the online help for more information about +this kernel. + Using the '-fg' and '-bg' flags will allow you to specify foreground +and background colors to be used for the plot as a whole. Note that these +flags require three arguments to specify the RGB color components. The '-t' +flag may be used to mark the background color as 'transparent' so only the +foreground color is shown when the image is used in an HTML document. + +3.3 Generating Other Image Formats +---------------------------------- + + GIF may be used as an intermediate format which can be converted to +something else as part of the graphcap DD string. For example, to use the +ImageMagick CONVERT task to produce a JPEG image the graphcap DD string +could be written as + + g-jpeg|UNIX generic interface to JPEG file generator:\ + :DD=ugif,tmp$sgk,!{ sgidispatch sgi2gif -w $(PX) -h $(PY) \ + -bg 0 0 0 -fg 255 255 255 -root sgi $F | \ + convert sgi$$.gif sgi$$.jpg ; rm $F; }&: \ + :MF#1:NF:tc=sgi_image_format: + +The DD string first uses the SGI2GIF translator to produce a 'sgi.gif' +image, then calls the convert task (which is assumed to be in the user's +path) to convert this to JPEG as a separate step. The :MF field is +set to one meaning each frame will generate a new file. The '$$' used in +the filenames (e.g. 'sgi$$.gif') is the process id created for the shell +running the DD command meaning multiple filenames of the form 'sgi12345.gif' +will be created, each with a unique id number so the images aren't over- +written. In the past this form of DD string could be used with the standard +sgi2uapl postscript translator and a host task such as 'gs' to convert +postscript to some other format. + +4. Interfacing to Web CGI Scripts +---------------------------------- + + It would be impossible to give complete details about interfacing +IRAF programs to CGI scripts due to the variety of languages and tasks +that may be used. To begin lets look at how to execute a task from the +host level, which is essentially what we'll be doing from within a CGI +script. + In principle this can be done in one of two ways: Either invoke +the executable directly with the correct command line arguments, or run +the CL with the input redirected to execute the task. In the first case +you must know in which executable the task resides, core IRAF system tasks +(e.g. things in the PLOT and IMAGES packages) have their executables in +the main $iraf/bin. directory, NOAO package tasks have the +executables in the $iraf/noao/bin. directory. There is usually a +separate executable for each package and you can probably figure out which +one goes for each package otherwise just look at the package cl file to +find out, for example the PLOT package defines the task in the +$iraf/pkg/plot/plot.cl file, if you look in their you'll see that is +defines the tasks as (part of the file reads) + +task contour, + surface, hafton, velvect = "plot$x_ncar.e" + +which means that the CONTOUR, SURFACE, etc tasks are in the "x_ncar.e" +executable. + Once you find the correct binary, you need to create a file with +the task parameters: usually it's easiest to set the parameters and then +dump the parameter file with 'dpar', e.g. + + cl> dpar listpix > listpix.par + +It's likely that CGI scripts will need to set certain parameters itself so +thought must be given to how to edit this list of default parameters with +values given in the CGI script. + +To run the task you would then do something like: + + % $iraf/bin.sparc/x_images.e listpix @listpix.par + +In this case you must be careful that ALL of the task parameters are +defined, this is done by 'dpar' but empty string parameters will always +be prompted for. On a host command line simply respond to the parameter +prompts by hitting the return key, from with a CGI script these must +be supplied automatically in some way (e.g. via redirection). + In the second case you create a command file and input it to the +cl, for example + + % cl < cl.input >& some_logfile + +where cl.input contains CL commands such as + + wfits.scale=no # set a parameter wfits image*.imh + mta # call a task + logout # logout of the CL + +You must be careful about making sure you are in the right directory and +that parameters are given explicitly if they're like to change, but with +this approach you can call any iraf task. + +4.1 Graphics Tasks +------------------- + + Regardless of the method chosen, you need to be careful about +redirecting any required input or text/graphics output. Graphics output +can be redirected either by setting the "device" parameter to e.g. 'vdm' +to create a file called 'vdm' in the uparm directory, or using the '>G' CL +syntax as in + + cl> surface dev$pix >G surf.plot # redirect metacode to a file + cl> surface dev$pix dev="vdm" # save metacode to uparm dir + cl> surface dev$pix dev="stdplot" # to print it out + cl> gflush # flush graphics buffer + +Which of these approaches works best for depends depends on the tasks you +need and the method of execution chosen above. Note that the ">G" syntax +will only work for tasks executed within the CL, setting a device +parameter to something that creates a file will work with either method. + For non-interactive tasks like SURFACE or CONTOUR this file is +created automatically, interactive tasks however may need to create +metacode files explicitly or else the CGI script must take care to extract +only those plots of interest from the metacode file (e.g. with a separate +call to GKIEXTRACT). + Interactive tasks must also satisfy requests for cursor commands, +including the usual 'q' keystroke needed to exit the task. Since cursor +commands are in reality queries to the CL any binary run as a host task +will generate a cursor prompt on the standard output the same as for any +other parameter query. The response to a cursor query however is usually +of the form + x y wcs key strval + +where 'x' and 'y' are the cursor position, 'wcs' is the WCS of those coords +(usually not important), 'key' is the keystroke you would normally enter, +and if 'key' is a color the 'strval' is the remainder of that color command. +See section 3.7 of the "help cursors" help page for more details on alternate +graphics input. Note however, that your CGI script must know in advance the +order in which the prompts will occur to be able to satisfy them correctly, +e.g. any parameter prompts generated by empty string values should be met +with a newline, and cursor prompts with something as above. Since the tasks +will be very narrowly defined as to how they are run this usually isn't +difficult to set up. + +4.2 Example +----------- + + As an example let create a CGI script to execute the PCOL task +from a web interface. All that we need to do this is the PLOT package +binary to execute the task, a 'graphcap' file, and the SGIKERN binary in +order to convert our graphics metacode to a GIF format using the specified +graphcap entries and the newly installed SGI2GIF translator. In the +following we detail the steps involved in creating this script on a system +with IRAF installed, your application may vary somewhat. We use a +C-shell script here but the same principles apply to all scripting +languages, users should contact site support with questions. + +----------------------------------------------------------------------------- + +#!/bin/csh -f +# +# Sample CGI script demonstrating the using the PCOL graphics task to +# produce an 'sgigif.gif' file of the resulting plot which can be shown +# as an image of the output web page. The script does not show how to +# parse arguments or format the resulting HTML page. All that is required +# for IRAF execution is the binary for the task to be run, the SGIKERN +# binary, and a graphcap file to produce the GIF (given below). The CGI +# script can define the task parameters itself or use a predefined 'dpar' +# dump to set defaults as we do below. + +# The REMOTE_ADDR variable is defined in the environment of the CGI +# script automatically, we specify it here for demonstration purposes. +set REMOTE_ADDR = 140.252.30.95 + +# This would be defined as the graphcap file installed for the local web +# server. + +# The only graphcap entries needed to output graphics to a GIF file using +# the SGI translator is as follows: +# +# vdm|stdvdm|Virtual Device Metafile:\ +# :co#80:li#35:xr#1024:yr#1024:zr#256:ar#.77:ch#.0294:cw#.0125:\ +# :X1#0:X2#1023:Y1#0:Y2#1023: +# +# g-gif|UNIX generic interface to multi-frame GIF file generator:\ +# :DD=ugif,tmp$sgk,!{ //sgi2gif.e -w $(PX) -h $(PY) \ +# -bg 0 0 0 -fg 255 255 255 -root sgigif $F.[1-8] ; \ +# rm $F.[1-8]; }&:MF#8:NF:tc=sgi_image_format: +# +# sgi_image_format|Generic raster file format specification:\ +# :kf=bin$x_sgikern.e:tn=sgikern:ar#.75:\ +# :xr#640:yr#480:PX#640:PY#480:XW#640:YW#480:\ +# :BI:MF#1:YF:NB#8:LO#1:LS#0:XO#0:YO#0: +# +# Note that the path to the sgigif.e binary is specified explicitly, this +# must be replaced by the path to the actual binary. +# +# On the web server this file would normally be installed in the cgi-bin +# or some other directory, the cgi script itself needs to define this location +# with the following variable: + +set graphcap = /tmp/graphcap + +# A uparm directory needs to be defined for saving the VDM file. This is +# defined based on the REMOTE_ADDR so we can have multiple connections +# running at the same time without concurrency problems. + +set uparm = /tmp/uparm-$REMOTE_ADDR/ + +# Create the uparm directory we'll be using... +mkdir $uparm + +# Execute the graphics task desired. In this example we're running the PCOL +# task and assume we've saved the parameters to a 'pcol.dpar' file in the +# current directory. In practice the parameters can be specified using a +# dpar file in the cgi-bin dir or explicitly on the command line. To execute +# the task we call the binary directly, direct output to /dev/null and +# redirect input blank lines to respond to params that take no value. We +# must set the uparm and graphcap values set above to handle the graphics. +# The CGI script can insert values such as 'image' based on arguments, the +# defaults come from a predefined dpar file. + +/iraf/iraf/bin.ssun/x_plot.e >>& /dev/null << EOF +set uparm = $uparm +set graphcap = $graphcap +pcol @pcol.dpar pcol.device="vdm" + +EOF + +# At this point the GKI metacode is saved in the uparm$vdm file, where +# 'uparm' is set above and is created by the custom graphcap file we're +# using. To convert GKI metacode to the final GIF file we call the SGIKERN +# directly and specify the device as 'g-gif' which produces an 'sgigif.gif' +# file in the current directory. Graphcap entries can be created to name +# the file anything desired, that filename is then used as a URL for the +# web page returned. + +/iraf/iraf/bin.ssun/x_sgikern.e >>& /dev/null << EOF +set uparm = $uparm +set graphcap = $graphcap +sgikern input=uparm\$vdm device=g-gif generic=yes +EOF + +# Finally, clean up the temp files we've created. +/bin/rm -rf $uparm + diff --git a/unix/gdev/sgidev/mkpkg b/unix/gdev/sgidev/mkpkg new file mode 100644 index 00000000..e9dac3df --- /dev/null +++ b/unix/gdev/sgidev/mkpkg @@ -0,0 +1,9 @@ +# Make the SGI device host level translation programs [MACHDEP]. + +$call update +$exit + +update: + ! sh -x mkpkg.sh + ! mv $hlib/sgi*.e $hbin + ; diff --git a/unix/gdev/sgidev/mkpkg.sh b/unix/gdev/sgidev/mkpkg.sh new file mode 100644 index 00000000..85d6c83a --- /dev/null +++ b/unix/gdev/sgidev/mkpkg.sh @@ -0,0 +1,60 @@ +# Make the SGI translators and install them in hlib. + +$CC -c $HSI_CF sgiUtil.c + +$CC -c $HSI_CF sgidispatch.c +$CC $HSI_LF sgidispatch.o ../../hlib/libos.a $HSI_LIBS -o sgidispatch.e +mv -f sgidispatch.e ../../hlib +rm sgidispatch.o + +$CC -c $HSI_CF sgi2uimp.c +$CC $HSI_LF sgi2uimp.o sgiUtil.o $HSI_LIBS -o sgi2uimp.e +mv -f sgi2uimp.e ../../hlib +rm sgi2uimp.o + +$CC -c $HSI_CF sgi2uapl.c +$CC $HSI_LF sgi2uapl.o sgiUtil.o $HSI_LIBS -o sgi2uapl.e +mv -f sgi2uapl.e ../../hlib +rm sgi2uapl.o + +$CC -c $HSI_CF sgi2uqms.c +$CC $HSI_LF sgi2uqms.o sgiUtil.o $HSI_LIBS -o sgi2uqms.e +mv -f sgi2uqms.e ../../hlib +rm sgi2uqms.o + +$CC -c $HSI_CF sgi2uptx.c +$CC $HSI_LF sgi2uptx.o sgiUtil.o $HSI_LIBS -o sgi2uptx.e +mv -f sgi2uptx.e ../../hlib +rm sgi2uptx.o + +$CC -c $HSI_CF sgi2uhplj.c +$CC $HSI_LF sgi2uhplj.o sgiUtil.o $HSI_LIBS -o sgi2uhplj.e +mv -f sgi2uhplj.e ../../hlib +rm sgi2uhplj.o + +$CC -c $HSI_CF sgi2uhpgl.c +$CC $HSI_LF sgi2uhpgl.o sgiUtil.o $HSI_LIBS -o sgi2uhpgl.e +mv -f sgi2uhpgl.e ../../hlib +rm sgi2uhpgl.o + +$CC -c $HSI_CF sgi2ueps.c +$CC $HSI_LF sgi2ueps.o sgiUtil.o $HSI_LIBS -o sgi2ueps.e +mv -f sgi2ueps.e ../../hlib +rm sgi2ueps.o + +$CC -c $HSI_CF sgi2gif.c +$CC $HSI_LF sgi2gif.o sgiUtil.o $HSI_LIBS -o sgi2gif.e +mv -f sgi2gif.e ../../hlib +rm sgi2gif.o + +$CC -c $HSI_CF sgi2xbm.c +$CC $HSI_LF sgi2xbm.o sgiUtil.o $HSI_LIBS -o sgi2xbm.e +mv -f sgi2xbm.e ../../hlib +rm sgi2xbm.o + +$CC -c $HSI_CF sgi2svg.c +$CC $HSI_LF sgi2svg.o sgiUtil.o $HSI_LIBS -o sgi2svg.e +mv -f sgi2svg.e ../../hlib +rm sgi2svg.o + +rm sgiUtil.o diff --git a/unix/gdev/sgidev/sgi2gif.c b/unix/gdev/sgidev/sgi2gif.c new file mode 100644 index 00000000..e46d4d28 --- /dev/null +++ b/unix/gdev/sgidev/sgi2gif.c @@ -0,0 +1,731 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#include "sgiUtil.h" + + +/* + * SGI2GIF.C -- Read an IRAF SGI bitmap file on standard input and convert + * to a GIF format image on standard outout. + * + * Usage: + * sgi2gif.e [-params] [ [sgi_bitmap] [sgi_bitmap] ... ] + * + * -w N width of input bitmap and output image + * -h N height of input bitmap and output image + * -i invert the bitmap values before conversion + * -t set background color as transparent + * -root set the root rame for output file (default stdout) + * -fg R G B specify foreground color + * -bg R G B specify background color + * + * The input file name and the switches may occur in any order. The + * foreground/background flags require three arguments giving the values + * of the RGB components of the color as a decimal number in the range 0-255. + * Enabling the transparency flag will cause a GIF 89 image to be written, + * otherwise the default will be a GIF 87 format image. The transparent + * color will always be the backgrund color. The bitmap may be inverted + * here using the -i flag. + * + * Sample graphcaps for this translator might look like: + * + * g-gif|UNIX generic interface to multi-frame GIF file generator:\ + * :DD=ugif,tmp$sgk,!{ sgidispatch sgi2gif -w $(PX) -h $(PY) \ + * -bg 0 0 0 -fg 255 255 255 -root sgigif $F.[1-8] ; \ + * rm $F.[1-8]; }&:MF#8:NF:tc=sgi_image_format: + * + * sgi_image_format|Generic raster file format specification:\ + * :kf=bin$x_sgikern.e:tn=sgikern:ar#.75:\ + * :xr#640:yr#480:PX#640:PY#480:XW#640:YW#480:\ + * :BI:MF#1:YF:NB#8:LO#1:LS#0:XO#0:YO#0: + * + * The 'g-gif' entry takes one or more graphics file input and converts + * each input frame to a redirected file on output called 'sgigifXXX.gif' + * where the 'XXX' is frame number. + * + * To change the image size the graphcap :xr, :PX, :XW (X-dimension) and + * :yr, :PY, :XY (Y-dimension) fields all need to be changed. The -i + * or -t flags must be specified in the graphcap DD string along with the + * -fg/bg flags and their arguments. + */ + + +#define NBITS_CHAR 8 /* number of bits in a char */ +#define DEF_WIDTH 640 /* default image width */ +#define DEF_HEIGHT 480 /* default image height */ +#define DEF_BG 255 /* default background RGB */ +#define DEF_FG 0 /* default foreground RGB */ +#define MAX_INFILES 16 /* max number of input bitmaps */ +#define SZ_FNAME 64 /* size of a filename */ + +typedef int code_int; +typedef long int count_int; +typedef unsigned char byte; + +static byte *pixels; + +static int px = DEF_WIDTH; +static int py = DEF_HEIGHT; +static int nrows = DEF_HEIGHT; +static int ncols = DEF_WIDTH; +static int transparent = 0; +static int invert = 0; +static int red[] = { DEF_BG, DEF_FG } ; +static int green[] = { DEF_BG, DEF_FG } ; +static int blue[] = { DEF_BG, DEF_FG } ; +static char *infile[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; +static char *s_root = "sgigif_"; + +static int GIFNextPixel(); +static void BumpPixel(), GIFEncode(), Putword(), compress(); +static void output(), cl_block(), cl_hash(), char_init(); +static void char_out(), flush_char(), unpack1to8(); + + + +/* MAIN -- Main entry point for the task. + */ +int +main (int argc, char *argv[]) +{ + FILE *fdi, *fdo; + char fname[SZ_FNAME]; + char *root = s_root; + byte *buffer, *ip; + int i, index, numin=0, len_buf; + int interlace, background, bpp; + + + /* Process the command line. + */ + for (i=1; i < argc; i++) { + if (argv[i][0] == '-') { + if (strcmp (argv[i], "-w") == 0) { + ncols = px = atoi (argv[++i]); + } else if (strcmp (argv[i], "-h") == 0) { + nrows = py = atoi (argv[++i]); + } else if (strcmp (argv[i], "-i") == 0) { + invert++; + } else if (strcmp (argv[i], "-root") == 0) { + root = argv[++i]; + } else if (strcmp (argv[i], "-t") == 0) { + transparent++; + } else if (strcmp (argv[i], "-bg") == 0) { + if (isdigit(argv[++i][0])) + red[0] = atoi (argv[i]); + else + fprintf (stderr, + "sgi2gif: invalid -bg arg '%s'\n", argv[i]); + if (isdigit(argv[++i][0])) + green[0] = atoi (argv[i]); + else + fprintf (stderr, + "sgi2gif: invalid -bg arg '%s'\n", argv[i]); + if (isdigit(argv[++i][0])) + blue[0] = atoi (argv[i]); + else + fprintf (stderr, + "sgi2gif: invalid -bg arg '%s'\n", argv[i]); + } else if (strcmp (argv[i], "-fg") == 0) { + if (isdigit(argv[++i][0])) + red[1] = atoi (argv[i]); + else + fprintf (stderr, + "sgi2gif: invalid -bg arg '%s'\n", argv[i]); + if (isdigit(argv[++i][0])) + green[1] = atoi (argv[i]); + else + fprintf (stderr, + "sgi2gif: invalid -bg arg '%s'\n", argv[i]); + if (isdigit(argv[++i][0])) + blue[1] = atoi (argv[i]); + else + fprintf (stderr, + "sgi2gif: invalid -bg arg '%s'\n", argv[i]); + } else { + fprintf (stderr, "sgi2gif: unknown switch '%s'\n", argv[i]); + } + } else { + /* input sgi-bitmap file specification */ + if (numin < MAX_INFILES) + infile[numin++] = argv[i]; + } + } + + /* Allocate space for the images. */ + len_buf = px / NBITS_CHAR; + buffer = (byte *) malloc (len_buf); + ip = pixels = (byte *) malloc (px * (py + 1)); + + /* Loop over the input bitmaps, writing the converted output to + * either stdout or a filename. + */ + for (index = 0; index == 0 || index < numin; index++) { + + /* Open the input file. */ + fdi = (infile[index] ? fopen (infile[index], "r") : stdin); + + /* Open the output file. For multiple input files force each + * output to a new image, when reading from stdin or only one + * bitmap write to stdout if we didn't set the rootname. + */ + if (numin <= 1 && strcmp (root, s_root) == 0) { + fdo = stdout; + } else { + if (numin > 1) + sprintf (fname, "%s%d.gif", root, index); + else + sprintf (fname, "%s.gif", root); + fdo = fopen (fname, "w+"); + } + + /* Now unpack this bitmap to the output image as byte data. */ + ip = pixels; + while (fread (buffer, len_buf, 1, fdi)) { + /* If we're on a MSB ordered machine wordswap the bitmap so + * it's in the correct order for unpacking to be interpreted + * as an LSB-ordered image. + */ + if ( ! isSwapped ()) + bswap4 (buffer, buffer, len_buf); + + unpack1to8 ((ip+=px), buffer, px); + } + + /* All set, write it out. */ + GIFEncode (fdo, px, py, (interlace=0), (background=0), (bpp=1), + red, green, blue); + + fflush (fdi); + fflush (fdo); + if (fdi != stdin) + fclose (fdi); + if (fdo != stdout) + fclose (fdo); + } + + /* Clean up. */ + free (buffer); + free (pixels); + + return (0); +} + + +/* UNPACK1TO8 -- Unpack each bit in the bitmap to a byte on output. + */ + +static void +unpack1to8 (byte *dest, byte *src, int len) +{ + register int i, b; + byte c = 0; + + for (i = 0, b = 0; i < len; i++) { + if (b > 7) { + b = 0; + c = (invert ? ~(*src++) : (*src++) ); + } + *dest++ = (byte) ((c >> (b++)) & 1); + } +} + + +/* GIF Writing Procedures. + * + * Based on GIFENCOD by David Rowley . A + * Lempel-Zim compression based on "compress". Original Copyright 1990, + * David Koblas, heavily modified since then.... + */ + +#define GIFBITS 12 + +static int Width, Height; +static int curx, cury; +static long CountDown; +static int Interlace; + + +/* GIFENCODE -- GIF Image compression interface. + */ + +static void +GIFEncode (fp, GWidth, GHeight, GInterlace, Background, Bpp, Red, Green, Blue) +FILE *fp; +int GWidth, GHeight; +int GInterlace; +int Background; +int Bpp; +int Red[], Green[], Blue[]; +{ + int B; + int RWidth, RHeight; + int LeftOfs, TopOfs; + int Resolution; + int ColorMapSize; + int InitCodeSize; + int i; + + Interlace = GInterlace; + + ColorMapSize = 1 << Bpp; + + RWidth = Width = GWidth; + RHeight = Height = GHeight; + LeftOfs = TopOfs = 0; + + Resolution = Bpp; + + /* Calculate number of bits we are expecting */ + CountDown = (long)Width * (long)Height; + + /* The initial code size */ + if (Bpp <= 1) + InitCodeSize = 2; + else + InitCodeSize = Bpp; + + /* Set up the current x and y position */ + curx = cury = 0; + + /* Write the Magic header */ + fwrite ((transparent ? "GIF89a" : "GIF87a"), 1, 6, fp); + + /* Write out the screen width and height */ + Putword (RWidth, fp); + Putword (RHeight, fp); + + /* Indicate that there is a global colour map */ + B = 0x80; /* Yes, there is a color map */ + + /* OR in the resolution */ + B |= (Resolution - 1) << 5; + + /* OR in the Bits per Pixel */ + B |= (Bpp - 1); + + /* Write it out */ + fputc (B, fp); + + /* Write out the Background colour */ + fputc (Background, fp); + + /* Byte of 0's (future expansion) */ + fputc (0, fp); + + /* Write out the Global Colour Map */ + for (i = 0; i < ColorMapSize; ++i) { + fputc (Red[i], fp); + fputc (Green[i], fp); + fputc (Blue[i], fp); + } + + /* If doing transparency, write the extension. */ + if (transparent) { + fputc (0x21, fp); /* graphics extension... */ + fputc (0xf9, fp); /* transparency... */ + fputc (0x4, fp); + fputc (0x1, fp); + fputc (0x0, fp); + fputc (0x0, fp); + fputc ((char) 0, fp); /* background color index */ + fputc (0x0, fp); + } + + /* Write an Image separator */ + fputc (',', fp); + + /* Write the Image header */ + Putword (LeftOfs, fp); + Putword (TopOfs, fp); + Putword (Width, fp); + Putword (Height, fp); + + /* Write out whether or not the image is interlaced */ + if (Interlace) + fputc (0x40, fp); + else + fputc (0x00, fp); + + /* Write out the initial code size */ + fputc (InitCodeSize, fp); + + /* Go and actually compress the data */ + compress (InitCodeSize + 1, fp); + + /* Write out a Zero-length packet (to end the series) */ + fputc (0, fp); + + /* Write the GIF file terminator */ + fputc (';', fp); +} + + +/* Bump the 'curx' and 'cury' to point to the next pixel + */ +static void +BumpPixel() +{ + /* Bump the current X position */ + ++curx; + + /* If at the end of a scan line, set curx back to the beginning. */ + if (curx == Width) { + curx = 0; + ++cury; + } +} + + +/* Return the next pixel from the image + */ +static int +GIFNextPixel () +{ + int r; + + if (CountDown == 0) + return EOF; + + --CountDown; + r = (int) pixels[ cury * ncols + curx ] ; + BumpPixel(); + return r; +} + + +/* Write out a word to the GIF file + */ +static void +Putword (w, fp) +int w; +FILE*fp; +{ + unsigned short val = w; + + fputc (val & 0xff, fp); + fputc ((val / 256) & 0xff, fp); +} + + +/* + * GIF Image compression - modified 'compress' + * + * Based on: compress.c - File compression ala IEEE Computer, June 1984. + * + * By Authors: Spencer W. Thomas, Jim McKie, Steve Davies, Ken Turkowski, + * James A. Woods, Joe Orost + * + * Lempel-Ziv compression based on 'compress'. GIF modifications by + * David Rowley (mgardi@watdcsu.waterloo.edu) + */ + +#define HSIZE 5003 /* 80% occupancy */ + +static int n_bits; /* number of bits/code */ +static int maxbits = GIFBITS; /* user settable max # bits/code */ +static code_int maxcode; /* maximum code, given n_bits */ + /* should NEVER generate this code */ +static code_int maxmaxcode = (code_int) 1 << GIFBITS; +#define MAXCODE(n_bits) (((code_int) 1 << (n_bits)) - 1) + +static count_int htab[HSIZE]; +static unsigned short codetab [HSIZE]; +#define HashTabOf(i) htab[i] +#define CodeTabOf(i) codetab[i] + +/* To save much memory, we overlay the table used by compress() with those + * used by decompress(). The tab_prefix table is the same size and type + * as the codetab. The tab_suffix table needs 2**GIFBITS characters. We + * get this from the beginning of htab. The output stack uses the rest + * of htab, and contains characters. There is plenty of room for any + * possible stack (stack used to be 8000 characters). + */ + +#define tab_prefixof(i) CodeTabOf(i) +#define tab_suffixof(i) ((unsigned char *)(htab))[i] + +static code_int free_ent = 0; /* first unused entry */ +static code_int hsize = HSIZE; /* for dynamic table sizing */ + + +/* block compression parameters -- after all codes are used up, + * and compression rate changes, start over. + */ +static int clear_flg = 0; + +/* + * compress stdin to stdout + * + * Algorithm: use open addressing double hashing (no chaining) on the + * prefix code / next character combination. We do a variant of Knuth's + * algorithm D (vol. 3, sec. 6.4) along with G. Knott's relatively-prime + * secondary probe. Here, the modular division first probe is gives way + * to a faster exclusive-or manipulation. Also do block compression with + * an adaptive reset, whereby the code table is cleared when the compression + * ratio decreases, but after the table fills. The variable-length output + * codes are re-sized at this point, and a special CLEAR code is generated + * for the decompressor. Late addition: construct the table according to + * file size for noticeable speed improvement on small files. Please direct + * questions about this implementation to ames!jaw. + */ + +static FILE *g_outfile; +static int g_init_bits; +static int ClearCode; +static int EOFCode; +static int cur_bits = 0; + +static unsigned long cur_accum = 0; +static unsigned long masks[] = { + 0x0000, 0x0001, 0x0003, 0x0007, 0x000F, + 0x001F, 0x003F, 0x007F, 0x00FF, + 0x01FF, 0x03FF, 0x07FF, 0x0FFF, + 0x1FFF, 0x3FFF, 0x7FFF, 0xFFFF }; + +static int a_count; /* Number of characters so far in this 'packet' */ +static char accum[256]; /* Define the storage for the packet accumulator */ + +static void +compress (init_bits, outfile) +int init_bits; +FILE *outfile; +{ + register long fcode; + register code_int i /* = 0 */; + register int c; + register code_int ent; + register code_int disp; + register code_int hsize_reg; + register int hshift; + + /* Set up the globals: g_init_bits - initial number of bits + * g_outfile - pointer to output file + */ + g_init_bits = init_bits; + g_outfile = outfile; + + /* Set up the necessary values */ + clear_flg = 0; + cur_accum = 0; + cur_bits = 0; + maxbits = GIFBITS; + maxcode = MAXCODE(n_bits = g_init_bits); + + ClearCode = (1 << (init_bits - 1)); + EOFCode = ClearCode + 1; + free_ent = ClearCode + 2; + + char_init(); + for (i=0; i 0) + goto probe; +nomatch: + output ((code_int) ent); + ent = c; + if (free_ent < maxmaxcode) { /* } */ + CodeTabOf (i) = free_ent++; /* code -> hashtable */ + HashTabOf (i) = fcode; + } else + cl_block(); + } + + /* + * Put out the final code. + */ + output ((code_int)ent); + output ((code_int) EOFCode); +} + +/* + * Output the given code. + * Inputs: + * code: A n_bits-bit integer. If == -1, then EOF. This assumes + * that n_bits =< (long)wordsize - 1. + * Outputs: + * Outputs code to the file. + * Assumptions: + * Chars are 8 bits long. + * Algorithm: + * Maintain a GIFBITS character long buffer (so that 8 codes will + * fit in it exactly). Use the VAX insv instruction to insert each + * code in turn. When the buffer fills up empty it and start over. + */ + +static void +output (code) +code_int code; +{ + cur_accum &= masks[ cur_bits ]; + + if (cur_bits > 0) + cur_accum |= ((long)code << cur_bits); + else + cur_accum = code; + + cur_bits += n_bits; + + while (cur_bits >= 8) { + char_out ((unsigned int)(cur_accum & 0xff)); + cur_accum >>= 8; + cur_bits -= 8; + } + + /* + * If the next entry is going to be too big for the code size, + * then increase it, if possible. + */ + if (free_ent > maxcode || clear_flg) { + + if (clear_flg) { + maxcode = MAXCODE (n_bits = g_init_bits); + clear_flg = 0; + } else { + ++n_bits; + if (n_bits == maxbits) + maxcode = maxmaxcode; + else + maxcode = MAXCODE(n_bits); + } + } + + if (code == EOFCode) { + /* At EOF, write the rest of the buffer. */ + while (cur_bits > 0) { + char_out ((unsigned int)(cur_accum & 0xff)); + cur_accum >>= 8; + cur_bits -= 8; + } + flush_char(); + fflush (g_outfile); + if (ferror (g_outfile)) + perror ("error writing output file"); + } +} + +/* + * Clear out the hash table + */ +static void +cl_block () /* table clear for block compress */ +{ + + cl_hash ((count_int) hsize); + free_ent = ClearCode + 2; + clear_flg = 1; + + output ((code_int)ClearCode); +} + +static void +cl_hash(hsize) /* reset code table */ +register count_int hsize; +{ + + register count_int *htab_p = htab + hsize; + + register long i; + register long m1 = -1; + + i = hsize - 16; + do { /* might use Sys V memset(3) here */ + *(htab_p - 16) = m1; + *(htab_p - 15) = m1; + *(htab_p - 14) = m1; + *(htab_p - 13) = m1; + *(htab_p - 12) = m1; + *(htab_p - 11) = m1; + *(htab_p - 10) = m1; + *(htab_p - 9) = m1; + *(htab_p - 8) = m1; + *(htab_p - 7) = m1; + *(htab_p - 6) = m1; + *(htab_p - 5) = m1; + *(htab_p - 4) = m1; + *(htab_p - 3) = m1; + *(htab_p - 2) = m1; + *(htab_p - 1) = m1; + htab_p -= 16; + } while ((i -= 16) >= 0); + + for (i += 16; i > 0; --i) + *--htab_p = m1; +} + +/* Set up the 'byte output' routine + */ +static void +char_init() +{ + register int i; + + a_count = 0; + for (i=0; i<256; i++) + accum[i] = 0; +} + +/* Add a character to the end of the current packet, and if it is 254 + * characters, flush the packet to disk. + */ +static void +char_out (c) +int c; +{ + accum[ a_count++ ] = c; + if (a_count >= 254) + flush_char(); +} + +/* Flush the packet to disk, and reset the accumulator */ +static void +flush_char() +{ + if (a_count > 0) { + fputc (a_count, g_outfile); + fwrite (accum, 1, a_count, g_outfile); + a_count = 0; + } +} diff --git a/unix/gdev/sgidev/sgi2svg.c b/unix/gdev/sgidev/sgi2svg.c new file mode 100644 index 00000000..be25a704 --- /dev/null +++ b/unix/gdev/sgidev/sgi2svg.c @@ -0,0 +1,245 @@ +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "sgiUtil.h" + + +/* +** SGI2SVG.C -- Read IRAF SGI metacode from standard input, translate into +** Scalable Vector Graphics (SVG) format. +** +** Usage +** sgi2svg.e [-params] [sgi_metacode] [| lpr -Papple] +** +** -fg FG color specified as RGB triplet (e.g. 'F00' is red) +** -bg BG color specified as RGB triplet (e.g. '0F0' is green) +** -fill fill color specified as RGB triplet (e.g. '00F' is blue) +** -w width of plot, device pixels starting from l +** -h height of plot, device pixels starting from b +** -p pen width +** +** Option values must be separated from their flags by a space; the input +** file name and the switches may occur in any order. +** +** Sample Graphcap: +** +** g-svg|UNIX generic interface to SVG file generator:\ +** :DD=usvg,tmp$sgk,!{ sgidispatch sgi2svg -w $(PX) -h $(PY) \ +** -bg FFF -fg 000 -fill FFF $F > sgi$$.svg ; }&:PX#640:PY#480:\ +** :kf=bin$x_sgikern.e:tn=sgikern:tc=sgi_apl: +*/ + +#define OSOK 0 /* normal successful completion */ +#define LEN_MCBUF 1024 /* number of SGK instrs in buffer */ +#define SGK_FRAME 1 /* new frame instruction */ +#define SGK_MOVE 2 /* move pen */ +#define SGK_DRAW 3 /* draw pen */ +#define SGK_SETLW 4 /* set line width */ +#define GKI_MAXNDC 32767. /* SGK units */ + + +/* Device opcodes and parameters. + */ +#define DEF_LEFT 0 /* origin in device pixels in x */ +#define DEF_BOTTOM 0 /* origin in device pixels in y */ +#define DEF_WIDTH 640 /* width in x (240d/i, 11" paper) */ +#define DEF_HEIGHT 480 /* height in y (240d/i, 8.5" paper)*/ +#define DEF_PENWIDTH 1 /* origin in device pixels in x */ + + +/* Commands to setup SVG environment. +*/ +static char *svg_prolog[] = { + "\n", + "\n", + NULL +}; + +/* Opcode instruction. +*/ +struct sgi_inst { + short opcode; + short x, y; +}; + + +int pen_width = DEF_PENWIDTH; /* initial line width */ +int width = DEF_WIDTH; /* margins */ +int height = DEF_HEIGHT; +char *bg = "#FFF"; /* BG/FG colors */ +char *fg = "#000"; +char *fill = "#FFF"; /* vector fill color */ + + +static void translate (FILE *in, FILE *out); + + + +/* MAIN -- Main entry point for SGI2UHPGL. Optional arguments are device +** window parameters and name of input file. +*/ +int +main (int argc, char *argv[]) +{ + FILE *in; + char *infile = "stdin", *argp; + int argno; + register char **lp; + + + /* Process the command line. + */ + for (argno=1; (argp = argv[argno]) != NULL; argno++) { + if (argp[0] == '-') { + /* A window-control or pen width switch. + */ + switch (argp[1]) { + case 'f': + if (argp[2] == 'g') + fg = argv[++argno]; + else + fill = argv[++argno]; + break; + case 'b': + bg = argv[++argno]; + break; + case 'w': width = atoi (argv[++argno]); break; + case 'h': height = atoi (argv[++argno]); break; + case 'p': pen_width = atoi (argv[++argno]); break; + default: + break; + } + + } else { + /* Input sgi-metacode file specification. + */ + infile = argp; + } + } + + + /* Open the input file. */ + if (strcmp (infile, "stdin") == 0) + in = stdin; + else + in = fopen (infile, "r"); + if (in == NULL) { + fprintf (stderr, "Fatal error (sgi2svg): Cannot open `%s'\n", + infile); + fflush (stderr); + exit (OSOK+1); + } + + + /* Output the standard prolog. + */ + for (lp=svg_prolog; *lp; lp++) + fputs (*lp, stdout); + + fprintf (stdout,""); + fprintf (stdout, + "\n", + bg, fg); + fprintf (stdout, + "\n", fill, bg); + + + + /* Process the metacode. + */ + translate (in, stdout); + + + /* Clean up. + */ + fprintf (stdout, ""); /* output the end of file */ + if (in != stdin) + fclose (in); + + return (0); +} + + +/* TRANSLATE -- Interpret input SGI metacode instructions into device +** instructions and write to stdout. +*/ +static void +translate (FILE *in, FILE *out) +{ + register struct sgi_inst *sgip; + struct sgi_inst inbuf[LEN_MCBUF], *buftop; + int n, in_stroke=0, swap_bytes = isSwapped(); + int x, y, gnum=1; + + + /* Process the metacode: + */ + while ((n = fread ((char *)inbuf, sizeof(*sgip), LEN_MCBUF, in)) > 0) { + if (swap_bytes) + bswap2 ((unsigned char *)inbuf, (unsigned char *)inbuf, + sizeof(*sgip) * n); + + buftop = inbuf + n; + + for (sgip = inbuf; sgip < buftop; sgip++) { + switch (sgip->opcode) { + case SGK_FRAME: + fprintf (out, "\n"); + break; + + case SGK_MOVE: + x = (int) (((float)sgip->x / GKI_MAXNDC) * width); + y = (int) (((float)sgip->y / GKI_MAXNDC) * height); + y = height - y + 1; + if (in_stroke) /* end current stroke */ + fprintf (out, "\"/>"); + + /* Begin a new output stroke. + */ + fprintf (out, "x / GKI_MAXNDC) * width); + y = (int) (((float)sgip->y / GKI_MAXNDC) * height); + y = height - y + 1; + fprintf (out, " %d,%d", x, y); + in_stroke = 1; + break; + + case SGK_SETLW: + /* Set pen width. + */ + pen_width = sgip->x + 1; + if (in_stroke) /* end current stroke */ + fprintf (out, "\"/>"); + fprintf (out, "", + gnum++, pen_width); + in_stroke = 0; + break; + + default: + fprintf (stderr, "sgi2svg: unrecognized sgi opcode %d\n", + sgip->opcode); + break; + } + } + } + + /* Terminate plotting and exit. + */ + fprintf (out, " \"/>\n"); +} diff --git a/unix/gdev/sgidev/sgi2uapl.c b/unix/gdev/sgidev/sgi2uapl.c new file mode 100644 index 00000000..3c59d284 --- /dev/null +++ b/unix/gdev/sgidev/sgi2uapl.c @@ -0,0 +1,545 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include + +#ifdef SOLARIS +#include +#endif + +#define import_spp +#define import_error +#include + +#include "sgiUtil.h" + + +/* + * SGI2UAPL.C -- Read IRAF SGI metacode from standard input, translate into + * Postscript for the Apple Laserwriter and write to standard output. + * + * Usage: + * + * sgi2uapl.e [-params] [sgi_metacode] [| lpr -Plw] + * + * -4 use 4 byte point encoding scheme (default is 7 byte) + * -t omit the timestamp/logo normally written to corner of plot + * -l N left edge; x plot origin in device pixels + * -b N bottom edge; y plot origin in device pixels + * -w N width of plot, device pixels starting from l + * -h N height of plot, device pixels starting from b + * -p O.S pen width `origin' and `slope' + * + * Numeric values may be appended directly to their flags or separated by a + * space; the input file name and the switches may occur in any order. + * Note that you can arrange for the Postscript output to be saved in a file + * as well as directed to the printer by calling the translator as + * + * sgi2uapl.e [params] | tee -a file | lpr -Plw + */ + +#define OSOK 0 /* normal successful completion */ +#define LEN_MCBUF 1024 /* number of SGK instrs in buffer */ +#define SGK_FRAME 1 /* new frame instruction */ +#define SGK_MOVE 2 /* move pen */ +#define SGK_DRAW 3 /* draw pen */ +#define SGK_SETLW 4 /* set line width */ +#define SGK_MAXNDC 32767 /* SGK units */ + +/* Device opcodes and parameters. The default edge and width parameters (DEF_) + * are given in Apple Laserwriter pixels, at 300 dots/inch. Although bypassing + * the device-independence of Postscript, this achieves greater efficiency + * both in translator performance and in transmission rate to the plotter. + * The device y-origin is at the lower left corner of the page, but we take + * care of this with a Postscript coordinate transformation. Thus the maximum + * page `width' is 11*300 pixels, `height' is 8.5*300 pixels. + */ +#define DEV_FRAME "showpage setcoords setjoins\n" /* newframe */ +#define DEV_SETLW "setlinewidth\n" /* linewidth */ + +#define MAX_POINTS 512 /* maximum points on stack before a STROKE */ +#define DEF_LEFT 30 /* origin in device pixels in x */ +#define DEF_WIDTH 3180 /* width in x (300d/i, 11" paper) */ +#define DEF_BOTTOM 60 /* origin in device pixels in y */ +#define DEF_HEIGHT 2415 /* height in y (300d/i, 8.5" paper) */ +#define DEF_PENBASE 3 /* base pen width (LW 1->2) */ +#define DEF_PENSLOPE 4 /* pen width slope (LW 2->4, 3->6 etc.) */ +#define SZ_PENCMD 16 /* total no. of chars in penwidth instruction */ +#define SZ_PENVAL 2 /* no. of chars in penwidth value */ +#define SZ_VCODE 7 /* no. of chars in MOVE or DRAW opcode */ +#define SZ_VECT 17 /* total no. chars in a MOVE or DRAW inst. */ +#define SZ_COORD 4 /* no. of chars in device coordinate */ +#define XY_MOVE 0 +#define XY_DRAW 1 + +struct sgi_inst { + short opcode; + short x; + short y; +}; + +/* Commands to setup Postscript environment. + */ +static char *ps_init[] = { + "%!PS-Adobe-2.0", + "/devppi 300 def", + "/userppi 72 def", + "/pagewidth 8.5 def", + "/devpixtouser { userppi mul devppi div } def", + "/pagetolandscape 90 def", + "/setcoords { pagewidth userppi mul 0 translate", + " pagetolandscape rotate 1 devpixtouser 1 devpixtouser scale } def", + "/setjoins { 1 setlinejoin 1 setlinecap } def", + "erasepage initgraphics setcoords setjoins", + NULL }; + +/* 7BYTE -- Postscript procedures to move or draw, with the X,Y coordinates + * encoded as a 4 byte sequence (7 bytes including the command name and spaces) + * following the command name. This is the fastest encoding, since it + * minimizes the Postscript interpreter execution time. + * + * bit 76543210 + * ------------------------------------------ + * 0 01XXXXXX hi 6 X bits + * 1 01XXXXXX li 6 X bits + * 2 01YYYYYY hi 6 Y bits + * 3 01YYYYYY lo 6 Y bits + */ +static char *ps_7byte[] = { + "/getpoint {", + " currentfile read pop 8#77 and 6 bitshift", + " currentfile read pop 8#77 and or", + " currentfile read pop 8#77 and 6 bitshift", + " currentfile read pop 8#77 and or", + " } def", + "/m { getpoint moveto } def", + "/d { getpoint lineto } def", + NULL }; + +/* 4BYTE -- Postscript procedure to draw an arbitrary series of vectors, + * encoded 4 bytes per point. This is the most space efficient encoding, + * but the runtime may be somewhat longer than for the 7byte encoding, + * due to the Postscript interpreter overhead. + * + * Optional Flag byte: + * > move instruction + * + draw instruction + * $ terminate plotting + * other ignored (e.g., whitespace) + * + * Point Encoding: + * bit 76543210 + * ------------------------------------------ + * 1 01XXXXXX hi 6 X bits + * 2 01XXXXXX lo 6 X bits + * 3 01YYYYYY hi 6 Y bits + * 4 01YYYYYY lo 6 Y bits + * + * Data points are encoded 12 bits (0-4095) per X,Y coordinate. The flag byte + * is used as the terminator, to toggle the move/draw state, and to permit + * whitespace to be ignored. A high bit is set in each byte to ensure a + * printable character, as control codes would interfere with the operation of + * the Postscript interpreter. + */ +#define CH_MOVE '>' +#define CH_DRAW '+' +#define CH_EXITPLOT '$' + +static char *ps_4byte[] = { + "/plot { /movepen { moveto } def", + " { currentfile read not { exit } if", + " { dup 8#100 ge", + " { exit }", + " { dup 8#076 eq", + " { pop /movepen { moveto } def", + " currentfile read not { exit } if }", + " { dup 8#053 eq", + " { pop /movepen { lineto } def", + " currentfile read not { exit } if }", + " { dup 8#044 eq", + " { exit }", + " { pop currentfile read not { exit } if }", + " ifelse }", + " ifelse }", + " ifelse }", + " ifelse", + " } loop", + " dup 8#044 eq { pop exit } { 8#77 and 6 bitshift } ifelse", + " currentfile read pop 8#77 and or", + " currentfile read pop 8#77 and 6 bitshift", + " currentfile read pop 8#77 and or", + " movepen", + " } loop", + " } def", + NULL }; + +static int fourbyte = 0; +static int penmode = -1; +static int omit_logo = 0; +static int dev_left; +static int dev_bottom; +static int dev_width; +static int dev_height; +static int dev_penbase = DEF_PENBASE; +static int dev_penslope = DEF_PENSLOPE; +static int npts = 0; + + +static void translate (FILE *in, FILE *out); +static char *make_label (void); +static void textout (FILE *out, char *text[]); +static char *penencode (int val, char *code); +static void xy_flush (FILE *out); +static void xy_point (FILE *out, register int x, register int y, int flag); + + + +/* MAIN -- Main entry point for SGI2UAPL. Optional arguments are device + * window parameters and name of input file. + */ +int +main (int argc, char *argv[]) +{ + FILE *in; + char *infile; + char *argp; + int argno; + int np; + char penparam[SZ_PENCMD]; + + + infile = "stdin"; + + /* Process the command line. + */ + for (argno=1; (argp = argv[argno]) != NULL; argno++) { + if (argp[0] == '-') { + /* A window-control or pen width switch. + */ + switch (argp[1]) { + case '4': + fourbyte++; + break; + case 't': + omit_logo++; + break; + case 'l': + dev_left = get_iarg (argp[2], argv, argno, DEF_LEFT); + break; + case 'b': + dev_bottom = get_iarg (argp[2], argv, argno, DEF_BOTTOM); + break; + case 'w': + dev_width = get_iarg (argp[2], argv, argno, DEF_WIDTH); + break; + case 'h': + dev_height = get_iarg (argp[2], argv, argno, DEF_HEIGHT); + break; + case 'p': + if (argp[2] == (char) 0) + if (argv[argno+1] == NULL) { + fprintf (stderr, "missing arg to switch `%s';", + argp); + fprintf (stderr, " reset to %d.%d\n", dev_penbase, + dev_penslope); + } else + strcpy (penparam, argv[++argno]); + else + strcpy (penparam, argv[argno]+2); + + np = sscanf (penparam, "%d . %d", &dev_penbase, + &dev_penslope); + if (np == 1) { + dev_penslope = dev_penbase; + } else if (np < 1) { + dev_penbase = DEF_PENBASE; + dev_penslope = DEF_PENSLOPE; + } + + break; + default: + fprintf (stderr, "sgi2uapl: unknown switch '%s'\n", argp); + } + + } else { + /* Input sgi-metacode file specification. + */ + infile = argp; + } + } + + if (strcmp (infile, "stdin") == 0) + in = stdin; + else + in = fopen (infile, "r"); + + if (in == NULL) { + fprintf (stderr, "Fatal error (sgi2uapl): Cannot open `%s'\n", + infile); + fflush (stderr); + exit (OSOK+1); + } + + /* Process the metacode. + */ + translate (in, stdout); + + if (in != stdin) + fclose (in); + + return (0); +} + + +/* TRANSLATE -- Interpret input SGI metacode instructions into device + * instructions and write to stdout. + */ +static void +translate (FILE *in, FILE *out) +{ + register struct sgi_inst *sgip; + struct sgi_inst inbuf[LEN_MCBUF], *buftop; + int n, x, y, curpoints = 0, swap_bytes; + float xscale, yscale; + + + swap_bytes = isSwapped(); + + xscale = (float) dev_width / (float) SGK_MAXNDC; + yscale = (float) dev_height / (float) SGK_MAXNDC; + + /* Output device initialization. */ + textout (out, ps_init); + + /* Define the Postscript plotting procedures. */ + if (fourbyte) + textout (out, ps_4byte); + else + textout (out, ps_7byte); + + /* Initialize pen width. */ + fwrite (penencode (dev_penbase, DEV_SETLW), SZ_PENCMD, 1, out); + + /* Process the metacode: + */ + while ((n = fread ((char *)inbuf, sizeof(*sgip), LEN_MCBUF, in)) > 0) { + if (swap_bytes) + bswap2 ((unsigned char *)inbuf, (unsigned char *)inbuf, + sizeof(*sgip) * n); + + buftop = inbuf + n; + + for (sgip = inbuf; sgip < buftop; sgip++) { + switch (sgip->opcode) { + case SGK_FRAME: + xy_flush (out); + fprintf (out, DEV_FRAME); + break; + + case SGK_MOVE: + x = dev_left + sgip->x * xscale; + y = dev_bottom + sgip->y * yscale; + xy_point (out, x, y, XY_MOVE); + break; + + case SGK_DRAW: + x = dev_left + sgip->x * xscale; + y = dev_bottom + sgip->y * yscale; + xy_point (out, x, y, XY_DRAW); + + /* Limit number of points passed to Postscript between + * 'stroke' commands to draw the buffered points. + */ + curpoints = curpoints + 1; + if (curpoints > MAX_POINTS) { + xy_flush (out); + xy_point (out, x, y, XY_MOVE); + curpoints = 0; + } + break; + + case SGK_SETLW: { + /* Set pen width. + */ + int x = max (0, sgip->x - 1); + + xy_flush (out); + curpoints = 0; + fwrite (penencode ( + max (1, dev_penbase + x * dev_penslope), DEV_SETLW), + SZ_PENCMD, 1, out); + } + break; + + default: + fprintf (stderr, "sgi2uapl: unrecognized sgi opcode %d\n", + sgip->opcode); + break; + } + } + } + + /* Terminate plotting and exit. + */ + xy_flush (out); + + /* Add the NOAO logo and timestamp at the bottom of the page and + * output the page. + */ + if (!omit_logo) { + fprintf (out, "/Times-Roman findfont 24 scalefont setfont\n"); + + /* fprintf (out, "[-1 0 0 -1 2350 3180] setmatrix\n"); */ + fprintf (out, "initmatrix\n"); + fprintf (out, "-1 72 mul 300 div 1 72 mul 300 div scale\n"); + fprintf (out, "-2409 88 translate\n"); + + fprintf (out, "%d %d moveto\n", 1600, 3150); + fprintf (out, "[1 0 0 -1 0 0] concat\n"); + fprintf (out, "(%s) show\n", make_label()); + } + + fprintf (out, "showpage\n"); +} + + +/* XY_POINT -- Output a move or draw instruction, using either the 4 byte or + * 7 byte encoding scheme. + */ +static void +xy_point ( + FILE *out, /* output file */ + register int x, /* coords to move to */ + register int y, /* coords to move to */ + int flag /* move or draw? */ +) +{ + static char o[] = "m XXXX"; + register char *op = o; + register int n; + + if (fourbyte) { + if (npts == 0) { + fputs ("plot\n", out); + penmode = XY_MOVE; + } + + if (flag != penmode) + *op++ = ((penmode = flag) == XY_MOVE) ? CH_MOVE : CH_DRAW; + + *op++ = ((n = ((x >> 6) & 077)) == 077) ? n : (0100 | n); + *op++ = ((n = (x & 077)) == 077) ? n : (0100 | n); + *op++ = ((n = ((y >> 6) & 077)) == 077) ? n : (0100 | n); + *op++ = ((n = (y & 077)) == 077) ? n : (0100 | n); + + fwrite (o, op-o, 1, out); + if (!(++npts % 15)) + fputc ('\n', out); + + } else { + o[0] = (flag == XY_MOVE) ? 'm' : 'd'; + o[2] = ((n = ((x >> 6) & 077)) == 077) ? n : (0100 | n); + o[3] = ((n = (x & 077)) == 077) ? n : (0100 | n); + o[4] = ((n = ((y >> 6) & 077)) == 077) ? n : (0100 | n); + o[5] = ((n = (y & 077)) == 077) ? n : (0100 | n); + + fwrite (o, 6, 1, out); + if (!(++npts % 10)) + fputc ('\n', out); + else + fputc (' ', out); + } +} + + +/* XY_FLUSH -- Terminate the current drawing sequence, if any, and issue the + * stroke command to Postscript to draw the buffered points. + */ +static void +xy_flush (FILE *out) +{ + if (npts > 0) { + if (fourbyte) + fputs ("$\n", out); + else if (npts % 10) + fputc ('\n', out); + fputs ("stroke\n", out); + npts = 0; + } +} + + +/* PENENCODE -- Encode base, slope into a character string formatted for the + * device set-pen command. + */ +static char * +penencode ( + int val, /* device line width */ + char *code /* device set-linewidth command */ +) +{ + static char obuf[SZ_PENCMD+1]; + register int digit, n; + register char *op, *ip; + + for (op = &obuf[SZ_PENVAL-1], digit = SZ_PENVAL, n=val; --digit >= 0; + n = n / 10) + *op-- = n % 10 + '0'; + obuf[SZ_PENVAL] = ' '; + for (op = &obuf[SZ_PENVAL+1], ip = code, n = SZ_PENCMD; --n >= 0; ) + *op++ = *ip++; + + return (obuf); +} + + +/* TEXTOUT -- Output lines of text to a file. + */ +static void +textout ( + FILE *out, /* output file */ + char *text[] /* array of lines of text */ +) +{ + register char **lp; + + for (lp=text; *lp; lp++) { + fputs (*lp, out); + fputc ('\n', out); + } +} + + +/* MAKE_LABEL -- Generate the label for the output printer page. + */ +static char * +make_label (void) +{ + static char buf[128]; + char hostname[32]; + char username[32]; + struct passwd *pw; + time_t clock; + +#ifdef SOLARIS + sysinfo (SI_HOSTNAME, hostname, 32); +#else + gethostname (hostname, 32); +#endif + + clock = time(0); + pw = getpwuid (getuid()); + strcpy (username, pw->pw_name); + endpwent(); + + sprintf (buf, "NOAO/IRAF %s@%s %s", + username, hostname, asctime(localtime(&clock))); + + return (buf); +} diff --git a/unix/gdev/sgidev/sgi2ueps.c b/unix/gdev/sgidev/sgi2ueps.c new file mode 100644 index 00000000..345eb702 --- /dev/null +++ b/unix/gdev/sgidev/sgi2ueps.c @@ -0,0 +1,530 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "sgiUtil.h" + + +/* + * SGI2UEPS.C -- Read IRAF SGI metacode from standard input, translate into + * Encapsulated Postscript and write to standard output. + * + * Usage: + * + * sgi2ueps.e [-params] [sgi_metacode] [| lpr -Plw] + * + * -4 use 4 byte point encoding scheme (default is 7 byte) + * -l N left edge; x plot origin in device pixels + * -b N bottom edge; y plot origin in device pixels + * -w N width of plot, device pixels starting from l + * -h N height of plot, device pixels starting from b + * -p O.S pen width `origin' and `slope' + * + * Numeric values may be appended directly to their flags or separated by a + * space; the input file name and the switches may occur in any order. + * Note that you can arrange for the Postscript output to be saved in a file + * as well as directed to the printer by calling the translator as + * + * sgi2ueps.e [params] | tee -a file | lpr -Plw + */ + +#define OSOK 0 /* normal successful completion */ +#define LEN_MCBUF 1024 /* number of SGK instrs in buffer */ +#define SGK_FRAME 1 /* new frame instruction */ +#define SGK_MOVE 2 /* move pen */ +#define SGK_DRAW 3 /* draw pen */ +#define SGK_SETLW 4 /* set line width */ +#define SGK_MAXNDC 32767 /* SGK units */ + +/* Device opcodes and parameters. The default edge and width parameters (DEF_) + * are given in pixels at 300 dots/inch. Although bypassing the + * device-independence of Postscript, this achieves greater efficiency + * both in translator performance and in transmission rate to the plotter. + * The device y-origin is at the lower left corner of the page, but we take + * care of this with a Postscript coordinate transformation. Thus the maximum + * page `width' is 11*300 pixels, `height' is 8.5*300 pixels. + */ +#define DEV_FRAME "showpage setcoords setjoins\n" /* newframe */ +#define DEV_SETLW "setlinewidth\n" /* linewidth */ + +#define MAX_POINTS 512 /* maximum points on stack before a STROKE */ +#define DEF_LEFT 30 /* origin in device pixels in x */ +#define DEF_WIDTH 3180 /* width in x (300d/i, 11" paper) */ +#define DEF_BOTTOM 60 /* origin in device pixels in y */ +#define DEF_HEIGHT 2415 /* height in y (300d/i, 8.5" paper) */ +#define DEV_UNITS 300 /* EPS translator units: N per inch */ +#define EPS_UNITS 72 /* PostScript units (points) */ +#define DEF_PENBASE 3 /* base pen width (LW 1->2) */ +#define DEF_PENSLOPE 4 /* pen width slope (LW 2->4, 3->6 etc.) */ +#define SZ_PENCMD 16 /* total no. of chars in penwidth instruction */ +#define SZ_PENVAL 2 /* no. of chars in penwidth value */ +#define SZ_VCODE 7 /* no. of chars in MOVE or DRAW opcode */ +#define SZ_VECT 17 /* total no. chars in a MOVE or DRAW inst. */ +#define SZ_COORD 4 /* no. of chars in device coordinate */ +#define XY_MOVE 0 +#define XY_DRAW 1 + +struct sgi_inst { + short opcode; + short x; + short y; +}; + +/* Commands to setup Postscript environment. + */ +static char *ps_init[] = { + "/devppi 300 def", + "/userppi 72 def", + "/pagewidth 8.5 def", + "/devpixtouser { userppi mul devppi div } def", + "/setscale { 1 devpixtouser 1 devpixtouser scale } def", + "/pagetolandscape 90 def", + "/setcoords { pagewidth userppi mul 0 translate", + " pagetolandscape rotate setscale } def", + "/setjoins { 1 setlinejoin 1 setlinecap } def", + NULL }; + +static char *ps_endprolog[] = { + "%%EndProlog", + "%%Page: 1 1", + "gsave setscale setjoins", + NULL }; + +/* 7BYTE -- Postscript procedures to move or draw, with the X,Y coordinates + * encoded as a 4 byte sequence (7 bytes including the command name and spaces) + * following the command name. This is the fastest encoding, since it + * minimizes the Postscript interpreter execution time. + * + * bit 76543210 + * ------------------------------------------ + * 0 01XXXXXX hi 6 X bits + * 1 01XXXXXX li 6 X bits + * 2 01YYYYYY hi 6 Y bits + * 3 01YYYYYY lo 6 Y bits + */ +static char *ps_7byte[] = { + "/getpoint {", + " currentfile read pop 8#77 and 6 bitshift", + " currentfile read pop 8#77 and or", + " currentfile read pop 8#77 and 6 bitshift", + " currentfile read pop 8#77 and or", + " } def", + "/m { getpoint moveto } def", + "/d { getpoint lineto } def", + NULL }; + +/* 4BYTE -- Postscript procedure to draw an arbitrary series of vectors, + * encoded 4 bytes per point. This is the most space efficient encoding, + * but the runtime may be somewhat longer than for the 7byte encoding, + * due to the Postscript interpreter overhead. + * + * Optional Flag byte: + * > move instruction + * + draw instruction + * $ terminate plotting + * other ignored (e.g., whitespace) + * + * Point Encoding: + * bit 76543210 + * ------------------------------------------ + * 1 01XXXXXX hi 6 X bits + * 2 01XXXXXX lo 6 X bits + * 3 01YYYYYY hi 6 Y bits + * 4 01YYYYYY lo 6 Y bits + * + * Data points are encoded 12 bits (0-4095) per X,Y coordinate. The flag byte + * is used as the terminator, to toggle the move/draw state, and to permit + * whitespace to be ignored. A high bit is set in each byte to ensure a + * printable character, as control codes would interfere with the operation of + * the Postscript interpreter. + */ +#define CH_MOVE '>' +#define CH_DRAW '+' +#define CH_EXITPLOT '$' + +static char *ps_4byte[] = { + "/plot { /movepen { moveto } def", + " { currentfile read not { exit } if", + " { dup 8#100 ge", + " { exit }", + " { dup 8#076 eq", + " { pop /movepen { moveto } def", + " currentfile read not { exit } if }", + " { dup 8#053 eq", + " { pop /movepen { lineto } def", + " currentfile read not { exit } if }", + " { dup 8#044 eq", + " { exit }", + " { pop currentfile read not { exit } if }", + " ifelse }", + " ifelse }", + " ifelse }", + " ifelse", + " } loop", + " dup 8#044 eq { pop exit } { 8#77 and 6 bitshift } ifelse", + " currentfile read pop 8#77 and or", + " currentfile read pop 8#77 and 6 bitshift", + " currentfile read pop 8#77 and or", + " movepen", + " } loop", + " } def", + NULL }; + +static int npts = 0; +static int fourbyte = 0; +static int penmode = -1; +static int dev_left; +static int dev_bottom; +static int dev_width; +static int dev_height; +static int dev_penbase = DEF_PENBASE; +static int dev_penslope = DEF_PENSLOPE; +static char progname[SZ_LINE+1]; + +static void translate (FILE *in, FILE *out); +static void xy_point (FILE *out, register int x, register int y, int flag); +static void xy_flush (FILE *out); +static char *penencode (int val, char *code); +static void textout (FILE *out, char *text[]); +static void eps_comments (FILE *out); + + + +/* MAIN -- Main entry point for SGI2UAPL. Optional arguments are device + * window parameters and name of input file. + */ +int +main (int argc, char *argv[]) +{ + FILE *in; + char *infile; + char *argp; + int argno; + int np; + char penparam[SZ_PENCMD]; + + + strcpy (progname, argv[0]); + infile = "stdin"; + + /* Process the command line. + */ + for (argno=1; (argp = argv[argno]) != NULL; argno++) { + if (argp[0] == '-') { + /* A window-control or pen width switch. + */ + switch (argp[1]) { + case '4': + fourbyte++; + break; + case 'l': + dev_left = get_iarg (argp[2], argv, argno, DEF_LEFT); + break; + case 'b': + dev_bottom = get_iarg (argp[2], argv, argno, DEF_BOTTOM); + break; + case 'w': + dev_width = get_iarg (argp[2], argv, argno, DEF_WIDTH); + break; + case 'h': + dev_height = get_iarg (argp[2], argv, argno, DEF_HEIGHT); + break; + case 'p': + if (argp[2] == (char) 0) + if (argv[argno+1] == NULL) { + fprintf (stderr, "missing arg to switch `%s';", + argp); + fprintf (stderr, " reset to %d.%d\n", dev_penbase, + dev_penslope); + } else + strcpy (penparam, argv[++argno]); + else + strcpy (penparam, argv[argno]+2); + + np = sscanf (penparam, "%d . %d", &dev_penbase, + &dev_penslope); + if (np == 1) { + dev_penslope = dev_penbase; + } else if (np < 1) { + dev_penbase = DEF_PENBASE; + dev_penslope = DEF_PENSLOPE; + } + + break; + default: + fprintf (stderr, "sgi2ueps: unknown switch '%s'\n", argp); + } + + } else { + /* Input sgi-metacode file specification. + */ + infile = argp; + } + } + + if (strcmp (infile, "stdin") == 0) + in = stdin; + else + in = fopen (infile, "r"); + + if (in == NULL) { + fprintf (stderr, "Fatal error (sgi2ueps): Cannot open `%s'\n", + infile); + fflush (stderr); + exit (OSOK+1); + } + + /* Process the metacode. + */ + translate (in, stdout); + + if (in != stdin) + fclose (in); + + return (0); +} + + +/* TRANSLATE -- Interpret input SGI metacode instructions into device + * instructions and write to stdout. + */ +static void +translate (FILE *in, FILE *out) +{ + register struct sgi_inst *sgip; + struct sgi_inst inbuf[LEN_MCBUF], *buftop; + int n, x, y, curpoints = 0, swap_bytes; + float xscale, yscale; + + + swap_bytes = isSwapped(); + + xscale = (float) dev_width / (float) SGK_MAXNDC; + yscale = (float) dev_height / (float) SGK_MAXNDC; + + /* Output device initialization. */ + eps_comments (out); + textout (out, ps_init); + + /* Define the Postscript plotting procedures. */ + if (fourbyte) + textout (out, ps_4byte); + else + textout (out, ps_7byte); + + textout (out, ps_endprolog); + + /* Initialize pen width. */ + fwrite (penencode (dev_penbase, DEV_SETLW), SZ_PENCMD, 1, out); + + /* Process the metacode: + */ + while ((n = fread ((char *)inbuf, sizeof(*sgip), LEN_MCBUF, in)) > 0) { + if (swap_bytes) + bswap2 ((unsigned char *)inbuf, (unsigned char *)inbuf, + sizeof(*sgip) * n); + + buftop = inbuf + n; + + for (sgip = inbuf; sgip < buftop; sgip++) { + switch (sgip->opcode) { + case SGK_FRAME: + xy_flush (out); + fprintf (out, DEV_FRAME); + break; + + case SGK_MOVE: + x = dev_left + sgip->x * xscale; + y = dev_bottom + sgip->y * yscale; + xy_point (out, x, y, XY_MOVE); + break; + + case SGK_DRAW: + x = dev_left + sgip->x * xscale; + y = dev_bottom + sgip->y * yscale; + xy_point (out, x, y, XY_DRAW); + + /* Limit number of points passed to Postscript between + * 'stroke' commands to draw the buffered points. + */ + curpoints = curpoints + 1; + if (curpoints > MAX_POINTS) { + xy_flush (out); + xy_point (out, x, y, XY_MOVE); + curpoints = 0; + } + break; + + case SGK_SETLW: { + /* Set pen width. + */ + int x = max (0, sgip->x - 1); + + xy_flush (out); + curpoints = 0; + fwrite (penencode ( + max (1, dev_penbase + x * dev_penslope), DEV_SETLW), + SZ_PENCMD, 1, out); + } + break; + + default: + fprintf (stderr, "sgi2ueps: unrecognized sgi opcode %d\n", + sgip->opcode); + break; + } + } + } + + /* Terminate plotting and exit. + */ + xy_flush (out); + + fprintf (out, "grestore showpage\n"); +} + + +/* XY_POINT -- Output a move or draw instruction, using either the 4 byte or + * 7 byte encoding scheme. + */ +static void +xy_point ( + FILE *out, /* output file */ + register int x, /* coords to move to */ + register int y, /* coords to move to */ + int flag /* move or draw? */ +) +{ + static char o[] = "m XXXX"; + register char *op = o; + register int n; + + if (fourbyte) { + if (npts == 0) { + fputs ("plot\n", out); + penmode = XY_MOVE; + } + + if (flag != penmode) + *op++ = ((penmode = flag) == XY_MOVE) ? CH_MOVE : CH_DRAW; + + *op++ = ((n = ((x >> 6) & 077)) == 077) ? n : (0100 | n); + *op++ = ((n = (x & 077)) == 077) ? n : (0100 | n); + *op++ = ((n = ((y >> 6) & 077)) == 077) ? n : (0100 | n); + *op++ = ((n = (y & 077)) == 077) ? n : (0100 | n); + + fwrite (o, op-o, 1, out); + if (!(++npts % 15)) + fputc ('\n', out); + + } else { + o[0] = (flag == XY_MOVE) ? 'm' : 'd'; + o[2] = ((n = ((x >> 6) & 077)) == 077) ? n : (0100 | n); + o[3] = ((n = (x & 077)) == 077) ? n : (0100 | n); + o[4] = ((n = ((y >> 6) & 077)) == 077) ? n : (0100 | n); + o[5] = ((n = (y & 077)) == 077) ? n : (0100 | n); + + fwrite (o, 6, 1, out); + if (!(++npts % 10)) + fputc ('\n', out); + else + fputc (' ', out); + } +} + + +/* XY_FLUSH -- Terminate the current drawing sequence, if any, and issue the + * stroke command to Postscript to draw the buffered points. + */ +static void +xy_flush (FILE *out) +{ + if (npts > 0) { + if (fourbyte) + fputs ("$\n", out); + else if (npts % 10) + fputc ('\n', out); + fputs ("stroke\n", out); + npts = 0; + } +} + + +/* PENENCODE -- Encode base, slope into a character string formatted for the + * device set-pen command. + */ +static char * +penencode ( + int val, /* device line width */ + char *code /* device set-linewidth command */ +) +{ + static char obuf[SZ_PENCMD+1]; + register int digit, n; + register char *op, *ip; + + for (op = &obuf[SZ_PENVAL-1], digit = SZ_PENVAL, n=val; --digit >= 0; + n = n / 10) + *op-- = n % 10 + '0'; + obuf[SZ_PENVAL] = ' '; + for (op = &obuf[SZ_PENVAL+1], ip = code, n = SZ_PENCMD; --n >= 0; ) + *op++ = *ip++; + + return (obuf); +} + + +/* TEXTOUT -- Output lines of text to a file. + */ +static void +textout ( + FILE *out, /* output file */ + char *text[] /* array of lines of text */ +) +{ + register char **lp; + + for (lp=text; *lp; lp++) { + fputs (*lp, out); + fputc ('\n', out); + } +} + + +/* EPS_COMMENTS -- Set identifying comments for EPS conformance. + */ +static void +eps_comments (FILE *out) +{ + time_t clock; + int llx, lly, urx, ury; + + clock = time(0); + + fprintf (out, "%%!PS-Adobe-3.0 EPSF-3.0\n"); + fprintf (out, "%%%%Title: IRAF SGI plot\n"); + fprintf (out, "%%%%Creator: %s\n", progname); + fprintf (out, "%%%%CreationDate: %s", asctime(localtime(&clock))); + + /* Compute bounding box in PostScript coordinates. */ + llx = ((float) dev_left / (float) DEV_UNITS) * (float) EPS_UNITS; + lly = ((float) dev_bottom / (float) DEV_UNITS) * (float) EPS_UNITS; + urx = ((float) (dev_left + dev_width) / (float) DEV_UNITS) + * (float) EPS_UNITS; + ury = ((float) (dev_bottom + dev_height) / (float) DEV_UNITS) + * (float) EPS_UNITS; + + fprintf (out, "%%%%BoundingBox: %d %d %d %d\n", llx, lly, urx, ury); + fprintf (out, "%%%%Pages: 1\n"); + fprintf (out, "%%%%EndComments\n"); +} diff --git a/unix/gdev/sgidev/sgi2uhpgl.c b/unix/gdev/sgidev/sgi2uhpgl.c new file mode 100644 index 00000000..2e952446 --- /dev/null +++ b/unix/gdev/sgidev/sgi2uhpgl.c @@ -0,0 +1,160 @@ +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "sgiUtil.h" + + +/* + * SGI2UHPGL.C -- Read IRAF SGI metacode from standard input, translate into + * HP graphics language call for HP 7550A plotter + * + * Usage + * sgi2uhpgl.e [sgi_metacode] [| lpr -Papple] + * + */ + +#define OSOK 0 /* normal successful completion */ +#define LEN_MCBUF 1024 /* number of SGK instrs in buffer */ +#define SGK_FRAME 1 /* new frame instruction */ +#define SGK_MOVE 2 /* move pen */ +#define SGK_DRAW 3 /* draw pen */ +#define SGK_SETLW 4 /* set line width */ +#define GKI_MAXNDC 32767 /* SGK units */ + +/* Device opcodes and parameters. + */ +#define DEV_INIT "IN;DF;SP1;" /* initialize */ +#define DEV_END "SP0;PG:" /* terminate */ +#define DEV_FRAME "PG;" /* newframe */ +#define DEV_MOVE "PU" /* move */ +#define DEV_DRAW "PD" /* draw */ +#define PRES 1016 /* plotter resolution per inch */ +#define XLEN_INCHES 10.0 /* width of plot (x) in inches */ +#define YLEN_INCHES 8.0 /* height of plot (y) in inches */ +#define XSCALE PRES * XLEN_INCHES / GKI_MAXNDC +#define YSCALE PRES * YLEN_INCHES / GKI_MAXNDC + + +#define SZ_COORD 4 /* no. of chars in device coordinate */ + +struct sgi_inst { + short opcode; + short x; + short y; +}; + +static void translate (FILE *in, FILE *out); + + +/* MAIN -- Main entry point for SGI2UHPGL. Optional arguments are device + * window parameters and name of input file. + */ +int +main (int argc, char *argv[]) +{ + FILE *in; + char *infile; + + + infile = "stdin"; + + /* Process the command line. + */ + infile = argv[1]; + + if (strcmp (infile, "stdin") == 0) + in = stdin; + else + in = fopen (infile, "r"); + + if (in == NULL) { + fprintf (stderr, "Fatal error (sgi2uhpp): Cannot open `%s'\n", + infile); + fflush (stderr); + exit (OSOK+1); + } + + /* Process the metacode. + */ + translate (in, stdout); + + if (in != stdin) + fclose (in); + + return (0); +} + + +/* TRANSLATE -- Interpret input SGI metacode instructions into device + * instructions and write to stdout. + */ +static void +translate (FILE *in, FILE *out) +{ + register struct sgi_inst *sgip; + struct sgi_inst inbuf[LEN_MCBUF], *buftop; + int n, swap_bytes; + float x, y; + + + swap_bytes = isSwapped(); + + /* Output device initialization. + */ + fprintf (out, "%s\n", DEV_INIT); + + /* Initialize pen width. Not implemented. + */ + + /* Process the metacode: + */ + while ((n = fread ((char *)inbuf, sizeof(*sgip), LEN_MCBUF, in)) > 0) { + if (swap_bytes) + bswap2 ((unsigned char *)inbuf, (unsigned char *)inbuf, + sizeof(*sgip) * n); + + buftop = inbuf + n; + + for (sgip = inbuf; sgip < buftop; sgip++) { + switch (sgip->opcode) { + case SGK_FRAME: + fprintf (out, "%s\n", DEV_FRAME); + break; + + case SGK_MOVE: + x = sgip->x * XSCALE; + y = sgip->y * YSCALE; + fprintf (out, + "%s%06.0f%s%06.0f%s\n", DEV_MOVE, x, ",", y, ";"); + break; + + case SGK_DRAW: + x = sgip->x * XSCALE; + y = sgip->y * YSCALE; + fprintf (out, + "%s%06.0f%s%06.0f%s\n", DEV_DRAW, x, ",", y, ";"); + break; + + case SGK_SETLW: + /* Set pen width. + */ + break; + default: + fprintf (stderr, "sgi2uhpp: unrecognized sgi opcode %d\n", + sgip->opcode); + break; + } + } + } + + /* Terminate plotting and exit. + */ + fwrite (DEV_END, strlen(DEV_END), 1, out); + fprintf (out, "\n"); +} diff --git a/unix/gdev/sgidev/sgi2uhplj.c b/unix/gdev/sgidev/sgi2uhplj.c new file mode 100644 index 00000000..7c8956ce --- /dev/null +++ b/unix/gdev/sgidev/sgi2uhplj.c @@ -0,0 +1,223 @@ +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "sgiUtil.h" + + +/* + * SGI2UHPLJ.C -- Read IRAF SGI rasterfile from standard input, translate into + * the Hewlett Packard Printer Command Language (HP Laserjet Series) and + * write to standard output. + * + * Warning + * The output of this is for 150 dpi. At this resolution it will take + * some 200 seconds to plot an simple "prow". + * + * Usage + * sgi2uhplj.e [-params] [sgi_] [| lpr -Phpraw] + * + * -l N left edge; x plot origin in device pixels def DEF_LEFT + * -b N bottom edge; y plot origin in device pixels def DEF_BOTTOM + * -w N width of plot, device pixels starting from l def DEF_WIDTH + * -h N height of plot, device pixels starting from b def DEF_HEIGHT + * + * Numeric values may be appended directly to their flags or separated by a + * space; the input file name and the switches may occur in any order. + */ + +#define OSOK 0 /* normal successful completion */ +#define NBITS_CHAR 8 /* number of bits in a char */ + +/* Device opcodes and parameters. The default edge and width parameters (DEF_) + * are given in HP pixels, at 150 dots/inch. The HP plots in portrait mode + * by default so RO must be set in GRAPHCAP. Thus the maximum page `width' is + * 11*150pixels, `height' is 8.5*150 pixels. + */ + +#define DEV_INIT "\033*t150R\033*r1A" /* Enter graph. */ +#define DEV_END "\033*rB\014" /* Exit graph. */ +#define DEV_VECT "\033*p%03dX\033*p%03dY"/* x,y cursor posn in dots */ +#define DEV_RAST "\033*b%03dW" /* transfer raster graphics */ + +#define DEF_LEFT 15 /* origin in device pixels in x */ +#define DEF_WIDTH 1216 /* width in x (150d/i, 8.5" paper) */ +#define DEF_BOTTOM 30 /* origin in device pixels in y */ +#define DEF_HEIGHT 1590 /* height in y (150d/i, 11" paper) */ + +#define SZ_VECT 14 /* total chars in cursor position command */ +#define SZ_RAST 7 /* total chars in transfer graphics command */ + +/* graphcap entry for uhplj and sgi_hplaserjet. one problem with current + * entry is that graph comes out slightly to the right of center on the page + * The printer used, "hpraw", is site dependent. + * + * uhplj|UNIX generic interface to Hewlett-Packard LaserJet II:\ + * :BF:WS:XO#0:YO#0:LO#2:LS#2:\ + * :DD=plnode!hpii,tmp$sgk,!{ sgidispatch sgi2uhpii $F \ + * -l$(XO) -b$(YO) -w$(PX) -h$(PY) $F | lpr -Phpraw; rm $F; }&:\ + * :tc=sgi_hplaserjet: + * + * sgi_hplaserjet|Hewlett Packard LaserJet Plus at 150 dpi:\ + * :kf=bin$x_sgikern.e:tn=sgikern:cw#.0125:ch#.0294:\ + * :ar#1.325:xs#.2032:ys#.2692:xr#1200:yr#1590:\ + * :XO#8:YO#0:XW#1200:YW#1590:PX#1216:PY#1590:LO#1:LS#0:\ + * :BI:MF#8:RO:NB#8: + */ + +int dev_left; +int dev_bottom; +int dev_width; +int dev_height; + +static void translate (FILE *in, FILE *out); +static char *xyencode (int x, int y); + + +/* MAIN -- Main entry point for SGI2UHPII. Optional arguments are device + * window parameters and name of input file. + */ +int +main (int argc, char *argv[]) +{ + FILE *in; + char *infile; + char *argp; + int argno; + + + infile = "stdin"; + + /* Process the command line. + */ + for (argno=1; (argp = argv[argno]) != NULL; argno++) { + if (argp[0] == '-') { + /* A window-control or pen width switch. + */ + switch (argp[1]) { + case 'l': + dev_left = get_iarg (argp[2], argv, argno, DEF_LEFT); + break; + case 'b': + dev_bottom = get_iarg (argp[2], argv, argno, DEF_BOTTOM); + break; + case 'w': + dev_width = get_iarg (argp[2], argv, argno, DEF_WIDTH); + break; + case 'h': + dev_height = get_iarg (argp[2], argv, argno, DEF_HEIGHT); + break; + default: + break; + } + + } else { + /* Input sgi-raster file specification. + */ + infile = argp; + } + } + + if (strcmp (infile, "stdin") == 0) + in = stdin; + else + in = fopen (infile, "r"); + + if (in == NULL) { + fprintf (stderr, "Fatal error (sgi2uhpii): Cannot open `%s'\n", + infile); + fflush (stderr); + exit (OSOK+1); + } + + /* Process the rasterfile. + */ + translate (in, stdout); + + if (in != stdin) + fclose (in); + + return (0); +} + + +/* TRANSLATE -- Interpret input SGI Raster File format into Hewlett Packard + * Raster graphics instructions and write to stdout. + */ +static void +translate (FILE *in, FILE *out) +{ + int n1, swap_bytes; + int n, nlines, length, len_buf; + register unsigned char *bp1, *buffer1; + char buf_rast [SZ_RAST]; + + + swap_bytes = isSwapped (); + + len_buf = dev_width / NBITS_CHAR; + buffer1 = (unsigned char *)malloc (len_buf); + + /* Output device initialization. + */ + fwrite (xyencode (dev_left, dev_bottom), SZ_VECT, 1, out); + fwrite (DEV_INIT, strlen(DEV_INIT), 1, out); + + /* Process the raster file + */ + nlines = dev_height; + while ((n = fread (buffer1, len_buf, 1, in)) > 0) { + + if (swap_bytes) + bswap2 (buffer1, buffer1, len_buf); + + /* Keep track of number of lines left on the page. + */ + if (!(nlines--)) { + nlines += dev_height; + fwrite (DEV_END, strlen (DEV_END), 1, out); + fwrite (xyencode (dev_left, dev_bottom), SZ_VECT, 1, out); + fwrite (DEV_INIT, strlen (DEV_INIT), 1, out); + } + + /* Search for trailing null bytes to trim them off. + */ + length = len_buf; + for (bp1 = buffer1+length; length && *(--bp1) == 0; length--) + ; + + n1 = length; + if (n1 == 0) { + n1 = 1; + *buffer1 = 0; + } + + /* Now copy out this line and prefix it with the control codes. + */ + sprintf (buf_rast, DEV_RAST, n1); + fwrite (buf_rast, SZ_RAST, 1, out); + fwrite (buffer1, n1, 1, out); + } + + /* Terminate plotting and exit. + */ + fwrite (DEV_END, strlen(DEV_END), 1, out); +} + + +/* XYENCODE -- Encode x, y into a character string formatted for the device. + */ +static char * +xyencode (int x, int y) +{ + static char obuf [SZ_VECT]; + + memset (obuf, 0, SZ_VECT); + sprintf (obuf, DEV_VECT, x, y); + return (obuf); +} diff --git a/unix/gdev/sgidev/sgi2uimp.c b/unix/gdev/sgidev/sgi2uimp.c new file mode 100644 index 00000000..a8f566ed --- /dev/null +++ b/unix/gdev/sgidev/sgi2uimp.c @@ -0,0 +1,341 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "sgiUtil.h" + + +/* + * SGI2UIMP.C -- Read IRAF SGI metacode from standard input, translate into + * the Impress language and write to standard output. + * + * Usage + * sgi2uimp.e [-params] [sgi_metacode] [| lpr -v -Pimagen] + * + * -l N left edge; x plot origin in device pixels def DEF_LEFT + * -b N bottom edge; y plot origin in device pixels def DEF_BOTTOM + * -w N width of plot, device pixels starting from l def DEF_WIDTH + * -h N height of plot, device pixels starting from b def DEF_HEIGHT + * -p O.S pen width `origin' and `slope' def DEF_PENBASE + * .DEF_PENSLOPE + * + * Numeric values may be appended directly to their flags or separated by a + * space; the input file name and the switches may occur in any order. + * The windowing parameters are specified explicitly rather than using the + * plotter resolution and paper size due to differences in exactly where + * each different Imagen begins and ends plotting within the paper window. + * + */ + +#define OSOK 0 /* normal successful completion */ +#define LEN_MCBUF 1024 /* number of SGK instrs in buffer */ +#define SGK_FRAME 1 /* new frame instruction */ +#define SGK_MOVE 2 /* move pen */ +#define SGK_DRAW 3 /* draw pen */ +#define SGK_SETLW 4 /* set line width */ +#define GKI_MAXNDC 32767 /* SGK units */ + +/* Device opcodes and parameters. The default edge and width parameters + * (DEF_), given in device pixels for a 240 dot/inch Imagen with 8 1/2" x 11" + * paper, should be modified to fit the local plotter. + */ +#define DEF_LEFT 85 /* origin in device pixels in x */ +#define DEF_WIDTH 2490 /* width in x (240d/i, 11" paper) */ +#define DEF_BOTTOM 50 /* origin in device pixels in y */ +#define DEF_HEIGHT 1905 /* height in y (240d/i, 8.5" paper)*/ +#define DEF_PENBASE 2 /* base pen width */ +#define DEF_PENSLOPE 2 /* pen slope (b.s=3.2 ==> 3,5,7,9) */ +#define SZ_PENPARAM 5 /* max chars in penwidth parameter */ +#define BLACK_LINE 15 /* draw solid line */ +#define CREATE_PATH 230 /* set up set of vertices */ +#define DRAW_PATH 234 /* draw that set of vertices */ +#define END_DOCUMENT 255 /* end of document */ +#define END_PAGE 219 /* formfeed */ +#define HV_VALUE 125 /* 0 11 11 101 (orig, axes, orient)*/ +#define SET_ABS_H 135 /* move absolute in h */ +#define SET_ABS_V 137 /* move absolute in v */ +#define SET_HV_SYSTEM 205 /* establish coordinate system */ +#define SET_PEN 232 /* set pen width */ +#define SZ_HEAD 3 /* # header opcode bytes in obuf */ +#define SZ_TAIL 2 /* # trailing opcode bytes in obuf */ +#define COUNT_OFFSET 1 /* byte offset to npoints in obuf */ + +/* Output macros -- watch out for SZ_OBUF; some Imagens have a limited amount + * of memory for the DRAW buffer: + */ +#define SZ_OBUF (1024) +#define DECL_OBUF register char *op; char *np; char obuf[SZ_OBUF+1]; +#define o_clear (op=obuf) +#define o_flush(o) fwrite(obuf,op-obuf,1,o) +#define putbyte(v) (*op++ = (v)) +#define putword(v) ((*op++ = (v)/256), (*op++ = (v)%256)) +#define setcount(b,v) ((np = obuf+b), (*np++ = (v)/256), (*np = (v)%256)) +#define npoints ((op-obuf - SZ_HEAD)/4) +#define obuf_full ((op-obuf + SZ_TAIL) >= SZ_OBUF) + +struct sgi_inst { + short opcode; + short x; + short y; +}; + +int imp_left; +int imp_bottom; +int imp_width; +int imp_height; +int imp_penbase = DEF_PENBASE; +int imp_penslope = DEF_PENSLOPE; + +static void translate (FILE *in, FILE *out); + + +/* MAIN -- Main entry point for SGI2UIMP. Optional arguments are device + * window parameters and name of input file. + */ +int +main (int argc, char *argv[]) +{ + FILE *in; + char *infile; + char *argp; + int argno; + int np; + char penparam[SZ_PENPARAM]; + + + infile = "stdin"; + + /* Process the command line. + */ + for (argno=1; (argp = argv[argno]) != NULL; argno++) { + if (argp[0] == '-') { + /* A window-control or pen width switch. + */ + switch (argp[1]) { + case 'l': + imp_left = get_iarg (argp[2], argv, argno, DEF_LEFT); + break; + case 'b': + imp_bottom = get_iarg (argp[2], argv, argno, DEF_BOTTOM); + break; + case 'w': + imp_width = get_iarg (argp[2], argv, argno, DEF_WIDTH); + break; + case 'h': + imp_height = get_iarg (argp[2], argv, argno, DEF_HEIGHT); + break; + case 'p': + if (argp[2] == (char) 0) + if (argv[argno+1] == NULL) { + fprintf (stderr, "missing arg to switch `%s';", + argp); + fprintf (stderr, " reset to %d.%d\n", imp_penbase, + imp_penslope); + } else + strcpy (penparam, argv[++argno]); + else + strcpy (penparam, argv[argno]+2); + + np = sscanf (penparam, "%d . %d", &imp_penbase, + &imp_penslope); + if (np == 1) { + imp_penslope = imp_penbase; + } else if (np < 1) { + imp_penbase = DEF_PENBASE; + imp_penslope = DEF_PENSLOPE; + } + + break; + default: + break; + } + + } else { + /* Input sgi-metacode file specification. + */ + infile = argp; + } + } + + if (strcmp (infile, "stdin") == 0) + in = stdin; + else + in = fopen (infile, "r"); + + if (in == NULL) { + fprintf (stderr, "Fatal error (sgi2uimp): Cannot open `%s'\n", + infile); + fflush (stderr); + exit (OSOK+1); + } + + /* Process the metacode. + */ + translate (in, stdout); + + if (in != stdin) + fclose (in); + + return (0); +} + + +/* TRANSLATE -- Interpret input SGI metacode instructions into the device + * language and write to stdout. + */ +static void +translate (FILE *in, FILE *out) +{ + int n, x, y, swap_bytes; + float xscale, yscale; + register struct sgi_inst *sgip; + struct sgi_inst inbuf[LEN_MCBUF], *buftop; + DECL_OBUF; + + swap_bytes = isSwapped(); + + xscale = (float) imp_width / (float) GKI_MAXNDC; + yscale = (float) imp_height / (float) GKI_MAXNDC; + + /* Output device header instructions. + */ + fprintf (out, "@Document(%s, %s, %s, %s, %s, %s)", + "language impress", "pagecollation on", "jamresistance on", + "name \"IRAF SGI plot\"", "prerasterization on", "jobheader off"); + + /* Output page orientation and coordinate system initialization. + */ + putc (SET_HV_SYSTEM, out); + putc (HV_VALUE, out); + + /* Initialize pen width. + */ + putc (SET_PEN, out); + putc (1 * imp_penbase, out); + + o_clear; + + /* Process the metacode: + */ + while ((n = fread ((char *)inbuf, sizeof(*sgip), LEN_MCBUF, in)) > 0) { + + if (swap_bytes) + bswap2 ((unsigned char *)inbuf, (unsigned char *)inbuf, + sizeof(*sgip) * n); + + buftop = inbuf + n; + + for (sgip = inbuf; sgip < buftop; sgip++) { + switch (sgip->opcode) { + case SGK_FRAME: + /* Terminate and output any DRAW buffer contents. + */ + if (npoints > 1) { + setcount (COUNT_OFFSET, npoints); + putbyte (DRAW_PATH); + putbyte (BLACK_LINE); + o_flush (out); + } + + o_clear; + putbyte (END_PAGE); + putbyte (SET_ABS_H); + putword (0); + putbyte (SET_ABS_V); + putword (0); + o_flush (out); + break; + + case SGK_MOVE: + /* Terminate and output any DRAW buffer contents. + */ + if (npoints > 1) { + setcount (COUNT_OFFSET, npoints); + putbyte (DRAW_PATH); + putbyte (BLACK_LINE); + o_flush (out); + } + + x = imp_left + sgip->x * xscale; + y = imp_bottom + sgip->y * yscale; + + /* Initialize output buffer for start of draw instruction. + */ + o_clear; + putbyte (CREATE_PATH); + putword (1); + putword (x); putword (y); + + break; + + case SGK_DRAW: + x = imp_left + sgip->x * xscale; + y = imp_bottom + sgip->y * yscale; + putword (x); putword (y); + + /* If we are about to exceed output buffer, flush and re- + * initialize starting with current point. + */ + if (obuf_full) { + setcount (COUNT_OFFSET, npoints); + putbyte (DRAW_PATH); + putbyte (BLACK_LINE); + o_flush (out); + + /* Reinitialize DRAW buffer. + */ + o_clear; + putbyte (CREATE_PATH); + putword (1); + putword (x); putword (y); + } + + break; + + case SGK_SETLW: + /* Terminate and output any DRAW buffer contents. + */ + if (npoints > 1) { + setcount (COUNT_OFFSET, npoints); + putbyte (DRAW_PATH); + putbyte (BLACK_LINE); + o_flush (out); + o_clear; + } + + /* Set pen width. + */ + putc (SET_PEN, out); + putc ((imp_penbase + ((sgip->x) - 1) * imp_penslope), out); + break; + + default: + fprintf (stderr, "sgi2uimp: unrecognized sgi opcode %d\n", + sgip->opcode); + break; + } + } + } + + /* Flush any remaining buffered points. + */ + if (npoints > 1) { + setcount (COUNT_OFFSET, npoints); + putbyte (DRAW_PATH); + putbyte (BLACK_LINE); + o_flush (out); + } + + /* Signal end of page and end of document. + */ + putc (END_PAGE, out); + putc (END_DOCUMENT, out); +} diff --git a/unix/gdev/sgidev/sgi2uptx.c b/unix/gdev/sgidev/sgi2uptx.c new file mode 100644 index 00000000..6c44f334 --- /dev/null +++ b/unix/gdev/sgidev/sgi2uptx.c @@ -0,0 +1,61 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define NBITS_CHAR 8 /* number of bits in a char */ +#define MASK 64 /* printronix raster flag */ +#define START_LINE "\005" /* start of raster line control code */ +#define END_LINE "\012" /* end of raster line control code */ +#define START_PAGE "\014" /* form feed */ + +/* PRINTRONIX translator from the SGI bitmap file to the STDOUT */ + +int +main (int argc, char *argv[]) +{ + + FILE *fpi; + char *buffer; + int n, len_buf, nlines; + int index; /* goes through all 8 files */ + int px, py; + + px = atoi (argv[1]); + py = atoi (argv[2]); + len_buf = px/NBITS_CHAR; + buffer = (char *) malloc (len_buf); + + for (index=3; index +#include +#include +#include + +#define import_spp +#define import_error +#include + +#include "sgiUtil.h" + + +/* + * SGI2UQMS.C -- Read IRAF SGI metacode from standard input, translate into + * the QMS Vector Graphics Mode (Talaris Lasergrafix, QUIC Command Mode) and + * write to standard output. + * + * Usage + * sgi2uqms.e [-params] [sgi_metacode] [| lpr -Pqms] + * + * -l N left edge; x plot origin in device pixels def DEF_LEFT + * -b N bottom edge; y plot origin in device pixels def DEF_BOTTOM + * -w N width of plot, device pixels starting from l def DEF_WIDTH + * -h N height of plot, device pixels starting from b def DEF_HEIGHT + * -p O.S pen width `origin' and `slope' def DEF_PENBASE + * .DEF_PENSLOPE + * + * Numeric values may be appended directly to their flags or separated by a + * space; the input file name and the switches may occur in any order. + */ + +#define OSOK 0 /* normal successful completion */ +#define LEN_MCBUF 1024 /* number of SGK instrs in buffer */ +#define SGK_FRAME 1 /* new frame instruction */ +#define SGK_MOVE 2 /* move pen */ +#define SGK_DRAW 3 /* draw pen */ +#define SGK_SETLW 4 /* set line width */ +#define GKI_MAXNDC 32767 /* SGK units */ + +/* Device opcodes and parameters. The default edge and width parameters (DEF_) + * are given in QMS pixels, at 300 dots/inch. The QMS y-origin is at the + * top of the page, so in GRAPHCAP, YF must be set, and Landscape Orientation + * used in the QMS. Thus the maximum page `width' is 11*300 pixels, `height' + * is 8.5*300 pixels. + */ +#define DEV_INIT "\012^PY^-\012^ISYNTAX00010^IOL^F^IGV" /* Enter graph.*/ +#define DEV_END "^IGE^ISYNTAX00000^IOP^O\012^PN^-\012" /* Exit graph. */ +#define DEV_FRAME "^," /* QMS Vector Graphics Mode form feed instr */ +#define DEV_MOVE "^U" /* QMS (VGM) pen-up instruction */ +#define DEV_DRAW "^D" /* QMS (VGM) pen-down instruction */ +#define DEV_SETLW "^PW" /* QMS (VGM) Set Line Width (follow w/ nn) */ + +#define DEF_LEFT 30 /* origin in device pixels in x */ +#define DEF_WIDTH 3180 /* width in x (300d/i, 11" paper) */ +#define DEF_BOTTOM 60 /* origin in device pixels in y */ +#define DEF_HEIGHT 2415 /* height in y (300d/i, 8.5" paper) */ +#define DEF_PENBASE 3 /* base pen width (LW 1->2) */ +#define DEF_PENSLOPE 4 /* pen width slope (LW 2->4, 3->6 etc.) */ +#define SZ_PENCMD 5 /* total no. of chars in penwidth instruction */ +#define SZ_PENVAL 2 /* no. of chars in penwidth value */ +#define SZ_VECT 11 /* total no. chars in a MOVE or DRAW inst. */ +#define SZ_COORD 4 /* no. of chars in device coordinate */ + +struct sgi_inst { + short opcode; + short x; + short y; +}; + +int dev_left; +int dev_bottom; +int dev_width; +int dev_height; +int dev_penbase = DEF_PENBASE; +int dev_penslope = DEF_PENSLOPE; + +static void translate (FILE *in, FILE *out); +static char *xyencode (int opcode, int x, int y); +static char *penencode (char *opcode, int val); + + + +/* MAIN -- Main entry point for SGI2UQMS. Optional arguments are device + * window parameters and name of input file. + */ +int +main (int argc, char *argv[]) +{ + FILE *in; + char *infile; + char *argp; + int argno; + int np; + char penparam[SZ_PENCMD]; + + + infile = "stdin"; + + /* Process the command line. + */ + for (argno=1; (argp = argv[argno]) != NULL; argno++) { + if (argp[0] == '-') { + /* A window-control or pen width switch. + */ + switch (argp[1]) { + case 'l': + dev_left = get_iarg (argp[2], argv, argno, DEF_LEFT); + break; + case 'b': + dev_bottom = get_iarg (argp[2], argv, argno, DEF_BOTTOM); + break; + case 'w': + dev_width = get_iarg (argp[2], argv, argno, DEF_WIDTH); + break; + case 'h': + dev_height = get_iarg (argp[2], argv, argno, DEF_HEIGHT); + break; + case 'p': + if (argp[2] == (char) 0) + if (argv[argno+1] == NULL) { + fprintf (stderr, "missing arg to switch `%s';", + argp); + fprintf (stderr, " reset to %d.%d\n", dev_penbase, + dev_penslope); + } else + strcpy (penparam, argv[++argno]); + else + strcpy (penparam, argv[argno]+2); + + np = sscanf (penparam, "%d . %d", &dev_penbase, + &dev_penslope); + if (np == 1) { + dev_penslope = dev_penbase; + } else if (np < 1) { + dev_penbase = DEF_PENBASE; + dev_penslope = DEF_PENSLOPE; + } + + break; + default: + break; + } + + } else { + /* Input sgi-metacode file specification. + */ + infile = argp; + } + } + + if (strcmp (infile, "stdin") == 0) + in = stdin; + else + in = fopen (infile, "r"); + + if (in == NULL) { + fprintf (stderr, "Fatal error (sgi2uqms): Cannot open `%s'\n", + infile); + fflush (stderr); + exit (OSOK+1); + } + + /* Process the metacode. + */ + translate (in, stdout); + + if (in != stdin) + fclose (in); + + return (0); +} + + +/* TRANSLATE -- Interpret input SGI metacode instructions into device + * instructions and write to stdout. + */ +static void +translate (FILE *in, FILE *out) +{ + int n, x, y, swap_bytes; + float xscale, yscale; + register struct sgi_inst *sgip; + struct sgi_inst inbuf[LEN_MCBUF], *buftop; + + + swap_bytes = isSwapped(); + + xscale = (float) dev_width / (float) GKI_MAXNDC; + yscale = (float) dev_height / (float) GKI_MAXNDC; + + /* Output device initialization. + */ + fwrite (DEV_INIT, strlen(DEV_INIT), 1, out); + + /* Initialize pen width. + */ + fwrite (penencode (DEV_SETLW, dev_penbase), SZ_PENCMD, 1, out); + + /* Process the metacode: + */ + while ((n = fread ((char *)inbuf, sizeof(*sgip), LEN_MCBUF, in)) > 0) { + + if (swap_bytes) + bswap2 ((unsigned char *)inbuf, (unsigned char *)inbuf, + sizeof(*sgip) * n); + + buftop = inbuf + n; + + for (sgip = inbuf; sgip < buftop; sgip++) { + switch (sgip->opcode) { + case SGK_FRAME: + fwrite (DEV_FRAME, strlen(DEV_FRAME), 1, out); + break; + + case SGK_MOVE: + x = dev_left + sgip->x * xscale; + y = dev_bottom + sgip->y * yscale; + fwrite (xyencode ('U', x, y), SZ_VECT, 1, out); + break; + + case SGK_DRAW: + x = dev_left + sgip->x * xscale; + y = dev_bottom + sgip->y * yscale; + fwrite (xyencode ('D', x, y), SZ_VECT, 1, out); + break; + + case SGK_SETLW: + /* Set pen width. + */ + fwrite (penencode (DEV_SETLW, dev_penbase + + ((sgip->x) - 1) * dev_penslope), SZ_PENCMD, 1, out); + break; + + default: + fprintf (stderr, "sgi2uqms: unrecognized sgi opcode %d\n", + sgip->opcode); + break; + } + } + } + + /* Terminate plotting and exit. + */ + fwrite (DEV_END, strlen(DEV_END), 1, out); +} + + +/* XYENCODE -- Encode x, y into a character string formatted for the device. + */ +static char * +xyencode ( + int opcode, /* draw or move */ + int x, /* must be positive */ + int y /* must be positive */ +) +{ + static char obuf[] = "^X0000:0000"; + register int digit, n; + register char *op; + int i; + + obuf[1] = opcode; + i = SZ_VECT - 1 - SZ_COORD - 1; + for (op = &obuf[i], digit = SZ_COORD, n=x; --digit >= 0; n = n / 10) + *op-- = n % 10 + '0'; + i = SZ_VECT - 1; + for (op = &obuf[i], digit = SZ_COORD, n=y; --digit >= 0; n = n / 10) + *op-- = n % 10 + '0'; + + return (obuf); +} + + +/* PENENCODE -- Encode base, slope into a character string formatted for the + * device set-pen command. + */ +static char * +penencode ( + char *opcode, /* device set-linewidth command */ + int val /* device line width */ +) +{ + static char obuf[SZ_PENCMD+1]; + register int digit, n; + register char *op; + + strcpy (obuf, opcode); + for (op = &obuf[SZ_PENCMD-1], digit = SZ_PENVAL, n=val; --digit >= 0; + n = n / 10) + *op-- = n % 10 + '0'; + + return (obuf); +} diff --git a/unix/gdev/sgidev/sgi2xbm.c b/unix/gdev/sgidev/sgi2xbm.c new file mode 100644 index 00000000..6d4c230a --- /dev/null +++ b/unix/gdev/sgidev/sgi2xbm.c @@ -0,0 +1,135 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#include "sgiUtil.h" + + +/* SGI2XBM.C -- Read an IRAF SGI bitmap file on standard input and convert + * to a GIF format image on standard outout. + * + * Usage: + * sgi2xbm.e [-w N] [-h NY] [-i] [ [sgi_bitmap] [sgi_bitmap] ... ] + * + * -w N width of input bitmap and output image + * -h N height of input bitmap and output image + * -i invert the bitmap values before conversion + * + * The input file name and the switches may occur in any order. The bitmap + * may be inverted here using the -i flag. + * + * Sample graphcaps for this translator might look like: + * + * g-xbm|UNIX generic interface to multi-frame XBM file generator:\ + * :DD=ugif,tmp$sgk,!{ sgidispatch sgi2xbm -w $(PX) -h $(PY) \ + * $F.[1-8] > sgixbm$$; rm $F.[1-8]; }&:\ + * :MF#8:NF:tc=sgi_image_format: + * + * sgi_image_format|Generic raster file format specification:\ + * :kf=bin$x_sgikern.e:tn=sgikern:ar#.75:\ + * :xr#640:yr#480:PX#640:PY#480:XW#640:YW#480:\ + * :BI:MF#1:YF:NB#8:LO#1:LS#0:XO#0:YO#0: + * + * All bitmaps will be dumped to the file 'sgixbmXXX' in the local directory + * where XXX is a pid. + * + * To change the image size the graphcap :xr, :PX, :XW (X-dimension) and + * :yr, :PY, :XY (Y-dimension) fields all need to be changed. The -i + * flag must be specified in the graphcap DD string. + * + */ + +#define NBITS_CHAR 8 /* number of bits in a char */ +#define DEF_WIDTH 640 /* default image width */ +#define DEF_HEIGHT 480 /* default image height */ +#define MAX_INFILES 16 /* max number of input bitmaps */ +#define SZ_FNAME 64 /* size of a filename */ + +typedef unsigned char byte; + +static int px = DEF_WIDTH; +static int py = DEF_HEIGHT; +static int invert = 0; +static char *infile[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; + + +int +main (int argc, char *argv[]) +{ + FILE *fd; + byte *buffer; + int i, n, len_buf, numin = 0, cnt = 0; + int index; /* goes through all files */ + + + /* Process the command line. + */ + for (i=1; i < argc; i++) { + if (argv[i][0] == '-') { + if (strcmp (argv[i], "-w") == 0) + px = atoi (argv[++i]); + else if (strcmp (argv[i], "-h") == 0) + py = atoi (argv[++i]); + else if (strcmp (argv[i], "-i") == 0) + invert++; + } else { + /* input sgi-bitmap file specification */ + if (numin < MAX_INFILES) + infile[numin++] = argv[i]; + } + + } + + /* Allocate some space for the working buffer. */ + len_buf = px / NBITS_CHAR; + buffer = (byte *) malloc (len_buf); + + /* Loop over the input bitmaps, writing the converted output to + * the stdout. + */ + for (index = 0; index == 0 || index < numin; index++) { + + /* Open the input file. */ + fd = (infile[index] ? fopen (infile[index], "r") : stdin); + + if (index > 0) printf ("\n"); + + printf ("#define xbm%03d_width %d\n", index, px); + printf ("#define xbm%03d_height %d\n", index, py); + printf ("static char xbm%03d_bits[] = {\n ", index); + + n = 0; + cnt = 0; + while (fread (buffer, len_buf, 1, fd)) { + /* If we're on a MSB ordered machine wordswap the bitmap so + * it's in the correct order for unpacking to be interpreted + * as an LSB-ordered image. + */ + if (!isSwapped ()) + bswap4 (buffer, buffer, len_buf); + + /* Write out the pixels. */ + for (i=0; i < len_buf; i++, cnt++) { + printf ("0x%.2x", + (byte) (invert ? ~buffer[i]: buffer[i])), n += 4; + if (cnt < (len_buf * py - 1)) + printf (","), n++; + else + printf ("};\n"); + if (n > 70) + printf ("\n "), n=0; + } + } + + if (fd != stdin) + fclose (fd); + fflush (fd); + } + free (buffer); + + return (0); +} diff --git a/unix/gdev/sgidev/sgiUtil.c b/unix/gdev/sgidev/sgiUtil.c new file mode 100644 index 00000000..25214450 --- /dev/null +++ b/unix/gdev/sgidev/sgiUtil.c @@ -0,0 +1,132 @@ +/** + * SGIUTIL.C -- Shared utility procedures for the SGI translators. + */ + +#include +#include +#include +#include + +#define import_spp +#define import_error +#include + + +/** + * BSWAP2 -- Move bytes from array "a" to array "b", swapping successive + * pairs of bytes. The two arrays may be the same but may not be offset + * and overlapping. + */ +void +bswap2 ( + unsigned char *a, /* input array */ + unsigned char *b, /* output array */ + int nbytes /* number of bytes to swap */ +) +{ + register unsigned char *ip, *op, *otop; + register unsigned int temp; + + ip = a; + op = b; + otop = op + (nbytes & ~1); + + /* Swap successive pairs of bytes. + */ + while (op < otop) { + temp = *ip++; + *op++ = *ip++; + *op++ = temp; + } + + /* If there is an odd byte left, move it to the output array. + */ + if (nbytes & 1) + *op = *ip; +} + + +/* BSWAP4 - Move bytes from array "a" to array "b", swapping the four bytes + * in each successive 4 byte group, i.e., 12345678 becomes 43218765. + * The input and output arrays may be the same but may not partially overlap. +*/ +void +bswap4 ( + unsigned char *a, /* input array */ + unsigned char *b, /* output array */ + int nbytes /* number of bytes to swap */ +) +{ + register int n; + register unsigned char *ip, *op, *tp; + static unsigned char temp[4]; + + tp = temp; + ip = (unsigned char *)a; + op = (unsigned char *)b; + + /* Swap successive four byte groups. + */ + for (n = nbytes >> 2; --n >= 0; ) { + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + } + + /* If there are any odd bytes left, move them to the output array. + * Do not bother to swap as it is unclear how to swap a partial + * group, and really incorrect if the data is not modulus 4. + */ + for (n = nbytes & 03; --n >= 0; ) + *op++ = *ip++; +} + + +/** + * ISSWAPPED -- Test whether we are running on a byte-swapped machine. + */ +int +isSwapped (void) +{ + union { + short tswap; + char b[2]; + } test; + + test.tswap = 1; + return ((int) test.b[0]); +} + + +/** + * GET_IARG -- Get an integer argument, whether appended directly to flag + * or separated by a whitespace character; if error, report and assign + * default. + */ +int +get_iarg ( + char argp, + char **argv, + int argno, + int def_val +) +{ + int temp_val; + + if (argp == (char) 0) { + if (argv[argno+1] == NULL) { + fprintf (stderr, "missing arg to switch `%c';", argp); + fprintf (stderr, " reset to %d\n", def_val); + temp_val = def_val; + } else + temp_val = atoi (argv[++argno]); + } else + temp_val = atoi (argv[argno]+2); + + return (temp_val); +} diff --git a/unix/gdev/sgidev/sgiUtil.h b/unix/gdev/sgidev/sgiUtil.h new file mode 100644 index 00000000..9630a03e --- /dev/null +++ b/unix/gdev/sgidev/sgiUtil.h @@ -0,0 +1,10 @@ +/** + * SGIUTIL.H -- Declarations for the SGI utility routines. + */ + +void bswap2 (unsigned char *a, unsigned char *b, int nbytes); +void bswap4 (unsigned char *a, unsigned char *b, int nbytes); + +int isSwapped (void); + +int get_iarg (char argp, char **argv, int argno, int def_val); diff --git a/unix/gdev/sgidev/sgidispatch.c b/unix/gdev/sgidev/sgidispatch.c new file mode 100644 index 00000000..90201460 --- /dev/null +++ b/unix/gdev/sgidev/sgidispatch.c @@ -0,0 +1,70 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define import_spp +#define import_error +#define import_kernel +#define import_knames +#include + + +/* + * SGIDISPATCH.C -- Determine pathname to the executable for the named SGI + * translator, and execute the translator. Pass all command line arguments + * to the child, which also inherits stdin, stdout, and stderr. + * + * Usage: sgidispatch translator [args] + */ + +#define DEF_HOST "unix" /* default host system */ +#define F_OK 0 /* access mode `file exists' */ +#ifndef X_OK +#define X_OK 1 /* access mode `executable' */ +#endif + +char *irafpath(); + + +/* MAIN -- Main entry point for SGIDISPATCH. + */ +int +main (int argc, char *argv[]) +{ + char tpath[SZ_PATHNAME+1]; + char translator[SZ_PATHNAME+1]; + int ip; + + /* Do nothing if called with no arguments. + */ + if (argc < 2) + exit (OSOK); + + /* Construct pathname to translator. + */ + strcpy (translator, argv[1]); + ip = strlen (translator); + if (strcmp (&translator[ip], ".e") != 0) + strcat (translator, ".e"); + sprintf (tpath, "%s", irafpath(translator)); + + if (access (tpath, X_OK) == ERR) { + fprintf (stderr, "Fatal (sgidispatch): unable to access SGI"); + fprintf (stderr, " translator `%s'\n", tpath); + fflush (stderr); + exit (OSOK+1); + } + + /* Set up i/o for translator and attempt to fork. + */ + argv[argc] = 0; + execv (tpath, &argv[1]); + fprintf (stderr, "Fatal (sgidispatch): unable to execv(%s, ...)\n", + tpath); + fflush (stderr); + exit (OSOK+1); +} diff --git a/unix/gdev/zfiogd.x b/unix/gdev/zfiogd.x new file mode 100644 index 00000000..a401f9ff --- /dev/null +++ b/unix/gdev/zfiogd.x @@ -0,0 +1,420 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# ZFIOGD -- FIO device driver for the interactive binary graphics devices. +# This code is host system dependent (at least in part) as well as node +# dependent, since the set of graphics devices available on a particular node +# can vary greatly. The devices for which driver subroutines are linked +# into this particular version of ZFIOGD are listed below. The individual +# driver subroutines must be named explicitly in the case statements in +# each generic driver subroutine. + +define DEVICES "|iism70|iism75|imtool|" +define DEF_OSDEV_1 "unix:/tmp/.IMT%d" +define DEF_OSDEV_2 "fifo:/dev/imt1i:/dev/imt1o" +define IMTDEV "IMTDEV" +define DELIMCH ',' + +define SZ_OSDEV 512 # device specification string +define MAXDEV 8 +define MAXBYTES 4000 # fifo transfer size, bytes +define MAXTRYS 50 # fifo timeout +define DELAY 10 # fifo i/o interval, msec + +define IISM70 1 # IIS Model 70 image display +define IISM75 2 # IIS Model 75 image display +define IMTOOL 3 # IMTOOL-type display server +define NDEVICES 3 + + +# ZOPNGD -- Open a binary graphics device. The format of the DEVINFO string +# is "devname:osdev" (the KI will have already taken care of any network +# node prefix by the time we are called). + +procedure zopngd (devinfo, mode, chan) + +char devinfo[ARB] #I PACKED device info string +int mode #I access mode +int chan #O receives assigned channel + +bool first_time +pointer devname, envname +pointer sp, info, imtdev, osdev, pkfname, ip, op +int nchars, dev, oschan, arg1, arg2, i +int strdic(), ctoi() +data first_time /true/ +define err_ 91 + +int gd_dev[MAXDEV], gd_oschan[MAXDEV] +int gd_status[MAXDEV], gd_arg1[MAXDEV], gd_arg2[MAXDEV] +common /zgdcom/ gd_dev, gd_oschan, gd_status, gd_arg1, gd_arg2 + +begin + call smark (sp) + call salloc (info, SZ_OSDEV, TY_CHAR) + call salloc (osdev, SZ_OSDEV, TY_CHAR) + call salloc (imtdev, SZ_OSDEV, TY_CHAR) + call salloc (pkfname, SZ_OSDEV, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (envname, SZ_FNAME, TY_CHAR) + + if (first_time) { + do i = 1, MAXDEV + gd_dev[i] = NULL + first_time = false + } + + # Parse device specification. + # ----------------------------- + call strupk (devinfo, Memc[info], SZ_OSDEV) + + # Extract generic device name. + op = devname + for (ip=info; Memc[ip] != EOS && Memc[ip] != DELIMCH; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + if (Memc[ip] == DELIMCH) + ip = ip + 1 + else + goto err_ + + # Look up the generic device name in the device table. + dev = strdic (Memc[devname], Memc[osdev], 0, DEVICES) + if (dev <= 0) + goto err_ + + # Get the OS device name. + op = osdev + for (; Memc[ip] != EOS && Memc[ip] != DELIMCH; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + if (Memc[ip] == DELIMCH) + ip = ip + 1 + + # Get any optional integer arguments. + if (ctoi (Memc, ip, arg1) <= 0) + arg1 = 0 + if (Memc[ip] == DELIMCH) + ip = ip + 1 + if (ctoi (Memc, ip, arg2) <= 0) + arg2 = 0 + + # Edit device specification as necessary. + # ------------------------------------------ + + # If the generic device is IMTOOL and we have an old style OS device + # name, convert it to the format required by the ND driver. If the + # OS device name is null supply the default value. If the user has + # "IMTDEV" defined in their host environment this overrides the value + # passed in the argument list. + + if (dev == IMTOOL) { + call strpak (IMTDEV, Memc[envname], SZ_FNAME) + call zgtenv (Memc[envname], Memc[imtdev], SZ_OSDEV, nchars) + + if (nchars > 0) { + # Environment override. + call strupk (Memc[imtdev], Memc[osdev], SZ_OSDEV) + + } else if (Memc[osdev] == '/') { + # Old style device name. Convert to the form "fifo:in:out". + call strcpy ("fifo:", Memc[imtdev], SZ_OSDEV) + call strcat (Memc[osdev], Memc[imtdev], SZ_OSDEV) + call strcat ("i:", Memc[imtdev], SZ_OSDEV) + call strcat (Memc[osdev], Memc[imtdev], SZ_OSDEV) + call strcat ("o", Memc[imtdev], SZ_OSDEV) + call strcpy (Memc[imtdev], Memc[osdev], SZ_OSDEV) + } + } + + # Allocate a slot in the GD device table for the device. We need this + # to vector to the correct sub-driver when an i/o function is called. + + for (chan=1; chan <= MAXDEV; chan=chan+1) + if (gd_dev[chan] == NULL) + break + if (chan > MAXDEV) + goto err_ + + # Try to physically open the device. [ADD NEW DEVICES HERE]. + switch (dev) { + case IISM70: + call strpak (Memc[osdev], Memc[pkfname], SZ_OSDEV) + call zopm70 (Memc[pkfname], mode, oschan) + case IISM75: + call strpak (Memc[osdev], Memc[pkfname], SZ_OSDEV) + call zopm75 (Memc[pkfname], mode, oschan) + + case IMTOOL: + if (Memc[osdev] == EOS) { + # Supply default value. + call strpak (DEF_OSDEV_1, Memc[pkfname], SZ_OSDEV) + call zopnnd (Memc[pkfname], mode, oschan) + if (oschan == ERR) { + call strpak (DEF_OSDEV_2, Memc[pkfname], SZ_OSDEV) + call zopnnd (Memc[pkfname], mode, oschan) + } + } else { + call strpak (Memc[osdev], Memc[pkfname], SZ_OSDEV) + call zopnnd (Memc[pkfname], mode, oschan) + } + + default: + oschan = ERR + } + + if (oschan == ERR) + goto err_ + + gd_dev[chan] = dev + gd_oschan[chan] = oschan + gd_status[chan] = OK + gd_arg1[chan] = arg1 + gd_arg2[chan] = arg2 + + call sfree (sp) + return +err_ + chan = ERR + call sfree (sp) +end + + +# ZCLSGD -- Close a binary graphics device. + +procedure zclsgd (chan, status) + +int chan #I channel assigned device +int status #O receives status of close + +int gd_dev[MAXDEV], gd_oschan[MAXDEV] +int gd_status[MAXDEV], gd_arg1[MAXDEV], gd_arg2[MAXDEV] +common /zgdcom/ gd_dev, gd_oschan, gd_status, gd_arg1, gd_arg2 + +begin + # [ADD NEW DEVICES HERE]. + + if (chan < 1 || chan > MAXDEV) { + status = ERR + return + } + + switch (gd_dev[chan]) { + case IISM70: + call zclm70 (gd_oschan[chan], status) + case IISM75: + call zclm75 (gd_oschan[chan], status) + case IMTOOL: + call zclsnd (gd_oschan[chan], status) + default: + status = ERR + } + + gd_dev[chan] = NULL +end + + +# ZARDGD -- Read from a binary graphics device. + +procedure zardgd (chan, buf, maxbytes, offset) + +int chan # channel assigned device +char buf[ARB] # buffer to be filled +int maxbytes # max bytes to read +long offset # file offset (function code else zero) + +int nread, nleft, ntries, n, op +int gd_dev[MAXDEV], gd_oschan[MAXDEV] +int gd_status[MAXDEV], gd_arg1[MAXDEV], gd_arg2[MAXDEV] +common /zgdcom/ gd_dev, gd_oschan, gd_status, gd_arg1, gd_arg2 + +begin + gd_status[chan] = OK + + # [ADD NEW DEVICES HERE]. + + switch (gd_dev[chan]) { + case IISM70: + call zrdm70 (gd_oschan[chan], buf, maxbytes, offset) + case IISM75: + call zrdm75 (gd_oschan[chan], buf, maxbytes, offset) + + case IMTOOL: + # Nothing special here, except that we can only move 4096 bytes at + # a time through the pipe to the display server. Some provision + # for timeout is necessary in the event that the sender dies during + # the transfer. + # + # [we don't need all this for the ND driver, but there is still + # a 4096 byte limit for fifo's, so leave this in for now.] + + nread = 0 + ntries = 0 + op = 1 + + for (nleft=maxbytes; nleft > 0; ) { + n = min (nleft, MAXBYTES) + call zardnd (gd_oschan[chan], buf[op], n, offset) + call zawtnd (gd_oschan[chan], n) + if (n < 0) { + nread = ERR + break + } + + nread = nread + n + op = op + n / SZB_CHAR + nleft = nleft - n + if (n == 0) + call zwmsec (DELAY) + + ntries = ntries + 1 + if (ntries > MAXTRYS) { + nread = ERR + break + } + } + + gd_status[chan] = nread + + default: + gd_status[chan] = ERR + } +end + + +# ZAWRGD -- Write to a binary graphics device. + +procedure zawrgd (chan, buf, nbytes, offset) + +int chan # channel assigned device +char buf[ARB] # buffer containing the data +int nbytes # nbytes to be written +long offset # file offset (function code else zero) + +int nwrote, nleft, ntries, n, ip +int gd_dev[MAXDEV], gd_oschan[MAXDEV] +int gd_status[MAXDEV], gd_arg1[MAXDEV], gd_arg2[MAXDEV] +common /zgdcom/ gd_dev, gd_oschan, gd_status, gd_arg1, gd_arg2 + +begin + gd_status[chan] = OK + + # [ADD NEW DEVICES HERE]. + + switch (gd_dev[chan]) { + case IISM70: + call zwrm70 (gd_oschan[chan], buf, nbytes, offset) + case IISM75: + call zwrm75 (gd_oschan[chan], buf, nbytes, offset) + + case IMTOOL: + nwrote = 0 + ntries = 0 + ip = 1 + + for (nleft=nbytes; nleft > 0; ) { + n = min (nleft, MAXBYTES) + call zawrnd (gd_oschan[chan], buf[ip], n, offset) + call zawtnd (gd_oschan[chan], n) + if (n < 0) { + nwrote = ERR + break + } + + ip = ip + n / SZB_CHAR + nwrote = nwrote + n + nleft = nleft - n + if (n == 0) + call zwmsec (DELAY) + + ntries = ntries + 1 + if (ntries > MAXTRYS) { + nwrote = ERR + break + } + } + + gd_status[chan] = nwrote + + default: + gd_status[chan] = ERR + } +end + + +# ZAWTGD -- Wait for i/o to a binary graphics device. + +procedure zawtgd (chan, status) + +int chan # channel assigned device +int status # receives nbytes transferred or ERR + +int gd_dev[MAXDEV], gd_oschan[MAXDEV] +int gd_status[MAXDEV], gd_arg1[MAXDEV], gd_arg2[MAXDEV] +common /zgdcom/ gd_dev, gd_oschan, gd_status, gd_arg1, gd_arg2 + +begin + if (gd_status[chan] == ERR) { + status = ERR + return + } + + # [ADD NEW DEVICES HERE]. + + switch (gd_dev[chan]) { + case IISM70: + call zwtm70 (gd_oschan[chan], status) + case IISM75: + call zwtm75 (gd_oschan[chan], status) + case IMTOOL: + status = gd_status[chan] + default: + status = ERR + } +end + + +# ZSTTGD -- Get the file status of a binary graphics device. + +procedure zsttgd (chan, what, lvalue) + +int chan # channel assigned device +int what # status parameter being queried +long lvalue # receives value of parameter + +int gd_dev[MAXDEV], gd_oschan[MAXDEV] +int gd_status[MAXDEV], gd_arg1[MAXDEV], gd_arg2[MAXDEV] +common /zgdcom/ gd_dev, gd_oschan, gd_status, gd_arg1, gd_arg2 + +begin + # [ADD NEW DEVICES HERE]. + + switch (gd_dev[chan]) { + case IISM70: + call zstm70 (gd_oschan[chan], what, lvalue) + case IISM75: + call zstm75 (gd_oschan[chan], what, lvalue) + + case IMTOOL: + switch (what) { + case FSTT_FILSIZE: + lvalue = gd_arg1[chan] * gd_arg2[chan] * SZB_CHAR + case FSTT_BLKSIZE: + lvalue = gd_arg1[chan] * SZB_CHAR + case FSTT_OPTBUFSIZE: + lvalue = gd_arg1[chan] * SZB_CHAR + case FSTT_MAXBUFSIZE: + lvalue = 32768 + default: + lvalue = ERR + } + default: + lvalue = ERR + } +end diff --git a/unix/hlib/README b/unix/hlib/README new file mode 100644 index 00000000..3d95447b --- /dev/null +++ b/unix/hlib/README @@ -0,0 +1,13 @@ +HLIB -- Host system library. All global library files which are machine at all + host system dependent are placed in this library, rather than in lib$. + +cllogout.cl log out of the CL (not normally host dependent) +clpackage.cl contains host system dependent device names +config.h very host dependent +iraf.h potentially host dependent +irafuser.csh sets up UNIX/CSH environment for IRAF +libc the C runtime library header files (mostly portable) +login.cl default login.cl file (contains device names) +mach.h machine constants (machine dependent) +mkiraf.csh set up UNIX/IRAF files for a user +zzsetenv.def environment startup file (contains device names) diff --git a/unix/hlib/allocate.cl b/unix/hlib/allocate.cl new file mode 100644 index 00000000..1c8a6308 --- /dev/null +++ b/unix/hlib/allocate.cl @@ -0,0 +1,11 @@ +# ALLOCATE -- Allocate a device. The real work is done by the hidden CL +# _allocate task, but we provide a script interface as well to provide +# scope for machine dependent additions. + +procedure allocate (device) + +string device { prompt = "device to be allocated" } + +begin + _allocate (device) +end diff --git a/unix/hlib/buglog.csh b/unix/hlib/buglog.csh new file mode 100755 index 00000000..832c9ad0 --- /dev/null +++ b/unix/hlib/buglog.csh @@ -0,0 +1,130 @@ +#! /bin/csh +# BUGLOG -- Format, edit, and log a new bug to the system bugs file. +# +# Usage: +# +# buglog [module] log a new bug to the system bugsfile +# buglog -e edit the system bugfile (with locking) +# +# The system bugsfile is locked for exclusive access while a bug is being +# logged, or while the bugsfile is being edited. Logging can be aborted either +# by typing , or by editing the editor with ":q!" (i.e., by exiting +# the editor without modifying the temporary file being edited). Bugs are +# formatted and edited in a small temporary file in /tmp and are added at the +# end of the bugsfile only if the task is not aborted and the edit modifies +# the input bug template. To go back and edit a previously logged bug use +# "buglog -e". +# +# Record Format: +# +# NUMBER: record number, decimal, sequential. +# MODULE: package.task or library.procedure or 'unknown' +# SYSTEM: versions of iraf in which bug was present +# DATE: date bug logged, unix format date string +# FROM: user login name +# BUG: description of the bug +# STATUS: 'fixed in V2.X', 'unresolved', etc. +# +# New records are added to the tail of the bugfile. Left justify field labels, +# indent text to the first tab stop, one blank line between bug entries. +# ---------------------------------------------------------------------------- + +unalias rm set find echo sleep tail sed cmp echo cat mail + +set bugfile = "${iraf}local/bugs.log" +set arcfile = "/u1/ftp/iraf/v214/bugs.log" +set tmpfile = "/tmp/bug." +set lokfile = "/tmp/bug.lok" + +set number = 1 +set module = "$1" +set from = "`whoami`" +set date = "`date`" +set system = "V2.14" +set irafmail = "iraf@iraf.noao.edu" +set buglog = "adass-iraf-buglog@iraf.noao.edu" + +# Get exclusive access to the bugfile. + +if (-e $lokfile) then + find $bugfile -newer $lokfile -exec rm -f $lokfile \; + while (-e $lokfile) + echo "waiting for access to system bugfile" + sleep 15 + end +endif + +date > $lokfile +onintr cleanup + +# If we were called as "buglog -e", simply edit the locked bugfile. + +if ("$1" == "-e") then + vi + $bugfile + goto cleanup +endif + +# Increment the bug record number. + +set number = "`grep '^NUMBER:' $bugfile | tail -1 | sed -e 's/^NUMBER:.//'`" +if ("$number" == "") then + set number = 1 +else + set number = "`expr $number + 1`" +endif + +# Get module name if not given on command line. + +if ($module == "") then + echo -n "Module: " + set module = "$<" +endif + +# Format new bug entry in a temporary file and edit it. + +set tmpfile = $tmpfile$number +if (-e $tmpfile) then + echo "file $tmpfile already exists" + rm -i $tmpfile + if (-e $tmpfile) then + goto editbug + endif +endif + +echo "NUMBER: $number" >> $tmpfile +echo "MODULE: $module" >> $tmpfile +echo "SYSTEM: $system" >> $tmpfile +echo "DATE: $date" >> $tmpfile +echo "FROM: $from" >> $tmpfile +echo "" >> $tmpfile +echo "BUG: ..." >> $tmpfile +echo "" >> $tmpfile +echo "STATUS: ..." >> $tmpfile + +editbug: +cp $tmpfile $tmpfile.ORIG +vi $tmpfile + +# Add new bug entry to bugfile (exiting the editor without modifying the file +# causes the bug to be discarded). + +cmp -s $tmpfile $tmpfile.ORIG +if ($status) then + echo "" >> $bugfile; cat $tmpfile >> $bugfile + echo "" >> $arcfile; cat $tmpfile >> $arcfile + mail -s "buglog.$number"": module = $module, author = $from" $irafmail\ + < $tmpfile +# mail -s "buglog.$number"": module = $module, author = $from" $buglog\ +# < $tmpfile + rm -f $tmpfile $tmpfile.ORIG +else + echo "system bugfile not modified" + rm -f $tmpfile $tmpfile.ORIG +endif + +# Cleanup (vector here on interrupt). + +cleanup: +if (-e $lokfile) then + rm -f $lokfile +endif diff --git a/unix/hlib/buglog.sh b/unix/hlib/buglog.sh new file mode 100755 index 00000000..ac4e614e --- /dev/null +++ b/unix/hlib/buglog.sh @@ -0,0 +1,140 @@ +#!/bin/bash +# +# BUGLOG -- Format, edit, and log a new bug to the system bugs file. +# +# Usage: +# +# buglog [module] log a new bug to the system bugsfile +# buglog -e edit the system bugfile (with locking) +# +# The system bugsfile is locked for exclusive access while a bug is being +# logged, or while the bugsfile is being edited. Logging can be aborted either +# by typing , or by editing the editor with ":q!" (i.e., by exiting +# the editor without modifying the temporary file being edited). Bugs are +# formatted and edited in a small temporary file in /tmp and are added at the +# end of the bugsfile only if the task is not aborted and the edit modifies +# the input bug template. To go back and edit a previously logged bug use +# "buglog -e". +# +# Record Format: +# +# NUMBER: record number, decimal, sequential. +# MODULE: package.task or library.procedure or 'unknown' +# SYSTEM: versions of iraf in which bug was present +# DATE: date bug logged, unix format date string +# FROM: user login name +# BUG: description of the bug +# STATUS: 'fixed in V2.X', 'unresolved', etc. +# +# New records are added to the tail of the bugfile. Left justify field labels, +# indent text to the first tab stop, one blank line between bug entries. +# ---------------------------------------------------------------------------- + +iraf="`/bin/echo ${iraf}/ | tr -s '/'`" + +bugfile="${iraf}local/bugs.log" +arcfile="/u1/ftp/iraf/v216/bugs.log" +tmpfile="/tmp/bug." +lokfile="/tmp/bug.lok" + +number=1 +module="$1" +from="`whoami`" +date="`date`" +system="V2.16" +irafmail="admin@iraf.net" +buglog="adass-iraf-buglog@iraf.noao.edu" + +# Cleanup (vector here on interrupt). + +cleanup() { + if [ -e $lokfile ]; then + rm -f $lokfile + fi + exit 0 +} + +# Get exclusive access to the bugfile. + +if [ -e $lokfile ]; then + find $bugfile -newer $lokfile -exec rm -f $lokfile \; + while [ -e $lokfile ]; do + /bin/echo "waiting for access to system bugfile" + sleep 15 + done +fi + +date > $lokfile +trap cleanup 2 + +# If we were called as "buglog -e", simply edit the locked bugfile. + +if [ "$1" = "-e" ]; then + vi + $bugfile + cleanup +fi + +# Increment the bug record number. + +number="`grep '^NUMBER:' $bugfile | tail -1 | sed -e 's/^NUMBER:.//'`" +if [ "$number" = "" ]; then + number=1 +else + number="`expr $number + 1`" +fi + +# Get module name if not given on command line. + +if [ "$module" = "" ]; then + /bin/echo -n "Module: " + read module +fi + +# Format new bug entry in a temporary file and edit it. + +SKP=0 +tmpfile=$tmpfile$number +if [ -e $tmpfile ]; then + /bin/echo "file $tmpfile already exists" + rm -i $tmpfile + if [ -e $tmpfile ]; then + SKP=1 + fi +fi + +if [ $SKP = 0 ]; then + /bin/echo "NUMBER: $number" >> $tmpfile + /bin/echo "MODULE: $module" >> $tmpfile + /bin/echo "SYSTEM: $system" >> $tmpfile + /bin/echo "DATE: $date" >> $tmpfile + /bin/echo "FROM: $from" >> $tmpfile + /bin/echo "" >> $tmpfile + /bin/echo "BUG: ..." >> $tmpfile + /bin/echo "" >> $tmpfile + /bin/echo "STATUS: ..." >> $tmpfile +fi + +cp $tmpfile $tmpfile.ORIG +vi $tmpfile + +# Add new bug entry to bugfile (exiting the editor without modifying the file +# causes the bug to be discarded). + +cmp -s $tmpfile $tmpfile.ORIG +if [ $? = 0 ]; then + /bin/echo "system bugfile not modified" + rm -f $tmpfile $tmpfile.ORIG +else + /bin/echo "" >> $bugfile; cat $tmpfile >> $bugfile + if [ -e $arcfile ]; then + /bin/echo "" >> $arcfile; cat $tmpfile >> $arcfile + fi + mail -s "buglog.$number"": module = $module, author = $from" $irafmail\ + < $tmpfile +# mail -s "buglog.$number"": module = $module, author = $from" $buglog\ +# < $tmpfile + rm -f $tmpfile $tmpfile.ORIG +fi + +cleanup + diff --git a/unix/hlib/cl.csh b/unix/hlib/cl.csh new file mode 100755 index 00000000..12938b53 --- /dev/null +++ b/unix/hlib/cl.csh @@ -0,0 +1,153 @@ +#!/bin/csh +# +# CL.CSH -- Startup the version of the CL executable compiled for the +# architecture or floating point hardware appropriate for the current +# machine. This script can be used to invoke a number of CL flavors +# depending on how it is called. The install script will create a 'cl' +# and 'ecl' command link to this script with the intent that a different +# binary would be started for each command. + + +# Determine CL binary to run based on how we were called. + +set cl_binary = "vocl.e" + +if (`echo $0 | egrep ecl` != "") then + set cl_binary = "ecl.e" + +else if (`echo $0 | egrep vo` != "") then + set cl_binary = "vocl.e" + +else if ($#argv > 0) then + if ("$argv[1]" == "-old" || "$argv[1]" == "-o") then + set cl_binary = "cl.e" + else if ("$argv[1]" == "-vo") then + set cl_binary = "vocl.e" + else if ("$argv[1]:e" == "c") then + # Workaround for autoconf scripts attempting to use this command as + # a valid compiler option. On some systems (mostly Debian) a valid + # CC command can't be found and eventually the 'cl' (lisp) compiler + # is tried. It will always apparently have the conftest.c test file, + # so simply exit with a code to tell autoconf it won't work. + exit 1 + endif +endif + + +# Determine IRAF root directory (value set in install script). +set d_iraf = "/iraf/iraf/" +if ($?iraf) then + if (! -e $iraf) then + echo "Warning: iraf=$iraf does not exist (check .cshrc or .login)" + echo "Session will default to iraf=$d_iraf" + unsetenv iraf ; sleep 3 + endif +endif +if ($?iraf == 0) then + setenv iraf "$d_iraf" +endif + +# Check for a version query. +if ($#argv > 0) then + if ("$argv[1]" == "-v" || "$argv[1]" == "-version" || \ + "$argv[1]" == "-V" || "$argv[1]" == "--version") then + head -1 $iraf/unix/hlib/motd + exit 0 + endif +endif + + +# Determine platform architecture. +if (-e $iraf/unix/hlib/irafarch.csh) then + set ACTUAL_ARCH = `$iraf/unix/hlib/irafarch.csh -actual` +else + set ACTUAL_ARCH = $IRAFARCH +endif + +if ($?IRAFARCH) then + if (-e $iraf/bin.${IRAFARCH}/${cl_binary}) then + set MACH = $IRAFARCH + else + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + if ("$ACTUAL_ARCH" != "$IRAFARCH") then + echo "ERROR: IRAFARCH set to '$IRAFARCH', should be '$ACTUAL_ARCH'" + endif + exit 1 + endif + setenv arch ".$MACH" + +else + set os_mach = `uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + + if (-e $iraf/unix/hlib/irafarch.csh) then + set MACH = `$iraf/unix/hlib/irafarch.csh` + else + set MACH = $os_mach + endif + + if ("$os_mach" == "linux") then # handle linux systems + if (`uname -m` == "x86_64") then + setenv mach linux64 + else + setenv mach linux + endif + else if ("$os_mach" == "darwin") then # handle Mac systems + if ("`uname -m`" == "x86_64") then + setenv mach macintel + else + setenv mach macosx + endif + else if ("$os_mach" == "cygwin") then + setenv mach cygwin + else + set mach = `uname -s | tr '[A-Z]' '[a-z]'` + endif + + setenv arch ".$MACH" + if (! $?IRAFARCH) then + setenv IRAFARCH "$MACH" + endif + + if (! (-e $iraf/bin.${MACH}/${cl_binary}) ) then + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + exit 1 + endif +endif + +# Recent linux systems display a problem in how pointer addresses +# interact with the stack and can result in a segfault. Remove the +# stacksize limit for IRAF processes until this is better understood. +if ("$IRAFARCH" == "redhat" || \ + "$IRAFARCH" == "linux64" || \ + "$IRAFARCH" == "linux") then + limit stacksize unlimited +endif + + +# Just run the CL if IRAFARCH already defined. +if ($?IRAFARCH) then + if ($IRAFARCH == "") then + setenv arch "" + else + setenv arch ".$IRAFARCH" + endif + + setenv IRAFBIN ${iraf}bin$arch/ + set file = ${IRAFBIN}$cl_binary + if (-e $file) then + exec $file + else + echo "$file not found" + endif +endif + + +# Set the architecture to be used. +setenv IRAFARCH $MACH + + +setenv arch .$IRAFARCH +setenv IRAFBIN ${iraf}bin$arch/ + +# Run the desired CL. +exec ${IRAFBIN}$cl_binary diff --git a/unix/hlib/cl.csh.ORIG b/unix/hlib/cl.csh.ORIG new file mode 100755 index 00000000..bab64f9d --- /dev/null +++ b/unix/hlib/cl.csh.ORIG @@ -0,0 +1,212 @@ +#!/bin/csh -f +# +# CL.CSH -- Startup the version of the CL executable compiled for the +# architecture or floating point hardware appropriate for the current +# machine. This script can be used to invoke a number of CL flavors +# depending on how it is called. The install script will create a 'cl' +# and 'ecl' command link to this script with the intent that a different +# binary would be started for each command. + + +# Determine CL binary to run based on how we were called. + +set cl_binary = "ecl.e" + +if (`echo $0 | egrep ecl` != "") then + set cl_binary = "ecl.e" + +else if (`echo $0 | egrep vo` != "") then + set cl_binary = "vocl.e" + +else if ($#argv > 0) then + if ("$argv[1]" == "-old" || "$argv[1]" == "-o") then + set cl_binary = "cl.e" + else if ("$argv[1]" == "-vo" || "$argv[1]" == "-o") then + set cl_binary = "vocl.e" + else if ("$argv[1]:e" == "c") then + # Workaround for autoconf scripts attempting to use this command as + # a valid compiler option. On some systems (mostly Debian) a valid + # CC command can't be found and eventually the 'cl' (lisp) compiler + # is tried. It will always apparently have the conftest.c test file, + # so simply exit with a code to tell autoconf it won't work. + exit 1 + endif +endif + + +# Determine IRAF root directory (value set in install script). +set d_iraf = "/iraf/iraf/" +if ($?iraf) then + if (! -e $iraf) then + echo "Warning: iraf=$iraf does not exist (check .cshrc or .login)" + echo "Session will default to iraf=$d_iraf" + unsetenv iraf ; sleep 3 + endif +endif +if ($?iraf == 0) then + setenv iraf "$d_iraf" +endif + + +# Check for a version query. +if ($#argv > 0) then + if ("$argv[1]" == "-v" || "$argv[1]" == "-version" || \ + "$argv[1]" == "-V" || "$argv[1]" == "--version") then + head -1 $iraf/unix/hlib/motd + exit 0 + endif +endif + + +# Determine platform architecture. +if ($?IRAFARCH) then + if (-e $iraf/bin.${IRAFARCH}/${cl_binary}) then + set MACH = $IRAFARCH + endif +endif + +if (! $?MACH) then + + # SUN-IRAF + setenv OSNAME `uname` + if ($OSNAME == 'SunOS') then + setenv OSVERSION `uname -r | cut -c1` + if ($OSVERSION == 5) then + set MACH = `uname -p` + switch ($MACH) + case sparc: + set MACH = ssol + breaksw + endsw + else + set MACH = `mach` + endif + + else + + # PC-IRAF + set os_mach = `uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + if (-f /etc/redhat-release) then + if (`uname -m` == "ppc") then + setenv mach linuxppc + else + setenv mach redhat + endif + else + set mach = `uname -s | tr '[A-Z]' '[a-z]'` + endif + + if ($mach == "darwin") then + if ("`uname -m`" == "i386") then + setenv mach macintel + else + setenv mach macosx + endif + else if ($os_mach == "cygwin") then + setenv mach cygwin + endif + + + if (-e $iraf/bin.$mach/$cl_binary) then + set MACH = $mach + else if (-e $iraf/bin.freebsd/$cl_binary) then + set MACH = freebsd + else if (-e $iraf/bin.macosx/$cl_binary) then + set MACH = macosx + else if (-e $iraf/bin.macintel/$cl_binary) then + set MACH = macintel + else if (-e $iraf/bin.cygwin/$cl_binary) then + set MACH = cygwin + else if (-e $iraf/bin.linux/$cl_binary) then + set MACH = linux + else if (-e $iraf/bin.redhat/$cl_binary) then + set MACH = redhat + else if (-e $iraf/bin.linuxppc/$cl_binary) then + set MACH = linuxppc + else if (-e $iraf/bin.sunos/$cl_binary) then + set MACH = sunos + else if (-e $iraf/bin.linuz/$cl_binary) then + set MACH = linuz + else + echo "cannot find $iraf/bin.xxx/$cl_binary" + exit 1 + endif + + endif + +endif + +# Check for obsolete IRAFBIN definition. +if ($?IRAFBIN && !($?IRAFARCH)) then + echo "Use IRAFARCH rather than IRAFBIN to specify the machine architecture" + echo "IRAFARCH, if defined, should be one of ffpa,f68881,i386,sparc, etc." +endif + +# Just run the CL if IRAFARCH already defined. +if ($?IRAFARCH) then + if ($IRAFARCH == "") then + setenv arch "" + else + setenv arch ".$IRAFARCH" + endif + + # Recent linux systems display a problem in how pointer addresses + # interact with the stack and can result in a segfault. Remove the + # stacksize limit for IRAF processes until this is better understood. + if ("$IRAFARCH" == "redhat" || \ + "$IRAFARCH" == "linux" || \ + "$IRAFARCH" == "linuxppc") then + limit stacksize unlimited + endif + + setenv IRAFBIN ${iraf}bin$arch/ + set file = ${IRAFBIN}$cl_binary + if (-e $file) then + exec $file + else + echo "$file not found" + endif +endif + + +# Determine the architecture to be used. +if ("$MACH" == "freebsd") then # PC-IRAF + setenv IRAFARCH "freebsd" +else if ("$MACH" == "linux") then + setenv IRAFARCH "linux" +else if ("$MACH" == "redhat") then + setenv IRAFARCH "redhat" +else if ("$MACH" == "linuxppc") then + setenv IRAFARCH "linuxppc" +else if ("$MACH" == "macosx") then + setenv IRAFARCH "macosx" +else if ("$MACH" == "macintel") then + setenv IRAFARCH "macintel" +else if ("$MACH" == "cygwin") then + setenv IRAFARCH "cygwin" +else if ("$MACH" == "sunos") then + setenv IRAFARCH "sunos" +else if ("$MACH" == "linuz") then + setenv IRAFARCH "linuz" + +else if ("$MACH" == "ssol") then # SUN-IRAF + setenv IRAFARCH "ssun" +else if ("$MACH" == "sparc") then + setenv IRAFARCH "sparc" +endif + +# Recent linux systems display a problem in how pointer addresses +# interact with the stack and can result in a segfault. Remove the +# stacksize limit for IRAF processes until this is better understood. +if ("$IRAFARCH" == "redhat" || \ + "$IRAFARCH" == "linux" || \ + "$IRAFARCH" == "linuxppc") then + limit stacksize unlimited +endif + +setenv arch .$IRAFARCH +setenv IRAFBIN ${iraf}bin$arch/ +set file = ${IRAFBIN}$cl_binary + +# Run the desired CL. +exec $file diff --git a/unix/hlib/cl.sh b/unix/hlib/cl.sh new file mode 100755 index 00000000..67bcd428 --- /dev/null +++ b/unix/hlib/cl.sh @@ -0,0 +1,165 @@ +#!/bin/bash +# +# CL.SH -- Startup the version of the CL executable compiled for the +# architecture or floating point hardware appropriate for the current +# machine. This script can be used to invoke a number of CL flavors +# depending on how it is called. The install script will create a 'cl' +# and 'ecl' command link to this script with the intent that a different +# binary would be started for each command. + + +# Determine CL binary to run based on how we were called. + + +nm=${0##*/} +cl_binary="vocl.e" + +case "$nm" in + "cl" | "cl.sh") + cl_binary="vocl.e" + ;; + "ecl" | "ecl.sh") + cl_binary="vocl.e" + ;; + "vocl" | "vocl.sh") + cl_binary="vocl.e" + ;; + *) + if (( $# > 1 )); then + if [ $1 == "-old" -o $1 == "-o" ]; then + cl_binary="cl.e" + elif [ $1 == "-ecl" -o $1 == "-e" ]; then + cl_binary="ecl.e" + elif [ $1 == "-vo" ]; then + cl_binary="vocl.e" + elif [ ${1##*.} == "c" ]; then + # Workaround for autoconf scripts attempting to use this + # command as a valid compiler option. On some systems (mostly + # Debian) a valid CC command can't be found and eventually + # the 'cl' (lisp) compiler is tried. It will always apparently + # have the conftest.c test file, so simply exit with a code to + # tell autoconf it won't work. + exit 1 + fi + fi +esac + +# Determine IRAF root directory (value set in install script). +d_iraf="/iraf/iraf/" +if [ -n $iraf ]; then + if [ ! -e $iraf ]; then + echo "Warning: iraf=$iraf does not exist \(check .cshrc or .login\)" + echo "Session will default to iraf=$d_iraf" + unset iraf ; sleep 3 + fi +fi +if [ -z $iraf ]; then + export iraf="$d_iraf" +fi + +# Check for a version query. +if (( $# > 1 )); then + case "$1" in + "-v" | "-V" | "-version" | "--version") + head -1 $iraf/unix/hlib/motd + exit 0 + ;; + *) + ;; + esac +fi + + +# Determine platform architecture. +if [ -e $iraf/unix/hlib/irafarch.sh ]; then + ACTUAL_ARCH=`$iraf/unix/hlib/irafarch.sh -actual` +else + ACTUAL_ARCH=$IRAFARCH +fi + +if [ -n "$IRAFARCH" ]; then + if [ -e $iraf/bin.${IRAFARCH}/${cl_binary} ]; then + MACH=$IRAFARCH + else + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + if [ "$ACTUAL_ARCH" != "$IRAFARCH" ]; then + echo "ERROR: IRAFARCH set to '$IRAFARCH', should be '$ACTUAL_ARCH'" + fi + exit 1 + fi + export arch=".$MACH" + +else + os_mach=`uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + + if [ -e $iraf/unix/hlib/irafarch.csh ]; then + MACH=`$iraf/unix/hlib/irafarch.csh` + else + MACH=$os_mach + fi + + if [ "$os_mach" == "linux" ]; then # handle linux systems + if [ `uname -m` == "x86_64" ]; then + export mach="linux64" + else + export mach="linux" + fi + elif [ "$os_mach" == "darwin" ]; then # handle Mac systems + if [ "`uname -m`" == "x86_64" ]; then + export mach="macintel" + else + export mach="macosx" + fi + elif [ "$os_mach" == "cygwin" ]; then + export mach="cygwin" + else + mach=`uname -s | tr '[A-Z]' '[a-z]'` + fi + + export arch=".$MACH" + if [ -z $IRAFARCH ]; then + export IRAFARCH="$MACH" + fi + + if [ ! -e $iraf/bin.${MACH}/${cl_binary} ]; then + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + exit 1 + fi +fi + + +# Recent linux systems display a problem in how pointer addresses +# interact with the stack and can result in a segfault. Remove the +# stacksize limit for IRAF processes until this is better understood. +if [ "$IRAFARCH" == "redhat" -o \ + "$IRAFARCH" == "linux64" -o \ + "$IRAFARCH" == "linux" ]; then + ulimit -s unlimited +fi + + +# Just run the CL if IRAFARCH already defined. +if [ -n "$IRAFARCH" ]; then + if [ -z $IRAFARCH ]; then + export arch="" + else + export arch=".$IRAFARCH" + fi + + export IRAFBIN=${iraf}bin$arch/ + file=${IRAFBIN}$cl_binary + if [ -e $file ]; then + exec $file + else + echo "$file not found" + fi +fi + + +# Set the architecture to be used. +export IRAFARCH=$MACH +export arch=.$IRAFARCH +export IRAFBIN=${iraf}bin$arch/ + +# Run the desired CL. +exec ${IRAFBIN}$cl_binary diff --git a/unix/hlib/cllogout.cl b/unix/hlib/cllogout.cl new file mode 100644 index 00000000..c597320f --- /dev/null +++ b/unix/hlib/cllogout.cl @@ -0,0 +1,5 @@ +#{ System logout file; executed when logging off from the CL. Perform any +# cleanup functions you want executed at logout time. + +if (deftask ("_logout") && access ("home$logout.cl")) + _logout();; diff --git a/unix/hlib/clpackage.cl b/unix/hlib/clpackage.cl new file mode 100644 index 00000000..cb017cd7 --- /dev/null +++ b/unix/hlib/clpackage.cl @@ -0,0 +1,59 @@ +#{ CLPACKAGE.CL -- Package definitions file for the "clpackage" package. +# When this script is run, the current package is "clpackage", the default +# startup package. NOTE -- See hlib$zzsetenv.def for additional environment +# definitions. + +# Uncomment and edit the following to change the default values of these +# CL parameters for your site. + +#ehinit = "nostandout eol noverify" +#epinit = "standout showall" +#keeplog = no +#logfile = "home$logfile" +#logmode = "commands nobackground noerrors notrace" + +szprcache = 4 + +# IRAF standard system package script task declarations. + +task dbms.pkg = "dbms$dbms.cl" +task dataio.pkg = "dataio$dataio.cl" +task images.pkg = "images$images.cl" +task language.pkg = "language$language.cl" +task lists.pkg = "lists$lists.cl" +task obsolete.pkg = "obsolete$obsolete.cl" +task plot.pkg = "plot$plot.cl" +task proto.pkg = "proto$proto.cl" +task softools.pkg = "softools$softools.cl" +task system.pkg = "system$system.cl" +task utilities.pkg = "utilities$utilities.cl" + +# Handy task to call the user's logout.cl file. +task $_logout = "home$logout.cl" + +# Define the external (user-configurable) packages. +cl < hlib$extern.pkg + + +# Load dynamically-defined external packages. +if (access ("hlib$extpkg.cl") == yes) + cl < hlib$extpkg.cl +; + + +# Load packages needed by dynamic external packages. These are reloaded +# in the login.cl. +images +proto +utilities +noao + +# Load the SYSTEM package. Avoid printing menu, but do not change the +# default value of the menus switch. + +if (menus) { + menus = no; system; menus = yes +} else + system + +keep diff --git a/unix/hlib/clpackage.hd b/unix/hlib/clpackage.hd new file mode 100644 index 00000000..8d967dc6 --- /dev/null +++ b/unix/hlib/clpackage.hd @@ -0,0 +1,86 @@ +# Help directory for the package CLPACKAGE (the root package of the CL). + +$dataio = "pkg$dataio/" +$dbms = "pkg$dbms/" +$images = "pkg$images/" +$language = "pkg$language/" +$lists = "pkg$lists/" +$obsolete = "pkg$obsolete/" +$plot = "pkg$plot/" +$proto = "pkg$proto/" +$softools = "pkg$softools/" +$system = "pkg$system/" +$utilities = "pkg$utilities/" +$xtools = "pkg$xtools/doc/" + +# Define help files for the standard IRAF system packages. + +dataio men = dataio$dataio.men, + hlp = .., + sys = dataio$dataio.hlp, + pkg = dataio$dataio.hd, + src = dataio$dataio.cl + +dbms men = dbms$dbms.men, + hlp = .., + sys = dbms$dbms.hlp, + pkg = dbms$dbms.hd, + src = dbms$dbms.cl + +images men = images$images.men, + hlp = .., + sys = images$images.hlp, + pkg = images$images.hd, + src = images$images.cl + +language men = language$language.men, + hlp = .., + sys = language$language.hlp, + pkg = language$language.hd, + src = language$language.cl + +lists men = lists$lists.men, + hlp = .., + sys = lists$lists.hlp, + pkg = lists$lists.hd, + src = lists$lists.cl + +obsolete men = obsolete$obsolete.men, + hlp = .., + sys = obsolete$obsolete.hlp, + pkg = obsolete$obsolete.hd, + src = obsolete$obsolete.cl + +plot men = plot$plot.men, + hlp = .., + sys = plot$plot.hlp, + pkg = plot$plot.hd, + src = plot$plot.cl + +proto men = proto$proto.men, + hlp = .., + sys = proto$proto.hlp, + pkg = proto$proto.hd, + src = proto$proto.cl + +softools men = softools$softools.men, + hlp = .., + sys = softools$softools.hlp, + pkg = softools$softools.hd, + src = softools$softools.cl + +system men = system$system.men, + hlp = .., + sys = system$system.hlp, + pkg = system$system.hd, + src = system$system.cl + +utilities men = utilities$utilities.men, + hlp = .., + sys = utilities$utilities.hlp, + pkg = utilities$utilities.hd, + src = utilities$utilities.cl + +xtools hlp=xtools$xtools.men, + sys=xtools$README, + pkg=xtools$xtools.hd diff --git a/unix/hlib/clpackage.men b/unix/hlib/clpackage.men new file mode 100644 index 00000000..dd46fd32 --- /dev/null +++ b/unix/hlib/clpackage.men @@ -0,0 +1,13 @@ + dataio - Data format conversion package (RFITS, etc.) + dbms - Database management package (not yet implemented) + images - General image processing package + language - The command language itself + lists - List processing package + local - The template local package + obsolete - Obsolete tasks + noao - The NOAO optical astronomy packages + plot - Plot package + proto - Prototype or interim tasks + softools - Software tools package + system - System utilities package + utilities - Miscellaneous utilities package diff --git a/unix/hlib/config.h b/unix/hlib/config.h new file mode 100644 index 00000000..a0d2db5e --- /dev/null +++ b/unix/hlib/config.h @@ -0,0 +1,79 @@ +# System configuration parameters. Sizes are in SPP chars unless otherwise +# specified. + +define FIRST_FD 10 # first open file descriptor +define LAST_FD 4096 # number of file descriptors +define PSIOCTRL 9 # the last pseudofile (see etc$prpsio.x) +define FBUF_ALLOC vmalloc # call to allocate file buffer +define LEN_DEVTBL 150 # FIO device table (7 cells/device) +define LEN_RANDBUF 8 # bufsize = LEN_RANDBUF * blksize +define LEN_SEQBUF 8 # bufsize = LEN_SEQBUF * optbufsize +define SZ_STDIOBUF 1024 # size of STDIN/STDOUT buffers +define SZ_PBBUF 1024 # default size of FIO pushback buf + +define SZ_MEM 1 # size of Mem common +define SZ_MEMALIGN SZ_DOUBLE # alignment criteria for malloc +define SZ_PHYSMEM 750000 # max phys memory available to a task +define SZ_STACK 8192 # size of a stack segment (salloc) +define SZ_STKHDR (4*SZ_POINTER) # size of stack segment header +define SZ_VMEMALIGN SZ_VMPAGE # alignment criterium for vmalloc +define VMEM_BASE 0 # fwa to align with, vmalloc +define SZ_WORKSET 100000 # tasks normal working set size +define LEN_JUMPBUF 1024 # buffer for ZSVJMP +define JUMPCOM zjucom # IRAF Main ZDOJMP common + +define MAX_ONEXIT 10 # max onexit procedures +define MAX_ONERROR 10 # max onerror procedures +define MAX_CLGFILPAR 10 # max open params for CLGFIL +define MAX_CHILDPROCS 10 # max connected subprocesses +define MAX_BKGJOBS 10 # max detached processes + +define IM_FALLOC YES # "falloc" pixel storage file (IMIO)? +define IM_PACKDENSITY 0.6 # minimum storage efficiency for images + +define MT_MAXTAPES 2 # maximum open tape drives +define MT_SZBDEFIBUF 65535 # def. input buffer size (bytes) +define MT_SZBDEFOBUF 8192 # def. output buffer size (bytes) + +# File Locking. + +define OS_FILELOCKING false # OS provides file locking +define FILELOCK_PERIOD 120 # minimum lifetime of a file lock, secs +define MIN_TIMELEFT 60 # rollback if less time left on lock + +# Characteristics of host OS filenames. + +define CASE_INSENSITIVE false # is case ignored in OS filenames +define HOST_CASE 'L' # case used [UL] if case insensitive +define UNDERSCORE_PERMITTED true # is _ permitted in filenames +define PERIOD_PERMITTED true # is . permitted in root +define MAX_ROOTLEN 128 # max chars in OS root filename +define MAX_EXTNLEN 32 # max chars in OS filename extension +define EXTN_DELIMITER '.' # character preceding extension +define LEADING_ALPHA_ONLY false # first char must be a letter +define ONECASE_OUT false # output filenames in host case + +# IRAF vs OS filename extensions. + +define EXTN_MAP "" +define RESERVED_EXTNS "|zsf|zvf|zl1|zl2|zmd|zlk|" + +# Escape sequence encoding metacharacters. + +define VFN_ESCAPE_CHAR '\1' # escape character for encoding +define SHIFT_NEXTCHAR '0' # shift next char to upper case +define SHIFT_TO_LOWER '1' # shift to lower case +define SHIFT_TO_UPPER '2' # shift to upper case +define UNDERSCORE_CODE '3' # code for encoding _ +define PERIOD_CODE '4' # code for encoding . + +# Reserved filenames and filename extensions. + +define SETENV_FILE "zzsetenv.def" +define FNMAPPING_FILE "zzfnmap.zvf" +define SUBFILE_EXTN ".zsf" +define FNMAPFILE_EXTN ".zvf" +define TIMELOCK1_EXTN ".zl1" +define TIMELOCK2_EXTN ".zl2" +define DEGENFLAG_EXTN ".zmd" +define LOCKFILE_EXTN ".zlk" diff --git a/unix/hlib/d1mach.f b/unix/hlib/d1mach.f new file mode 100644 index 00000000..ccecd107 --- /dev/null +++ b/unix/hlib/d1mach.f @@ -0,0 +1,463 @@ + DOUBLE PRECISION FUNCTION D1MACH(I) +C +C DOUBLE-PRECISION MACHINE CONSTANTS +C +C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. +C +C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C +C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. +C +C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. +C +C D1MACH( 5) = LOG10(B) +C +C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, +C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY +C REMOVING THE C FROM COLUMN 1. +C ON RARE MACHINES A STATIC STATEMENT MAY NEED TO BE ADDED. +C (BUT PROBABLY MORE SYSTEMS PROHIBIT IT THAN REQUIRE IT.) +C +C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), ONE OF THE FIRST +C TWO SETS OF CONSTANTS BELOW SHOULD BE APPROPRIATE. IF YOU DO NOT +C KNOW WHICH SET TO USE, TRY BOTH AND SEE WHICH GIVES PLAUSIBLE +C VALUES. +C +C WHERE POSSIBLE, DECIMAL, OCTAL OR HEXADECIMAL CONSTANTS ARE USED +C TO SPECIFY THE CONSTANTS EXACTLY. SOMETIMES THIS REQUIRES USING +C EQUIVALENT INTEGER ARRAYS. IF YOUR COMPILER USES HALF-WORD +C INTEGERS BY DEFAULT (SOMETIMES CALLED INTEGER*2), YOU MAY NEED TO +C CHANGE INTEGER TO INTEGER*4 OR OTHERWISE INSTRUCT YOUR COMPILER +C TO USE FULL-WORD INTEGERS IN THE NEXT 5 DECLARATIONS. +C +C COMMENTS JUST BEFORE THE END STATEMENT (LINES STARTING WITH *) +C GIVE C SOURCE FOR D1MACH. +C + INTEGER SMALL(2) + INTEGER LARGE(2) + INTEGER RIGHT(2) + INTEGER DIVER(2) + INTEGER LOG10(2) + INTEGER I +C/6S +C/7S + SAVE SMALL, LARGE, RIGHT, DIVER, LOG10 +C/ + DOUBLE PRECISION DMACH(5) +C + EQUIVALENCE (DMACH(1),SMALL(1)) + EQUIVALENCE (DMACH(2),LARGE(1)) + EQUIVALENCE (DMACH(3),RIGHT(1)) + EQUIVALENCE (DMACH(4),DIVER(1)) + EQUIVALENCE (DMACH(5),LOG10(1)) +C +C MACHINE CONSTANTS FOR BIG-ENDIAN IEEE ARITHMETIC (BINARY FORMAT) +C MACHINES IN WHICH THE MOST SIGNIFICANT BYTE IS STORED FIRST, +C SUCH AS THE AT&T 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. +C SUN 3), AND MACHINES THAT USE SPARC, HP, OR IBM RISC CHIPS. +C +C DATA SMALL(1),SMALL(2) / 1048576, 0 / +C DATA LARGE(1),LARGE(2) / 2146435071, -1 / +C DATA RIGHT(1),RIGHT(2) / 1017118720, 0 / +C DATA DIVER(1),DIVER(2) / 1018167296, 0 / +C DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 / +C +C MACHINE CONSTANTS FOR LITTLE-ENDIAN (BINARY) IEEE ARITHMETIC +C MACHINES IN WHICH THE LEAST SIGNIFICANT BYTE IS STORED FIRST, +C E.G. IBM PCS AND OTHER MACHINES THAT USE INTEL 80X87 OR DEC +C ALPHA CHIPS. +C + DATA SMALL(1),SMALL(2) / 0, 1048576 / + DATA LARGE(1),LARGE(2) / -1, 2146435071 / + DATA RIGHT(1),RIGHT(2) / 0, 1017118720 / + DATA DIVER(1),DIVER(2) / 0, 1018167296 / + DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 / +C +C MACHINE CONSTANTS FOR AMDAHL MACHINES. +C +C DATA SMALL(1),SMALL(2) / 1048576, 0 / +C DATA LARGE(1),LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1),RIGHT(2) / 856686592, 0 / +C DATA DIVER(1),DIVER(2) / 873463808, 0 / +C DATA LOG10(1),LOG10(2) / 1091781651, 1352628735 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 /, SC/987/ +C +C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777774B / +C +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B /, SC/987/ +C +C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. +C +C DATA SMALL(1) / O"00564000000000000000" / +C DATA SMALL(2) / O"00000000000000000000" / +C +C DATA LARGE(1) / O"37757777777777777777" / +C DATA LARGE(2) / O"37157777777777777774" / +C +C DATA RIGHT(1) / O"15624000000000000000" / +C DATA RIGHT(2) / O"00000000000000000000" / +C +C DATA DIVER(1) / O"15634000000000000000" / +C DATA DIVER(2) / O"00000000000000000000" / +C +C DATA LOG10(1) / O"17164642023241175717" / +C DATA LOG10(2) / O"16367571421742254654" /, SC/987/ +C +C MACHINE CONSTANTS FOR CONVEX C-1 +C +C DATA SMALL(1),SMALL(2) / '00100000'X, '00000000'X / +C DATA LARGE(1),LARGE(2) / '7FFFFFFF'X, 'FFFFFFFF'X / +C DATA RIGHT(1),RIGHT(2) / '3CC00000'X, '00000000'X / +C DATA DIVER(1),DIVER(2) / '3CD00000'X, '00000000'X / +C DATA LOG10(1),LOG10(2) / '3FF34413'X, '509F79FF'X /, SC/987/ +C +C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777776B / +C +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B /, SC/987/ +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C SMALL, LARGE, RIGHT, DIVER, LOG10 SHOULD BE DECLARED +C INTEGER SMALL(4), LARGE(4), RIGHT(4), DIVER(4), LOG10(4) +C +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - +C STATIC DMACH(5) +C +C DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ +C DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ +C DATA LOG10/40423K,42023K,50237K,74776K/, SC/987/ +C +C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 +C +C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1),LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1),DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1),LOG10(2) / '23210115, '10237777 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C +C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. +C +C DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF /, SC/987/ +C +C MACHINE CONSTANTS FOR THE INTERDATA 8/32 +C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. +C +C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE +C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. +C +C DATA SMALL(1),SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1),LARGE(2) / Z'7EFFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1),RIGHT(2) / Z'33100000', Z'00000000' / +C DATA DIVER(1),DIVER(2) / Z'34100000', Z'00000000' / +C DATA LOG10(1),LOG10(2) / Z'41134413', Z'509F79FF' /, SC/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C +C DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C +C DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1),LOG10(2) / "177464202324, "047674776746 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1),SMALL(2) / 8388608, 0 / +C DATA LARGE(1),LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / +C DATA DIVER(1),DIVER(2) / 620756992, 0 / +C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ +C +C DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C SMALL, LARGE, RIGHT, DIVER, LOG10 SHOULD BE DECLARED +C INTEGER SMALL(4), LARGE(4), RIGHT(4), DIVER(4), LOG10(4) +C +C DATA SMALL(1),SMALL(2) / 128, 0 / +C DATA SMALL(3),SMALL(4) / 0, 0 / +C +C DATA LARGE(1),LARGE(2) / 32767, -1 / +C DATA LARGE(3),LARGE(4) / -1, -1 / +C +C DATA RIGHT(1),RIGHT(2) / 9344, 0 / +C DATA RIGHT(3),RIGHT(4) / 0, 0 / +C +C DATA DIVER(1),DIVER(2) / 9472, 0 / +C DATA DIVER(3),DIVER(4) / 0, 0 / +C +C DATA LOG10(1),LOG10(2) / 16282, 8346 / +C DATA LOG10(3),LOG10(4) / -31493, -12296 /, SC/987/ +C +C DATA SMALL(1),SMALL(2) / O000200, O000000 / +C DATA SMALL(3),SMALL(4) / O000000, O000000 / +C +C DATA LARGE(1),LARGE(2) / O077777, O177777 / +C DATA LARGE(3),LARGE(4) / O177777, O177777 / +C +C DATA RIGHT(1),RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3),RIGHT(4) / O000000, O000000 / +C +C DATA DIVER(1),DIVER(2) / O022400, O000000 / +C DATA DIVER(3),DIVER(4) / O000000, O000000 / +C +C DATA LOG10(1),LOG10(2) / O037632, O020232 / +C DATA LOG10(3),LOG10(4) / O102373, O147770 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS +C WITH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, +C SUPPLIED BY IGOR BRAY. +C +C DATA SMALL(1),SMALL(2) / :10000000000, :00000100001 / +C DATA LARGE(1),LARGE(2) / :17777777777, :37777677775 / +C DATA RIGHT(1),RIGHT(2) / :10000000000, :00000000122 / +C DATA DIVER(1),DIVER(2) / :10000000000, :00000000123 / +C DATA LOG10(1),LOG10(2) / :11504046501, :07674600177 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 +C +C DATA SMALL(1),SMALL(2) / $00000000, $00100000 / +C DATA LARGE(1),LARGE(2) / $FFFFFFFF, $7FEFFFFF / +C DATA RIGHT(1),RIGHT(2) / $00000000, $3CA00000 / +C DATA DIVER(1),DIVER(2) / $00000000, $3CB00000 / +C DATA LOG10(1),LOG10(2) / $509F79FF, $3FD34413 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE VAX UNIX F77 COMPILER +C +C DATA SMALL(1),SMALL(2) / 128, 0 / +C DATA LARGE(1),LARGE(2) / -32769, -1 / +C DATA RIGHT(1),RIGHT(2) / 9344, 0 / +C DATA DIVER(1),DIVER(2) / 9472, 0 / +C DATA LOG10(1),LOG10(2) / 546979738, -805796613 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE VAX-11 WITH +C FORTRAN IV-PLUS COMPILER +C +C DATA SMALL(1),SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1),LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1),RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1),DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1),LOG10(2) / Z209A3F9A, ZCFF884FB /, SC/987/ +C +C MACHINE CONSTANTS FOR VAX/VMS VERSION 2.2 +C +C DATA SMALL(1),SMALL(2) / '80'X, '0'X / +C DATA LARGE(1),LARGE(2) / 'FFFF7FFF'X, 'FFFFFFFF'X / +C DATA RIGHT(1),RIGHT(2) / '2480'X, '0'X / +C DATA DIVER(1),DIVER(2) / '2500'X, '0'X / +C DATA LOG10(1),LOG10(2) / '209A3F9A'X, 'CFF884FB'X /, SC/987/ +C +C *** ISSUE STOP 779 IF ALL DATA STATEMENTS ARE COMMENTED... +C IF (SC .NE. 987) THEN +C DMACH(1) = 1.D13 +C IF ( SMALL(1) .EQ. 1117925532 +C * .AND. SMALL(2) .EQ. -448790528) THEN +C* *** IEEE BIG ENDIAN *** +C SMALL(1) = 1048576 +C SMALL(2) = 0 +C LARGE(1) = 2146435071 +C LARGE(2) = -1 +C RIGHT(1) = 1017118720 +C RIGHT(2) = 0 +C DIVER(1) = 1018167296 +C DIVER(2) = 0 +C LOG10(1) = 1070810131 +C LOG10(2) = 1352628735 +C ELSE IF ( SMALL(2) .EQ. 1117925532 +C * .AND. SMALL(1) .EQ. -448790528) THEN +C* *** IEEE LITTLE ENDIAN *** +C SMALL(2) = 1048576 +C SMALL(1) = 0 +C LARGE(2) = 2146435071 +C LARGE(1) = -1 +C RIGHT(2) = 1017118720 +C RIGHT(1) = 0 +C DIVER(2) = 1018167296 +C DIVER(1) = 0 +C LOG10(2) = 1070810131 +C LOG10(1) = 1352628735 +C ELSE IF ( SMALL(1) .EQ. -2065213935 +C * .AND. SMALL(2) .EQ. 10752) THEN +C* *** VAX WITH D_FLOATING *** +C SMALL(1) = 128 +C SMALL(2) = 0 +C LARGE(1) = -32769 +C LARGE(2) = -1 +C RIGHT(1) = 9344 +C RIGHT(2) = 0 +C DIVER(1) = 9472 +C DIVER(2) = 0 +C LOG10(1) = 546979738 +C LOG10(2) = -805796613 +C ELSE IF ( SMALL(1) .EQ. 1267827943 +C * .AND. SMALL(2) .EQ. 704643072) THEN +C* *** IBM MAINFRAME *** +C SMALL(1) = 1048576 +C SMALL(2) = 0 +C LARGE(1) = 2147483647 +C LARGE(2) = -1 +C RIGHT(1) = 856686592 +C RIGHT(2) = 0 +C DIVER(1) = 873463808 +C DIVER(2) = 0 +C LOG10(1) = 1091781651 +C LOG10(2) = 1352628735 +C ELSE +C WRITE(*,*)'Adjust D1MACH by uncommenting' +C WRITE(*,*)'data statements appropriate for your machine.' +C STOP 779 +C END IF +C SC = 987 +C END IF +C +C *** ISSUE STOP 778 IF ALL DATA STATEMENTS ARE OBVIOUSLY WRONG... +C IF (DMACH(4) .GE. 1.0D0) STOP 778 +C*C/6S +C*C IF (I .LT. 1 .OR. I .GT. 5) +C*C 1 CALL SETERR(24HD1MACH - I OUT OF BOUNDS,24,1,2) +C*C/7S +C* IF (I .LT. 1 .OR. I .GT. 5) +C* 1 CALL SETERR('D1MACH - I OUT OF BOUNDS',24,1,2) +C*C/ +C IF (I .LT. 1 .OR. I .GT. 5) THEN +C WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.' +C STOP +C END IF + IF (I .LT. 1 .OR. I .GT. 5) THEN + D1MACH = 0.0 + RETURN + END IF + D1MACH = DMACH(I) + RETURN +C +C* /* C source for D1MACH -- remove the * in column 1 */ +C*#include +C*#include +C*#include +C* +C*double d1mach_(long *i) +C*{ +C* switch(*i){ +C* case 1: return DBL_MIN; +C* case 2: return DBL_MAX; +C* case 3: return DBL_EPSILON/FLT_RADIX; +C* case 4: return DBL_EPSILON; +C* case 5: return log10(FLT_RADIX); +C* } +C* +C* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); +C* exit(1); +C* return 0; /* for compilers that complain of missing return values */ +C* } + END diff --git a/unix/hlib/deallocate.cl b/unix/hlib/deallocate.cl new file mode 100644 index 00000000..564d57be --- /dev/null +++ b/unix/hlib/deallocate.cl @@ -0,0 +1,12 @@ +# DEALLOCATE -- Deallocate a device. The real work is done by the hidden CL +# _deallocate task, but we provide a script interface as well to provide +# scope for machine dependent additions. + +procedure deallocate (device) + +string device { prompt = "device to be deallocated" } +bool rewind = yes + +begin + _deallocate (device, rewind) +end diff --git a/unix/hlib/devstatus.cl b/unix/hlib/devstatus.cl new file mode 100644 index 00000000..4e00540b --- /dev/null +++ b/unix/hlib/devstatus.cl @@ -0,0 +1,30 @@ +# DEVSTATUS -- Print status info for the named device. The basic function +# is performed by the hidden builtin _devstatus, but you may with to add +# additional machine dependent function to the script. + +procedure devstatus (device) + +string device { prompt = "device for which status is desired" } +bool verbose = no + +string logname, hostname +struct *devlist +string dev + +begin + dev = device + _devstatus (dev) + +# if (verbose) { +# # Print UNIX device status, too. +# +# devlist = "dev$devices" +# while (fscan (devlist, logname, hostname) != EOF) { +# if (logname == dev) { +# print ("!ls -l /dev/", hostname) | cl +# break +# } +# } +# devlist = "" +# } +end diff --git a/unix/hlib/diskspace.cl b/unix/hlib/diskspace.cl new file mode 100644 index 00000000..d252a4a9 --- /dev/null +++ b/unix/hlib/diskspace.cl @@ -0,0 +1,7 @@ +#{ DISKSPACE -- [MACHDEP] Summarize the amount of diskspace currently +# available. + +{ + # Call the UNIX "diskfree" command. + !!df +} diff --git a/unix/hlib/ecl.csh b/unix/hlib/ecl.csh new file mode 120000 index 00000000..bc54b0f4 --- /dev/null +++ b/unix/hlib/ecl.csh @@ -0,0 +1 @@ +cl.csh \ No newline at end of file diff --git a/unix/hlib/ecl.sh b/unix/hlib/ecl.sh new file mode 100755 index 00000000..027343a3 --- /dev/null +++ b/unix/hlib/ecl.sh @@ -0,0 +1,164 @@ +#!/bin/bash +# +# CL.SH -- Startup the version of the CL executable compiled for the +# architecture or floating point hardware appropriate for the current +# machine. This script can be used to invoke a number of CL flavors +# depending on how it is called. The install script will create a 'cl' +# and 'ecl' command link to this script with the intent that a different +# binary would be started for each command. + + +# Determine CL binary to run based on how we were called. + +nm=${0##*/} +cl_binary="vocl.e" + +case "$nm" in + "cl" | "cl.sh") + cl_binary="cl.e" + ;; + "ecl" | "ecl.sh") + cl_binary="ecl.e" + ;; + "vocl" | "vocl.sh") + cl_binary="vocl.e" + ;; + *) + if (( $# > 1 )); then + if [ $1 == "-old" -o $1 == "-o" ]; then + cl_binary="cl.e" + elif [ $1 == "-ecl" -o $1 == "-e" ]; then + cl_binary="ecl.e" + elif [ $1 == "-vo" ]; then + cl_binary="vocl.e" + elif [ ${1##*.} == "c" ]; then + # Workaround for autoconf scripts attempting to use this + # command as a valid compiler option. On some systems (mostly + # Debian) a valid CC command can't be found and eventually + # the 'cl' (lisp) compiler is tried. It will always apparently + # have the conftest.c test file, so simply exit with a code to + # tell autoconf it won't work. + exit 1 + fi + fi +esac + +# Determine IRAF root directory (value set in install script). +d_iraf="/iraf/iraf/" +if [ -n $iraf ]; then + if [ ! -e $iraf ]; then + echo "Warning: iraf=$iraf does not exist (check .cshrc or .login)" + echo "Session will default to iraf=$d_iraf" + unset iraf ; sleep 3 + fi +fi +if [ -z $iraf ]; then + export iraf="$d_iraf" +fi + +# Check for a version query. +if [ $# > 1 ]; then + case "$1" in + "-v" | "-V" | "-version" | "--version") + head -1 $iraf/unix/hlib/motd + exit 0 + ;; + *) + ;; + esac +fi + + +# Determine platform architecture. +if [ -e $iraf/unix/hlib/irafarch.sh ]; then + ACTUAL_ARCH=`$iraf/unix/hlib/irafarch.sh -actual` +else + ACTUAL_ARCH=$IRAFARCH +fi + +if [ -n "$IRAFARCH" ]; then + if [ -e $iraf/bin.${IRAFARCH}/${cl_binary} ]; then + MACH=$IRAFARCH + else + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + if [ "$ACTUAL_ARCH" != "$IRAFARCH" ]; then + echo "ERROR: IRAFARCH set to '$IRAFARCH', should be '$ACTUAL_ARCH'" + fi + exit 1 + fi + export arch=".$MACH" + +else + os_mach=`uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + + if [ -e $iraf/unix/hlib/irafarch.csh ]; then + MACH=`$iraf/unix/hlib/irafarch.csh` + else + MACH=$os_mach + fi + + if [ "$os_mach" == "linux" ]; then # handle linux systems + if [ `uname -m` == "x86_64" ]; then + export mach="linux64" + else + export mach="linux" + fi + elif [ "$os_mach" == "darwin" ]; then # handle Mac systems + if [ "`uname -m`" == "x86_64" ]; then + export mach="macintel" + else + export mach="macosx" + fi + elif [ "$os_mach" == "cygwin" ]; then + export mach="cygwin" + else + mach=`uname -s | tr '[A-Z]' '[a-z]'` + fi + + export arch=".$MACH" + if [ -z $IRAFARCH ]; then + export IRAFARCH="$MACH" + fi + + if [ ! -e $iraf/bin.${MACH}/${cl_binary} ]; then + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + exit 1 + fi +fi + + +# Recent linux systems display a problem in how pointer addresses +# interact with the stack and can result in a segfault. Remove the +# stacksize limit for IRAF processes until this is better understood. +if [ "$IRAFARCH" == "redhat" -o \ + "$IRAFARCH" == "linux64" -o \ + "$IRAFARCH" == "linux" ]; then + ulimit -s unlimited +fi + + +# Just run the CL if IRAFARCH already defined. +if [ -n "$IRAFARCH" ]; then + if [ -z $IRAFARCH ]; then + export arch="" + else + export arch=".$IRAFARCH" + fi + + export IRAFBIN=${iraf}bin$arch/ + file=${IRAFBIN}$cl_binary + if [ -e $file ]; then + exec $file + else + echo "$file not found" + fi +fi + + +# Set the architecture to be used. +export IRAFARCH=$MACH +export arch=.$IRAFARCH +export IRAFBIN=${iraf}bin$arch/ + +# Run the desired CL. +exec ${IRAFBIN}$cl_binary diff --git a/unix/hlib/extern.pkg b/unix/hlib/extern.pkg new file mode 100644 index 00000000..5afbabf9 --- /dev/null +++ b/unix/hlib/extern.pkg @@ -0,0 +1,41 @@ +# External (non core-system) packages. To install a new package, add the +# two statements to define the package root directory and package task, +# then add the package helpdb to the `helpdb' list. + +reset extern = iraf$extern/ + +reset noao = iraf$noao/ +task noao.pkg = noao$noao.cl + +reset vo = iraf$vo/ +task vo.pkg = vo$vo.cl + +#reset local = iraf$local/ +#task local.pkg = local$local.cl + + +# Manually defined external packages. Packages installed in the iraf$extern +# directory will be loaded dynamically, other packages may be defined here +# if for some reason they are non-standard and cannot be loaded dynamically. +# +# Package definitions have the form: +# +# reset example = extern$example/ <--- must have trailing '/' +# task example.pkg = example$example.cl +# +# Note the 'helpdb' string below must also be modified. + + + +# Initialize the helpdb string. We'll add to this when dyanamically +# loading packages when the next load the CLPACKAGE. +reset helpdb = "lib$helpdb.mip\ + ,noao$lib/helpdb.mip\ + ,vo$lib/helpdb.mip\ +# ,example$lib/helpdb.mip\ + " + + +# Do not modify below this line! +clpackage +keep diff --git a/unix/hlib/extern.pkg.DEF b/unix/hlib/extern.pkg.DEF new file mode 100644 index 00000000..8d1f9f76 --- /dev/null +++ b/unix/hlib/extern.pkg.DEF @@ -0,0 +1,16 @@ +# External (non core-system) packages. To install a new package, add the +# two statements to define the package root directory and package task, +# then add the package helpdb to the `helpdb' list. + +reset noao = iraf$noao/ +task noao.pkg = noao$noao.cl + +#reset tables = /iraf/extern/tables/ +#task tables.pkg = tables$tables.cl + +reset helpdb = "lib$helpdb.mip\ + ,noao$lib/helpdb.mip\ +# ,tables$lib/helpdb.mip\ + " + +keep diff --git a/unix/hlib/extern.pkg.IRAFNET b/unix/hlib/extern.pkg.IRAFNET new file mode 100644 index 00000000..8d1f9f76 --- /dev/null +++ b/unix/hlib/extern.pkg.IRAFNET @@ -0,0 +1,16 @@ +# External (non core-system) packages. To install a new package, add the +# two statements to define the package root directory and package task, +# then add the package helpdb to the `helpdb' list. + +reset noao = iraf$noao/ +task noao.pkg = noao$noao.cl + +#reset tables = /iraf/extern/tables/ +#task tables.pkg = tables$tables.cl + +reset helpdb = "lib$helpdb.mip\ + ,noao$lib/helpdb.mip\ +# ,tables$lib/helpdb.mip\ + " + +keep diff --git a/unix/hlib/extpkg.cl b/unix/hlib/extpkg.cl new file mode 100644 index 00000000..105dd5bf --- /dev/null +++ b/unix/hlib/extpkg.cl @@ -0,0 +1,58 @@ +# Dynamic Package Loading Script +# +# This script is "sourced" by the standard hlib$extern.pkg file when the +# CL is loaded to automatically define any packages installed in the +# iraf$extern directory. Both the package definition and helpdb strings +# are defined to include the package, negating the previous manual +# declarations required in hlib$extern.pkg +# +# + +string curdir, extdir, dpkg + +extdir = osfn ("iraf$extern") + +# Go to the dynamic package directory, but save the current directory so +# we can return when we're done. At this stage of the login we need to +# use host commands since the system package isn't available. +printf ("!pwd\n") | cl () | scan (curdir) +chdir (extdir) + +# Create a file list to process. +dpkg = mktemp ("tmp$dpkg") +if (access (dpkg) == yes) + printf ("!/bin/rm -f %s\n", osfn(dpkg)) | cl () +; +printf ("!/bin/ls -1ad [a-y]*\n") | cl (,> dpkg) + +list = dpkg +while (fscan (list, s1) != EOF) { + + # We define an environment variable for installed directories, e.g. a + # package support directory of data might require it's own definition. + # This also works to define the variable for actual package code, but + # we don't declare the package just yet. + if (access (s1) == yes && + (access (s1//"/.installed") == yes || + access (s1//"/"//s1//".cl") == yes)) { + printf ("reset %s = %s/%s/\nkeep\n", s1, osfn("iraf$extern"), s1) | cl () + } + ; + + # We assume we can dynamically load a package if there is a "foo.cl" + # script file in the 'foo' subdirectory. + if (access (s1//"/"//s1//".cl") == yes) { + printf ("task %s.pkg = %s$%s.cl\nkeep\n", s1, s1, s1) | cl () + + # Add to the helpdb string. + printf ("reset helpdb=%s,%s$lib/helpdb.mip\nkeep\n", + envget("helpdb"), s1) | cl () + } + ; +} + +# Clean uo and go back to the login directory. +printf ("!/bin/rm -f %s\n", osfn(dpkg)) | cl () +chdir (curdir) + +keep diff --git a/unix/hlib/f77.sh b/unix/hlib/f77.sh new file mode 100755 index 00000000..1033f0cf --- /dev/null +++ b/unix/hlib/f77.sh @@ -0,0 +1,296 @@ +#!/bin/bash +PATH=/v/bin:/bin:/usr/bin:/usr/local/bin +# f77-style shell script to compile and load fortran, C, and assembly codes +# usage: f77 [-g] [-O|-O[23456]] [-o absfile] [-c] files [-l library] +# -o objfile Override default executable name a.out. +# -c Do not call linker, leave relocatables in *.o. +# -S leave assembler output on file.s +# -l library (passed to ld). +# -u complain about undeclared variables +# -w omit all warning messages +# -w66 omit Fortran 66 compatibility warning messages +# -f* pass thru gcc optimizer options +# -W* pass thru gcc warning options +# files FORTRAN source files ending in .f . +# C source files ending in .c . +# Assembly language files ending in .s . +# efl source files ending in .e . +# -I includepath passed to C compiler (for .c files) +# -Ntnnn allow nnn entries in table t +# -cpp -Dxxx pipe through cpp +# +# [IRAF] -- For IRAF we had to modify the f77 script that came with Linux +# to remove the "f2ctmp_XX" prefix that the script was adding to the Fortran +# file names when compiling. The main problem with this is that it prevents +# source code debugging from working since the file that was compiled (e.g. +# f2ctmp_foo.f) no longer exists at run time. A lesser problem was that the +# code which deletes the f2ctmp_ files would return an exit 4 status, causing +# problems with XC (XC was modified for Linux to ignore this but it is still +# a bug with the f77 script). NOTE -- the old behavior is still present if +# the Fortran file has a .F extension. The modified (no f2ctmp_) behavior is +# for .f files. + +s=/tmp/stderr_$$ +t=/tmp/f77_$$ +#CC=${CC_f2c:-'/usr/bin/cc -m486'} +CC=${CC_f2c:-'gcc'} +CFLAGS=${CFLAGS:-"-I${iraf}unix/bin.${IRAFARCH}"} +EFL=${EFL:-/v/bin/efl} +EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'} +F2C=${F2C:-/usr/bin/f2c} +F2CFLAGS=${F2CFLAGS:='-KRw8 -Nn802'} +keepc=0 +warn=1 +xsrc=0 +rc=0 +lib=/lib/num/lib.lo +trap "rm -f $s ; exit \$rc" 0 +OUTF=a.out +cOPT=1 +G= +CPP=/bin/cat +CPPFLAGS= +# set -- `getopt cD:gI:N:Oo:Suw6 "$@"` +case $? in 0);; *) exit 1;; esac +while + test X"$1" != X-- +do + case "$1" + in + -b) CFLAGS="$CFLAGS -b $2" + shift 2 + ;; + + -K) keepc=1 + shift + ;; + + -c) cOPT=0 + shift + ;; + + -D) CPPFLAGS="$CPPFLAGS -D$2" + shift 2 + ;; + + -D*) CPPFLAGS="$CPPFLAGS $1" + shift 1 + ;; + + -f2c) F2C="$2" + #F2C="${iraf}/unix/bin/f2c.e" + shift 2 + ;; + + -f*) CFLAGS="$CFLAGS $1" + shift 1 + ;; + + -g) CFLAGS="$CFLAGS -g" + F2CFLAGS="$F2CFLAGS -g" + G="-g" + shift;; + + -x64) CFLAGS="$CFLAGS -mfloat64" + shift;; + + -I) CFLAGS="$CFLAGS -I$2" + shift 2 + ;; + + -I*) CFLAGS="$CFLAGS $1" + shift 1 + ;; + + -m*) CFLAGS="$CFLAGS $1" + shift 1 + ;; + + -o) OUTF=$2 + shift 2 + ;; + + -O*) + CFLAGS="$CFLAGS $1" + shift + ;; + + -arch) CFLAGS="$CFLAGS -arch $2" + shift 2 + ;; + + -U) CFLAGS="$CFLAGS -arch ppc -arch i386" + shift + ;; + + -u) F2CFLAGS="$F2CFLAGS -u" + shift + ;; + + -P) F2CFLAGS="$F2CFLAGS -P" + shift + ;; + + -FP) CFLAGS="$CFLAGS -include $2" + shift 2 + ;; + + -W*) CFLAGS="$CFLAGS $1" + warn=1 + shift 1 + ;; + + -w) F2CFLAGS="$F2CFLAGS -w" + CFLAGS="$CFLAGS -w" + warn=0 + case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift + case $2 in -6) shift;; esac;; esac + shift + ;; + + -x) xsrc=1 + shift + ;; + + -N) F2CFLAGS="$F2CFLAGS $1""$2" + shift 2 + ;; + + -N*|-C) F2CFLAGS="$F2CFLAGS $1" + shift 1 + ;; + + -cpp) CPP="/lib/cpp -traditional" + shift 1 + ;; + + -S) CFLAGS="$CFLAGS -S" + cOPT=0 + shift + ;; + + -*) + echo "invalid parameter $1" 1>&2 + shift + ;; + + *) set -- -- $@ + ;; + esac +done +shift + +while + test -n "$1" +do + case "$1" + in + *.f) + case "$1" in *.f) f=".f";; *.F) f=".F";; esac + b=`basename $1 $f` + if [ $warn = 0 ]; then + $F2C $F2CFLAGS $b.f 2>$s + sed '/^ arg .*: here/d' $s 1>&2 + else + $F2C $F2CFLAGS $b.f + fi + if [ $xsrc = 1 ]; then + sed -e "s/$b\\.f/$b.x/" < $b.c > $b.t; mv $b.t $b.c + fi + $CC $CPPFLAGS -c $CFLAGS $b.c 2>$s + rc=$? + sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2 + case $rc in 0);; *) exit 5;; esac + if [ $keepc = 0 ]; then + rm -f $b.c + fi + OFILES="$OFILES $b.o" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.F) + case "$1" in *.f) f=".f";; *.F) f=".F";; esac + b=`basename $1 $f` + trap "rm -f f2ctmp_$b.* ; exit 4" 0 + sed 's/\\$/\\-/; + s/^ *INCLUDE *'\(.*\)'.*$/#include "\1"/' $1 |\ + $CPP $CPPFLAGS |\ + egrep -v '^# ' > f2ctmp_$b.f + trap "rm -f f2ctmp_$b.* ; exit 4" 0 + $F2C $F2CFLAGS f2ctmp_$b.f + case $? in 0);; *) rm f2ctmp_* ; exit 5;; esac + rm -f f2ctmp_$b.f + mv f2ctmp_$b.c $b.c + if [ -f f2ctmp_$b.P ]; then mv f2ctmp_$b.P $b.P; fi + case $? in 0);; *) rm -f $b.c ; exit 5;; esac + trap "rm -f $s ; exit 4" 0 + $CC $CPPFLAGS -c $CFLAGS $b.c 2>$s + rc=$? + sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2 + case $rc in 0);; *) exit 5;; esac + if [ $keepc = 0 ]; then + rm -f $b.c + fi + OFILES="$OFILES $b.o" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.e) + b=`basename $1 .e` + $EFL $EFLFLAGS $1 >$b.f + case $? in 0);; *) exit;; esac + $F2C $F2CFLAGS $b.f + case $? in 0);; *) exit;; esac + $CC -c $CFLAGS $b.c + case $? in 0);; *) exit;; esac + OFILES="$OFILES $b.o" + rm $b.[cf] + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.s) + echo $1: 1>&2 + OFILE=`basename $1 .s`.o + ${AS:-/usr/bin/as} -o $OFILE $AFLAGS $1 + case $? in 0);; *) exit;; esac + OFILES="$OFILES $OFILE" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.c) + echo $1: 1>&2 + OFILE=`basename $1 .c`.o + $CC -c $CFLAGS $CPPFLAGS $1 + rc=$?; case $rc in 0);; *) exit;; esac + OFILES="$OFILES $OFILE" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.o) + OFILES="$OFILES $1" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + -l) + OFILES="$OFILES -l$2" + shift 2 + case $cOPT in 1) cOPT=2;; esac + ;; + -l*) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + -o) + OUTF=$2; shift 2;; + *) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + esac +done + +case $cOPT in 2) $CC $G -o $OUTF $OFILES -lf2c -lm;; esac +rc=$? +exit $rc diff --git a/unix/hlib/f77.sh.bak b/unix/hlib/f77.sh.bak new file mode 100755 index 00000000..49db55b0 --- /dev/null +++ b/unix/hlib/f77.sh.bak @@ -0,0 +1,297 @@ +#!/bin/sh +PATH=/v/bin:/bin:/usr/bin:/usr/local/bin +# f77-style shell script to compile and load fortran, C, and assembly codes +# usage: f77 [-g] [-O|-O[23456]] [-o absfile] [-c] files [-l library] +# -o objfile Override default executable name a.out. +# -c Do not call linker, leave relocatables in *.o. +# -S leave assembler output on file.s +# -l library (passed to ld). +# -u complain about undeclared variables +# -w omit all warning messages +# -w66 omit Fortran 66 compatibility warning messages +# -f* pass thru gcc optimizer options +# -W* pass thru gcc warning options +# files FORTRAN source files ending in .f . +# C source files ending in .c . +# Assembly language files ending in .s . +# efl source files ending in .e . +# -I includepath passed to C compiler (for .c files) +# -Ntnnn allow nnn entries in table t +# -cpp -Dxxx pipe through cpp +# +# [IRAF] -- For IRAF we had to modify the f77 script that came with Linux +# to remove the "f2ctmp_XX" prefix that the script was adding to the Fortran +# file names when compiling. The main problem with this is that it prevents +# source code debugging from working since the file that was compiled (e.g. +# f2ctmp_foo.f) no longer exists at run time. A lesser problem was that the +# code which deletes the f2ctmp_ files would return an exit 4 status, causing +# problems with XC (XC was modified for Linux to ignore this but it is still +# a bug with the f77 script). NOTE -- the old behavior is still present if +# the Fortran file has a .F extension. The modified (no f2ctmp_) behavior is +# for .f files. + +s=/tmp/stderr_$$ +t=/tmp/f77_$$ +#CC=${CC_f2c:-'/usr/bin/cc -m486'} +CC=${CC_f2c:-'gcc'} +CFLAGS=${CFLAGS:-"-I${iraf}unix/bin.${IRAFARCH}"} +EFL=${EFL:-/v/bin/efl} +EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'} +F2C=${F2C:-/usr/bin/f2c} +F2CFLAGS=${F2CFLAGS:='-KRw8 -Nn802'} +MARCH="-m64 -arch x86_64" +keepc=0 +warn=1 +xsrc=0 +rc=0 +lib=/lib/num/lib.lo +trap "rm -f $s ; exit \$rc" 0 +OUTF=a.out +cOPT=1 +G= +CPP=/bin/cat +CPPFLAGS= +# set -- `getopt cD:gI:N:Oo:Suw6 "$@"` +case $? in 0);; *) exit 1;; esac +while + test X"$1" != X-- +do + case "$1" + in + -b) CFLAGS="$CFLAGS -b $2" + shift 2 + ;; + + -K) keepc=1 + shift + ;; + + -c) cOPT=0 + shift + ;; + + -D) CPPFLAGS="$CPPFLAGS -D$2" + shift 2 + ;; + + -D*) CPPFLAGS="$CPPFLAGS $1" + shift 1 + ;; + + -f2c) F2C="$2" + F2C="${iraf}/unix/bin/f2c.e" + shift 2 + ;; + + -f*) CFLAGS="$CFLAGS $1" + shift 1 + ;; + + -g) CFLAGS="$CFLAGS -g" + F2CFLAGS="$F2CFLAGS -g" + G="-g" + shift;; + + -x64) CFLAGS="$CFLAGS -mfloat64" + shift;; + + -I) CFLAGS="$CFLAGS -I$2" + shift 2 + ;; + + -I*) CFLAGS="$CFLAGS $1" + shift 1 + ;; + + -m*) CFLAGS="$CFLAGS $1" + shift 1 + ;; + + -o) OUTF=$2 + shift 2 + ;; + + -O*) + CFLAGS="$CFLAGS $1" + shift + ;; + + -arch) CFLAGS="$CFLAGS -arch $2" + shift 2 + ;; + + -U) CFLAGS="$CFLAGS -arch ppc -arch i386" + shift + ;; + + -u) F2CFLAGS="$F2CFLAGS -u" + shift + ;; + + -P) F2CFLAGS="$F2CFLAGS -P" + shift + ;; + + -FP) CFLAGS="$CFLAGS -include $2" + shift 2 + ;; + + -W*) CFLAGS="$CFLAGS $1" + warn=1 + shift 1 + ;; + + -w) F2CFLAGS="$F2CFLAGS -w" + CFLAGS="$CFLAGS -w" + warn=0 + case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift + case $2 in -6) shift;; esac;; esac + shift + ;; + + -x) xsrc=1 + shift + ;; + + -N) F2CFLAGS="$F2CFLAGS $1""$2" + shift 2 + ;; + + -N*|-C) F2CFLAGS="$F2CFLAGS $1" + shift 1 + ;; + + -cpp) CPP="/lib/cpp -traditional" + shift 1 + ;; + + -S) CFLAGS="$CFLAGS -S" + cOPT=0 + shift + ;; + + -*) + echo "invalid parameter $1" 1>&2 + shift + ;; + + *) set -- -- $@ + ;; + esac +done +shift + +while + test -n "$1" +do + case "$1" + in + *.f) + case "$1" in *.f) f=".f";; *.F) f=".F";; esac + b=`basename $1 $f` + if [ $warn = 0 ]; then + $F2C $F2CFLAGS $b.f 2>$s + sed '/^ arg .*: here/d' $s 1>&2 + else + $F2C $F2CFLAGS $b.f + fi + if [ $xsrc = 1 ]; then + sed -e "s/$b\\.f/$b.x/" < $b.c > $b.t; mv $b.t $b.c + fi + $CC $CPPFLAGS -c $CFLAGS $b.c 2>$s + rc=$? + sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2 + case $rc in 0);; *) exit 5;; esac + if [ $keepc = 0 ]; then + rm -f $b.c + fi + OFILES="$OFILES $b.o" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.F) + case "$1" in *.f) f=".f";; *.F) f=".F";; esac + b=`basename $1 $f` + trap "rm -f f2ctmp_$b.* ; exit 4" 0 + sed 's/\\$/\\-/; + s/^ *INCLUDE *'\(.*\)'.*$/#include "\1"/' $1 |\ + $CPP $CPPFLAGS |\ + egrep -v '^# ' > f2ctmp_$b.f + trap "rm -f f2ctmp_$b.* ; exit 4" 0 + $F2C $F2CFLAGS f2ctmp_$b.f + case $? in 0);; *) rm f2ctmp_* ; exit 5;; esac + rm -f f2ctmp_$b.f + mv f2ctmp_$b.c $b.c + if [ -f f2ctmp_$b.P ]; then mv f2ctmp_$b.P $b.P; fi + case $? in 0);; *) rm -f $b.c ; exit 5;; esac + trap "rm -f $s ; exit 4" 0 + $CC $CPPFLAGS -c $CFLAGS $b.c 2>$s + rc=$? + sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2 + case $rc in 0);; *) exit 5;; esac + if [ $keepc = 0 ]; then + rm -f $b.c + fi + OFILES="$OFILES $b.o" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.e) + b=`basename $1 .e` + $EFL $EFLFLAGS $1 >$b.f + case $? in 0);; *) exit;; esac + $F2C $F2CFLAGS $b.f + case $? in 0);; *) exit;; esac + $CC -c $CFLAGS $b.c + case $? in 0);; *) exit;; esac + OFILES="$OFILES $b.o" + rm $b.[cf] + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.s) + echo $1: 1>&2 + OFILE=`basename $1 .s`.o + ${AS:-/usr/bin/as} -o $OFILE $AFLAGS $1 + case $? in 0);; *) exit;; esac + OFILES="$OFILES $OFILE" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.c) + echo $1: 1>&2 + OFILE=`basename $1 .c`.o + $CC -c $CFLAGS $CPPFLAGS $1 + rc=$?; case $rc in 0);; *) exit;; esac + OFILES="$OFILES $OFILE" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + *.o) + OFILES="$OFILES $1" + case $cOPT in 1) cOPT=2;; esac + shift + ;; + -l) + OFILES="$OFILES -l$2" + shift 2 + case $cOPT in 1) cOPT=2;; esac + ;; + -l*) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + -o) + OUTF=$2; shift 2;; + *) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + esac +done + +case $cOPT in 2) $CC $G -o $OUTF $OFILES -lf2c -lm;; esac +rc=$? +exit $rc diff --git a/unix/hlib/fc.csh b/unix/hlib/fc.csh new file mode 100755 index 00000000..ab631b39 --- /dev/null +++ b/unix/hlib/fc.csh @@ -0,0 +1,37 @@ +#!/bin/csh -f +# +# FC.CSH -- Link an IMFORT or host fortran program from IRAF. A front end +# to XC, the purpose of this script is to determine the IRAF architecture +# and add the appropriate host compiler file to XC. + +# set echo + +# Scan the argument list and concatenate all arguments. +set args = "" +while ("$1" != "") + set args = "$args $1" + shift +end + +# Determine the desired architecture. +setenv IRAFARCH `$iraf/unix/hlib/irafarch.csh` +setenv MACH $IRAFARCH + +# Get float option switch. +switch ($IRAFARCH) +case macosx: + set float = "-/arch -//i386" + breaksw +case macint: + set float = "-/arch -//x86_64" + breaksw +case linux64: + set float = "-/m64" # FIXME + breaksw +default: + set float = "" + breaksw +endsw + +# Call XC with the appropriate float option. +xc $float $args diff --git a/unix/hlib/fc.sh b/unix/hlib/fc.sh new file mode 100755 index 00000000..88a0762c --- /dev/null +++ b/unix/hlib/fc.sh @@ -0,0 +1,30 @@ +#!/bin/bash +# +# FC.SH -- Link an IMFORT or host fortran program from IRAF. A front end +# to XC, the purpose of this script is to determine the IRAF architecture +# and add the appropriate host compiler file to XC. + + +# Determine the desired architecture. +IRAFARCH=`$iraf/unix/hlib/irafarch.csh` +MACH=$IRAFARCH + + +# Set any float option switch. +case $IRAFARCH in + macosx) + float="-/arch -//i386" + ;; + macintel) + float="-/arch -//x86_64" + ;; + linux64) + float="-/m64" # FIXME + ;; + *) + float="" + ;; +esac + +# Call XC with the appropriate float option. +xc $float $@ diff --git a/unix/hlib/gripes.cl b/unix/hlib/gripes.cl new file mode 100644 index 00000000..d05bedd5 --- /dev/null +++ b/unix/hlib/gripes.cl @@ -0,0 +1,65 @@ +# GRIPES -- Send gripes to the system. Gripes may be gripes, complaints, or +# suggestions. + +procedure gripes (subject) + +string subject { prompt = "Subject" } +file gripesfile = "hlib$gripesfile" +struct gripetext { len = 80 } +file tempfile +struct *list +struct timestring { len = 25 } +bool quit +bool verbose = yes + +begin + # Put gripe in tempfile and only append to the system gripefile if + # we complete normally. Thus if the user aborts us the gripe is + # not recorded. + + tempfile = mktemp ("uparm$gripe") // ".txt" + time (> tempfile) + list = tempfile + if (fscan (list, timestring) != EOF) + delete (tempfile, verify=no) + + # Print gripe report header. + print ("\n------------", >> tempfile) + print ("From: ", envget ("userid"), " ", timestring, >> tempfile) + + # Learn mode is not very useful for the subject string, since new + # gripemail virtually always deals with a different subject. Reset + # the subject string to null so that no prompt will be issued the + # next time we are called. + + print ("Subject: ", subject, >> tempfile) + subject = "" + + if (verbose) { + print ("Enter your gripe(s).\n") + print ("Type or '.' to quit, '~edit' to go into the editor:") + } + print (" ", >> tempfile) # skip line on output + print (" ") # skip line on terminal + + # Copy user text. Call up editor on temp file if "~edit" escape + # is entered, or any abbreviation thereof, and append file to + # gripesfile after exiting from the editor. + + while (scan (gripetext) != EOF) + if (substr (gripetext,1,1) == '.') { + break + } else if (substr (gripetext,1,2) == "~e") { + edit (tempfile) + clear; type (tempfile) + } else + print (gripetext, >> tempfile) + + # type (tempfile, >> gripesfile) +# UNIX + print ("!!mail iraf@noao.edu < ", osfn(tempfile)) | cl +# VMS + # print ("!mail ", osfn(tempfile), " 5355::iraf") | cl + + delete (tempfile, verify=no) +end diff --git a/unix/hlib/helplog.csh b/unix/hlib/helplog.csh new file mode 100755 index 00000000..8c740fd4 --- /dev/null +++ b/unix/hlib/helplog.csh @@ -0,0 +1,128 @@ +#! /bin/csh +# HELPLOG -- Format, edit, and log a new help digest to the system help file. +# +# Usage: +# +# helplog [none|system|applications] log a new help digest +# helplog -e edit the helpfile (with locking) +# +# The system helpfile is locked for exclusive access while a help digest is +# being logged, or while the helpfile is being edited. Logging can be +# aborted either by typing , or by editing the editor with ":q!" +# (i.e., by exiting the editor without modifying the temporary file being +# edited). Help logs are formatted and edited in a small temporary file in +# /tmp and are added at the end of the helpfile only if the task is not +# aborted and the edit modifies the input help log template. To go back and +# edit a previously logged help digest use "helplog -e". +# +# Record Format: +# +# NUMBER: record number, decimal, sequential. +# KEYWORDS: search keywords (eg task/package, category) +# DATE: date help digest logged, unix format date string +# FROM: user login name +# Q: digest of question +# A: digest of answer +# +# New records are added to the tail of the bugfile. Left justify field labels, +# indent text to the first tab stop, one blank line between bug entries. +# +# ---------------------------------------------------------------------------- + +unalias rm set find echo sleep tail sed cmp echo cat mail + +set helpfile = "${iraf}local/help.log" +set arcfile = "/u1/ftp/iraf/v212/help.log" +set tmpfile = "/tmp/help." +set lokfile = "/tmp/help.lok" + +set number = 1 +set keywords = "" +set from = "`whoami`" +set date = "`date`" +#set irafmail = "iraf@iraf.noao.edu valdes" +set irafmail = "sites@tucana.tuc.noao.edu valdes" +set newsgroup = "$1" + +# Get exclusive access to the helpfile. + +if (-e $lokfile) then + find $helpfile -newer $lokfile -exec rm -f $lokfile \; + while (-e $lokfile) + echo "waiting for access to system helpfile" + sleep 15 + end +endif + +date > $lokfile +onintr cleanup + +# If we were called as "helplog -e", simply edit the locked helpfile. + +if ("$1" == "-e") then + vi + $helpfile + goto cleanup +endif + +# Increment the help record number. + +set number = "`grep '^NUMBER:' $helpfile | tail -1 | sed -e 's/^NUMBER:.//'`" +if ("$number" == "") then + set number = 1 +else + set number = "`expr $number + 1`" +endif + +# Format new help entry in a temporary file and edit it. + +set tmpfile = $tmpfile$number +if (-e $tmpfile) then + echo "file $tmpfile already exists" + rm -i $tmpfile + if (-e $tmpfile) then + goto edithelp + endif +endif + +echo "NUMBER: $number" >> $tmpfile +echo "KEYWORDS: $keywords" >> $tmpfile +echo "DATE: $date" >> $tmpfile +echo "FROM: $from" >> $tmpfile +echo "" >> $tmpfile +echo "Q: ..." >> $tmpfile +echo "" >> $tmpfile +echo "A: ..." >> $tmpfile + +edithelp: +cp $tmpfile $tmpfile.ORIG +vi $tmpfile + +# Add new help entry to helpfile (exiting the editor without modifying the file +# causes the help to be discarded). + +cmp -s $tmpfile $tmpfile.ORIG +if ($status) then + while ($newsgroup != "system" && $newsgroup != "applications" && $newsgroup != "none") + echo -n "Newsgroup (none|system|applications): " + set newsgroup = "$<" + end + set keywords = "`grep '^KEYWORDS:' $tmpfile | tail -1 | sed -e 's/^KEYWORDS:.//'`" + echo "" >> $helpfile; cat $tmpfile >> $helpfile + echo "" >> $arcfile; cat $tmpfile >> $arcfile + mail -s "helplog.$number"": $keywords" $irafmail < $tmpfile + if ($newsgroup != "none") then + mail -s "helplog.$number"": $keywords"\ + adass-iraf-{$newsgroup}@iraf.noao.edu < $tmpfile + endif + rm -f $tmpfile $tmpfile.ORIG +else + echo "system helpfile not modified" + rm -f $tmpfile $tmpfile.ORIG +endif + +# Cleanup (vector here on interrupt). + +cleanup: +if (-e $lokfile) then + rm -f $lokfile +endif diff --git a/unix/hlib/helplog.sh b/unix/hlib/helplog.sh new file mode 100755 index 00000000..7fea4288 --- /dev/null +++ b/unix/hlib/helplog.sh @@ -0,0 +1,138 @@ +#!/bin/bash +# +# HELPLOG -- Format, edit, and log a new help digest to the system help file. +# +# Usage: +# +# helplog [none|system|applications] log a new help digest +# helplog -e edit the helpfile (with locking) +# +# The system helpfile is locked for exclusive access while a help digest is +# being logged, or while the helpfile is being edited. Logging can be +# aborted either by typing , or by editing the editor with ":q!" +# (i.e., by exiting the editor without modifying the temporary file being +# edited). Help logs are formatted and edited in a small temporary file in +# /tmp and are added at the end of the helpfile only if the task is not +# aborted and the edit modifies the input help log template. To go back and +# edit a previously logged help digest use "helplog -e". +# +# Record Format: +# +# NUMBER: record number, decimal, sequential. +# KEYWORDS: search keywords (eg task/package, category) +# DATE: date help digest logged, unix format date string +# FROM: user login name +# Q: digest of question +# A: digest of answer +# +# New records are added to the tail of the bugfile. Left justify field labels, +# indent text to the first tab stop, one blank line between bug entries. +# +# ---------------------------------------------------------------------------- + +iraf="`/bin/echo ${iraf}/ | tr -s '/'`" + +helpfile="${iraf}local/help.log" +arcfile="/u1/ftp/iraf/v216/help.log" +tmpfile="/tmp/help." +lokfile="/tmp/help.lok" + +number=1 +keywords="" +from="`whoami`" +date="`date`" +#irafmail="iraf@iraf.noao.edu valdes" +irafmail="sites@tucana.tuc.noao.edu valdes" +newsgroup="$1" + +# Cleanup (vector here on interrupt). + +cleanup() { + if [ -e $lokfile ]; then + rm -f $lokfile + fi + exit 0 +} + +# Get exclusive access to the helpfile. + +if [ -e $lokfile ]; then + find $helpfile -newer $lokfile -exec rm -f $lokfile \; + while [ -e $lokfile ]; do + /bin/echo "waiting for access to system helpfile" + sleep 15 + done +fi + +date > $lokfile +trap cleanup 2 + +# If we were called as "helplog -e", simply edit the locked helpfile. + +if [ "$1" = "-e" ]; then + vi + $helpfile + cleanup +fi + +# Increment the help record number. + +number="`grep '^NUMBER:' $helpfile | tail -1 | sed -e 's/^NUMBER:.//'`" +if [ "$number" = "" ]; then + number=1 +else + number="`expr $number + 1`" +fi + +# Format new help entry in a temporary file and edit it. + +SKP=0 +tmpfile=$tmpfile$number +if [ -e $tmpfile ]; then + /bin/echo "file $tmpfile already exists" + rm -i $tmpfile + if [ -e $tmpfile ]; then + SKP=1 + fi +fi + +if [ $SKP = 0 ]; then + /bin/echo "NUMBER: $number" >> $tmpfile + /bin/echo "KEYWORDS: $keywords" >> $tmpfile + /bin/echo "DATE: $date" >> $tmpfile + /bin/echo "FROM: $from" >> $tmpfile + /bin/echo "" >> $tmpfile + /bin/echo "Q: ..." >> $tmpfile + /bin/echo "" >> $tmpfile + /bin/echo "A: ..." >> $tmpfile +fi + +cp $tmpfile $tmpfile.ORIG +vi $tmpfile + +# Add new help entry to helpfile (exiting the editor without modifying the file +# causes the help to be discarded). + +cmp -s $tmpfile $tmpfile.ORIG +if [ $? = 0 ]; then + /bin/echo "system helpfile not modified" + rm -f $tmpfile $tmpfile.ORIG +else + while [ $newsgroup != "system" -a $newsgroup != "applications" -a $newsgroup != "none" ]; do + /bin/echo -n "Newsgroup (none|system|applications): " + read newsgroup + done + keywords="`grep '^KEYWORDS:' $tmpfile | tail -1 | sed -e 's/^KEYWORDS:.//'`" + /bin/echo "" >> $helpfile; cat $tmpfile >> $helpfile + if [ -e $arcfile ]; then + /bin/echo "" >> $arcfile; cat $tmpfile >> $arcfile + fi + mail -s "helplog.$number"": $keywords" $irafmail < $tmpfile + if [ $newsgroup != "none" ]; then + mail -s "helplog.$number"": $keywords"\ + adass-iraf-{$newsgroup}@iraf.noao.edu < $tmpfile + fi + rm -f $tmpfile $tmpfile.ORIG +fi + +cleanup + diff --git a/unix/hlib/i1mach.f b/unix/hlib/i1mach.f new file mode 100644 index 00000000..733a6bb9 --- /dev/null +++ b/unix/hlib/i1mach.f @@ -0,0 +1,661 @@ + INTEGER FUNCTION I1MACH(I) +C +C I/O UNIT NUMBERS. +C +C I1MACH( 1) = THE STANDARD INPUT UNIT. +C +C I1MACH( 2) = THE STANDARD OUTPUT UNIT. +C +C I1MACH( 3) = THE STANDARD PUNCH UNIT. +C +C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. +C +C WORDS. +C +C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. +C +C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. +C FOR FORTRAN 77, THIS IS ALWAYS 1. FOR FORTRAN 66, +C CHARACTER STORAGE UNIT = INTEGER STORAGE UNIT. +C +C INTEGERS. +C +C ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM +C +C SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1. +C +C I1MACH( 7) = A, THE BASE. +C +C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. +C +C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. +C +C FLOATING-POINT NUMBERS. +C +C ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT, +C BASE-B FORM +C +C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, +C 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX. +C +C I1MACH(10) = B, THE BASE. +C +C SINGLE-PRECISION +C +C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. +C +C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. +C +C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. +C +C DOUBLE-PRECISION +C +C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. +C +C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. +C +C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. +C +C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, +C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY +C REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF +C I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY +C WITH THE LOCAL OPERATING SYSTEM. FOR FORTRAN 77, YOU MAY WISH +C TO ADJUST THE DATA STATEMENT SO IMACH(6) IS SET TO 1, AND +C THEN TO COMMENT OUT THE EXECUTABLE TEST ON I .EQ. 6 BELOW. +C +C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), THE FIRST +C SET OF CONSTANTS BELOW SHOULD BE APPROPRIATE, EXCEPT PERHAPS +C FOR IMACH(1) - IMACH(4). +C +C COMMENTS JUST BEFORE THE END STATEMENT (LINES STARTING WITH *) +C GIVE C SOURCE FOR I1MACH. +C + INTEGER IMACH(16), OUTPUT, SMALL(2), I +C/6S +C/7S + SAVE IMACH +C/ + REAL RMACH +C + EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1)) +C +C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T +C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T +C PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). +C + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 7 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -125 / + DATA IMACH(13) / 128 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1021 / + DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR AMDAHL MACHINES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / O"00007777777777777777" / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR CONVEX C-1. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) /-1024 / +C DATA IMACH(16) / 1023 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) /32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 43 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE INTERDATA 8/32 +C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. +C +C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE +C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 62 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 62 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS +C WTIH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, +C SUPPLIED BY IGOR BRAY. +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / :17777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / +127 / +C DATA IMACH(14) / 47 / +C DATA IMACH(15) / -32895 / +C DATA IMACH(16) / +32637 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. +C +C DATA IMACH( 1) / 0 / +C DATA IMACH( 2) / 0 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 1 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 +C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. +C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) /-1024 / +C DATA IMACH(16) / 1023 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR VAX. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C *** ISSUE STOP 775 IF ALL DATA STATEMENTS ARE COMMENTED... +C IF (SANITY .NE. 987) THEN +C* *** CHECK FOR AUTODOUBLE *** +C SMALL(2) = 0 +C RMACH = 1E13 +C IF (SMALL(2) .NE. 0) THEN +C* *** AUTODOUBLED *** +C IF ( (SMALL(1) .EQ. 1117925532 +C * .AND. SMALL(2) .EQ. -448790528) +C * .OR. (SMALL(2) .EQ. 1117925532 +C * .AND. SMALL(1) .EQ. -448790528)) THEN +C* *** IEEE *** +C IMACH(10) = 2 +C IMACH(14) = 53 +C IMACH(15) = -1021 +C IMACH(16) = 1024 +C ELSE IF ( SMALL(1) .EQ. -2065213935 +C * .AND. SMALL(2) .EQ. 10752) THEN +C* *** VAX WITH D_FLOATING *** +C IMACH(10) = 2 +C IMACH(14) = 56 +C IMACH(15) = -127 +C IMACH(16) = 127 +C ELSE IF ( SMALL(1) .EQ. 1267827943 +C * .AND. SMALL(2) .EQ. 704643072) THEN +C* *** IBM MAINFRAME *** +C IMACH(10) = 16 +C IMACH(14) = 14 +C IMACH(15) = -64 +C IMACH(16) = 63 +C ELSE +C WRITE(*,*)'Adjust autodoubled I1MACH by uncommenting' +C WRITE(*,*)'data statements appropriate for your machine' +C WRITE(*,*)'and setting IMACH(I) = IMACH(I+3) for' +C WRITE(*,*)'I = 11, 12, and 13.' +C STOP 777 +C END IF +C IMACH(11) = IMACH(14) +C IMACH(12) = IMACH(15) +C IMACH(13) = IMACH(16) +C ELSE +C RMACH = 1234567. +C IF (SMALL(1) .EQ. 1234613304) THEN +C* *** IEEE *** +C IMACH(10) = 2 +C IMACH(11) = 24 +C IMACH(12) = -125 +C IMACH(13) = 128 +C IMACH(14) = 53 +C IMACH(15) = -1021 +C IMACH(16) = 1024 +C SANITY = 987 +C ELSE IF (SMALL(1) .EQ. -1271379306) THEN +C* *** VAX *** +C IMACH(10) = 2 +C IMACH(11) = 24 +C IMACH(12) = -127 +C IMACH(13) = 127 +C IMACH(14) = 56 +C IMACH(15) = -127 +C IMACH(16) = 127 +C SANITY = 987 +C ELSE IF (SMALL(1) .EQ. 1175639687) THEN +C* *** IBM *** +C IMACH(10) = 16 +C IMACH(11) = 6 +C IMACH(12) = -64 +C IMACH(13) = 63 +C IMACH(14) = 14 +C IMACH(15) = -64 +C IMACH(16) = 63 +C SANITY = 987 +C ELSE +C WRITE(*,*)'Adjust I1MACH by uncommenting' +C WRITE(*,*)'data statements appropriate for your machine.' +C STOP 777 +C END IF +C END IF +C IMACH( 1) = 5 +C IMACH( 2) = 6 +C IMACH( 3) = 7 +C IMACH( 4) = 6 +C IMACH( 5) = 32 +C IMACH( 6) = 4 +C IMACH( 7) = 2 +C IMACH( 8) = 31 +C IMACH( 9) = 2147483647 +C SANITY = 987 +C END IF +C IF (I .LT. 1 .OR. I .GT. 16) GO TO 30 + IF (I .LT. 1 .OR. I .GT. 16) THEN + I1MACH = -1 + RETURN + END IF +C + I1MACH = IMACH(I) +C/6S +C/7S + IF (I .EQ. 6) I1MACH = 1 +C/ + RETURN +C +C 30 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.' +C +C* CALL FDUMP +C +C STOP +C +C* /* C source for I1MACH -- remove the * in column 1 */ +C* /* Note that some values may need changing -- see the comments below. */ +C*#include +C*#include +C*#include +C*#include +C* +C*long i1mach_(long *i) +C*{ +C* switch(*i){ +C* case 1: return 5; /* standard input unit -- may need changing */ +C* case 2: return 6; /* standard output unit -- may need changing */ +C* case 3: return 7; /* standard punch unit -- may need changing */ +C* case 4: return 0; /* standard error unit -- may need changing */ +C* case 5: return 32; /* bits per integer -- may need changing */ +C* case 6: return 1; /* Fortran 77 value: 1 character */ +C* /* per character storage unit */ +C* case 7: return 2; /* base for integers -- may need changing */ +C* case 8: return 31; /* digits of integer base -- may need changing */ +C* case 9: return LONG_MAX; +C* case 10: return FLT_RADIX; +C* case 11: return FLT_MANT_DIG; +C* case 12: return FLT_MIN_EXP; +C* case 13: return FLT_MAX_EXP; +C* case 14: return DBL_MANT_DIG; +C* case 15: return DBL_MIN_EXP; +C* case 16: return DBL_MAX_EXP; +C* } +C* +C* fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); +C* exit(1); +C* return 0; /* for compilers that complain of missing return values */ +C* } + END diff --git a/unix/hlib/install.csh b/unix/hlib/install.csh new file mode 100755 index 00000000..1aa08984 --- /dev/null +++ b/unix/hlib/install.csh @@ -0,0 +1,3484 @@ +#!/bin/csh +# +# INSTALL -- Install IRAF on a UNIX/IRAF host. May also be run after the +# initial installation as a consistency check to verify that all the necessary +# links and file permissions are still in place (e.g., after updating UNIX +# itself). +# +# Installation: +# This file should be installed in the $iraf directory, if it is being +# installed as a patch to a distributed IRAF system the existing iraf$install +# script should be backed up and then this file used to replace it. Once +# in place the script may be made executable with the command +# +# % chmod 755 install +# +# Please consult the IRAF web pages for the latest information on bug fixes +# to this script. +# +# +# Usage: install [-n] [-r rootdir] [-i imdir] [-b localbindir] \ +# [-R oldroot] [-I oldimdir] [-u username (e.g., 'iraf')] +# [-l locallibdir] [-m mach (e.g., 'sparc', 'ssun') ] +# [-noedit] +# +# Example: +# % su +# % cd $hlib +# % ./install -n +# % ./install +# +# If run with no arguments, INSTALL will make an informed guess and prompt +# with this value; type to accept the value, or enter a new value. +# +# Use "install -n" to do a dry run to see what the would be done, without +# actually modifying the host system and IRAF configuration files. To do the +# actual installation one must be superuser, but anyone can run "install -n" +# to see what it would do. +# +# ---------------------------------------------------------------------------- + + +unset noclobber +onintr cleanup_ +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort which + +setenv path "(/sbin /usr/sbin /bin /usr/bin /usr/5bin /usr/ucb /etc /usr/etc $path /usr/local/bin /opt/local/bin /local/bin /home/local/bin /usr/openwin/bin /usr/X11R6/bin /usr/X11/bin)" + +# set echo + + + +############################################################################## +# START OF MACHDEP DEFINITIONS. +############################################################################## + +# MACHDEP definitions which may be reset below. +set LS = "/bin/ls" # [MACHDEP] +set LSDF = "-lLtgs" # [MACHDEP] + +set VERSION = "V2.16" +set V = `echo $VERSION | cut -c2-5` +set hmach = "INDEF" +set shlib = "no" +set pciraf = 0 +set suniraf = 0 +set do_tapecaps = 0 +set do_tapes = 1 +set do_pipes = 0 +set has_pipes = 1 +set hilite = 1 +set no_edit = 0 + + +# Utility aliases. +#alias PUT "mv -f \!*; chown $user \!$ " # [MACHDEP] +alias PUT "cp -p \!*; chown $user \!$ " # [MACHDEP] +alias BOLD_ON "(if ($hilite) tput bold)" +alias BOLD_OFF "(if ($hilite) tput sgr0)" +alias SO_ON "(if ($hilite) tput smso)" +alias SO_OFF "(if ($hilite) tput sgr0)" + +alias DO_OK "(echo -n '[ '; BOLD_ON; echo -n ' OK '; BOLD_OFF; echo ' ]')" +alias DO_WARN "(echo -n '[ '; BOLD_ON; echo -n 'WARN'; BOLD_OFF; echo ' ]')" +alias DO_FAIL "(echo -n '[ '; SO_ON; echo -n 'FAIL'; SO_OFF; echo ' ]')" + +alias MSG "(echo -n ' ';BOLD_ON;echo -n '*** ';BOLD_OFF; echo \!*)" +alias MSGB "(echo -n ' ';BOLD_ON;echo -n '*** ';echo \!*; BOLD_OFF)" +alias MSGN "(echo -n ' ';BOLD_ON;echo -n '*** ';BOLD_OFF; echo -n \!*)" +alias MSGBN "(echo -n ' ';BOLD_ON;echo -n '*** ';echo -n \!*; BOLD_OFF)" +alias ERRMSG "(echo -n ' ';BOLD_ON;echo -n 'ERROR: ' ;BOLD_OFF; echo \!*)" +alias WARNING "(echo -n ' ';BOLD_ON;echo -n 'WARNING: ';BOLD_OFF; echo \!*)" +alias NEWLINE "(echo '')" + +alias PROMPT "(BOLD_ON; echo -n \!*; BOLD_OFF; echo -n ' (yes): ')" +alias PROMPT_N "(BOLD_ON; echo -n \!*; BOLD_OFF; echo -n ' (no): ')" + +alias RM "rm -rf" +alias LN "ln -s" + + +#---------------------------------- +# Determine platform architecture. +#---------------------------------- + +set UNAME="" +if (-e /usr/bin/uname) then + set uname_cmd = /usr/bin/uname + set UNAME=`/usr/bin/uname | tr '[A-Z]' '[a-z]'` +else if (-e /bin/uname) then + set uname_cmd = /bin/uname + set UNAME=`/bin/uname | tr '[A-Z]' '[a-z]'` +else + WARNING "No 'uname' command found to determine architecture." + exit 1 +endif + +set WHOAMI=`whoami` +if (-e /usr/bin/whoami) then + set WHOAMI=`/usr/bin/whoami` +else if (-e /usr/ucb/whoami) then + set WHOAMI=`/usr/ucb/whoami` +else + WARNING "No 'whoami' command found for this architecture." + exit 1 +endif + + + + +switch ($UNAME) + case sunos: + set do_tapecaps = 1 + if (`$uname_cmd -m | cut -c2-` != "86pc") then + set suniraf = 1 + setenv OSVERSION `$uname_cmd -r | cut -c1` + if ($OSVERSION == 5) then # Sparc Solaris + set mach = "ssun" + set hmach = "ssol" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/usr/ucb/ls" + else # Sparc SunOS 4.x + set mach = "sparc" + set hmach = "sparc" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + endif + else + set pciraf = 1 + set mach = "sunos" # Intel Solaris + set hmach = "sunos" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LSDF = "-lLts" + endif + breaksw + case linux: + set pciraf = 1 + set do_tapecaps = 1 + if ($?IRAFARCH == 1) then + # Let IRAFARCH override the default for the machine. + set mach = "$IRAFARCH" + set hmach = "$IRAFARCH" + else if (`$uname_cmd -m` == "x86_64") then # Linux x86_64 + set mach = "linux64" + set hmach = "linux64" + else if (`$uname_cmd -m` == "ppc") then # LinuxPPC + if (-f /etc/redhat-release) then + set mach = "linuxppc" + set hmach = "linuxppc" + endif + else + set mach = "linux" + set hmach = "linux" + endif + set TAPES = "/dev/*st[0-7]" + set shlib = "no" + set LIBFILES = "" + breaksw + case freebsd: # FreeBSD 4.0 + set do_tapecaps = 1 + setenv OSVERSION `$uname_cmd -r | cut -c1` + if ($OSVERSION == 5) then # Sparc Solaris + set has_pipes = 0 + endif + set mach = "freebsd" + set hmach = "freebsd" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set pciraf = 1 + breaksw + case darwin: # Mac OS X + case macosx: + case macintel: + case ipad: + # Mac OS X doesn't appear to have tape support + # at this point. + set do_tapecaps = 0 + set do_tapes = 0 + set has_pipes = 0 + if ($?IRAFARCH == 1) then + # Let IRAFARCH override the default for the machine. + set mach = "$IRAFARCH" + set hmach = "$IRAFARCH" + else if (`$uname_cmd -m` == "x86_64") then # 64-bit OSX + set mach = "macintel" + set hmach = "macintel" + else if (`$uname_cmd -m |cut -c1-4` == "iPad") then # iPad/iPod OSX + set mach = "ipad" + set hmach = "ipad" + else # 32-bit OSX + set mach = "macosx" + set hmach = "macosx" + endif + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set pciraf = 1 + breaksw + case hp-ux: # HP/UX 10.20 + set mach = "hp700" + set hmach = "hp700" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LSDF = "-lLts" + + # reset for HP/UX + alias PUT 'mv -f \!*; chown $user \!$ ' + breaksw + case irix: # IRIX 6.5 + case irix64: + set mach = "irix" + set hmach = "irix" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LSDF = "-lLts" + breaksw + case aix: # AIX V4 + set mach = "rs6000" + set hmach = "rs6000" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LSDF = "-lLts" + breaksw + case osf1: # Alpha OSF/1 + set mach = "alpha" + set hmach = "alpha" + set TAPES = "/dev/*st[0-7]*" + set shlib = "yes" + set LIBFILES = "libiraf.so" + breaksw + case ultrix: # DEC Ultrix + set mach = "ultrix" + set hmach = "ultrix" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + breaksw + + default: + # We don't want to be limited by the CYGWIN version numbering so + # look for a truncated match here before punting. + set os_mach = `echo $UNAME | cut -c1-6` + if ("$os_mach" == "cygwin") then + set mach = "cygwin" + set hmach = "cygwin" + set shlib = "no" + set LIBFILES = "" + set TAPES = "" # no tape support + set do_tapecaps = 0 + set do_tapes = 0 + set has_pipes = 0 + breaksw + + else + ERRMSG "Unable to determine platform architecture." + exit 1 + endif +endsw + +############################################################################## +# END OF MACHDEP DEFINITIONS. +############################################################################## + + +#============================================================================= +# Declarations and initializations. +#============================================================================= + +set W = '\([ "]\)' # match a blank, tab, or quote +set TEMP = "/tmp/iraf_install.$$" +set exec = yes +set user = iraf +set port = 0 + +set imdir = "" # Initialize paths +set lbin = "" +set llib = "" +set cache = "" +set o_iraf = "" +set o_imdir = "" +set o_cache = "" + + + +#============================================================================= +# Initialize the path variables. +#============================================================================= + +set valid_iraf = 1 +if ($?iraf == 1) then + if (! (-d $iraf) || ! (-r $iraf) || \ + ("`$LS -lLd $iraf |& grep '.rw[xs]r.[xs]r.[xt]'`" == "") || \ + ("`$LS -lLd $iraf/.. |& grep '.rw[xs]r.[xs]r.[xt]'`" == "")) then + set valid_iraf = 0 + endif + if ($valid_iraf == 0) then + NEWLINE + BOLD_ON + echo -n ' ERROR: invalid $iraf value ' + echo "($iraf)" + BOLD_OFF + NEWLINE + MSG ' The iraf directory tree set by your environment variable, $iraf' + MSG " is not generally readable. This will prevent most users from" + MSG " being able to read iraf files, especially the binaries! " + NEWLINE + MSG " Please reset the permissions on the tree and try again..." + NEWLINE + exit 1 + endif + if (! -d $iraf) then + NEWLINE + WARNING "Env definition of iraf root is incorrect, resetting." + NEWLINE + setenv iraf "" + endif + +else + setenv iraf "" +endif + + +#============================================================================= +# Process any command line arguments. +#============================================================================= +while ("$1" != "") + switch ("$1") + case -n: # no execute + alias PUT "diff \!$ \!^; rm -f $TEMP" + set exec = no + breaksw + case -noedit: # no-edit installations + set no_edit = 1 + breaksw + case -port: # do a "port" install + set port = 1 + breaksw + case -hl: # disable highlighting + set hilite = 0 + alias BOLD_ON "(if ($hilite) tput bold)" + alias BOLD_OFF "(if ($hilite) tput sgr0)" + alias SO_ON "(if ($hilite) tput smso)" + alias SO_OFF "(if ($hilite) tput rmso)" + breaksw + case +hl: # enable highlighting + set hilite = 1 + alias BOLD_ON "(if ($hilite) tput bold)" + alias BOLD_OFF "(if ($hilite) tput sgr0)" + alias SO_ON "(if ($hilite) tput smso)" + alias SO_OFF "(if ($hilite) tput rmso)" + breaksw + case -f: # create fifo pipes + set do_pipes = 1 + breaksw + case -h: # print help summary + goto Usage + case -help: # print help summary + goto Usage + case --help: # print help summary + goto Usage + case -b: # set local bin directory + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-b ' switch" + exit 1 + endif + set lbin = "$1" + breaksw + case -l: # set local lib directory + if ("$shlib" == "yes") then + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-l ' switch" + exit 1 + endif + set llib = "$1" + else + set llib = "" + shift + endif + breaksw + case -c: # set cache directory + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-c ' switch" + exit 1 + endif + set cache = "$1" + breaksw + case -i: # set imdir directory + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-i ' switch" + exit 1 + endif + set imdir = "$1" + breaksw + case -m: # set machine type + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-m ' switch" + exit 1 + endif + set mach = "$1" + if ("$1" == "ssun") then + set hmach = "ssol" + else + set hmach = "$1" + endif + setenv IRAFARCH $mach + breaksw + case -r: # set root directory + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-r ' switch" + exit 1 + endif + setenv iraf "$1" + breaksw + case -C: # set old cache directory + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-C ' switch" + exit 1 + endif + set o_cache = "$1" + breaksw + case -I: # set old imdir directory + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-I ' switch" + exit 1 + endif + set o_imdir = "$1" + breaksw + case -R: # set old root directory + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-R ' switch" + exit 1 + endif + set o_iraf = "$1" + breaksw + case -u: # set user name for iraf, e.g, 'iraf' + if ("$2" != "") then + shift + else + ERRMSG "missing argument to '-u ' switch" + exit 1 + endif + set user = "$1" + breaksw + default: + ERRMSG "install: unknown argument $1" + goto Usage + breaksw + endsw + + if ("$2" == "") then + break + else + shift + endif +end + + + +#============================================================================= +# See whether we're gonna work ... +#============================================================================= +if ($exec == yes && $WHOAMI != "root" && $mach != "cygwin") then + clear + NEWLINE + BOLD_ON + echo " IRAF "$VERSION" System Installation" + echo " ================================" + BOLD_OFF + NEWLINE ; NEWLINE + BOLD_ON + echo "======================================================================" + echo -n "WARNING" + BOLD_OFF + echo ": This script must be run as root for changes to take effect." + echo " If you decide to proceed, the 'no-op' flag will be enabled" + echo " by default. No changes will be made to the system files," + echo " however you will be able to see what the script does." + BOLD_ON + echo "======================================================================" + BOLD_OFF + NEWLINE +no_op_proc_: + PROMPT "Proceed with a no-op installation anyway? " + setenv ans "$<" + if ("$ans" == "n" || "$ans" == "N" || "$ans" == "no") then + exit 0 + endif + if ("$ans" != "" && "$ans" != "y" && "$ans" != "Y" && "$ans" != "yes") then + echo "Huh?" + goto no_op_proc_ + endif + alias PUT "diff \!$ \!^; rm -f $TEMP" + set exec = no +endif + + +#============================================================================= +# Initialize the screen output. +#============================================================================= +clear +NEWLINE +BOLD_ON +echo " IRAF "$VERSION" System Installation" +echo " ================================" +BOLD_OFF +NEWLINE + +echo " Welcome to the IRAF installation script. This script will first" +echo " prompt you for several needed path names. The system will be verified" +echo " for proper structure before the actual install begins, all error must" +echo " must be corrected before you will be allowed to continue. Recommend-" +echo " ations for fixing problems will be made but no corrective action will" +echo " be taken directly. Once properly installed, you will be allowed to" +echo " do some minimal configuration." + +# Print a quick usage summary. +NEWLINE +echo -n " For each prompt: hit " +BOLD_ON ; echo -n ""; BOLD_OFF; +echo -n " to accept the default value, " +BOLD_ON ; echo -n "'q'" ; BOLD_OFF +echo ' to quit,' + +echo -n " or " +BOLD_ON ; echo -n "'help'"; BOLD_OFF +echo -n " or "; +BOLD_ON ; echo -n "'?'"; BOLD_OFF +echo -n " to print an explanation of the prompt." +NEWLINE +NEWLINE + + +#============================================================================= +# Prompt the user for needed paths. +#============================================================================= + +NEWLINE +BOLD_ON +echo "========================================================================" +echo "===================== Query for System Settings ======================" +echo "========================================================================" +BOLD_OFF +NEWLINE + + +#============================================================================= +# Set $iraf, the new root directory for iraf. The system must already have +# been read in at this directory (e.g., /iraf/iraf), but we assume that no +# files have yet been modified. +#============================================================================= + +if ("$iraf" == "") then + + if (-e "IRAF.NET" && -e "IS.PORT.GEN") then + # Use the current directory. + set d_iraf = `pwd` + + else + # Make a guess at what the new root directory is. + set d_iraf = "" + if (-d /iraf/iraf) then + set d_iraf = /iraf/iraf + else if (-d /iraf) then + set d_iraf = /iraf + else if (-d /usr/local/iraf) then + set d_iraf = /usr/local/iraf + else if (-d /usr/iraf) then + set d_iraf = /usr/iraf + else + # Search for an iraf directory. + set IDIRS = "/u* /local /home /opt /iraf* /" + foreach i ($IDIRS) + if (-d $i/iraf) then + set d_iraf = "$i/iraf" + break + endif + end + endif + + if ("$d_iraf" == "") then + set d_iraf = /iraf/iraf + endif + endif +else + set d_iraf = $iraf +endif + +# If the given directory doesn't exist, compute the root directory relative +# to $iraf/unix/hlib (our current directory, presumably). + +if (! -d $d_iraf) then + set d_iraf = `(cd ../..;pwd)` +endif + +iraf_prompt: + set d_iraf = `echo $d_iraf | sed -e 's+/\(["]*\)$+\1+'` + + BOLD_ON ; echo -n "New iraf root directory " ; BOLD_OFF + echo -n "($d_iraf): " + setenv iraf "$<" + if ("$iraf" == "") then + setenv iraf "$d_iraf" + else if ("$iraf" == "quit" || "$iraf" == "q") then + exit 0 + else if ("$iraf" == "help" || "$iraf" == "h" || "$iraf" == "?") then + NEWLINE + MSG "The iraf root directory is the place where the AS distribution" + MSG "file was unpacked; it contains subdirectories such as 'dev'," + MSG "'local', 'noao', 'pkg', and the file IS.PORT.GEN." + + set di = $d_iraf + if (((-d $di/dev) && (-d $di/pkg) && (-d $di/noao))) then + MSG "" + MSG "The default path '$d_iraf' appears to be correct ..." + else + MSG "" + MSG "The default path '$d_iraf' appears to be incorrect ..." + endif + NEWLINE + + setenv iraf $d_iraf + goto iraf_prompt + endif + + +# See whether this looks like a reasonable $iraf directory +if (! (-e $iraf)) then + NEWLINE + MSG "The '$iraf' directory doesn't exist." + MSG "Please try again..." + NEWLINE + goto iraf_prompt + +else if (! (-r $iraf) || \ + ("`$LS -lLd $iraf |& grep '.rw[xs]r.[xs]r.[xt]'`" == "") || \ + ("`$LS -lLd $iraf/.. |& grep '.rw[xs]r.[xs]r.[xt]'`" == "")) then + NEWLINE + MSG "The iraf directory tree is not generally readable." + MSG "This will prevent most users from being able to read iraf" + MSG "files, especially the binaries\\! " + MSG "Please reset the permissions and try again..." + NEWLINE + exit 1 + +else if (! ((-d $iraf/dev) && (-d $iraf/pkg) && (-d $iraf/noao))) then + NEWLINE + MSG "The definition of '$iraf' looks incorrect." + MSG "" + MSG "The iraf root directory is the place where the AS distribution" + MSG "file was unpacked; it contains subdirectories such as 'dev'," + MSG "'local', 'noao', 'pkg', and the file IS.PORT.GEN." + MSG "" + if (((-d $iraf/iraf/dev) && (-d $iraf/iraf/pkg) && (-d $iraf/iraf/noao))) then + MSG "The path '$iraf/iraf' appears to be correct ..." + set iraf = $iraf/iraf + else if (((-d $iraf/../dev) && (-d $iraf/../pkg) && (-d $iraf/../noao))) then + if (-d $iraf/..) then + pushd $iraf/.. >& /dev/null + setenv ip `echo $cwd` + MSG "The path '$ip' appears to be correct ..." + set iraf = $ip + popd >& /dev/null + endif + endif + MSG "" + MSG "Please verify your path and try again ..." + NEWLINE + goto iraf_prompt +endif + + +#============================================================================= +# Get the values of o_iraf and o_imdir from the current mkiraf.csh file, if +# not already otherwise defined. +#============================================================================= + +cd $iraf/unix/hlib +set WS = '[ ]' +if ("$o_iraf" == "") then + set o_iraf =\ + `grep "^set$WS*iraf" mkiraf.csh | sed -e "s+^.*=$WS*++" | sed -e 's+"++g'` +endif +if ("$o_imdir" == "") then + set o_imdir =\ + `grep "^set$WS*imdir" mkiraf.csh | sed -e "s+^.*=$WS*++" | sed -e 's+"++g'` +endif +if ("$o_cache" == "") then + set o_cache =\ + `grep "^set$WS*cachedir" mkiraf.csh | sed -e "s+^.*=$WS*++" | sed -e 's+"++g'` +endif + +# Strip any trailing / in the pathname to be matched, so that the trailing /, +# if present, will be LEFT in the occurrence of the path in the file. + +set o_iraf = `echo $o_iraf | sed -e 's+/\(["]*\)$+\1+'` +set o_imdir = `echo $o_imdir | sed -e 's+/\(["]*\)$+\1+'` +set o_cache = `echo $o_cache | sed -e 's+/\(["]*\)$+\1+'` + + +#============================================================================= +# Get the iraf parent directory to be used below. +#============================================================================= +pushd $iraf/.. >& /dev/null ; set iraf_p = `echo $cwd` ; popd >& /dev/null + + +#============================================================================= +# Set $imdir, the default user image storage root directory. Each user imdir +# will be a subdirectory of this directory by default, when MKIRAF is run. +# Since bulk image data can consume hundreds of megabytes of disk space, IRAF +# likes to keep such data on a public scratch device, which is probably not +# backed up, which has a short file expiration interval, and possibly which +# has been configured (newfs/mkfs) with a large block size for fast seq. i/o. +#============================================================================= + +if ("$imdir" == "") then + + if (-d $o_imdir) then + set d_imdir = $o_imdir + else if (-d /iraf) then + set d_imdir = /iraf/imdirs + else if (-d /home/iraf) then + set d_imdir = /home/iraf/imdirs + else if (-d $iraf_p) then + set d_imdir = $iraf_p/imdirs + else if (-d /usr/local/iraf) then + set d_imdir = /usr/local/iraf/imdirs + else + set d_imdir = /tmp + endif + +imdir_prompt: + BOLD_ON ; echo -n "Default root image storage directory " ; BOLD_OFF + echo -n "($d_imdir): " + set imdir = "$<" + if ("$imdir" == "") then + set imdir = "$d_imdir" + else if ("$imdir" == "quit" || "$imdir" == "q") then + exit 0 + else if ("$imdir" == "help" || "$imdir" == "h" || "$imdir" == "?") then + NEWLINE + MSG "The root imdir directory is the default image storage dir" + MSG 'for OIF images (i.e. the ".imh" format) used by all users on' + MSG "this system. Individual user dirs will be created as needed." + MSG "It should be some large data disk on the machine which has a" + MSG "regular backup, scratch or tmp disks should be avoided or data" + MSG "may be lost." + MSG "" + MSG 'The "HDR$" syntax should not be used at this stage, please' + MSG 'edit the hlib$mkiraf.csh script after installation if you wish' + MSG "to make this the default." + NEWLINE + setenv imdir $d_imdir + goto imdir_prompt + endif + + # Cannot have iraf and imdir the same. + if ("$imdir" == "$iraf") then + NEWLINE + MSG "The definition of imdir cannot be the same as the iraf" + MSG "root, please choose a different directory. Ideally this" + MSG "should be some large data area on your system or a user" + MSG "data area such as /home, /users, /u1, etc." + NEWLINE + NEWLINE + goto imdir_prompt + endif +endif + + +#============================================================================= +# Set $cache, the default user file cache root directory. +#============================================================================= + +if ("$cache" == "") then + + if (-d /iraf) then + set d_cache = /iraf/cache + else if (-d /home/iraf) then + set d_cache = /home/iraf/cache + else if (-d $iraf_p) then + set d_cache = $iraf_p/cache + else if (-d /usr/local/iraf) then + set d_cache = /usr/local/iraf/cache + else + set d_cache = /tmp + endif + +cache_prompt: + BOLD_ON ; echo -n "Default root cache directory " ; BOLD_OFF + echo -n "($d_cache): " + set cache = "$<" + if ("$cache" == "") then + set cache = "$d_cache" + else if ("$cache" == "quit" || "$cache" == "q") then + exit 0 + else if ("$cache" == "help" || "$cache" == "h" || "$cache" == "?") then + NEWLINE + MSG "The root cache directory is the default storage directory for" + MSG "URL-referenced files. Individual user dirs will be created as" + MSG "needed. It should be some large data disk on the machine " + MSG "which has a regular backup, scratch or tmp disks should be" + MSG "avoided or data may be lost." + MSG "" + NEWLINE + setenv cache $d_cache + goto cache_prompt + endif + + # Cannot have iraf and cache the same. + if ("$cache" == "$iraf") then + NEWLINE + MSG "The definition of cache cannot be the same as the iraf" + MSG "root, please choose a different directory. Ideally this" + MSG "should be some large data area on your system or a user" + MSG "data area such as /home, /users, /u1, etc." + NEWLINE + NEWLINE + goto cache_prompt + endif +endif + + +#============================================================================= +# Get UNIX directory where HSI commands (links) are to be installed, if not +# set on command line. IRAF will only install a very few new commands in this +# directory. Ideally it should be a directory on the standard user $path, +# so that users do not have to customize their . files just to run IRAF. +#============================================================================= + +if ("$lbin" == "") then + # Look around and come up with a likely candidate directory. + if (-d /usr/local/bin) then + set d_lbin = /usr/local/bin + else if (-d /opt/local/bin) then + set d_lbin = /opt/local/bin + else if (-d /local/bin) then + set d_lbin = /local/bin + else + set d_lbin = /usr/bin + endif + +lbin_prompt: + BOLD_ON ; echo -n "Local unix commands directory " ; BOLD_OFF + echo -n "($d_lbin): " + set lbin = "$<" + if ("$lbin" == "") then + set lbin = "$d_lbin" + else if ("$lbin" == "quit" || "$lbin" == "q") then + exit 0 + else if ("$lbin" == "help" || "$lbin" == "h" || "$lbin" == "?") then + NEWLINE + MSG "The local bin directory is the system directory into which the" + MSG "iraf commands (e.g. cl, mkiraf, mkpkg, etc) will be installed" + MSG "as symlinks to files in the iraf tree. This should be a common" + MSG "dir such as /usr/local/bin which will likely be found in every" + MSG "user's path." + NEWLINE + setenv lbin $d_lbin + goto lbin_prompt + endif + + # Create the local bin directory if it doesn't exist? + if (! (-e $lbin)) then + PROMPT " Sorry, but $lbin does not exist, create it? " + set ans = "$<" + if ("$ans" == "" || "$ans" == "y" || "$ans" == "yes") then + echo " Creating directory $lbin..." + if ($exec == yes) then + mkdir $lbin + endif + if (! (-e $lbin) && $exec == yes) then + ERRMSG "Cannot create $lbin, please retry..." + setenv lbin $d_lbin + goto lbin_prompt + endif + else + goto lbin_prompt + endif + NEWLINE + endif +endif + + + +#============================================================================= +# Get UNIX directory where IRAF shared library should be installed. +#============================================================================= + +if ("$shlib" == "yes") then + if ("$llib" == "") then + # Look around and come up with a likely candidate directory. + if (-d /usr/local/lib) then + set d_llib = /usr/local/lib + else if (-d /local/lib) then + set d_llib = /local/lib + else if (-d /usr/lib) then + set d_llib = /usr/lib + else if (-d /var/shlib) then + set d_llib = /var/shlib + else + set d_llib = /usr/shlib + endif + +llib_prompt: + BOLD_ON ; echo -n "Directory for local shared libraries " ; BOLD_OFF + echo -n "($d_llib): " + set llib = "$<" + if ("$llib" == "") then + set llib = "$d_llib" + else if ("$llib" == "quit" || "$llib" == "q") then + exit 0 + else if ("$llib" == "help" || "$llib" == "h" || "llib" == "?") then + NEWLINE + MSG "The local lib directory is the system directory into which" + MSG "the IRAF shared library will be installed as a symlink to" + MSG "the library in the iraf tree. The default prompt dir is" + MSG "one which will be used on this system w/out special user" + MSG "setup, choose another one with care." + NEWLINE + setenv llib $d_llib + goto llib_prompt + endif + + # Create the local lib directory if it doesn't exist? + if (! (-e $llib)) then + PROMPT " Sorry, but $llib does not exist, create it? " + set ans = "$<" + if ("$ans" == "" || "$ans" == "y" || "$ans" == "yes") then + echo " Creating directory $llib..." + if ($exec == yes) then + mkdir $llib + endif + if (! (-e $llib) && $exec == yes) then + ERRMSG "Cannot create $lbin, please retry..." + setenv llib $d_llib + goto llib_prompt + endif + else + goto llib_prompt + endif + NEWLINE + endif + endif +endif + + + +############################################################################## +# +# Step 1: VERIFICATION +# +# Run some simple checks to be sure the system was unpacked correctly +# and the settings used are correct. Verification tests include: +# +# o Verify the machine type and document settings. +# o Check iraf root directory looks correct. +# o Check iraf root and imdir aren't the same +# o Check iraf user exists in passwd file/NIS. +# o Check iraf user login path in passwd file is iraf$local. +# o Check iraf tree for proper structure. +# o Check binary dirs are both populated correctly. +# o Check that the local bin directory exists. +# o Check that the local lib directory exists. +# +# An error at this stage will cause the script to exit so we can reset +# and try again. +# +############################################################################## + +set err_stat = 0 # initialize error stats +set err_count = 0 +set warn_stat = 0 # initialize warning stats +set warn_count = 0 + +NEWLINE +BOLD_ON +echo "========================================================================" +echo "===================== Verifying System Settings ======================" +echo "========================================================================" +BOLD_OFF + + +# Verify the machine type and document the old root pathnames. +NEWLINE +BOLD_ON; echo -n "Hostname = "; \ + BOLD_OFF; echo `hostname` | awk '{printf("%-20.20s ", $1)}' +BOLD_ON; echo -n "OS version = "; \ + BOLD_OFF; echo `$uname_cmd`" "`$uname_cmd -r` +BOLD_ON; echo -n "Architecture = "; \ + BOLD_OFF; echo $mach | awk '{printf("%-20s ", $1)}' +BOLD_ON; echo -n "HSI arch = "; \ + BOLD_OFF; echo $hmach | awk '{printf("%-20s\n", $1)}' +BOLD_ON; echo -n "New iraf root = "; \ + BOLD_OFF; echo $iraf | awk '{printf("%-20s ", $1)}' +BOLD_ON; echo -n "Old iraf root = "; \ + BOLD_OFF; echo $o_iraf | awk '{printf("%-20s\n", $1)}' +BOLD_ON; echo -n "New imdir = "; \ + BOLD_OFF; echo $imdir | awk '{printf("%-20s ", $1)}' +BOLD_ON; echo -n "Old imdir = "; \ + BOLD_OFF; echo $o_imdir | awk '{printf("%-20s\n", $1)}' +BOLD_ON; echo -n "New cache = "; \ + BOLD_OFF; echo $cache | awk '{printf("%-20s ", $1)}' +BOLD_ON; echo -n "Old cache = "; \ + BOLD_OFF; echo $o_cache | awk '{printf("%-20s\n", $1)}' +BOLD_ON; echo -n "Local bin dir = "; \ + BOLD_OFF; echo $lbin | awk '{printf("%-20s\n", $1)}' +if ("$shlib" == "yes") then + BOLD_ON; echo -n "Local lib dir = "; \ + BOLD_OFF; echo $llib | awk '{printf("%-20s\n", $1)}' +endif +NEWLINE ; NEWLINE + + +# Check iraf root directory looks correct. +echo -n "Checking definition of iraf root directory ... " +if (! ((-d $iraf/dev) && (-d $iraf/pkg) && (-d $iraf/noao))) then + DO_FAIL ; set err_stat = 1 ; set iraf_root_ok = 0 + NEWLINE + MSG "The definition of '$iraf' looks incorrect. The iraf root" + MSG "directory is the place where the AS distribution was unpacked," + MSG "it contains subdirectories such as 'dev', 'local', 'noao', and" + MSG "'pkg' and the binary directory links." + MSG "" + if (((-d $iraf/iraf/dev) && (-d $iraf/iraf/pkg) && (-d $iraf/iraf/noao))) then + MSG "The path '$iraf/iraf' appears to be correct ..." + set iraf = $iraf/iraf + else if (((-d $iraf/../dev) && (-d $iraf/../pkg) && (-d $iraf/../noao))) then + if (-d $iraf/..) then + pushd $iraf/.. >& /dev/null + setenv ip `echo $cwd` + MSG "The path '$ip' appears to be correct ..." + set iraf = $ip + popd >& /dev/null + endif + endif + MSG "Please verify your path and try again ..." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK ; set iraf_root_ok = 1 +endif + + +# Cannot have iraf and imdir the same. +echo -n "Checking iraf root and imdir directory ... " +if ($iraf == $imdir) then + DO_FAIL ; set err_stat = 1 + NEWLINE + MSG "The 'imdir' pixel storage directory cannot be the same as the" + MSG "iraf root directory. Please choose another directory." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK +endif + +# Cannot have iraf and cache the same. +echo -n "Checking iraf root and cache directory ... " +if ($iraf == $cache) then + DO_FAIL ; set err_stat = 1 + NEWLINE + MSG "The 'cache' storage directory cannot be the same as the" + MSG "iraf root directory. Please choose another directory." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK +endif + + + +if ($no_edit == 0) then + +# Check for write permission on iraf directory... +echo -n "Checking iraf directory write permissions ... " + + set TEST = "_inst.check" + if ($exec == "yes") then + set back = $cwd/ + chdir $iraf_p/iraf + touch $TEST >& /dev/null + if (-e $TEST) then + rm $TEST + DO_OK + else + DO_WARN ; set warn_stat = 1 + NEWLINE + MSG "You do not have write permission on the iraf directory." + MSG "This will prevent the install script from modifying files" + MSG "in the tree needed to complete the setup. If this is an" + MSG "NFS disk there can be several explanations aside from just" + MSG "the usual permissions problems:" + MSG "" + MSG " 1) The NFS disk is mounted read-only" + MSG " 2) The NFS disk is mounted with the 'nosuid' option" + MSG " 3) The NFS disk is exported with the 'all_squash' option" + MSG " which remaps your userid to 'anonymous'" + MSG "" + MSG "The script can continue by installing the command links on" + MSG "the local machine, but will not edit the iraf path into the" + MSG "files. If you choose not to do this the verification stage" + MSG "will be completed but the installation will then abort." + MSG "" + MSG "In either case, you should verify the server iraf path is" + MSG "correct for this machine and rerun the install script or" + MSG "make the appropriate links as needed." + MSG "" + MSG "" + + echo -n ' ' + BOLD_ON + echo -n '*** Would you like to continue with a no-edit install? ' + BOLD_OFF + echo -n "(yes) " + + set ans = "$<" + if ("$ans" == "" || "$ans" == "y" || "$ans" == "yes") then + set no_edit = 1 + else + set err_stat = 1 + endif + NEWLINE + set warn_count = `expr $warn_count + 1` + endif + chdir $back + else + DO_OK + endif +endif + + + +# Check iraf user. + +goto _no_user_check + +# Check for iraf user disabled for all platforms with v2.15 +if ($mach == "macosx" || $mach == "macintel" || $mach == "cygwin") then + goto _no_user_check +endif + +echo -n "Checking for iraf user account ... " +set pass = "" +if (($pciraf && ($mach == "macosx" || $mach == "macintel" || $mach == "cygwin")) || (!(-r /etc/passwd)) ) then + # Special-case user info check for OS X and systems where the /etc/passwd + # file may not contain the user info or isn't readable. + + set id_found = 0 + foreach d ($path) + if (-e $d/id) then + set id_found = 1 + break + endif + end + if ($id_found == 1) then + if (`id iraf |& grep -i 'no such user'` != "") then + DO_WARN ; set warn_stat = 1 + NEWLINE + MSG "No 'iraf' user was found on the system. The iraf user should" + MSG "be created before installing the system to ensure all files" + MSG "are owned by the iraf user, and the have the proper environment" + MSG "defined for installation and maintanence." + NEWLINE + + else + DO_OK + + # Check iraf user login path and shell + echo -n "Checking iraf user login directory ... " + + set v = `finger iraf |& egrep '^Directory'` + set ihome = `echo $v[2] | sed -e 's+/\(["]*\)$+\1+'` + set shel = `echo $v[4] | sed -e 's+/\(["]*\)$+\1+' | grep csh` + if ("$ihome" != "$iraf/local" && $shel == "") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The iraf user login info appears to be incorrect. For the" + MSG "given iraf root this path should be '$iraf/local'," + MSG "please run the 'chpass' command to change this. The iraf" + MSG "user account should also be defined to use a C-shell." + if ("$iraf_root_ok" == 0) then + MSG "(This error may be related to the incorrect definition of" + MSG "the iraf root directory seen above.)" + endif + NEWLINE + else + DO_OK + endif + + else + + endif + endif + +else + set pass1 = "`grep ^iraf: /etc/passwd`" + set pass2 = "`ypcat passwd |& grep ^iraf:`" + + if ("$pass1" == "" && "$pass2" == "") then + DO_WARN ; set warn_stat = 1 + NEWLINE + MSG "No 'iraf' user was found in the /etc/passwd file. The iraf" + MSG "user should be created before installing the system to ensure" + MSG "all files are owned by the iraf user, and the have the proper" + MSG "environment defined for installation and maintanence." + NEWLINE + else + DO_OK + + # Check iraf user login path in passwd file is iraf$local. + echo -n " Checking iraf user login directory ... " + if ("$pass1" != "") then + set pass = `grep ^iraf: /etc/passwd |sed -e 's/[ \*]/_/g' |sed -e 's/:/ /g'` + else + set pass = `ypcat passwd | grep ^iraf: |sed -e 's/[ \*]/_/g' |sed -e 's/:/ /g'` + endif + + set c = `echo $pass | wc -w` + set indx = `expr $c - 1` + + set ihome = `echo $pass[$indx] | sed -e 's+/\(["]*\)$+\1+'` + if ("$ihome" != "$iraf/local") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The iraf user login directory appears to be incorrect." + MSG "For the given iraf root this path should be '$iraf/local'," + MSG "please edit the /etc/passwd file to change this." + if ("$iraf_root_ok" == 0) then + MSG "(This error may be related to the incorrect definition of" + MSG "the iraf root directory seen above.)" + endif + NEWLINE + else + DO_OK + endif + + echo -n " Checking iraf user account shell ... " + set shel = `echo $pass[$c] | sed -e 's+/\(["]*\)$+\1+' | grep csh` + if ($shel == "") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The iraf user login directory appears to be incorrect." + MSG "The account should be configured to use a C-shell in order" + MSG "to take advantage of a preconfigured environment which will" + MSG "make maintainence easier. Please edit the passwd file or" + MSG "use the 'chsh' command (if available) to change this." + NEWLINE + else + DO_OK + endif + endif +endif + +_no_user_check: + + +# Skip the ownership check on some platforms. +if ($V != "2.15" && $V != "2.16") then + if ($mach != "cygwin" && $mach != "macosx" && $mach != "macintel") then + + # Check file ownership. + if ($mach == "hp700" || $mach == "rs6000") then + set downr = `$LS -lLd $iraf_p/iraf | awk '{print ($4)}'` + set fownr = `$LS -lLd $iraf_p/iraf/mkpkg | awk '{print ($4)}'` + else + set downr = `$LS -lLd $iraf_p/iraf | awk '{print ($3)}'` + set fownr = `$LS -lLd $iraf_p/iraf/mkpkg | awk '{print ($3)}'` + endif + set dperm = `$LS -lLd $iraf_p/iraf | awk '{print ($1)}'` + set fperm = `$LS -lLd $iraf_p/iraf/mkpkg | awk '{print ($1)}'` + + + echo -n "Checking file ownerships ... " + if ("$downr" == "iraf" && "$fownr" == "iraf") then + DO_OK + else if ("$downr" == "tody" && "$fownr" == "tody") then + # Special exemption for NOAO installations. + DO_OK + else + DO_WARN ; set warn_stat = 1 + NEWLINE + MSG "(root dir owned by $downr, iraf files owned by $fownr)" + MSG "The iraf tree should be owned by the iraf user so it can" + MSG "be updated and maintained properly." + MSG "" + MSG 'To fix this, login as root, set the iraf environment, and' + MSG 'issue the commands:' + MSG "" + MSG " cd " `echo $iraf_p` + MSG ' chown -R iraf . # change dir owner' + MSG ' cd $hbin # go to HSI bin dir' + MSG ' chown 0 alloc.e # fix alloc.e ownership' + MSG ' chmod 4755 alloc.e # fix permissions' + NEWLINE + set warn_count = `expr $warn_count + 1` + endif + + endif + +# Check file/directory permissions. +echo -n "Checking file permissions ... " + +set err_seen = 0 +foreach dir ($iraf_p $iraf_p/iraf $iraf_p/iraf/unix $iraf_p/iraf/unix/hlib) + if ("`$LS -lLd $dir | grep '.rw[xs]r.[xs]r.[xt]'`" == "") then + set err_seen = 1 + break + endif +end + +if ("$err_seen" == 0) then + DO_OK +else + DO_FAIL ; set err_stat = 1 + NEWLINE + MSG "The permissions on the iraf directory tree appear to be too" + MSG "restrictive to allow group or world user to access the file" + MSG "This may prevent users other than $downr from starting the system" + NEWLINE + set err_count = `expr $err_count + 1` +endif + +endif + + +# Check iraf tree for proper structure. +set check_iraf_tree = 0 # for v214 and earlier + +set iraf_r = $iraf # iraf root directory +set iraf_p = $iraf_r:h # iraf parent directory +set iraf_b = $iraf_p/irafbin # irafbin directory +set iraf_tree_ok = 1 + +set iraf_ib = $iraf/bin.$mach # irafbin IB directory +set iraf_nb = $iraf/noao/bin.$mach # irafbin NB directory + + +if ($check_iraf_tree == 1) then + +set iraf_ib = $iraf_b/bin.$mach # irafbin IB directory +set iraf_nb = $iraf_b/noao.bin.$mach # irafbin NB directory + + +echo "Checking proper iraf tree structure in $iraf_p ..." + +echo -n " Checking for 'iraf' subdir ... " +if (-d "$iraf_p/iraf") then + DO_OK +else + DO_FAIL ; set err_stat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` +endif + +echo -n " Checking for 'irafbin' subdir ... " +if (-d "$iraf_p/irafbin") then + DO_OK +else + set temp = $iraf_tree_ok + #echo -n "[ "; BOLD_ON; echo -n "Not Found" ; BOLD_OFF; echo " ]" ; + echo "" + set iraf_tree_ok = 0 + + # Look for a fallback to recover ... + echo -n " Checking for fallback tree structure ... " + set iraf_p = $iraf/../ + set iraf_b = $iraf_p/irafbin # irafbin directory + set iraf_ib = $iraf_b/bin.$mach # irafbin IB directory + set iraf_nb = $iraf_b/noao.bin.$mach # irafbin NB directory + if (-d "$iraf_p/irafbin") then + echo -n " "; DO_OK ; set iraf_tree_ok = $temp + else + echo -n " "; DO_FAIL; set err_stat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` + endif +endif + + +echo "'irafbin/bin.$mach'" | \ + awk '{ printf (" Checking for %s subdir ... \t", $1) }' +if (-d "$iraf_p/irafbin/bin.$mach") then + echo -n " "; DO_OK +else + echo -n " "; DO_FAIL; set err_stat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` +endif + +echo "'irafbin/noao.bin.$mach'" | \ + awk '{ printf (" Checking for %s subdir ...\t\t", $1) }' +if (-d "$iraf_p/irafbin/noao.bin.$mach") then + DO_OK +else + DO_FAIL ; set err_stat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` +endif + +if ("$iraf_tree_ok" == 0) then + NEWLINE + MSG "An error was detected in the structure of the iraf tree." + MSG "Your directory tree should look something like:" + MSG "" + MSG " $iraf_p" + MSG " / \" + MSG " (AS) /iraf /irafbin" + MSG " / \" + MSG " (IB) bin.$mach noao.bin.$mach (NB)" + MSG "" + MSG "The AS, IB, and NB distribution files are shown where they" + MSG "should be unpacked. Please verify the structure and the" + MSG "system architecture." + NEWLINE +endif + +endif # if (check_iraf_tree) + + + + +# Check binary dirs are both populated correctly. +echo -n "Checking Core system binary directory ... " +if (! (-e "$iraf_ib/cl.e" && -e "$iraf_ib/x_system.e")) then + if ($port == 1) then + DO_WARN ; set warn_stat = 1 + else + DO_FAIL ; set err_stat = 1 + endif + NEWLINE + MSG "The core system binary directory, $iraf_ib, does" + MSG "not appear to contain the proper binaries." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK +endif + +echo -n "Checking NOAO package binary directory ... " +if (! (-e "$iraf_nb/x_apphot.e" && -e "$iraf_nb/x_rv.e")) then + if ($port == 1) then + DO_WARN ; set warn_stat = 1 + else + DO_FAIL ; set err_stat = 1 + endif + if (-e "$iraf_ib/x_apphot.e" && -e "$iraf_ib/x_rv.e") then + NEWLINE + MSG "The NOAO package binary directory, $iraf_nb, is" + MSG "empty but the binaries appear to have been unpacked in the" + MSG "core system directory, $iraf_ib. These will need to be moved," + MSG "please delete the binaries and start again, be sure to unpack" + MSG "the NB distribution files in the $iraf_nb directory," + MSG "and the core system file in the $iraf_ib directory." + NEWLINE + else + NEWLINE + MSG "The NOAO package binary directory, $iraf_nb, does" + MSG "not appear to contain the proper files." + NEWLINE + endif + set err_count = `expr $err_count + 1` +else + DO_OK +endif + + +# Check that the specified local bin directory exists. +echo -n "Checking that local bin directory exists ... " +if (-d "$lbin") then + DO_OK +else + DO_FAIL ; set err_stat = 1 + NEWLINE + MSG "The specified local bin directory does not exist. This" + MSG "directory should be a common local bin directory which " + MSG "is found in all user's paths, e.g. /usr/local/bin." + MSG "Please create the directory or else reset and try again." + NEWLINE + set err_count = `expr $err_count + 1` +endif + + +# Check that the specified local lib directory exists. +if ("$shlib" == "yes") then + echo -n "Checking that local lib directory exists ... " + if (-d "$llib") then + DO_OK + else + DO_FAIL ; set err_stat = 1 + NEWLINE + MSG "The specified local lib directory does not exist. This" + MSG "directory should be a common local lib directory which " + MSG "is found in all user's paths, e.g. /usr/local/lib." + MSG "This directory is required for the iraf shared library." + MSG "Please create the directory or else reset and try again." + NEWLINE + set err_count = `expr $err_count + 1` + endif +endif + + +# See if we're good to go ... +if ("$err_stat" != "0") then + NEWLINE ; NEWLINE + BOLD_ON + echo "======================================================================" + echo "| An error occured during verification. Please take corrective |" + echo "| action before rerunning the install script. |" + echo "======================================================================" + BOLD_OFF + NEWLINE + exit $err_stat +endif + + + +# ============================================ +# The following is partially system dependent. +# ============================================ + +# Set the BINDIRS pathnames - directories where the HSI executables go. +set host = "$iraf/unix" +set hbin = "$iraf/unix/bin.$hmach" +set hlib = "$iraf/unix/hlib" +set fbin = "$iraf/bin" + +# Replace any // by /. +set host = `echo $host | sed -e "s+//+/+g"` +set hbin = `echo $hbin | sed -e "s+//+/+g"` +set fbin = `echo $fbin | sed -e "s+//+/+g"` +set hlib = `echo $hlib | sed -e "s+//+/+g"` + +# Strip any trailing /. +set host = `echo $host | sed -e 's+/\(["]*\)$+\1+'` +set hbin = `echo $hbin | sed -e 's+/\(["]*\)$+\1+'` +set fbin = `echo $fbin | sed -e 's+/\(["]*\)$+\1+'` +set hlib = `echo $hlib | sed -e 's+/\(["]*\)$+\1+'` +set BINDIRS = "$hbin $hlib $fbin $host" + +# The following file lists are partially system dependent. +set PATHFILES = "mkiraf.csh libc/iraf.h cl.csh" +set MODEFILES = "cl.csh fc.csh mkiraf.csh mkfloat.csh mkmlist.csh $host/reboot generic.e mkpkg.e rmbin.e rmfiles.e rpp.e rtar.e wtar.e xc.e xpp.e xyacc.e sgidispatch.e $hbin/sgi2*.e irafarch.csh" +set LINKFILES = "ecl.e cl.e mkiraf.csh mkmlist.csh generic.e mkpkg.e rmbin.e rmfiles.e rtar.e sgidispatch.e wtar.e rpp.e xpp.e xyacc.e xc.e" +set CMDLINKS = "ecl cl mkiraf mkmlist generic mkpkg rmbin rmfiles rtar sgidispatch wtar rpp xpp xyacc xc irafarch" + + +#============================================================================= +# See whether there is an existing commands dir we need to delete. +#============================================================================= + +echo -n "Checking for existing commands directory... " +set cl_found = 0 +set clpath = "" +foreach d ($path) + if (-e $d/cl) then + set cl_found = 1 + set clpath = $d/cl + break + endif +end +if ($cl_found == 1) then + set o_lbin = $clpath:h + + if ("$o_lbin" != "$lbin") then + DO_WARN + NEWLINE + MSG "IRAF commands were found in the directory:" + MSG "" + MSG " $o_lbin" + MSG "" + MSG " These commands may conflict with the commands now being" + MSG "installed in: '$lbin'" + MSG "" +del_cmd_: + PROMPT "Do you want to delete commands in the old directory? " + set ans = "$<" + + if ("$ans" == "" || "$ans" == "y" || "$ans" == "yes") then + NEWLINE + foreach i ($CMDLINKS) # remove the iraf commands + set file = $o_lbin/$i + if (-e $file) then + MSG "Deleting command $file ..." + if ($exec == yes) then + RM $file + endif + endif + end + else if ("$ans" == "quit" || "$ans" == "q") then + exit 1 + else if ("$ans" == "no" || "$ans" == "n") then + ; # fall through + else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG "Multiple commands such as 'cl' or 'mkiraf' on a machine" + MSG "may cause errors (such as 'command not found' due to an" + MSG "invalid link), or confusions as to which version of iraf" + MSG "is being run if the old link is still valid. This is" + MSG "because the command being used depends on the order in" + MSG 'which the directories occur in the users "$path" environ-' + MSG "ment variable (which may vary by user)." + MSG "" + MSG "It is recommended there be only one iraf command directory" + MSG "on a given system, other methods can be used to start a" + MSG "different IRAF installation. This script will not auto-" + MSG "matically remove those links, and will only correct the" + MSG "path is the local bin directory is the same as before." + MSG "" + MSG "Type 'q' to quit and rerun the install script to specify" + MSG "a different local bin directory, 'yes' to remove the old" + MSG "links, and 'no' to leave the old commands around." + MSG "" + NEWLINE + goto del_cmd_ + endif + NEWLINE + else + DO_OK + endif + +else + DO_OK +endif + + +#============================================================================= +# Prompt for the go-ahead ... +#============================================================================= +NEWLINE +proceed_: +PROMPT "Proceed with installation? " +set ans = "$<" +if ("$ans" == "" || "$ans" == "y" || "$ans" == "yes") then + NEWLINE +else if ("$ans" == "quit" || "$ans" == "q") then + exit 0 +else if ("$ans" == "no" || "$ans" == "n") then + exit 0 +else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG "If you proceed, the system will be installed on this machine." + MSG "This means that command links will be placed in the local bin" + MSG "directory, needed system files will be created, and the iraf" + MSG "root path will be edited into key files. Stopping at this stage" + MSG "will have no side effects on your system or the iraf files." + MSG "Type to continue, or 'q' to quit to exit the installation." + NEWLINE + goto proceed_ +else + echo "Huh?" + goto proceed_ +endif + + +############################################################################## +# +# Step 2: INSTALLATION +# +# Do the actual installation. This involves: +# +# 1) Editing the $iraf path into system files +# 2) Creating the link +# 3) Creating the system command links +# 4) Creating the image directory (imdir) +# 5) Creating the cache directory (cache) +# 6) Tape setup (modes on alloc.e and /dev tape devices) +# 7) Graphics/Display file installation/setup +# +############################################################################## + +# Begin installation. +# ------------------ + +set err_seen = 0 + + +NEWLINE +BOLD_ON +echo "========================================================================" +echo "========================= Begin Installation =========================" +echo "========================================================================" +BOLD_OFF + +# Skip ahead if we're not editing the files or touching the disk. +if ($no_edit == 1) then + goto end_no_edit +endif + + +NEWLINE +BOLD_ON +echo " Editing Paths" +echo " -------------" +BOLD_OFF + +# Edit the $iraf pathname in the .login file for user 'iraf'. +echo -n "Editing the iraf user .login/.cshrc paths ... " +cd $iraf/local + +foreach file (.cshrc .login) + if (-e $file) then + RM $TEMP >& /dev/null + sed -e "s+$W$o_iraf+\1$iraf+" $file > $TEMP + cmp -s $file $TEMP + if ($status) then + PUT $TEMP $file + endif + RM $TEMP >& /dev/null + else + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif + MSG "Cannot find the iraf $file file" + RM $TEMP >& /dev/null + endif +end +if ("$err_seen" == 0) then + DO_OK +endif + + +# If we're on a Mac OS X or Cygwin system the iraf login directory isn't easy +# to change and as of OSX 10.1 the default is to create this in /Users/iraf. +# If this is how things are set up then link the .login/.cshrc files in this +# directory so the account has the proper environment. + +set err_seen = 0 + +if ($V != "2.15" && $V != "2.16") then + + if ($pciraf && ($mach == "macosx" || $mach == "macintel" || $mach == "cygwin")) then + echo -n "Creating iraf user .login/.cshrc links ... " + + set v = `finger iraf |& egrep '^Directory'` + set ihome = `echo $v[2] | sed -e 's+/\(["]*\)$+\1+'` + + if ("$ihome" != "$iraf/local") then + cd $ihome # go to account login dir + + if (! (-e bugs.log)) then # make sure it's not iraf$local + foreach file (.cshrc .login) + if ($exec == yes) then + if (-e $file) then + RM $file >& /dev/null # remove old file + endif + ln -s $iraf/local/$file $file # make local link + + if (! (-e $file) && $exec == yes) then + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif + MSG "Cannot find the iraf $file file in $ihome" + RM $TEMP >& /dev/null + endif + + endif + end + endif + cd $iraf/local + + else + DO_OK + endif + + if ("$err_seen" == 0) then + DO_OK + endif + endif + +endif + + +# Edit the $iraf and $imdir paths in mkiraf.csh, cl.csh, and libc/iraf.h files. + +echo -n "Editing iraf/imdir paths into system files ... " +cd $iraf/unix/hlib + +set err_seen = 0 +foreach i ($PATHFILES) + if (-e $i) then + RM $TEMP >& /dev/null + sed -e "s+$W$o_iraf+\1$iraf+" $i |\ + sed -e "s+$W$o_cache+\1$cache+" | \ + sed -e "s+$W$o_imdir+\1$imdir+" > $TEMP + cmp -s $i $TEMP + if ($status) then + if ($exec == yes) then + PUT $TEMP $i + chmod 755 $i + endif + endif + RM $TEMP >& /dev/null + else + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif + MSG "File $i not found." + RM $TEMP >& /dev/null + endif +end +if ("$err_seen" == 0) then + DO_OK +endif + + + +NEWLINE +BOLD_ON +echo " Checking File Permissions" +echo " -------------------------" +BOLD_OFF + +# Set default file permissions for the executable files in the BINDIRS, +# in case the file mode has somehow been changed, e.g., in a file restore +# or copy. + +echo -n "Checking iraf file permissions ... " + +set err_seen = 0 +foreach i ($MODEFILES) + set file = $i + if (! -e $file) then + foreach j ($BINDIRS) + if (-e $j/$i) then + set file = $j/$i + break + endif + end + endif + + if (-e $file) then + if ("`$LS -l $file | grep '^.rw[xs]r.[xs]r.[xt]'`" == "") then + if ("$err_seen" == 0) then + DO_WARN + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif + MSG "Setting $file:t to mode 0755." + if ($exec == yes) then + chmod 755 $file + endif + endif + else + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif + MSG "File $file:t not found." + endif +end +if ("$err_seen" == 0) then + DO_OK +endif + + +# Create the root imdir as a public scratch directory, if not already created. +set err_seen = 0 +if (-d $imdir) then + if ("`$LS -ld $imdir | grep '^.rw[xs]r.[xs]r.[xt]'`" != "") then + echo -n 'Checking imdir permissions ...' + echo -n ' ' + else + echo -n 'Setting mode for $imdir to 0777 ' + if ($exec == yes) then + chmod 777 $imdir + endif + endif +else + echo -n "Creating root imdir at $imdir ... " + if ($exec == yes) then + mkdir $imdir; chmod 777 $imdir + endif +endif +if ("$err_seen" == 0) then + DO_OK +endif + + +# Create the root cache as a public scratch directory, if not already created. +set err_seen = 0 +if (-d $cache) then + if ("`$LS -ld $cache | grep '^.rw[xs]r.[xs]r.[xt]'`" != "") then + echo -n 'Checking cache permissions ...' + echo -n ' ' + else + echo -n 'Setting mode for $cache to 0777 ' + if ($exec == yes) then + chmod 777 $cache + endif + endif +else + echo -n "Creating root cache at $cache ... " + if ($exec == yes) then + mkdir $cache; chmod 777 $cache + endif +endif +if ("$err_seen" == 0) then + DO_OK +endif + + + +# Allow deletion of files in /tmp - needed for multiuser tape allocation. +echo -n "Reset /tmp sticky bit setting ... " +if ($exec == yes) then + chmod -t /tmp +endif +DO_OK + +# Initialize permissions of tape devices. +if ($do_tapes) then +echo -n "Setting tape device permissions ... " + if ($exec == yes) then + chmod 666 $TAPES >& /dev/null + chown root $TAPES >& /dev/null + endif + DO_OK +endif + + + +# Set owner=root for the device allocation task, alloc.e. + +echo -n "Checking alloc.e permissions ... " + +set err_seen = 0 +foreach i ($BINDIRS) + if (-e $i/alloc.e) then + if ("`$LS -l $i/alloc.e | grep 'rwsr-.*root'`" == "") then + if ($exec == yes) then + chown 0 $i/alloc.e + chmod u+s $i/alloc.e + endif + endif + break + else + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif + MSG "Cannot find alloc.e executable." + endif +end +if ("$err_seen" == 0) then + DO_OK +endif + + +# Target for no-edit install. +end_no_edit: + + +NEWLINE +BOLD_ON +echo " Creating File Links" +echo " -------------------" +BOLD_OFF + + +# Create a /iraf symlink on the system to establish a /iraf/iraf root +# path regardless of the actual root dir. We only do this if there is +# no /iraf on the system already. + +echo -n "Checking for /iraf symlink ... " +if (! -e /iraf) then + if ($exec == yes) then + ln -s $iraf_p /iraf + endif + if ($exec == no || -e /iraf/iraf ) then + DO_OK + else + DO_FAIL + set err_count = `expr $err_count + 1` + endif +else + DO_OK +endif + + +# Link $hlib/libc/iraf.h to . This is needed not only to compile C +# source files in iraf, but also to define $iraf, $host, etc. for iraf tasks. + +# Verify we have a /usr/include directory (some MacOSX systems won't) +echo -n "Checking /usr/include directory ... " +if (! -e /usr/include) then + if ($exec == yes) then + mkdir /usr/include + if (-d /usr/include) then + DO_OK + else + DO_FAIL + set err_count = `expr $err_count + 1` + endif + else + DO_OK + endif +else + DO_OK +endif + + +echo -n "Creating symlink ... " +set file1 = /usr/include/iraf.h +set file2 = $iraf/unix/hlib/libc/iraf.h + +set err_seen = 0 +if (-e $file1) then + if ("`$LS -l $file1 | grep $file2`" == "") then + if ($exec == yes) then + RM $file1 + endif + if ($exec == yes) then + ln -s $file2 $file1 + endif + endif +else + if ($exec == yes) then + ln -s $file2 $file1 + endif +endif +if (("$err_seen" == 0 && -e $file1) || $exec == "no") then + DO_OK +else + DO_FAIL + set err_count = `expr $err_count + 1` +endif + + +# Establish the remaining symbolic links to HSI tasks. +echo -n "Creating iraf command links in local bin dir ... " +cd $lbin + +set err_seen = 0 +foreach i ($LINKFILES) + # Locate the file to be linked to. + set file1 = $i:r + foreach j ($BINDIRS) + set file2 = $j/$file1.csh + if (-e $file2) then + break + endif + set file2 = $j/$i + if (-e $file2) then + break + endif + end + + # Verify or set the link. + if (-e $file1) then + if ("`$LS -l $file1 | grep $file2`" == "") then + if ($exec == yes) then + RM $file1 + endif + if ($exec == yes) then + ln -s $file2 $file1 + endif + endif + else + if ($exec == yes) then + RM $file1 + ln -s $file2 $file1 + endif + endif + + if (! (-e $file1) && "$exec" == "yes") then + if ("$err_seen" == 0) then + DO_FAIL + endif + MSG "Could not make link $file1 -> $file2" + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif +end +if ("$err_seen" == 0) then + DO_OK +endif + + +# Establish the remaining symbolic links to shared libraries. +if ("$shlib" == "yes") then + echo -n "Creating iraf library links in local lib dir ... " + cd $llib + + set err_seen = 0 + foreach i ($LIBFILES) + # Locate the file to be linked to. + set file1 = $i + foreach j ($iraf/bin.$mach $iraf/bin.$hmach) + set file2 = $j/$i + if (-e $file2) then + break + endif + end + + # Verify or set the link. + if (-e $file1) then + if ("`$LS -l $file1 | grep $file2`" == "") then + if ($exec == yes) then + RM $file1 + endif + if ($exec == yes) then + ln -s $file2 $file1 + endif + endif + else + if ($exec == yes) then + RM $file1 + ln -s $file2 $file1 + endif + endif + + if (! (-e $file1) && "$exec" == "yes") then + if ("$err_seen" == 0) then + DO_FAIL + endif + MSG "Could not make link $file1 -> $file2" + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif + end + if ("$err_seen" == 0) then + DO_OK + endif +endif + + +# Mark the system update time. +if ($no_edit == 0) then + echo -n 'Marking system update time hlib$utime ... ' + if ($exec == yes) then + touch $hlib/utime + endif + DO_OK +endif + + +#============================================================================= +# Install the VOClient Daemon code. +#============================================================================= + +NEWLINE +BOLD_ON +echo " Installing VOClient Code" +echo " ------------------------" +BOLD_OFF + + +echo -n "Creating 'voclientd' symlink ... " +set file1 = $lbin/voclientd +set file2 = $iraf/vo/java/voclientd + +set err_seen = 0 +if (-e $file1) then + if ("`$LS -l $file1 | grep $file2`" == "") then + if ($exec == yes) then + RM $file1 + endif + if ($exec == yes) then + ln -s $file2 $file1 + endif + endif +else + if ($exec == yes) then + ln -s $file2 $file1 + endif +endif +if (("$err_seen" == 0 && -e $file1) || $exec == "no") then + DO_OK +else + DO_FAIL + set err_count = `expr $err_count + 1` +endif + + +echo -n "Creating 'voclient.jar' symlink ... " +set file1 = $lbin/voclient.jar +set file2 = $iraf/vo/java/voclient.jar + +set err_seen = 0 +if (-e $file1) then + if ("`$LS -l $file1 | grep $file2`" == "") then + if ($exec == yes) then + RM $file1 + endif + if ($exec == yes) then + ln -s $file2 $file1 + endif + endif +else + if ($exec == yes) then + ln -s $file2 $file1 + endif +endif +if (("$err_seen" == 0 && -e $file1) || $exec == "no") then + DO_OK +else + DO_FAIL + set err_count = `expr $err_count + 1` +endif + + + +#============================================================================= +# Common code for XGTERM/XIMTOOL installation. +#============================================================================= + +NEWLINE +BOLD_ON +echo " Creating Graphics Device Files" +echo " ------------------------------" +BOLD_OFF + +if ($do_pipes == 0 || $has_pipes == 0) then + goto _no_pipes +endif + +# Make sure special device entries for the display servers exist in /dev. +echo -n "Creating /dev/imt1 fifo pipes for image display ... " + +set err_seen = 0 +foreach i (/dev/imt1i /dev/imt1o) + if (-e $i) then + # Check the file permissions. + if ("`$LS -l $i | grep '^.rwxrwxrwx'`" == "") then + if ($exec == yes) then + chmod 777 $i + endif + endif + else + if ($exec == yes) then + set mkfifo_found = 0 + foreach d ($path) + if (-e $d/mkfifo) then + set mkfifo_found = 1 + break + endif + end + if ($mkfifo_found == 1) then + mkfifo $i + else + mknod $i p + endif + chmod 777 $i + endif + endif + + if (! (-e $i) && $exec == "yes") then + if ("$err_seen" == 0) then + DO_FAIL + endif + MSG "Could not create fifo $i" + set err_seen = 1 + set err_count = `expr $err_count + 1` + endif +end +if ("$err_seen" == 0) then + DO_OK +endif + + +# The old /dev/imt1 entry is now just a link to /dev/imt1o. +echo -n "Creating /dev/imt fifo pipes link ... " +set file = /dev/imt1 + +set err_seen = 0 +if (-e $file) then + if ("`$LS -l $file | grep imt1o`" == "") then + if ($exec == yes) then + RM $file + ln -s /dev/imt1o $file + endif + endif +else + if ($exec == yes) then + ln -s /dev/imt1o $file + endif +endif +if (("$err_seen" == 0 && -e $file) || $exec == "no") then + DO_OK +else + DO_FAIL + set err_count = `expr $err_count + 1` +endif + +_no_pipes: + +if ($mach == "cygwin") then + echo -n "Creating special graphcap file ... " + cp $iraf/dev/graphcap.inet $iraf/dev/graphcap + DO_OK +endif + +#============================================================================= +# Install the default IMTOOLRC frame buffer configuration file. The path +# /usr/local/lib path hardwired in to imtool and cannot easily be changed, but +# if installation of the default imtoolrc in this directory is not possible, +# the file can be installed in each imtool user's login directory as .imtoolrc, +# or the environment variable IMTOOLRC can be defined in each imtool user's +# .login or .cshrc to define the path to the file. +#============================================================================= + +# Verify imtoolrc link. +echo -n "Checking /usr/local/lib directory ... " +if (! -e /usr/local/lib) then + if ($exec == yes) then + if (! -e /usr/local) then + mkdir /usr/local + endif + mkdir /usr/local/lib + if (-d /usr/local/lib) then + DO_OK + else + DO_FAIL + set err_count = `expr $err_count + 1` + endif + else + DO_OK + endif +else + DO_OK +endif + + +# Verify or set the IMTOOLRC link. +if ($exec == yes) then + cd /usr/local/lib +endif +set file1 = imtoolrc +set file2 = $iraf/dev/imtoolrc + +echo -n "Creating /usr/local/lib/imtoolrc link ... " + +set err_seen = 0 +if (-e $file1) then + if ("`$LS $file1`" == "$file1") then + if ("`$LS -l $file1 | grep $file2`" == "") then + if ($exec == yes) then + RM $file1 + ln -s $file2 $file1 + endif + endif + endif +else + if ($exec == yes) then + ln -s $file2 $file1 + endif +endif +if (("$err_seen" == 0 && -e $file1) || $exec == "no") then + DO_OK +else + DO_FAIL + set err_count = `expr $err_count + 1` +endif + + +#============================================================================= +# Make sure there are entries in the the termcap and graphcap files for xgterm +# and imtool. This is almost a no-op however we check in case there's an +# ancient local version which may have been replaced repeatedly rather than +# diff/merged over time. +#============================================================================= + +echo -n "Checking if termcap file contains an XGterm entry ... " +set temp = `grep -l xgterm $iraf/dev/termcap | grep -v '^#'` +if ("$temp" == "") then + DO_FAIL + set err_count = `expr $err_count + 1` +else + DO_OK +endif + +echo -n "Checking graphcap file for XGterm/imtool entries ... " +set gcok = yes +foreach i (xgterm imtool) + set temp = `grep -l $i $iraf/dev/graphcap | grep -v '^#'` + if ("$temp" == "" && "$gcok" == "yes") then + DO_FAIL + set err_count = `expr $err_count + 1` + set gcok = no + endif +end +if ($gcok == yes) then + DO_OK +endif + +if ("$err_count" > 0) then + goto fini_ +endif + + + +############################################################################## +# +# Step 3: POST-INSTALL CONFIGURATION +# +# Do some of the post-installation config required of all systems. +# This involves: +# +# 1) Creating a dev$tapecap for this system +# 2) Adding machine to dev$hosts file +# 3) Check for display servers +# 4) Check for graphics terminals +# 5) Delete unused HSI binaries +# 6) Strip system sources +# +############################################################################## + +# Begin configuration. +# -------------------- + +set err_seen = 0 + +NEWLINE ; NEWLINE +BOLD_ON +echo "========================================================================" +echo "===================== Post-Install Configuration =====================" +echo "========================================================================" +BOLD_OFF +NEWLINE + + +echo " The system should be fully functional at this point however some" +echo "post-install configuration may be required to make use of all the" +echo "features such as networking or tape access. Additional software such" +echo "as external packages or display servers will need to be installed" +echo "separately. Some minimal configuration can be accomplished now but" +echo -n "you should consult the " +BOLD_ON +echo -n "IRAF Site Manager's Guide" +BOLD_OFF +echo " for a more complete" +echo "discussion of IRAF system management, configuration of printers, etc." + +NEWLINE +post_install_: +PROMPT "Proceed to post-install configuration stage? " +set ans = "$<" +if ("$ans" == "" || "$ans" == "y") then + NEWLINE + BOLD_ON + echo "------------------------------------------------------------------------" + BOLD_OFF +else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG " If you continue, some minimal configuration of the IRAF net-" + MSG "working and tapecap file will be performed. Additional checks" + MSG "on the availability of display servers and graphics terminals will" + MSG "also be done." + NEWLINE + goto post_install_ +else if ("$ans" == "no" || "$ans" == "n") then + NEWLINE; NEWLINE + goto fini_ +else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 +else + echo "Huh?" + goto post_install_ +endif + + +#============================================================================== +# Set up the dev$hosts file to enable iraf networking on this system. +#============================================================================== + + +# Get the networking values. +set hname = "`hostname`" +set lhost_abbr = `hostname | awk '{printf ("%16.16s\n", $1 ) }'` +set ihosts = $iraf/dev/hosts +set tmp_host = /tmp/_host$$ + + +if (`echo $hname | grep "\."` != "") then + # When using FQDN lnode may not be set.... + set is_fqdn = yes + set domain = "`hostname | sed -e 's/^[a-zA-Z0-9_\-]*\.//g'`" + set lhost = "`hostname | sed -e 's/\.[a-zA-Z0-9]*//g'`" +else + set is_fqdn = no + set domain = "" + set lhost = $hname +endif +set nnode = "`hostname`" + +# Compute the recommended hosts entry. +set irafks = $iraf/bin.$mach/irafks.e +set bang = '\\!' +if ("$is_fqdn" == "no") then + set rec = `echo $lhost " : " ${hname}${bang}${irafks}` +else + set rec = `echo $lhost $lhost_abbr " : " ${nnode}${bang}${irafks}` +endif + + + +NEWLINE +BOLD_ON +echo " IRAF Networking Config" +echo " ----------------------" +BOLD_OFF +NEWLINE + +echo " IRAF Networking can be used to access a remote image, tape device," +echo "display server, or other network service. It's configuration is not" +echo "a requirement for normal IRAF operations and it can be updated at any" +echo 'time by editing the IRAF dev$hosts file with new entries.' +NEWLINE +echo " In this stage we will add an entry for the current platform to the" +echo "hosts file. In a local network installation this script should be run" +echo "on each system to add a networking entry as well as to install other" +echo "system files needed by IRAF." + +net_conf_: +NEWLINE +PROMPT "Configure IRAF Networking on this machine? " +set ans = "$<" +if ("$ans" == "" || "$ans" == "y") then + + # Check to see if the current machine is already in the hosts file. + set overwrite = 0 + set have_entry = 0 + grep $lhost $ihosts >& /dev/null + if ($status == 0) then + # Compare the recommended entry with the one already in the file. + echo $rec >& /tmp/_net_rec.$$ + grep $lhost $ihosts >& /tmp/_net_exists.$$ + diff -bitw /tmp/_net_rec.$$ /tmp/_net_exists.$$ >& /dev/null + if ($status == 0) then + RM /tmp/_net_*.$$ + set have_entry = 1 + NEWLINE + echo "Host '$lhost' exists with recommended entry in $ihosts." + NEWLINE + goto net_proc_ + + else + RM /tmp/_net_*.$$ + NEWLINE + echo "Host '$lhost' exists with entry in $ihosts other than what" + echo "would be computed by this script:" + NEWLINE + echo ' Recommended dev$hosts file entry used for this machine: ' + NEWLINE + if ("$is_fqdn" == "no") then + echo " "$lhost " : "$hname"\!"$irafks + else + echo " "$lhost $lhost_abbr " : " $nnode"\!"$irafks + endif + NEWLINE + echo ' Existing entry found in the dev$hosts file: ' + NEWLINE + echo -n " "; grep $lhost $ihosts + NEWLINE + +net_overwrite_: + NEWLINE + PROMPT_N "Overwrite the existing entry with recommended one?" + set ans = "$<" + if ("$ans" == "" || "$ans" == "no" || "$ans" == "n") then + set overwrite = 0 + goto net_check_ + else if ("$ans" == "y" || "$ans" == "yes") then + set overwrite = 1 + # fall through + else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG "Answering 'yes' will replace the entry in the file" + MSG "with the one created by this script, answering 'no'" + MSG "will leave the current entry (which may be correct)" + MSG "intact." + NEWLINE + goto net_overwrite_ + else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 + else + echo "Huh? " + goto net_overwrite_ + endif + + endif + + else + # This host isn't currently in the file. +net_rec_: + NEWLINE + echo 'Recommended dev$hosts file entry used for this machine: ' + NEWLINE + if ("$is_fqdn" == "no") then + echo " "$lhost " : "$hname"\!"$irafks + else + echo " "$lhost $lhost_abbr " : " $nnode"\!"$irafks + endif + NEWLINE + +net_proc_: + PROMPT "Proceed with this entry? " + set ans = "$<" + if ("$ans" == "" || "$ans" == "y") then + ; + else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG 'If you continue the recommended entry will be added to the' + MSG "IRAF dev$hosts file as is, otherwise you will be asked if" + MSG "you wish to edit the file manually." + NEWLINE + goto net_proc_ + + else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 + else if ("$ans" == "no" || "$ans" == "n") then +net_edit_: + PROMPT 'Do you wish to edit the dev$hosts file manually? ' + set ans = "$<" + + if ("$ans" == "" || "$ans" == "y") then + if ($?EDITOR) then + $EDITOR $ihosts + else + vi $ihosts + endif + goto net_check_ + else if ("$ans" == "no" || "$ans" == "n") then + MSG "Skipping network configuration." + goto net_check_ + else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 + else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG 'If you say yes you will be allowed to edit the dev$hosts' + MSG "file manually. You should use the existing entries as a" + MSG "template. Be sure the host name and iraf path are correct" + MSG "for this machine." + NEWLINE + goto net_edit_ + else + echo "Huh? " + goto net_edit_ + endif + else + echo "Huh?" + goto net_proc_ + endif + + endif + + # If we have an entry already in the file skip ahead to the check. + if ($have_entry == 1) then + goto net_check_ + endif + + # When exported to other sites the default dev$hosts file is the one + # configured for the NOAO network. Check to see whether we really *are* + # running at NOAO so we don't wipe this out assuming it's a fresh install + # and we can treat the file as an existing installation (i.e. append to + # the hosts file). + set is_noao = 0 + ifconfig -a |& grep 140.252 >& /dev/null + if ($status == 0) then + set is_noao = 1 + endif + + grep kpno.noao.edu $ihosts >& /dev/null + if ($status == 0 && $is_noao == 0) then + # If we're here then the hosts file is the NOAO default, but we are + # not running on an NOAO network machine. So, we want to initialize + # the hosts file by getting rid of the NOAO hosts, adding a standard + # "header" and adding the current platform. + + NEWLINE + echo 'Creating backup of default dev$hosts file...' + if ($exec == yes) then + cp $iraf/dev/hosts $iraf/dev/hosts.ORIG + endif + + echo 'Initializing dev$hosts file ...' + + + echo "# HOSTS -- IRAF local network host table." > $tmp_host + echo "" >> $tmp_host + echo -n "# Logical nodes (lpnode = line printer" >> $tmp_host + echo "output, plnode = plotter output)." >> $tmp_host + echo "#lpnode : @ursa" >> $tmp_host + echo "#plnode : @ursa" >> $tmp_host + echo "" >> $tmp_host + echo "# Host table." >> $tmp_host + echo "" >> $tmp_host + + if ("$is_fqdn" == "no") then + echo $lhost $hname $iraf/bin.$mach/irafks.e | \ + awk '{printf("%-16s\t: %s\!%s\n",$1,$2,$3)}' >> $tmp_host + else + echo $lhost $lhost_abbr $hname $iraf/bin.$mach/irafks.e | \ + awk '{printf("%-16s %s\t: %s\!%s\n",$1,$2,$3,$4)}' >> $tmp_host + endif + + # Copy the header to the file + if ($exec == yes) then + cp $tmp_host $ihosts + else + cat $tmp_host + endif + + RM $tmp_host + echo "Host '$hname' has been added to the network configuration file..." + + else + # If we get to this point we're appending a hosts file that is + # correct for the current network, NOAO or not. + + + # Pull off the file "header" and "data" to separate segments. + head -7 $ihosts >& /tmp/_hhdr$$ + if ($overwrite == 1) then + more +8 $ihosts | grep -v $lhost >& /tmp/_hdat$$ + else + more +8 $ihosts >& /tmp/_hdat$$ + endif + + if ("$is_fqdn" == "no") then + echo $lhost $hname $iraf/bin.$mach/irafks.e | \ + awk '{printf("%-16s\t: %s\!%s\n",$1,$2,$3)}' >> /tmp/_hdat$$ + else + echo $lhost $lhost_abbr $hname $iraf/bin.$mach/irafks.e | \ + awk '{printf("%-16s %s\t: %s\!%s\n",$1,$2,$3,$4)}' >> /tmp/_hdat$$ + endif + +net_sort_: + # See if we want to sort the file. + PROMPT "Do you want to sort the hosts file by node name? " + set ans = "$<" + if ("$ans" == "" || "$ans" == "y" || "$ans" == "yes") then + sort /tmp/_hdat$$ >& /tmp/_hsdat$$ + else if ("$ans" == "no" || "$ans" == "n") then + cp /tmp/_hdat$$ /tmp/_hsdat$$ + else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG "Answering 'yes' will sort the hosts file." + NEWLINE + goto net_sort_ + else if ("$ans" == "quit" || "$ans" == "q") then + exit 0 + else + echo "Huh? " + goto net_sort_ + endif + + # Finally, put together the hosts file. + cat /tmp/_hhdr$$ /tmp/_hsdat$$ >& $tmp_host + + # Copy the header to the file + if ($exec == yes) then + cp $tmp_host $ihosts + else + cat $tmp_host + endif + + RM $tmp_host /tmp/_hhdr$$ /tmp/_hdat$$ /tmp/_hsdat$$ + endif + + + # Host should be added to the dev$hosts file, let's check to see that + # it actually works... + + # See what NETSTATUS says about this setup. +net_check_: + NEWLINE + echo -n "Checking that iraf networking is properly enabled ... " + echo -n " " + set system = $iraf/bin.$mach/x_system.e + setenv iraf $iraf/ + set errstat = 0 + if (-e $system) then + set net = `$system netstatus | grep -i "interface disabled"` + if ("$net" == "") then + DO_OK + else + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The NETSTATUS task claims that networking is disabled." + MSG "Please contact http://iraf.net with questions or check" + MSG "the Site Manager's Guide for details on how to properly" + MSG "configure networking." + NEWLINE + endif + else + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The NETSTATUS task binary could not be executed or does not" + MSG "exist. Please contact http://iraf.net with questions or" + MSG "check the Site Manager's Guide for details on how to properly" + MSG "configure networking." + NEWLINE + endif + +net_restart_: + if ($errstat == 1) then + PROMPT "Would you like to return to networking setup? " + set ans = "$<" + if ("$ans" == "" || "$ans" == "y" || "$ans" == "yes") then + goto net_conf_ + else if ("$ans" == "n" || "$ans" == "no") then + ; # fall through + else if ("$ans" == "h" || "$ans" == "help" || "$ans" == "?") then + NEWLINE + MSG "Answering 'yes' will return you to the top of the networking" + MSG "configuration where you can make changes. Answering 'no'" + MSG "will leave the current (unworking) configuration in place." + NEWLINE + goto net_restart_ + else if ("$ans" == "q" || "$ans" == "quit") then + exit 1 + else + echo "Huh? " + goto net_restart_ + endif + endif + +else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG 'If you continue a recommended entry can be added to the' + MSG 'IRAF dev$hosts file, otherwise you will be asked if' + MSG "you wish to edit the file manually." + NEWLINE + goto net_conf_ +else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 +else if ("$ans" == "no" || "$ans" == "n") then + NEWLINE + goto end_net_ +else + echo "Huh?" + goto net_conf_ +endif + +end_net_: +BOLD_ON +echo "------------------------------------------------------------------------" +BOLD_OFF + +NEWLINE + + +#============================================================================== +# Set up the default tapecap file for the machine. +#============================================================================== + +# Skip the configuration if the system already has a default dev$tapecap +# file. We only need to do this for e.g. PC-IRAF systems where we need +# to create a default based on the OS version. + +if (! $do_tapecaps ) then + goto skip_tape_ +endif + + +NEWLINE +BOLD_ON +echo " Tapecap Device File Config" +echo " --------------------------" +BOLD_OFF +NEWLINE + +echo ' By default IRAF will search for a dev$tapecap. file (where' +echo " is the system name) when looking for a tape configuration file." +echo "Platforms such as PC-IRAF and Sun/IRAF support multiple OS versions" +echo "and so the proper template file must be used. This configuration will" +echo "allow you to setup a default tapecap for this system, it may be skipped" +echo "if this machine has no tape drive attached." +NEWLINE + +tape_conf_: +PROMPT "Create a default tapecap file? " +set ans = "$<" +if ("$ans" == "" || "$ans" == "y") then + + # Figure out what the template should be. + if ($pciraf == 1) then + if ("$UNAME" == "linux") then + set tapefile = "tapecap.linux" + else if ("$UNAME" == "sunos") then + set tapefile = "tapecap.solaris" + else if ("$UNAME" == "freebsd") then + set tapefile = "tapecap.freebsd" + endif + else if ($suniraf == 1) then + setenv OSVERSION `$uname_cmd -r | cut -c1` + if ($OSVERSION == 5) then + set tapefile = "tapecap.solaris" + else + set tapefile = "tapecap.sunos" + endif + else + set tapefile = tapecap.$UNAME + endif + + # Get the (possibly abbreviated) local host name. + set lhost = `hostname | awk '{printf ("%16.16s\n", $1 ) }'` + + set file1 = $iraf/dev/tapecap.$lhost + set file2 = $tapefile + if (! -e $file1) then +tape_link1_: + echo "Creating default file 'tapecap.$lhost' from $tapefile..." + if ($exec == yes) then + chdir $iraf/dev + if (-e $file1) then + # Remove the link in case it exists but points to a file + # which doesn't. + RM tapecap.$lhost >& /dev/null + endif + ln -s $tapefile tapecap.$lhost + endif + else + if ("`$LS -l $file1 | grep $file2`" != "") then + echo "Tapecap symlink 'tapecap.$lhost' exists and is ok." + else + echo "Tapecap symlink 'tapecap.$lhost' exists but is invalid...." + echo "Deleting invalid link...." + if ($exec == yes) then + RM $file1 >& /dev/null + endif + goto tape_link1_ + endif + endif + + + # See if we want to make this the dev$tapecap default. + NEWLINE ; NEWLINE + echo ' In the event a dev$tapecap. file is not found on this' + echo 'system IRAF will fallback to use just dev$tapecap. In cases where' + echo 'the node name changes, this installation is shared with another' + echo 'machine or in a local network, or any case where a tapecap.' + echo 'is not found, the dev$tapecap file will be the default tapecap used' + echo "for all IRAF systems." + echo "" + + +tape_def_: + PROMPT 'Do you wish to create a default dev$tapecap link? ' + set ans = "$<" + if ("$ans" == "" || "$ans" == "y") then + + set file1 = $iraf/dev/tapecap + if (! -e $file1) then +tape_link2_: + echo -n 'Creating default dev$tapecap link to dev$' + echo "$tapefile..." + if ($exec == yes) then + chdir $iraf/dev + if (-e $file1) then + # Remove the link in case it exists but points to a file + # which doesn't. + RM tapecap >& /dev/null + endif + ln -s $tapefile tapecap + endif + else + if ("`$LS -l $file1 | grep $tapefile`" != "") then + echo "Tapecap symlink 'tapecap' exists and is ok." + else + echo "Tapecap symlink 'tapecap' exists but is invalid...." + echo "Deleting invalid link...." + if ($exec == yes) then + RM $file1 >& /dev/null + endif + goto tape_link2_ + endif + endif + + else if ("$ans" == "no" || "$ans" == "n") then + ; + else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 + else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG 'A dev$tapecap file is the fallback file used if there is no' + MSG "tapecap. file found. If you continue a link will be made" + MSG "to the template file appropriate for this machine." + NEWLINE + goto tape_def_ + else + echo "Huh?" + goto tape_def_ + endif + +else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 +else if ("$ans" == "no" || "$ans" == "n") then + NEWLINE + goto end_tape_ +else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG "If you continue a default tapecap appropriate for this system" + MSG 'will be created in the $iraf/dev directory' + NEWLINE + goto tape_conf_ +else + echo "Huh?" + goto tape_conf_ +endif + +end_tape_: +BOLD_ON +echo "------------------------------------------------------------------------" +BOLD_OFF + +NEWLINE +skip_tape_: + + + +#============================================================================== +# Delete the unused HSI binaries in the system to recover disk space. +#============================================================================== + +if ($pciraf == 0 && $suniraf == 0) then + goto skip_hsi_del_ +endif + + +# Get the set of currently installed system binaries. +set archs = "" +foreach i ($iraf/bin.*) + set dir = $i:t + if ($dir:r == "bin") then + set sz = `(chdir $i ; du -s | awk '{printf ("%d", $1)}')` + if (`$LS -lL $i | wc -l` > 1) then + if (-e "$i/cl.e" && -e "$i/x_system.e") then + # Save the list of installed binaries, allow for changes between + # the binary arch and HSI arch here (e.g. ssun->ssol). + if ("$dir:e" == "ssun") then + set archs = `echo $archs ssol` + else + set archs = `echo $archs $dir:e` + endif + endif + endif + endif +end + + + +# Check for HSI bin directories. +set delete_bin = "" +set empty_bin = "" +foreach i ($iraf_p/iraf/unix/bin.*) + set dir = $i:t + if ($dir:r == "bin") then + set sz = `(chdir $i ; du -s | awk '{printf ("%d", $1)}')` + if (`$LS -lL $i | wc -l` > 1) then + set d = `$LS $LSDF $i/* | head -2 | tail -1` + if ("`echo $archs | grep $dir:e`" == "") then + set delete_bin = `echo $delete_bin $dir` + endif + else + if ($sz > 8 && "`echo $archs | grep $dir:e`" == "") then + set delete_bin = `echo $delete_bin $dir` + endif + endif + else + continue + endif +end + +# If there were no unused bin directories found then skip this section. +if ("$delete_bin" == "") then + goto end_hsi_del_ +endif + + + +NEWLINE +BOLD_ON +echo " Delete Unneeded HSI Binaries" +echo " ----------------------------" +BOLD_OFF +NEWLINE + +echo ' The following bin directories in the iraf$unix directories were' +echo "found to be unused on this machine:" +NEWLINE +set tot = 0 +foreach i ($delete_bin) + set p = `echo $iraf/unix/$i | sed -e 's://:/:g'` + set sz = `du -s $p` + set tot = `expr $tot + $sz[1]` + echo $sz[1] $p | awk '{printf ("\t (%5d Kb)\t%s\n", $1, $2)}' +end +set tot = `expr $tot / 1000` +NEWLINE +echo "The contents of these directories may be safely deleted to reclaim" +echo "about $tot Mb of disk space without affecting the IRAF runtime system." +NEWLINE + + +hsi_del_: +PROMPT "Do you wish to delete these unused HSI binaries? " +set ans = "$<" +if ("$ans" == "" || "$ans" == "y") then + NEWLINE + chdir $iraf/unix + foreach i ($delete_bin) + echo -n "Delete HSI binaries in $i ... " + if ($exec == yes) then + if (-e $i) then + rm -rf $i/* + DO_OK + else + DO_FAIL + NEWLINE + MSG "Hmm, I can't find '$i' in '$cwd', skipping..." + NEWLINE + endif + else + # No-op okay + DO_OK + endif + end +else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 +else if ("$ans" == "no" || "$ans" == "n") then + NEWLINE + goto end_hsi_del_ +else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG "This system contains binaries needed for multi-architecture" + MSG "support, however you do not appear to need all of the binaries" + MSG "supplied. Removing uneeded binaries can recover some disk" + MSG "space that could be used for data." + NEWLINE + goto hsi_del_ +else + echo "Huh?" + goto hsi_del_ +endif + +end_hsi_del_: +BOLD_ON +echo "------------------------------------------------------------------------" +BOLD_OFF + +NEWLINE +skip_hsi_del_: + + +#============================================================================== +# Strip the system sources. +#============================================================================== + +NEWLINE +BOLD_ON +echo " Strip IRAF System Sources" +echo " -------------------------" +BOLD_OFF +NEWLINE + +echo " Source code for all IRAF tasks and interfaces is included with this" +echo "installation, but is strictly only required if you plan to develop this" +echo "code. The sources may be deleted from the system without affecting the" +echo "runtime environment (including help pages, compilation of external pack-" +echo "ages or local task development) allowing you to reclaim 50-60Mb of disk" +echo "space for the system. Stripping sources is recommended for systems very" +echo "short on space, leaving it on the system will allow IRAF site support to" +echo "send code fixes and compilation instructions as needed to fix problems" +echo "which have no other workaround." +NEWLINE + +strip_: +PROMPT_N "Do you wish to strip the system of sources? " +set ans = "$<" +if ("$ans" == "y" || "$ans" == "yes") then + NEWLINE + echo -n "Stripping core system sources ... " + if ($exec == yes) then + cd $iraf + $lbin/mkpkg strip + endif + DO_OK + echo -n "Stripping NOAO package sources ... " + if ($exec == yes) then + cd $iraf/noao + $lbin/mkpkg -p noao strip + endif + DO_OK +else if ("$ans" == "q" || "$ans" == "quit") then + exit 0 +else if ("$ans" == "" || "$ans" == "no" || "$ans" == "n") then + NEWLINE + goto end_strip_ +else if ("$ans" == "help" || "$ans" == "h" || "$ans" == "?") then + NEWLINE + MSG "Stripping system sources can recover considerable amounts of" + MSG "disk space while leaving a full runtime system. Sources should" + MSG "be stripp if there is insufficient room and you do not plan to" + MSG "do any development of the Core system or NOAO package." + NEWLINE + goto strip_ +else + echo "Huh?" + goto strip_ +endif + +#BOLD_ON +#echo "------------------------------------------------------------------------" +#BOLD_OFF + +end_strip_: +NEWLINE + + + +#============================================================================== +# Post-Install Verification +#============================================================================== + +NEWLINE +BOLD_ON +echo "========================================================================" +echo "===================== Post-Install Verification ======================" +echo "========================================================================" +BOLD_OFF +NEWLINE + + +#============================================================================== +# Check for available display servers on this system. +#============================================================================== + +NEWLINE +BOLD_ON +echo " Display Server Availability" +echo " ---------------------------" +BOLD_OFF +NEWLINE + +set DISPLAY_SERVERS = "ximtool ximtool-alt saoimage ds9 saotng" + +echo "Display Servers Found on This Machine:" +NEWLINE + +set found = 0 +foreach i ($DISPLAY_SERVERS) + set p = `which $i |& grep -i "^\/"` + if ($status == 0) then + set d = `$LS $LSDF $p | head -2 | tail -1` + echo $d | awk '{printf (" ( Date: %3s %2s %-5s ) ", $7, $8, $9) }' + echo " "`which $i` + set found = 1 + endif +end +if ($found == 0) then + BOLD_ON + echo " No Display Servers Found" + BOLD_OFF + NEWLINE + MSG "No display servers were found on this machine or in the user" + MSG "path. A display server such as XImtool/SAOimage/SAOtng/DS9" + MSG "is required to be running on the local machine before an iraf" + MSG "display command (e.g. DISPLAY/TVMARK/IMEXAMINE) will work." + MSG "" + MSG "Remote displays (i.e. the server on one machine and IRAF on" + MSG "another) require either iraf networking be enabled or the X" + MSG "'DISPLAY' variable be set so the server appears on the remote" + MSG "machine." + MSG "" + MSG " XImtool can be downloaded as part of X11IRAF from:" + MSG "" + MSG " http://iraf.net/ftp/iraf/x11iraf" + MSG "" + MSG "or it's mirror sites." + MSG " For information on DS9 please see" + MSG "" + MSG " http://hea-www.harvard.edu/RD/ds9/" + MSG "" + MSG "Please contact http://iraf.net with questions." +endif +NEWLINE + +BOLD_ON +echo "------------------------------------------------------------------------" +BOLD_OFF + +end_servers_: + + + +#============================================================================== +# Check for available graphics terminals on this system. +#============================================================================== + +NEWLINE +BOLD_ON +echo " Graphics Terminal Availability" +echo " ------------------------------" +BOLD_OFF +NEWLINE + +set GRAPHICS_TERMS = "xgterm xterm" + +echo "Graphics Terminals Found on This Machine:" +NEWLINE + +set found = 0 +foreach i ($GRAPHICS_TERMS) + set p = `which $i |& grep "^\/"` + if ($status == 0) then + set d = `$LS $LSDF $p | head -2 | tail -1` + echo $d | awk '{printf (" ( Date: %3s %2s %-5s ) ", $7, $8, $9) }' + echo " "`which $i` + set found = 1 + endif +end +if ($found == 0) then + BOLD_ON + echo " No Suitable Graphics Terminals Found" + BOLD_OFF + NEWLINE + MSG "No 'xterm' or 'xgterm' binary was found on this systen or" + MSG "in the user path. IRAF graphics require some form of " + MSG "graphics-enabled terminal window to be running or else" + MSG "garbarge characters will appear on the screen. Windows" + MSG "such as 'cmdtool', 'rxvt', 'aixterm', 'hpterm', 'decterm'" + MSG "do not support graphics and should not be used for IRAF." + MSG "" + MSG "The default terminal type is set in the login.cl when" + MSG "a user runs MKIRAF, this is the type of window they should" + MSG "be running when starting IRAF. Users can use the 'show" + MSG "terminal' command to see the current setting, or 'stty" + MSG "xterm' or 'stty xgterm' command (or rerun MKIRAF and reset" + MSG "the default terminal type) to change the default iraf terminal." + MSG "" + MSG "XGterm can be downloaded as part of X11IRAF from" + MSG "" + MSG " http://iraf.net/ftp/iraf/x11iraf" + MSG "" + MSG "or it's mirror sites. Xterm will normally be a part of the" + MSG "system, if not found please check your path." + MSG "" +endif +NEWLINE + +#BOLD_ON +#echo "------------------------------------------------------------------------" +#BOLD_OFF + +end_terms_: + + + +#============================================================================= +# Finish up and set the exit status. +#============================================================================= +fini_: + +NEWLINE ; NEWLINE +if ("$err_count" > 0) then + BOLD_ON + echo "========================================================================" + echo "================= Installation Completed With Errors =================" + echo "========================================================================" + BOLD_OFF + NEWLINE + exit 1 +else + BOLD_ON + echo "========================================================================" + echo -n "Congratulations! " + BOLD_OFF + echo "IRAF has been successfully installed on this system." + BOLD_ON + echo "========================================================================" + BOLD_OFF + NEWLINE + echo " To begin using the system simply log in as any user and from the" + echo "directory you wish to use as your iraf login directory type:" + echo "" + echo -n ' % '; + BOLD_ON; echo -n 'mkiraf'; BOLD_OFF + echo ' # create a login.cl file' + echo -n ' % '; + BOLD_ON; echo -n 'cl'; BOLD_OFF + echo ' # start IRAF' + echo "" + echo "The 'iraf' user is already configured with a login.cl file so a simple" + echo "'cl' command is sufficient to start the system." + NEWLINE + echo "Additional information can be found at the IRAF.NET web site:" + NEWLINE + BOLD_ON ; echo " http://iraf.net" ; BOLD_OFF + NEWLINE + echo "Please contact http://iraf.net with any questions or problems." + NEWLINE + NEWLINE + + BOLD_ON + echo "========================================================================" + echo "================ Installation Completed With No Errors ===============" + echo "========================================================================" + BOLD_OFF + NEWLINE + exit 0 +endif + +cleanup_: + exit 0 + + + +# Print usage information. We will not get here unless the "-help" flag +# was issued. + +Usage: + echo "Usage: install [-n] [-h] [-hl] [-f] [-r rootdir] [-i imdir]" + echo " [-b localbindir] [-R oldroot] [-I oldimdir]" + echo " [-u username ] [-l locallibdir] [-m mach ]" + echo " [-noedit]" + echo "" + echo " where -n # no execute" + echo " -h # print this help summary" + echo " +hl # enable highlighted text" + echo " -hl # disable highlighted text" + echo " -f # create fifo pipes (if supported)" + echo " -r # set iraf root directory" + echo " -c # set cache directory" + echo " -i # set imdir directory" + echo " -b # set local bin directory" + echo " -l # set local lib directory" + echo " -R # set old iraf root directory" + echo " -I # set old imdir directory" + echo " -u # set username to own files" + echo " -m # set machine type (ssun, linux, etc)" + echo " -noedit # install but don't edit pathnames" + exit 0 diff --git a/unix/hlib/install.old b/unix/hlib/install.old new file mode 100755 index 00000000..8764f337 --- /dev/null +++ b/unix/hlib/install.old @@ -0,0 +1,943 @@ +#!/bin/csh +# +# INSTALL -- Install IRAF on a UNIX/IRAF host. May also be run after the +# initial installation as a consistency check to verify that all the necessary +# links and file permissions are still in place (e.g., after updating UNIX +# itself). +# +# Usage: install [-n] [-r rootdir] [-i imdir] [-b localbindir] \ +# [-R oldroot] [-I oldimdir] [-u username (e.g., 'iraf')] +# [-m mach (e.g., 'sparc', 'mc68020') ] +# +# Example: +# % su +# % cd $hlib +# % install -n +# % install +# +# If run with no arguments, INSTALL will make an informed guess and prompt +# with this value; type to accept the value, or enter a new value. +# +# Use "install -n" to do a dry run to see what the would be done, without +# actually modifying the host system and IRAF configuration files. To do the +# actual installation one must be superuser, but anyone can run "install -n" +# to see what it would do. +# ---------------------------------------------------------------------------- + +unset noclobber +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch +set path = (/sbin /usr/sbin /bin /usr/bin /usr/ucb /etc /usr/etc) + +#set echo + +set W = '\([ "]\)' # match a blank, tab, or " +set TEMP = "/tmp/I_temp" +set exec = yes +set user = iraf +set LS = /bin/ls +alias PUT "mv -f \!*; chown $user \!$ " + +# Determine platform architecture. +if (-f /etc/redhat-release) then + if (`uname -m` == "ppc") then + set mach = linuxppc + else + set mach = redhat + endif +else + set mach = `uname -s | tr '[A-Z]' '[a-z]'` +endif + +if ($mach == "darwin") then + set mach = macosx +endif + +if ($?iraf == 1) then + if (! -d $iraf) then + setenv iraf "" + endif +else + setenv iraf "" +endif + +set imdir = "" +set lbin = "" +set o_iraf = "" +set o_imdir = "" + +# Process any command line arguments. +while ("$1" != "") + switch ("$1") + case -n: # no execute + alias PUT "diff \!$ \!^; rm -f $TEMP" + set exec = no + breaksw + case -b: # set local bin directory (unix) + if ("$2" != "") then + shift + else + echo "missing argument to '-b ' switch" + exit 1 + endif + set lbin = "$1" + breaksw + case -i: # set imdir directory + if ("$2" != "") then + shift + else + echo "missing argument to '-i ' switch" + exit 1 + endif + set imdir = "$1" + breaksw + case -m: # set machine type + if ("$2" != "") then + shift + else + echo "missing argument to '-m ' switch" + exit 1 + endif + set mach = "$1" + breaksw + case -r: # set root directory + if ("$2" != "") then + shift + else + echo "missing argument to '-r ' switch" + exit 1 + endif + setenv iraf "$1" + breaksw + case -I: # set old imdir directory + if ("$2" != "") then + shift + else + echo "missing argument to '-I ' switch" + exit 1 + endif + set o_imdir = "$1" + breaksw + case -R: # set old root directory + if ("$2" != "") then + shift + else + echo "missing argument to '-R ' switch" + exit 1 + endif + set o_iraf = "$1" + breaksw + case -u: # set user name for iraf, e.g, 'iraf' + if ("$2" != "") then + shift + else + echo "missing argument to '-u ' switch" + exit 1 + endif + set user = "$1" + breaksw + default: + echo "install: unknown argument $1" + breaksw + endsw + + if ("$2" == "") then + break + else + shift + endif +end + +# Set $iraf, the new root directory for iraf. The system must already have +# been read in at this directory (e.g., /usr/iraf), but we assume that no +# files have yet been modified. + +if ("$iraf" == "") then + # Make a guess at what the new root directory is. + set d_iraf = "" + if (-d /iraf/iraf) then + set d_iraf = /iraf/iraf + else if (-d /iraf) then + set d_iraf = /iraf + else if (-d /usr/iraf) then + set d_iraf = /usr/iraf + else + # Search for a directory /u*/iraf. + foreach i (/u*) + if (-d $i/iraf) then + set d_iraf = "$i/iraf" + break + endif + end + # Search for a directory /*/iraf. + if ("$d_iraf" == "") then + foreach i (/*) + if (-d $i/iraf) then + set d_iraf = "$i/iraf" + break + endif + end + endif + endif + + if ("$d_iraf" == "") then + set d_iraf = /usr/iraf + endif +else + set d_iraf = $iraf +endif + +# If the given directory doesn't exist, compute the root directory relative +# to $iraf/unix/hlib (our current directory, presumably). + +if (! -d $d_iraf) then + set d_iraf = `(cd ../..;cwd)` +endif + +set d_iraf = `echo $iraf | sed -e 's+/\(["]*\)$+\1+'` +echo -n "new iraf root directory ($d_iraf): " +setenv iraf "$<" +if ("$iraf" == "") then + setenv iraf "$d_iraf" +endif + +# Get the values of o_iraf and o_imdir from the current mkiraf.csh file, if +# not already otherwise defined. + +cd $iraf/unix/hlib +set WS = '[ ]' +if ("$o_iraf" == "") then + set o_iraf =\ + `grep "^set$WS*iraf" mkiraf.csh | sed -e "s+^.*=$WS*++" | sed -e 's+"++g'` +endif +if ("$o_imdir" == "") then + set o_imdir =\ + `grep "^set$WS*imdir" mkiraf.csh | sed -e "s+^.*=$WS*++" | sed -e 's+"++g'` +endif + +# Strip any trailing / in the pathname to be matched, so that the trailing /, +# if present, will be LEFT in the occurrence of the path in the file. + +set o_iraf = `echo $o_iraf | sed -e 's+/\(["]*\)$+\1+'` +set o_imdir = `echo $o_imdir | sed -e 's+/\(["]*\)$+\1+'` + +# Set $imdir, the default user image storage root directory. Each user imdir +# will be a subdirectory of this directory by default, when MKIRAF is run. +# Since bulk image data can consume hundreds of megabytes of disk space, IRAF +# likes to keep such data on a public scratch device, which is probably not +# backed up, which has a short file expiration interval, and possibly which +# has been configured (newfs/mkfs) with a large block size for fast seq. i/o. + +if ("$imdir" == "") then + if (-d $o_imdir) then + set d_imdir = $o_imdir + else if (-d /tmp2) then + set d_imdir = /tmp2/iraf + else if (-d /tmp3) then + set d_imdir = /tmp3/iraf + else if (-d /usr/tmp) then + set d_imdir = /usr/tmp + else + set d_imdir = /tmp + endif + + echo -n "default root image storage directory ($d_imdir): " + set imdir = "$<" + if ("$imdir" == "") then + set imdir = "$d_imdir" + endif +endif + +# Get UNIX directory where HSI commands (links) are to be installed, if not +# set on command line. IRAF will only install a very few new commands in this +# directory. Ideally it should be a directory on the standard user $path, +# so that users do not have to customize their . files just to run IRAF. + +if ("$lbin" == "") then + # Look around and come up with a likely candidate directory. + if (-d /usr/local/bin) then + set d_lbin = /usr/local/bin + else if (-d /local/bin) then + set d_lbin = /local/bin + else + set d_lbin = /usr/bin + endif + + echo -n "local unix commands directory ($d_lbin): " + set lbin = "$<" + if ("$lbin" == "") then + set lbin = "$d_lbin" + endif +endif + +# Verify the machine type. +echo "install iraf for machine type $mach" +# Document the old root pathnames. +echo "old iraf root = $o_iraf, old imdir = $o_imdir" + +# Cannot have iraf and imdir the same. +if ($iraf == $imdir) then + echo "imdir cannot be the same as the iraf root, try again" + exit 1 +endif + +# The following is partially system dependent. +# ------------------------------------------ +# Set the BINDIRS pathnames - directories where the HSI executables go. +set host = "$iraf/unix" +set hbin = "$iraf/unix/bin.$mach" # "mach" is SUN specific!! +set hlib = "$iraf/unix/hlib" +set fbin = "$iraf/bin" + +# Replace any // by /. +set host = `echo $host | sed -e "s+//+/+g"` +set hbin = `echo $hbin | sed -e "s+//+/+g"` +set fbin = `echo $fbin | sed -e "s+//+/+g"` +set hlib = `echo $hlib | sed -e "s+//+/+g"` + +# Strip any trailing /. +set host = `echo $host | sed -e 's+/\(["]*\)$+\1+'` +set hbin = `echo $hbin | sed -e 's+/\(["]*\)$+\1+'` +set fbin = `echo $fbin | sed -e 's+/\(["]*\)$+\1+'` +set hlib = `echo $hlib | sed -e 's+/\(["]*\)$+\1+'` +set BINDIRS = "$hbin $hlib $fbin" + +# The following file lists are partially system dependent. +set PATHFILES = "mkiraf.csh libc/iraf.h cl.csh" +set MODEFILES = "mkiraf.csh mkmlist.csh generic.e mkpkg.e rmbin.e rmfiles.e rpp.e rtar.e wtar.e xc.e xpp.e xyacc.e sgidispatch.e $hbin/sgi2*.e cl.csh mkfloat.csh fc.csh $host/reboot" +set LINKFILES = "cl.e generic.e mkiraf.csh mkmlist.csh mkpkg.e rmbin.e rmfiles.e rtar.e sgidispatch.e wtar.e rpp.e xpp.e xyacc.e xc.e" +# ------------------------------------------ + +# Begin installation. +# ------------------ + +echo "installing iraf at $iraf, imdir=$imdir, lbindir=$lbin" +echo -n "proceed with installation? (yes): "; set temp = $< +if (! ($temp == "" || $temp == "y" || $temp == "yes")) then + echo "installation terminated" + exit 1 +else + echo "" +endif + +# Create the root imdir as a public scratch directory, if not already created. +if (! -d $imdir) then + echo "creating root imdir at $imdir" + if ($exec == yes) then + mkdir $imdir; chmod 777 $imdir + endif +else + if ($exec == yes) then + chmod 777 $imdir + endif + echo "default root imdir is ok" +endif + +# Allow deletion of files in /tmp - needed for multiuser tape allocation. +if ($exec == yes) then + echo "set delete permission on /tmp" + chmod -t /tmp +endif + +# Initialize permissions of tape devices. +if ($exec == yes) then + echo "set mode 0666 on magtape devices to permit tape allocation" + chmod 666 /dev/*st[0-4]* +endif + +# Set owner=root for the device allocation task, alloc.e. + +foreach i ($BINDIRS) + if (-e $i/alloc.e) then + if ("`$LS -l $i/alloc.e | grep 'rwsr-.*root'`" != "") then + echo "device allocation task $i/alloc.e is ok" + else + echo "chown $i/alloc.e to root, set uid modebit" + if ($exec == yes) then + chown 0 $i/alloc.e + chmod u+s $i/alloc.e + endif + endif + break + else + echo "cannot find alloc.e" + endif +end + +# Edit the $iraf pathname in the .login file for user 'iraf'. +cd $iraf/local + +if (-e .login) then + rm -f $TEMP >& /dev/null + sed -e "s+$W$o_iraf+\1$iraf+" .login > $TEMP + cmp -s .login $TEMP + if ($status) then + echo "updating $iraf/local/.login" + PUT $TEMP .login + else + echo "iraf .login file is ok" + rm -f $TEMP + endif +else + echo "cannot find the iraf .login file" +endif + +# Edit the $iraf and $imdir pathnames in the mkiraf.csh and libc/iraf.h files. +cd $iraf/unix/hlib + +foreach i ($PATHFILES) + if (-e $i) then + rm -f $TEMP >& /dev/null + sed -e "s+$W$o_iraf+\1$iraf+" $i |\ + sed -e "s+$W$o_imdir+\1$imdir+" > $TEMP + cmp -s $i $TEMP + if ($status) then + echo "updating $i" + PUT $TEMP $i + if ($exec == yes) then + chmod 755 $i + endif + else + echo "$i is ok" + rm -f $TEMP + endif + else + echo "cannot find $i" + endif +end + +# Set default file permissions for the executable files in the BINDIRS, +# in case the file mode has somehow been changed, e.g., in a file restore +# or copy. + +echo "--------------- Check File Permissions ----------------" + +foreach i ($MODEFILES) + set file = $i + if (! -e $file) then + foreach j ($BINDIRS) + if (-e $j/$i) then + set file = $j/$i + break + endif + end + endif + + if (-e $file) then + if ("`$LS -l $file | grep '^.rwxr.xr.x'`" != "") then + echo "file $file exists with the correct permissions" + else + echo "set mode for $file to 0755" + if ($exec == yes) then + chmod 755 $file + endif + endif + else + echo "cannot find $file" + endif +end + +# Link $hlib/libc/iraf.h to . This is needed not only to compile C +# source files in iraf, but also to define $iraf, $host, etc. for iraf tasks. + +echo "---------------- Check Symbolic Links -----------------" +set file1 = /usr/include/iraf.h +set file2 = $iraf/unix/hlib/libc/iraf.h + +if (-e $file1) then + if ("`$LS -l $file1 | grep $file2`" != "") then + echo "symbolic link $file1 is ok" + else + echo "link $file1 exists but is invalid; unlink $file1" + if ($exec == yes) then + rm -f $file1 + endif + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif +else + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif +endif + +# Establish the remaining symbolic links to HSI tasks. +echo "directory $lbin" +cd $lbin + +foreach i ($LINKFILES) + # Locate the file to be linked to. + set file1 = $i:r + foreach j ($BINDIRS) + set file2 = $j/$file1.csh + if (-e $file2) then + break + endif + set file2 = $j/$i + if (-e $file2) then + break + endif + end + + # Verify or set the link. + if ("`$LS $file1`" == "$file1") then + if ("`$LS -l $file1 | grep $file2`" != "") then + echo "symbolic link $file1 is ok" + else + echo "link $file1 exists but is invalid; unlink $file1" + if ($exec == yes) then + rm -f $file1 + endif + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif + else + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif +end + +# Mark the system update time. +echo 'touch hlib$utime' +if ($exec == yes) then + touch $hlib/utime +endif + +#exit 0 # COMMENT OUT FOR SUN/IRAF + +# SUN/IRAF specific stuff. +# ------------------------------ + +if ($mach == linux || $mach == redhat || $mach == suse || \ + $mach == freebsd || $mach == sunos || $mach == linuxppc) then + set pciraf = yes +else + set pciraf = no +endif + +# If PC-IRAF only do X. +if ($pciraf == yes) then + goto xconfig +endif + +# Install custom suntools (GTERM and IMTOOL). + +if ("`grep Release.4 /etc/motd`" != "" || `mach` == "i386") then + set SUNOS4 = yes +else + set SUNOS4 = no +endif + +echo "" +echo "------------ Custom Suntools Installation -------------" + +if ($SUNOS4 == "yes") then + # SunOS 4.0 and later versions. + # Install GTERM and IMTOOL executables in /usr/bin. + # ---------------------------------- + + # Get the path to the user bin directory. + set usrbin = /usr/bin + if ($mach != `mach`) then + echo -n "/usr/bin directory for machine type $mach ($usrbin): " + set usrbin = "$<" + if ("$usrbin" == "") then + set usrbin = "$usrbin" + endif + endif + + # Install the executables. + cd $usrbin + foreach i (gterm imtool) + set file2 = $hbin/$i.e + # Check if installed executable, if any, is up to date. + if (-e $i) then + rm -f $TEMP.[12] >& /dev/null + size $i > $TEMP.1; size $file2 > $TEMP.2 + cmp -s $TEMP.1 $TEMP.2 + if ($status || "`find $file2 -newer $i -print`" != "") then + set uptodate = no + else + set uptodate = yes + endif + rm $TEMP.[12] + else + set uptodate = no + endif + + # Update file if necessary. + if ($uptodate == no) then + echo "copy $file2 to $usrbin/$i" + if (-e $file2) then + if ($exec == yes) then + if (-e $i) then + rm -f $i + endif + cp $file2 $i + endif + else + echo "file $file2 not found" + endif + else + echo "installed version of $i is up to date" + endif + end + + # Add entries for GTERM and IMTOOL to rootmenu file, if necessary. + set file = /usr/lib/rootmenu + if ("`grep gterm $file`" != "" &&\ + "`grep imtool $file`" != "") then + echo "standard rootmenu file is ok (has gterm, imtool entries)" + else + echo -n "add entries for gterm and imtool to rootmenu file? (yes): " + set temp = "$<" + + if ("$temp" == "" || "$temp" == "y" || "$temp" == "yes") then + (rm -f $TEMP; rm -f $TEMP.s) >& /dev/null + if ("`grep gterm $file`" == "") then + echo '7a\' > $TEMP.s + echo '"Gterm" gterm' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + if ("`grep imtool $file`" == "") then + echo '8a\' > $TEMP.s + echo '"ImTool" imtool' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + endif + endif + +else + # Install the custom Suntools - SunOS versions prior to 4.0. + # ------------------------------- + echo -n "install custom suntools (GTERM, IMTOOL)? (yes): "; set temp = "$<" + if (! ("$temp" == "" || "$temp" == "y" || "$temp" == "yes")) then + echo "suntools installation skipped" + exit 0 + endif + + # The custom suntools executable is upwards compatible with standard + # suntools. If the answer to the query below is yes, the new executable + # replaces /usr/bin/suntools, which is renamed /usr/bin/suntools.BAK. + # If the answer is no, GTERM and IMTOOL will be linked to the uninstalled + # IRAF version of suntools, $iraf/local/suntools, which will work, but + # runtime memory requirements will be 800 Kb or so greater than otherwise. + # The main reason one would not want to use the IRAF /usr/bin/suntools is + # if a custom version of /usr/bin/suntools containing tools not in the + # standard SUN version of suntools has already been installed. + + echo -n "install custom version of /usr/bin/suntools executable? (yes): " + set temp = "$<" + + if ("$temp" == "" || "$temp" == "y" || "$temp" == "yes") then + # Install custom version of /usr/bin/suntools, and make links for gterm + # and imtool in /usr/bin, like the other suntools. + + set usrbin = /usr/bin + set file2 = $hbin/suntools.e + + if ($mach != `mach`) then + echo -n "/usr/bin directory for machine type $mach ($usrbin): " + set usrbin = "$<" + if ("$usrbin" == "") then + set usrbin = "$usrbin" + endif + endif + + set suntools = $usrbin/suntools + + # Check if installed executable is up to date. + rm -f $TEMP.[12] >& /dev/null + size $suntools > $TEMP.1; size $file2 > $TEMP.2 + cmp -s $TEMP.1 $TEMP.2 + if ($status || "`find $file2 -newer $suntools -print`" != "") then + set uptodate = no + else + set uptodate = yes + endif + + rm $TEMP.[12] + + # Update file if necessary. + if ($uptodate == no) then + if (! -e $suntools.BAK) then + echo "rename standard suntools ($suntools) to $suntools.BAK" + if ($exec == yes) then + cp $suntools $suntools.BAK + endif + endif + + echo "copy $file2 to $suntools" + if (-e $file2) then + if ($exec == yes) then + cp $file2 temp + mv -f temp $suntools + endif + else + echo "file $file2 not found" + endif + else + echo "installed version of $suntools is up to date" + endif + + # Add entries for GTERM and IMTOOL to rootmenu file, if necessary. + set file = /usr/lib/rootmenu + if ("`grep gterm $file`" != "" &&\ + "`grep imtool $file`" != "") then + echo "standard rootmenu file is ok (has gterm, imtool entries)" + else + echo -n "add entries for gterm and imtool to rootmenu file? (yes): " + set temp = "$<" + + if ("$temp" == "" || "$temp" == "y" || "$temp" == "yes") then + (rm -f $TEMP; rm -f $TEMP.s) >& /dev/null + if ("`grep gterm $file`" == "") then + echo '7a\' > $TEMP.s + echo '"Gterm" gterm' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + if ("`grep imtool $file`" == "") then + echo '8a\' > $TEMP.s + echo '"ImTool" imtool' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + endif + endif + + # Make sure GTERM and IMTOOL links are in place. + echo "directory $usrbin" + cd $usrbin + + # Note that the following is resolved at runtime, hence the /usr/bin + # is correct regardless of the physical directory. + set exe = /usr/bin/suntools + + foreach i (gterm imtool) + if (-e $lbin/$i) then + echo "remove old symbolic link $lbin/$i" + if ($exec == yes) then + /bin/rm -f $lbin/$i + endif + endif + if (-e $i) then + if ("`$LS -l $i | grep $exe`" != "") then + echo "symbolic link $i is ok" + else + echo "link $i exists but is invalid; unlink it" + if ($exec == yes) then + /bin/rm -f $i + endif + echo "make symbolic link '$i' pointing to $exe" + if ($exec == yes) then + /bin/ln -s $exe $i + endif + endif + else + echo "make symbolic link '$i' pointing to $exe" + if ($exec == yes) then + ln -s $exe $i + endif + endif + end + + else + # Do not install custom suntools and rootmenu files; leave these in + # $hbin, but add links to $lbin for gterm, and imtool, pointing to + # local iraf version of suntools. + + set file = $hbin/suntools.e + if (! -e $file) then + echo "custom suntools executable $file is missing!!" + endif + + echo "directory $lbin" + cd $lbin + foreach i (gterm imtool) + if (-e /usr/bin/$i) then + echo "remove old symbolic link /usr/bin/$i" + if ($exec == yes) then + rm -f /usr/bin/$i + endif + endif + if (-e $i) then + if ("`$LS -l $i | grep iraf`" != "") then + echo "symbolic link $i is ok" + else + echo "link $i exists but is invalid; unlink it" + if ($exec == yes) then + rm -f $i + endif + echo "make symbolic link '$i' -> $file" + if ($exec == yes) then + ln -s $file $i + endif + endif + else + echo "make symbolic link '$i' -> $file" + if ($exec == yes) then + ln -s $file $i + endif + endif + end + endif +endif + +# Common code for GTERM/IMTOOL installation. +# ------------------------------------------- + +xconfig: + +# Make sure special device entries for the IMTOOL display server exist +# in /dev. + +foreach i (/dev/imt1i /dev/imt1o) + if (-e $i) then + echo "imtool device entry $i is ok" + else + echo "make device entry $i for imtool" + if ($exec == yes) then + if ($mach == linux || $mach == redhat || $mach == suse || \ + $mach == linuxppc) then + mknod $i p + else if ($mach == freebsd) then + mkfifo $i + else + mknod $i p + endif + chmod 777 $i + endif + endif +end + +# The old /dev/imt1 entry is now just a link to /dev/imt1o. +set file = /dev/imt1 +if (-e $file) then + if ("`$LS -l $file | grep imt1o`" != "") then + echo "imtool device entry $file is ok" + else + echo "make device entry $file for imtool" + if ($exec == yes) then + rm -f $file + ln -s /dev/imt1o $file + endif + endif +else + echo "make device entry $file for imtool" + if ($exec == yes) then + ln -s /dev/imt1o $file + endif +endif + +# Install the default IMTOOLRC frame buffer configuration file. The path +# /usr/local/lib path hardwired in to imtool and cannot easily be changed, but +# if installation of the default imtoolrc in this directory is not possible, +# the file can be installed in each imtool user's login directory as .imtoolrc, +# or the environment variable IMTOOLRC can be defined in each imtool user's +# .login or .cshrc to define the path to the file. + +# Verify imtoolrc link. +cd /usr/local/lib +set file1 = imtoolrc +set file2 = $iraf/dev/imtoolrc + +# Verify or set the link. +if ("`$LS $file1`" == "$file1") then + if ("`$LS -l $file1 | grep $file2`" != "") then + echo "symbolic link $file1 is ok" + else + echo "link $file1 exists but is invalid; unlink $file1" + if ($exec == yes) then + rm -f $file1 + endif + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif +else + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif +endif + +# Make sure there are entries in the the termcap and graphcap files for xgterm +# and imtool. + +set temp = `grep -l xgterm $iraf/dev/termcap | grep -v "^#"` +if ("$temp" == "") then + echo "WARNING: no xgterm entry in termcap file" +else + echo "termcap file is ok (contains xgterm entry)" +endif + +set gcok = yes +set temp = `grep -l xgterm $iraf/dev/graphcap | grep -v "^#"` +if ("$temp" == "") then + echo "WARNING: no xgterm entry in graphcap file" + set gcok = no +endif +set temp = `grep -l imtool $iraf/dev/graphcap | grep -v "^#"` +if ("$temp" == "") then + echo "WARNING: no imtool entry in graphcap file" + set gcok = no +endif +if ($gcok == yes) then + echo "graphcap file is ok (contains xgterm, imtool entries)" +endif + +# Install or update the XGTERM and XIMTOOL manual pages. +if ($pciraf == no && -e /usr/man/mann) then + cd /usr/man/mann + set src = $iraf/unix/x11 + + foreach i (xgterm ximtool) + set file1 = $i.n + set file2 = $src/$i.man + + # Install or update the manpage source file. + if (-e $file1) then + cmp -s $file1 $file2 + if ($status) then + echo "update $i manual page" + if ($exec == yes) then + cp $file2 $file1 + endif + else + echo "$i manual page is up to date" + endif + else + echo "install $i manual page in /usr/man/mann" + if ($exec == yes) then + cp $file2 $file1 + endif + endif + + # Rerun catman if necessary. + if (-e /usr/man/catl) then + set file2 = /usr/man/catl/$i.n + if (! -e $file2 || "`find $file1 -newer $file2 -print`" != "") then + echo "rerun catman on section n" + if ($exec == yes) then + /usr/etc/catman n + endif + endif + endif + end +endif diff --git a/unix/hlib/install.port b/unix/hlib/install.port new file mode 100755 index 00000000..dea23d01 --- /dev/null +++ b/unix/hlib/install.port @@ -0,0 +1,943 @@ +#!/bin/csh -f +# +# INSTALL -- Install IRAF on a UNIX/IRAF host. May also be run after the +# initial installation as a consistency check to verify that all the necessary +# links and file permissions are still in place (e.g., after updating UNIX +# itself). +# +# Usage: install [-n] [-r rootdir] [-i imdir] [-b localbindir] \ +# [-R oldroot] [-I oldimdir] [-u username (e.g., 'iraf')] +# [-m mach (e.g., 'sparc', 'mc68020') ] +# +# Example: +# % su +# % cd $hlib +# % install -n +# % install +# +# If run with no arguments, INSTALL will make an informed guess and prompt +# with this value; type to accept the value, or enter a new value. +# +# Use "install -n" to do a dry run to see what the would be done, without +# actually modifying the host system and IRAF configuration files. To do the +# actual installation one must be superuser, but anyone can run "install -n" +# to see what it would do. +# ---------------------------------------------------------------------------- + +unset noclobber +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch +set path = (/sbin /usr/sbin /bin /usr/bin /usr/ucb /etc /usr/etc) + +#set echo + +set W = '\([ "]\)' # match a blank, tab, or " +set TEMP = "/tmp/I_temp" +set exec = yes +set user = iraf +set LS = /bin/ls +alias PUT "mv -f \!*; chown $user \!$ " + +# Determine platform architecture. +if (-f /etc/redhat-release) then + if (`uname -m` == "ppc") then + set mach = linuxppc + else + set mach = redhat + endif +else + set mach = `uname -s | tr '[A-Z]' '[a-z]'` +endif + +if ($mach == "darwin") then + set mach = macosx +endif + +if ($?iraf == 1) then + if (! -d $iraf) then + setenv iraf "" + endif +else + setenv iraf "" +endif + +set imdir = "" +set lbin = "" +set o_iraf = "" +set o_imdir = "" + +# Process any command line arguments. +while ("$1" != "") + switch ("$1") + case -n: # no execute + alias PUT "diff \!$ \!^; rm -f $TEMP" + set exec = no + breaksw + case -b: # set local bin directory (unix) + if ("$2" != "") then + shift + else + echo "missing argument to '-b ' switch" + exit 1 + endif + set lbin = "$1" + breaksw + case -i: # set imdir directory + if ("$2" != "") then + shift + else + echo "missing argument to '-i ' switch" + exit 1 + endif + set imdir = "$1" + breaksw + case -m: # set machine type + if ("$2" != "") then + shift + else + echo "missing argument to '-m ' switch" + exit 1 + endif + set mach = "$1" + breaksw + case -r: # set root directory + if ("$2" != "") then + shift + else + echo "missing argument to '-r ' switch" + exit 1 + endif + setenv iraf "$1" + breaksw + case -I: # set old imdir directory + if ("$2" != "") then + shift + else + echo "missing argument to '-I ' switch" + exit 1 + endif + set o_imdir = "$1" + breaksw + case -R: # set old root directory + if ("$2" != "") then + shift + else + echo "missing argument to '-R ' switch" + exit 1 + endif + set o_iraf = "$1" + breaksw + case -u: # set user name for iraf, e.g, 'iraf' + if ("$2" != "") then + shift + else + echo "missing argument to '-u ' switch" + exit 1 + endif + set user = "$1" + breaksw + default: + echo "install: unknown argument $1" + breaksw + endsw + + if ("$2" == "") then + break + else + shift + endif +end + +# Set $iraf, the new root directory for iraf. The system must already have +# been read in at this directory (e.g., /usr/iraf), but we assume that no +# files have yet been modified. + +if ("$iraf" == "") then + # Make a guess at what the new root directory is. + set d_iraf = "" + if (-d /iraf/iraf) then + set d_iraf = /iraf/iraf + else if (-d /iraf) then + set d_iraf = /iraf + else if (-d /usr/iraf) then + set d_iraf = /usr/iraf + else + # Search for a directory /u*/iraf. + foreach i (/u*) + if (-d $i/iraf) then + set d_iraf = "$i/iraf" + break + endif + end + # Search for a directory /*/iraf. + if ("$d_iraf" == "") then + foreach i (/*) + if (-d $i/iraf) then + set d_iraf = "$i/iraf" + break + endif + end + endif + endif + + if ("$d_iraf" == "") then + set d_iraf = /usr/iraf + endif +else + set d_iraf = $iraf +endif + +# If the given directory doesn't exist, compute the root directory relative +# to $iraf/unix/hlib (our current directory, presumably). + +if (! -d $d_iraf) then + set d_iraf = `(cd ../..;cwd)` +endif + +set d_iraf = `echo $iraf | sed -e 's+/\(["]*\)$+\1+'` +echo -n "new iraf root directory ($d_iraf): " +setenv iraf "$<" +if ("$iraf" == "") then + setenv iraf "$d_iraf" +endif + +# Get the values of o_iraf and o_imdir from the current mkiraf.csh file, if +# not already otherwise defined. + +cd $iraf/unix/hlib +set WS = '[ ]' +if ("$o_iraf" == "") then + set o_iraf =\ + `grep "^set$WS*iraf" mkiraf.csh | sed -e "s+^.*=$WS*++" | sed -e 's+"++g'` +endif +if ("$o_imdir" == "") then + set o_imdir =\ + `grep "^set$WS*imdir" mkiraf.csh | sed -e "s+^.*=$WS*++" | sed -e 's+"++g'` +endif + +# Strip any trailing / in the pathname to be matched, so that the trailing /, +# if present, will be LEFT in the occurrence of the path in the file. + +set o_iraf = `echo $o_iraf | sed -e 's+/\(["]*\)$+\1+'` +set o_imdir = `echo $o_imdir | sed -e 's+/\(["]*\)$+\1+'` + +# Set $imdir, the default user image storage root directory. Each user imdir +# will be a subdirectory of this directory by default, when MKIRAF is run. +# Since bulk image data can consume hundreds of megabytes of disk space, IRAF +# likes to keep such data on a public scratch device, which is probably not +# backed up, which has a short file expiration interval, and possibly which +# has been configured (newfs/mkfs) with a large block size for fast seq. i/o. + +if ("$imdir" == "") then + if (-d $o_imdir) then + set d_imdir = $o_imdir + else if (-d /tmp2) then + set d_imdir = /tmp2/iraf + else if (-d /tmp3) then + set d_imdir = /tmp3/iraf + else if (-d /usr/tmp) then + set d_imdir = /usr/tmp + else + set d_imdir = /tmp + endif + + echo -n "default root image storage directory ($d_imdir): " + set imdir = "$<" + if ("$imdir" == "") then + set imdir = "$d_imdir" + endif +endif + +# Get UNIX directory where HSI commands (links) are to be installed, if not +# set on command line. IRAF will only install a very few new commands in this +# directory. Ideally it should be a directory on the standard user $path, +# so that users do not have to customize their . files just to run IRAF. + +if ("$lbin" == "") then + # Look around and come up with a likely candidate directory. + if (-d /usr/local/bin) then + set d_lbin = /usr/local/bin + else if (-d /local/bin) then + set d_lbin = /local/bin + else + set d_lbin = /usr/bin + endif + + echo -n "local unix commands directory ($d_lbin): " + set lbin = "$<" + if ("$lbin" == "") then + set lbin = "$d_lbin" + endif +endif + +# Verify the machine type. +echo "install iraf for machine type $mach" +# Document the old root pathnames. +echo "old iraf root = $o_iraf, old imdir = $o_imdir" + +# Cannot have iraf and imdir the same. +if ($iraf == $imdir) then + echo "imdir cannot be the same as the iraf root, try again" + exit 1 +endif + +# The following is partially system dependent. +# ------------------------------------------ +# Set the BINDIRS pathnames - directories where the HSI executables go. +set host = "$iraf/unix" +set hbin = "$iraf/unix/bin.$mach" # "mach" is SUN specific!! +set hlib = "$iraf/unix/hlib" +set fbin = "$iraf/bin" + +# Replace any // by /. +set host = `echo $host | sed -e "s+//+/+g"` +set hbin = `echo $hbin | sed -e "s+//+/+g"` +set fbin = `echo $fbin | sed -e "s+//+/+g"` +set hlib = `echo $hlib | sed -e "s+//+/+g"` + +# Strip any trailing /. +set host = `echo $host | sed -e 's+/\(["]*\)$+\1+'` +set hbin = `echo $hbin | sed -e 's+/\(["]*\)$+\1+'` +set fbin = `echo $fbin | sed -e 's+/\(["]*\)$+\1+'` +set hlib = `echo $hlib | sed -e 's+/\(["]*\)$+\1+'` +set BINDIRS = "$hbin $hlib $fbin" + +# The following file lists are partially system dependent. +set PATHFILES = "mkiraf.csh libc/iraf.h cl.csh" +set MODEFILES = "mkiraf.csh mkmlist.csh generic.e mkpkg.e rmbin.e rmfiles.e rpp.e rtar.e wtar.e xc.e xpp.e xyacc.e sgidispatch.e $hbin/sgi2*.e cl.csh mkfloat.csh fc.csh $host/reboot" +set LINKFILES = "cl.e generic.e mkiraf.csh mkmlist.csh mkpkg.e rmbin.e rmfiles.e rtar.e sgidispatch.e wtar.e rpp.e xpp.e xyacc.e xc.e" +# ------------------------------------------ + +# Begin installation. +# ------------------ + +echo "installing iraf at $iraf, imdir=$imdir, lbindir=$lbin" +echo -n "proceed with installation? (yes): "; set temp = $< +if (! ($temp == "" || $temp == "y" || $temp == "yes")) then + echo "installation terminated" + exit 1 +else + echo "" +endif + +# Create the root imdir as a public scratch directory, if not already created. +if (! -d $imdir) then + echo "creating root imdir at $imdir" + if ($exec == yes) then + mkdir $imdir; chmod 777 $imdir + endif +else + if ($exec == yes) then + chmod 777 $imdir + endif + echo "default root imdir is ok" +endif + +# Allow deletion of files in /tmp - needed for multiuser tape allocation. +if ($exec == yes) then + echo "set delete permission on /tmp" + chmod -t /tmp +endif + +# Initialize permissions of tape devices. +if ($exec == yes) then + echo "set mode 0666 on magtape devices to permit tape allocation" + chmod 666 /dev/*st[0-4]* +endif + +# Set owner=root for the device allocation task, alloc.e. + +#foreach i ($BINDIRS) +# if (-e $i/alloc.e) then +# if ("`$LS -l $i/alloc.e | grep 'rwsr-.*root'`" != "") then +# echo "device allocation task $i/alloc.e is ok" +# else +# echo "chown $i/alloc.e to root, set uid modebit" +# if ($exec == yes) then +# chown 0 $i/alloc.e +# chmod u+s $i/alloc.e +# endif +# endif +# break +# else +# echo "cannot find alloc.e" +# endif +#end + +# Edit the $iraf pathname in the .login file for user 'iraf'. +cd $iraf/local + +if (-e .login) then + rm -f $TEMP >& /dev/null + sed -e "s+$W$o_iraf+\1$iraf+" .login > $TEMP + cmp -s .login $TEMP + if ($status) then + echo "updating $iraf/local/.login" + PUT $TEMP .login + else + echo "iraf .login file is ok" + rm -f $TEMP + endif +else + echo "cannot find the iraf .login file" +endif + +# Edit the $iraf and $imdir pathnames in the mkiraf.csh and libc/iraf.h files. +cd $iraf/unix/hlib + +foreach i ($PATHFILES) + if (-e $i) then + rm -f $TEMP >& /dev/null + sed -e "s+$W$o_iraf+\1$iraf+" $i |\ + sed -e "s+$W$o_imdir+\1$imdir+" > $TEMP + cmp -s $i $TEMP + if ($status) then + echo "updating $i" + PUT $TEMP $i + if ($exec == yes) then + chmod 755 $i + endif + else + echo "$i is ok" + rm -f $TEMP + endif + else + echo "cannot find $i" + endif +end + +# Set default file permissions for the executable files in the BINDIRS, +# in case the file mode has somehow been changed, e.g., in a file restore +# or copy. + +echo "--------------- Check File Permissions ----------------" + +#foreach i ($MODEFILES) +# set file = $i +# if (! -e $file) then +# foreach j ($BINDIRS) +# if (-e $j/$i) then +# set file = $j/$i +# break +# endif +# end +# endif +# +# if (-e $file) then +# if ("`$LS -l $file | grep '^.rwxr.xr.x'`" != "") then +# echo "file $file exists with the correct permissions" +# else +# echo "set mode for $file to 0755" +# if ($exec == yes) then +# chmod 755 $file +# endif +# endif +# else +# echo "cannot find $file" +# endif +#end + +# Link $hlib/libc/iraf.h to . This is needed not only to compile C +# source files in iraf, but also to define $iraf, $host, etc. for iraf tasks. + +echo "---------------- Check Symbolic Links -----------------" +set file1 = /usr/include/iraf.h +set file2 = $iraf/unix/hlib/libc/iraf.h + +if (-e $file1) then + if ("`$LS -l $file1 | grep $file2`" != "") then + echo "symbolic link $file1 is ok" + else + echo "link $file1 exists but is invalid; unlink $file1" + if ($exec == yes) then + rm -f $file1 + endif + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif +else + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif +endif + +# Establish the remaining symbolic links to HSI tasks. +echo "directory $lbin" +cd $lbin + +foreach i ($LINKFILES) + # Locate the file to be linked to. + set file1 = $i:r + foreach j ($BINDIRS) + set file2 = $j/$file1.csh + if (-e $file2) then + break + endif + set file2 = $j/$i + if (-e $file2) then + break + endif + end + + # Verify or set the link. + if ("`$LS $file1`" == "$file1") then + if ("`$LS -l $file1 | grep $file2`" != "") then + echo "symbolic link $file1 is ok" + else + echo "link $file1 exists but is invalid; unlink $file1" + if ($exec == yes) then + rm -f $file1 + endif + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif + else + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif +end + +# Mark the system update time. +echo 'touch hlib$utime' +if ($exec == yes) then + touch $hlib/utime +endif + +#exit 0 # COMMENT OUT FOR SUN/IRAF + +# SUN/IRAF specific stuff. +# ------------------------------ + +if ($mach == linux || $mach == redhat || $mach == suse || \ + $mach == freebsd || $mach == sunos || $mach == linuxppc) then + set pciraf = yes +else + set pciraf = no +endif + +# If PC-IRAF only do X. +if ($pciraf == yes) then + goto xconfig +endif + +# Install custom suntools (GTERM and IMTOOL). + +if ("`grep Release.4 /etc/motd`" != "" || `mach` == "i386") then + set SUNOS4 = yes +else + set SUNOS4 = no +endif + +echo "" +echo "------------ Custom Suntools Installation -------------" + +if ($SUNOS4 == "yes") then + # SunOS 4.0 and later versions. + # Install GTERM and IMTOOL executables in /usr/bin. + # ---------------------------------- + + # Get the path to the user bin directory. + set usrbin = /usr/bin + if ($mach != `mach`) then + echo -n "/usr/bin directory for machine type $mach ($usrbin): " + set usrbin = "$<" + if ("$usrbin" == "") then + set usrbin = "$usrbin" + endif + endif + + # Install the executables. + cd $usrbin + foreach i (gterm imtool) + set file2 = $hbin/$i.e + # Check if installed executable, if any, is up to date. + if (-e $i) then + rm -f $TEMP.[12] >& /dev/null + size $i > $TEMP.1; size $file2 > $TEMP.2 + cmp -s $TEMP.1 $TEMP.2 + if ($status || "`find $file2 -newer $i -print`" != "") then + set uptodate = no + else + set uptodate = yes + endif + rm $TEMP.[12] + else + set uptodate = no + endif + + # Update file if necessary. + if ($uptodate == no) then + echo "copy $file2 to $usrbin/$i" + if (-e $file2) then + if ($exec == yes) then + if (-e $i) then + rm -f $i + endif + cp $file2 $i + endif + else + echo "file $file2 not found" + endif + else + echo "installed version of $i is up to date" + endif + end + + # Add entries for GTERM and IMTOOL to rootmenu file, if necessary. + set file = /usr/lib/rootmenu + if ("`grep gterm $file`" != "" &&\ + "`grep imtool $file`" != "") then + echo "standard rootmenu file is ok (has gterm, imtool entries)" + else + echo -n "add entries for gterm and imtool to rootmenu file? (yes): " + set temp = "$<" + + if ("$temp" == "" || "$temp" == "y" || "$temp" == "yes") then + (rm -f $TEMP; rm -f $TEMP.s) >& /dev/null + if ("`grep gterm $file`" == "") then + echo '7a\' > $TEMP.s + echo '"Gterm" gterm' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + if ("`grep imtool $file`" == "") then + echo '8a\' > $TEMP.s + echo '"ImTool" imtool' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + endif + endif + +else + # Install the custom Suntools - SunOS versions prior to 4.0. + # ------------------------------- + echo -n "install custom suntools (GTERM, IMTOOL)? (yes): "; set temp = "$<" + if (! ("$temp" == "" || "$temp" == "y" || "$temp" == "yes")) then + echo "suntools installation skipped" + exit 0 + endif + + # The custom suntools executable is upwards compatible with standard + # suntools. If the answer to the query below is yes, the new executable + # replaces /usr/bin/suntools, which is renamed /usr/bin/suntools.BAK. + # If the answer is no, GTERM and IMTOOL will be linked to the uninstalled + # IRAF version of suntools, $iraf/local/suntools, which will work, but + # runtime memory requirements will be 800 Kb or so greater than otherwise. + # The main reason one would not want to use the IRAF /usr/bin/suntools is + # if a custom version of /usr/bin/suntools containing tools not in the + # standard SUN version of suntools has already been installed. + + echo -n "install custom version of /usr/bin/suntools executable? (yes): " + set temp = "$<" + + if ("$temp" == "" || "$temp" == "y" || "$temp" == "yes") then + # Install custom version of /usr/bin/suntools, and make links for gterm + # and imtool in /usr/bin, like the other suntools. + + set usrbin = /usr/bin + set file2 = $hbin/suntools.e + + if ($mach != `mach`) then + echo -n "/usr/bin directory for machine type $mach ($usrbin): " + set usrbin = "$<" + if ("$usrbin" == "") then + set usrbin = "$usrbin" + endif + endif + + set suntools = $usrbin/suntools + + # Check if installed executable is up to date. + rm -f $TEMP.[12] >& /dev/null + size $suntools > $TEMP.1; size $file2 > $TEMP.2 + cmp -s $TEMP.1 $TEMP.2 + if ($status || "`find $file2 -newer $suntools -print`" != "") then + set uptodate = no + else + set uptodate = yes + endif + + rm $TEMP.[12] + + # Update file if necessary. + if ($uptodate == no) then + if (! -e $suntools.BAK) then + echo "rename standard suntools ($suntools) to $suntools.BAK" + if ($exec == yes) then + cp $suntools $suntools.BAK + endif + endif + + echo "copy $file2 to $suntools" + if (-e $file2) then + if ($exec == yes) then + cp $file2 temp + mv -f temp $suntools + endif + else + echo "file $file2 not found" + endif + else + echo "installed version of $suntools is up to date" + endif + + # Add entries for GTERM and IMTOOL to rootmenu file, if necessary. + set file = /usr/lib/rootmenu + if ("`grep gterm $file`" != "" &&\ + "`grep imtool $file`" != "") then + echo "standard rootmenu file is ok (has gterm, imtool entries)" + else + echo -n "add entries for gterm and imtool to rootmenu file? (yes): " + set temp = "$<" + + if ("$temp" == "" || "$temp" == "y" || "$temp" == "yes") then + (rm -f $TEMP; rm -f $TEMP.s) >& /dev/null + if ("`grep gterm $file`" == "") then + echo '7a\' > $TEMP.s + echo '"Gterm" gterm' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + if ("`grep imtool $file`" == "") then + echo '8a\' > $TEMP.s + echo '"ImTool" imtool' >> $TEMP.s + sed -f $TEMP.s < $file > $TEMP + PUT $TEMP $file; rm $TEMP.s + endif + endif + endif + + # Make sure GTERM and IMTOOL links are in place. + echo "directory $usrbin" + cd $usrbin + + # Note that the following is resolved at runtime, hence the /usr/bin + # is correct regardless of the physical directory. + set exe = /usr/bin/suntools + + foreach i (gterm imtool) + if (-e $lbin/$i) then + echo "remove old symbolic link $lbin/$i" + if ($exec == yes) then + /bin/rm -f $lbin/$i + endif + endif + if (-e $i) then + if ("`$LS -l $i | grep $exe`" != "") then + echo "symbolic link $i is ok" + else + echo "link $i exists but is invalid; unlink it" + if ($exec == yes) then + /bin/rm -f $i + endif + echo "make symbolic link '$i' pointing to $exe" + if ($exec == yes) then + /bin/ln -s $exe $i + endif + endif + else + echo "make symbolic link '$i' pointing to $exe" + if ($exec == yes) then + ln -s $exe $i + endif + endif + end + + else + # Do not install custom suntools and rootmenu files; leave these in + # $hbin, but add links to $lbin for gterm, and imtool, pointing to + # local iraf version of suntools. + + set file = $hbin/suntools.e + if (! -e $file) then + echo "custom suntools executable $file is missing!!" + endif + + echo "directory $lbin" + cd $lbin + foreach i (gterm imtool) + if (-e /usr/bin/$i) then + echo "remove old symbolic link /usr/bin/$i" + if ($exec == yes) then + rm -f /usr/bin/$i + endif + endif + if (-e $i) then + if ("`$LS -l $i | grep iraf`" != "") then + echo "symbolic link $i is ok" + else + echo "link $i exists but is invalid; unlink it" + if ($exec == yes) then + rm -f $i + endif + echo "make symbolic link '$i' -> $file" + if ($exec == yes) then + ln -s $file $i + endif + endif + else + echo "make symbolic link '$i' -> $file" + if ($exec == yes) then + ln -s $file $i + endif + endif + end + endif +endif + +# Common code for GTERM/IMTOOL installation. +# ------------------------------------------- + +xconfig: + +# Make sure special device entries for the IMTOOL display server exist +# in /dev. + +foreach i (/dev/imt1i /dev/imt1o) + if (-e $i) then + echo "imtool device entry $i is ok" + else + echo "make device entry $i for imtool" + if ($exec == yes) then + if ($mach == linux || $mach == redhat || $mach == suse || \ + $mach == linuxppc) then + mknod $i p + else if ($mach == freebsd) then + mkfifo $i + else + mknod $i p + endif + chmod 777 $i + endif + endif +end + +# The old /dev/imt1 entry is now just a link to /dev/imt1o. +set file = /dev/imt1 +if (-e $file) then + if ("`$LS -l $file | grep imt1o`" != "") then + echo "imtool device entry $file is ok" + else + echo "make device entry $file for imtool" + if ($exec == yes) then + rm -f $file + ln -s /dev/imt1o $file + endif + endif +else + echo "make device entry $file for imtool" + if ($exec == yes) then + ln -s /dev/imt1o $file + endif +endif + +# Install the default IMTOOLRC frame buffer configuration file. The path +# /usr/local/lib path hardwired in to imtool and cannot easily be changed, but +# if installation of the default imtoolrc in this directory is not possible, +# the file can be installed in each imtool user's login directory as .imtoolrc, +# or the environment variable IMTOOLRC can be defined in each imtool user's +# .login or .cshrc to define the path to the file. + +# Verify imtoolrc link. +cd /usr/local/lib +set file1 = imtoolrc +set file2 = $iraf/dev/imtoolrc + +# Verify or set the link. +if ("`$LS $file1`" == "$file1") then + if ("`$LS -l $file1 | grep $file2`" != "") then + echo "symbolic link $file1 is ok" + else + echo "link $file1 exists but is invalid; unlink $file1" + if ($exec == yes) then + rm -f $file1 + endif + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif + endif +else + echo "make symbolic link $file1 -> $file2" + if ($exec == yes) then + rm -f $file1 + ln -s $file2 $file1 + endif +endif + +# Make sure there are entries in the the termcap and graphcap files for xgterm +# and imtool. + +set temp = `grep -l xgterm $iraf/dev/termcap | grep -v "^#"` +if ("$temp" == "") then + echo "WARNING: no xgterm entry in termcap file" +else + echo "termcap file is ok (contains xgterm entry)" +endif + +set gcok = yes +set temp = `grep -l xgterm $iraf/dev/graphcap | grep -v "^#"` +if ("$temp" == "") then + echo "WARNING: no xgterm entry in graphcap file" + set gcok = no +endif +set temp = `grep -l imtool $iraf/dev/graphcap | grep -v "^#"` +if ("$temp" == "") then + echo "WARNING: no imtool entry in graphcap file" + set gcok = no +endif +if ($gcok == yes) then + echo "graphcap file is ok (contains xgterm, imtool entries)" +endif + +# Install or update the XGTERM and XIMTOOL manual pages. +if ($pciraf == no && -e /usr/man/mann) then + cd /usr/man/mann + set src = $iraf/unix/x11 + + foreach i (xgterm ximtool) + set file1 = $i.n + set file2 = $src/$i.man + + # Install or update the manpage source file. + if (-e $file1) then + cmp -s $file1 $file2 + if ($status) then + echo "update $i manual page" + if ($exec == yes) then + cp $file2 $file1 + endif + else + echo "$i manual page is up to date" + endif + else + echo "install $i manual page in /usr/man/mann" + if ($exec == yes) then + cp $file2 $file1 + endif + endif + + # Rerun catman if necessary. + if (-e /usr/man/catl) then + set file2 = /usr/man/catl/$i.n + if (! -e $file2 || "`find $file1 -newer $file2 -print`" != "") then + echo "rerun catman on section n" + if ($exec == yes) then + /usr/etc/catman n + endif + endif + endif + end +endif diff --git a/unix/hlib/iraf.h b/unix/hlib/iraf.h new file mode 120000 index 00000000..2ad69d48 --- /dev/null +++ b/unix/hlib/iraf.h @@ -0,0 +1 @@ +iraf32.h \ No newline at end of file diff --git a/unix/hlib/iraf32.h b/unix/hlib/iraf32.h new file mode 100644 index 00000000..e2d29a8c --- /dev/null +++ b/unix/hlib/iraf32.h @@ -0,0 +1,162 @@ +# IRAF.H -- Basic IRAF Definitions. These definitions are automatically +# included in every SPP program. See also lib$mach.h. + +# Generic constants. +define ARB 999999999 +define ERR -1 +define EOF -2 +define BOF -3 +define EOT -4 +define BOFL BOF +define EOFL EOF +define EOS 0 +define NO 0 +define YES 1 +define OK 0 +define NULL 0 + +# File I/O. +define READ_ONLY 1 # file access modes +define READ_WRITE 2 +define WRITE_ONLY 3 +define APPEND 4 +define NEW_FILE 5 +define TEMP_FILE 6 +define NEW_COPY 7 +define NEW_IMAGE 5 # nice synonyms for NEW_FILE +define NEW_STRUCT 5 +define NEW_TAPE 5 +define TEXT_FILE 11 # file types +define BINARY_FILE 12 +define DIRECTORY_FILE 13 +define STATIC_FILE 14 +define SYMLINK_FILE 15 +define SPOOL_FILE (-2) +define RANDOM 1 # advice for imagefiles +define SEQUENTIAL 2 +define CLIN 1 # STDIN of the ptask +define CLOUT 2 # STDOUT of the ptask +define STDIN 3 # pseudo files (MAXOFILES + i) +define STDOUT 4 +define STDERR 5 +define STDGRAPH 6 +define STDIMAGE 7 +define STDPLOT 8 + + +# Language Datatypes. +define SZ_BOOL 2 # sizes of the primitive types in chars +define SZ_CHAR 1 +define SZ_SHORT 1 +define SZ_INT 2 +define SZ_LONG 2 +define SZ_REAL 2 +define SZ_DOUBLE 4 +define SZ_COMPLEX 4 +define SZ_POINTER 2 +define SZ_STRUCT 2 +define SZ_USHORT 1 +define SZ_FNAME 255 # max chars in a file name +define SZ_PATHNAME 511 # OS dependent file names +define SZ_LINE 1023 # max chars in a line +define SZ_COMMAND 2047 # max size command block + +define SZ_MII_SHORT 1 # size of MII data in SPP chars +define SZ_MII_LONG 2 +define SZ_MII_REAL 2 +define SZ_MII_DOUBLE 4 +define SZ_MII_INT SZ_MII_LONG + +define SZ_INT32 2 # FIXED -- Do not change! +define SZ_LONG32 2 +define SZ_STRUCT32 2 + +define TY_BOOL 1 # codes for type arguments, sizeof +define TY_CHAR 2 +define TY_SHORT 3 +define TY_INT 4 +define TY_LONG 5 +define TY_REAL 6 +define TY_DOUBLE 7 +define TY_COMPLEX 8 +define TY_POINTER 9 +define TY_STRUCT 10 # last (regular) type code +define TY_USHORT 11 # for image i/o +define TY_UBYTE 12 # (special) for image i/o + +# Indefinite values. +define INDEFS (-32767) +define INDEFL (-2147483647) +define INDEFI INDEFL +define INDEFR 1.6e38 +define INDEFD 1.6d308 +define INDEFX (INDEF,INDEF) +define INDEF INDEFR + +define IS_INDEFS (($1)==INDEFS) +define IS_INDEFL (($1)==INDEFL) +define IS_INDEFI (($1)==INDEFI) +define IS_INDEFR (($1)==INDEFR) +define IS_INDEFD (($1)==INDEFD) +define IS_INDEFX (real($1)==INDEFR) +define IS_INDEF (($1)==INDEFR) + +# Useful macros for pointer conversions in data structures. +define P2C ((($1)-1)*2+1) +define P2S ((($1)-1)*2+1) +define P2I ($1) +define P2L ($1) +define P2R ($1) +define P2D ((($1)-1)/2+1) +define P2X ((($1)-1)/2+1) + +define P2P ($1) # no-op + +# Map the following onto host Fortran intrinsic functions if possible, +# else onto the andi, ori, etc. portable VOS functions. + +# define and andi +# define or ori +# define xor xori +# define not noti + +# Name conversions (to avoid conflicts with host system). Must agree with +# defines in hlib$libc/xnames.h. + +define access xfaccs +define calloc xcallc +define close xfcloe +define delete xfdele +define error xerror +define flush xffluh +define getc xfgetc +define getchar xfgetr +define malloc xmallc +define mfree xmfree +define mktemp xmktep +define note xfnote +define open xfopen +define poll xfpoll +define printf xprinf +define putc xfputc +define putchar xfputr +define qsort xqsort +define read xfread +define realloc xrealc +define seek xfseek +define sizeof xsizef +define strcat xstrct +define strcmp xstrcp +define strcpy xstrcy +define strlen xstrln +define ungetc xfungc +define write xfwrie +define fatal xfatal +define fchdir xfchdr +define fscan xfscan +define getopt xgtopt +define getpid xgtpid +define getuid xgtuid +define rename xfrnam +define reset xreset +define scan xxscan diff --git a/unix/hlib/iraf64.h b/unix/hlib/iraf64.h new file mode 100644 index 00000000..31198fdc --- /dev/null +++ b/unix/hlib/iraf64.h @@ -0,0 +1,164 @@ +# IRAF.H -- Basic IRAF Definitions. These definitions are automatically +# included in every SPP program. See also lib$mach.h. + +# Generic constants. +define ARB 999999999 +define ERR -1 +define EOF -2 +define BOF -3 +define EOT -4 +define BOFL BOF +define EOFL EOF +define EOS 0 +define NO 0 +define YES 1 +define OK 0 +define NULL 0 + +# File I/O. +define READ_ONLY 1 # file access modes +define READ_WRITE 2 +define WRITE_ONLY 3 +define APPEND 4 +define NEW_FILE 5 +define TEMP_FILE 6 +define NEW_COPY 7 +define NEW_IMAGE 5 # nice synonyms for NEW_FILE +define NEW_STRUCT 5 +define NEW_TAPE 5 +define TEXT_FILE 11 # file types +define BINARY_FILE 12 +define DIRECTORY_FILE 13 +define STATIC_FILE 14 +define SYMLINK_FILE 15 +define SPOOL_FILE (-2) +define RANDOM 1 # advice for imagefiles +define SEQUENTIAL 2 +define CLIN 1 # STDIN of the ptask +define CLOUT 2 # STDOUT of the ptask +define STDIN 3 # pseudo files (MAXOFILES + i) +define STDOUT 4 +define STDERR 5 +define STDGRAPH 6 +define STDIMAGE 7 +define STDPLOT 8 + + +# Language Datatypes. +define SZ_BOOL 4 # sizes of the primitive types in chars +define SZ_CHAR 1 +define SZ_SHORT 1 +define SZ_INT 4 +define SZ_LONG 4 +define SZ_REAL 2 +define SZ_DOUBLE 4 +define SZ_COMPLEX 4 +define SZ_POINTER 4 +define SZ_STRUCT 4 +define SZ_USHORT 1 +define SZ_FNAME 511 # max chars in a file name/URL +define SZ_PATHNAME 511 # OS dependent file names +define SZ_LINE 1023 # max chars in a line +define SZ_COMMAND 2047 # max size command block + +define TY_BOOL 1 # codes for type arguments, sizeof +define TY_CHAR 2 +define TY_SHORT 3 +define TY_INT 4 +define TY_LONG 5 +define TY_REAL 6 +define TY_DOUBLE 7 +define TY_COMPLEX 8 +define TY_POINTER 9 +define TY_STRUCT 10 # last (regular) type code +define TY_USHORT 11 # for image i/o +define TY_UBYTE 12 # (special) for image i/o + +define SZ_MII_SHORT 1 # size of MII data in SPP chars +define SZ_MII_LONG 2 +define SZ_MII_REAL 2 +define SZ_MII_DOUBLE 4 +define SZ_MII_INT SZ_MII_LONG + +define SZ_INT32 2 # FIXED -- Do not change ! +define SZ_LONG32 2 +define SZ_STRUCT32 2 + +# Indefinite values. +define INDEFS (-32767) +define INDEFL (-2147483647) +#define INDEFL (-9223372036854775807) +define INDEFI INDEFL +define INDEFR 1.6e38 +define INDEFD 1.6d308 +define INDEFX (INDEF,INDEF) +define INDEF INDEFR + +define IS_INDEFS (($1)==INDEFS) +define IS_INDEFL (($1)==INDEFL) +define IS_INDEFI (($1)==INDEFI) +define IS_INDEFR (($1)==INDEFR) +define IS_INDEFD (($1)==INDEFD) +define IS_INDEFX (real($1)==INDEFR) +define IS_INDEF (($1)==INDEFR) + +# Useful macros for pointer conversions in data structures. +define P2C ((($1)-1)*4+1) +define P2S ((($1)-1)*4+1) +define P2I ($1) +define P2L ($1) +define P2B ($1) +define P2R ((($1)-1)*2+1) +define P2D ($1) +define P2X ($1) + +define P2P ($1) # no-op + +# Map the following onto host Fortran intrinsic functions if possible, +# else onto the andi, ori, etc. portable VOS functions. + +# define and andi +# define or ori +# define xor xori +# define not noti + +# Name conversions (to avoid conflicts with host system). Must agree with +# defines in hlib$libc/xnames.h. + +define access xfaccs +define calloc xcallc +define close xfcloe +define delete xfdele +define error xerror +define flush xffluh +define getc xfgetc +define getchar xfgetr +define malloc xmallc +define mfree xmfree +define mktemp xmktep +define note xfnote +define open xfopen +define poll xfpoll +define printf xprinf +define putc xfputc +define putchar xfputr +define qsort xqsort +define read xfread +define realloc xrealc +define seek xfseek +define sizeof xsizef +define strcat xstrct +define strcmp xstrcp +define strcpy xstrcy +define strlen xstrln +define ungetc xfungc +define write xfwrie +define fatal xfatal +define fchdir xfchdr +define fscan xfscan +define getopt xgtopt +define getpid xgtpid +define getuid xgtuid +define rename xfrnam +define reset xreset +define scan xxscan diff --git a/unix/hlib/irafarch.csh b/unix/hlib/irafarch.csh new file mode 100755 index 00000000..a998aa01 --- /dev/null +++ b/unix/hlib/irafarch.csh @@ -0,0 +1,270 @@ +#!/bin/csh -f +# +# IRAFARCH -- Determine or set the current platform architecture parameters. +# +# Usage: irafarch +# irafarch -set [] [opts] +# irafarch [ -hsi | -nbits | -pipe | -tapecap | -tape ] +# +# -mach print the iraf architecture name [default] +# -hsi print the HSI arch +# -nbits print number of bits in an int (32 or 64) +# -pipe does platform support display fifo pipes? +# -tapecap does platform require tapecap changes? +# -tape does platform support tape drives? +# -shlib does platform support iraf shared libs? +# +# -actual print actual architecture name regardless of IRAFARCH +# -set manually reset the iraf environment architecture +# +# ---------------------------------------------------------------------------- + + +unset noclobber +onintr cleanup_ +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort which + +setenv path "(/sbin /usr/sbin /bin /usr/bin /usr/5bin /usr/ucb /etc /usr/etc $path /usr/local/bin /opt/local/bin /local/bin /home/local/bin /usr/openwin/bin /usr/X11R6/bin /usr/X11/bin)" + +# set echo + + +############################################################################## +# START OF MACHDEP DEFINITIONS. +############################################################################## + +set VERSION = "V2.16.1" +set hmach = "INDEF" +set nbits = 32 +set pipes = 1 +set shlibs = 0 +set tapecaps = 0 +set tapes = 1 + +set debug = 0 + + +#---------------------------------- +# Determine platform architecture. +#---------------------------------- + +if (-e /usr/bin/uname) then + set uname_cmd = /usr/bin/uname +else if (-e /bin/uname) then + set uname_cmd = /bin/uname +else + WARNING "No 'uname' command found to determine architecture." + exit 1 +endif + +setenv UNAME `$uname_cmd | tr '[A-Z]' '[a-z]'` +if ($UNAME == "sunos") then + setenv UNAME_M `$uname_cmd -m | cut -c2- | tr '[A-Z]' '[a-z]'` +else + setenv UNAME_M `$uname_cmd -m | tr '[A-Z]' '[a-z]' | tr ' ' '_'` +endif +setenv OSVERSION `$uname_cmd -r | cut -c1` + + + +# Allow an IRAFARCH definition in the environment to override. +if ($#argv == 1 && "$1" == "-actual") then + setenv MNAME $UNAME + setenv MNAME_M $UNAME_M + unsetenv IRAFARCH + +else if ($#argv == 1 && "$1" == "-current") then + setenv MNAME `/bin/ls -lad $iraf/bin | \ + awk '{ printf ("%s\n", $11) }' | \ + sed -e 's/bin.//g'` + setenv MNAME_M $UNAME_M + setenv IRAFARCH $MNAME + goto repeat_ + +else + if ($#argv == 0) then + if ($?IRAFARCH) then + repeat_: + setenv MNAME $IRAFARCH + setenv MNAME_M $UNAME_M + else + setenv MNAME $UNAME + setenv MNAME_M $UNAME_M + endif + + else + if ($#argv != 0 && "$1" == "-set") then + setenv MNAME $2 + setenv MNAME_M $2 + else + setenv MNAME $UNAME + setenv MNAME_M $UNAME_M + endif + endif +endif + + +# Set some common defaults for most platforms +set shlib = 0 # no shared lib support +set nbits = 32 # 32-bit architecture +set tapecaps = 1 # platform supports tapecaps +set tapes = 1 # platform support tape drives +set pipes = 1 # supports display fifo pipes + +set pciraf = 1 # PC-IRAF system +set suniraf = 0 # SUN-IRAF system + + +if ($debug == 1) then # DEBUG PRINT + if ($?IRAFARCH) then + echo " IRAFARCH = $IRAFARCH" + endif + echo " MNAME = $MNAME" + echo " MNAME_M = $MNAME_M" + echo "OSVERSION = $OSVERSION" +endif + +# Determine parameters for each architecture. +switch ($MNAME) + case darwin: # Mac OS X + case ipad: + case macosx: + case macintel: + if ($?IRAFARCH) then + set mach = "$IRAFARCH" + set hmach = "$IRAFARCH" + if ("$mach" == "macintel") then + set nbits = 64 + endif + else + if ("$MNAME_M" == "x86_64") then # 64-bit + set mach = "macintel" + set hmach = "macintel" + set nbits = 64 + else if ($MNAME_M == "x86" || $MNAME_M == "i386" || $MNAME_M == "ppc" || $MNAME_M == "power_macintosh") then + set mach = "macosx" + set hmach = "macosx" + set nbits = 32 + else + set mach = "ipad" # iOS Device + set hmach = "ipad" + set nbits = 32 + endif + endif + set tapecaps = 0 + set tapes = 0 + set pipes = 0 + breaksw + + case redhat: + case linux: + case linux64: + if ($?IRAFARCH) then + set mach = "$IRAFARCH" + set hmach = "$IRAFARCH" + if ("$mach" == "linux64") then + set nbits = 64 + endif + else + if ("$MNAME_M" == "x86_64") then # Linux x86_64 + set mach = "linux64" + set hmach = "linux64" + set nbits = 64 + else # Linux + set mach = "linux" + set hmach = "linux" + set nbits = 32 + endif + endif + breaksw + + case ssun: + case sparc: + case sunos: + set tapecaps = 1 + if ($UNAME_M != "86pc") then + set suniraf = 1 + set pciraf = 0 + if ($OSVERSION == 5) then # Sparc Solaris + set mach = "ssun" + set hmach = "ssol" + else # Sparc SunOS 4.x + set mach = "sparc" + set hmach = "sparc" + endif + else + set mach = "sunos" # Intel Solaris x86 + set hmach = "sunos" + set tapecaps = 0 + set tapes = 0 + set pipes = 0 + endif + breaksw + + case freebsd: # FreeBSD + set mach = "freebsd" + set hmach = "freebsd" + set tapecaps = 0 + set tapes = 0 + set pipes = 0 + breaksw + + default: + # We don't want to be limited by the CYGWIN version numbering so + # look for a truncated match here before punting. + set os_mach = `echo $UNAME | cut -c1-6` + if ("$os_mach" == "cygwin") then + set mach = "cygwin" + set hmach = "cygwin" + set shlib = 0 + set tapecaps = 0 + set tapes = 0 + set pipes = 0 + breaksw + + else + echo "Unable to configure platform IRAFARCH='$MNAME'." + exit 1 + endif +endsw + +############################################################################## +# END OF MACHDEP DEFINITIONS. +############################################################################## + + +if ($#argv == 0) then + echo $mach +else + + if ("$1" == "-mach") then + echo $mach + else if ("$1" == "-actual") then + echo $mach + else if ("$1" == "-current") then + echo $mach + else if ("$1" == "-hsi") then + echo $hmach + else if ("$1" == "-nbits") then + echo $nbits + else if ("$1" == "-pipes") then + echo $pipes + else if ("$1" == "-tapecap") then + echo $tapecaps + else if ("$1" == "-tapes") then + echo $tapes + else if ("$1" == "-shlib") then + echo $shlib + + else if ("$1" == "-set") then + if ("$2" != "") then + setenv IRAFARCH $2 + shift ; shift + endif + goto repeat_ + else + echo "Invalid option '"$1"'" + endif +endif + +exit 0 diff --git a/unix/hlib/irafarch.sh b/unix/hlib/irafarch.sh new file mode 100755 index 00000000..f42b61d2 --- /dev/null +++ b/unix/hlib/irafarch.sh @@ -0,0 +1,270 @@ +#!/bin/bash +# +# IRAFARCH -- Determine or set the current platform architecture parameters. +# +# Usage: irafarch +# irafarch -set [] [opts] +# irafarch [ -hsi | -nbits | -pipe | -tapecap | -tape ] +# +# -mach print the iraf architecture name [default] +# -hsi print the HSI arch +# -nbits print number of bits in an int (32 or 64) +# -pipe does platform support display fifo pipes? +# -tapecap does platform require tapecap changes? +# -tape does platform support tape drives? +# -shlib does platform support iraf shared libs? +# +# -actual print actual architecture name regardless of IRAFARCH +# -set manually reset the iraf environment architecture +# +# ---------------------------------------------------------------------------- + + +export PATH=/sbin:/usr/sbin:/bin:/usr/bin:/usr/5bin:/usr/ucb:/etc:/usr/etc:$PATH:/usr/local/bin:/opt/local/bin:/local/bin:/home/local/bin + + +############################################################################## +# START OF MACHDEP DEFINITIONS. +############################################################################## + +hmach="INDEF" +nbits=32 +pipes=1 +shlibs=0 +tapecaps=0 +tapes=1 + +debug=0 + +# Get the Utility aliases. +# Initialize the $iraf and environment. +if [ -z "$iraf" ]; then + bindir="`dirname $0`" # get iraf root directory + iraf=${bindir%/*}/../ +fi +source ${iraf}/unix/hlib/util.sh + + +#---------------------------------- +# Determine platform architecture. +#---------------------------------- + +if [ -e /usr/bin/uname ]; then + uname_cmd=/usr/bin/uname +elif [ -e /bin/uname ]; then + uname_cmd=/bin/uname +else + WARNING "No 'uname' command found to determine architecture." + exit 1 +fi + +export UNAME=`$uname_cmd | tr '[A-Z]' '[a-z]'` +if [ $UNAME == "sunos" ]; then + export UNAME_M=`$uname_cmd -m | cut -c2- | tr '[A-Z]' '[a-z]'` +else + export UNAME_M=`$uname_cmd -m | tr '[A-Z]' '[a-z]' | tr ' ' '_'` +fi +export OSVERSION=`$uname_cmd -r | cut -c1` + + +# Allow an IRAFARCH definition in the environment to override. + +_setmname() { + export MNAME=$1 + export MNAME_M=$2 +} + +if (( $# > 1 )); then + if [ "$1" == "-actual" ]; then + _setmname $UNAME $UNAME_M + unset IRAFARCH + + elif [ "$1" == "-current" ]; then + export MNAME=`/bin/ls -lad $iraf/bin | \ + awk '{ printf ("%s\n", $11) }' | \ + sed -e 's/bin.//g'` + export MNAME_M=$UNAME_M + export IRAFARCH=$MNAME + _setmname $IRAFARCH $UNAME_M + fi +else + if (( $# == 0 )); then + if [ -n "$IRAFARCH" ]; then + _setmname $IRAFARCH $UNAME_M + else + _setmname $UNAME $UNAME_M + fi + else + if [ "$1" == "-set" ]; then + _setmname $2 $2 + else + _setmname $UNAME $UNAME_M + fi + fi +fi + + +# Set some common defaults for most platforms +shlib=0 # no shared lib support +nbits=32 # 32-bit architecture +tapecaps=1 # platform supports tapecaps +tapes=1 # platform support tape drives +pipes=1 # supports display fifo pipes + +pciraf=1 # PC-IRAF system +suniraf=0 # SUN-IRAF system + +if (( $debug == 1 )); then # DEBUG PRINT + if [ -n "$IRAFARCH" ]; then + ECHO " IRAFARCH=$IRAFARCH" + fi + ECHO " MNAME=$MNAME" + ECHO " MNAME_M=$MNAME_M" + ECHO "OSVERSION=$OSVERSION" +fi + + +# Determine parameters for each architecture. +case "$MNAME" in + "darwin"|"ipad"|"macosx"|"macintel") # Mac OS X + if [ -n "$IRAFARCH" ]; then + mach="$IRAFARCH" + hmach="$IRAFARCH" + if [ "$mach" == "macintel" ]; then + nbits=64 + fi + else + if [ "$MNAME_M" == "x86_64" ]; then # 64-bit + mach="macintel" + hmach="macintel" + nbits=64 + elif [ "$MNAME_M" == "x86" -o "$MNAME_M" == "i386" ]; then + mach="macosx" + hmach="macosx" + nbits=32 + else + mach="ipad" # iOS Device + hmach="ipad" + nbits=32 + fi + fi + tapecaps=0 + tapes=0 + pipes=0 + ;; + + "redhat"|"linux"|"linux64") + if [ -n "$IRAFARCH" ]; then + mach="$IRAFARCH" + hmach="$IRAFARCH" + if [ "$mach" == "linux64" ]; then + nbits=64 + fi + else + if [ "$MNAME_M" == "x86_64" ]; then # Linux x86_64 + mach="linux64" + hmach="linux64" + nbits=64 + else # Linux + mach="linux" + hmach="linux" + nbits=32 + fi + fi + ;; + + "ssun"|"sparc"|"sunos") + tapecaps=1 + if [ $UNAME_M != "86pc" ]; then + suniraf=1 + pciraf=0 + if [ $OSVERSION == 5 ]; then # Sparc Solaris + mach= "ssun" + hmach= "ssol" + else # Sparc SunOS 4.x + mach="sparc" + hmach="sparc" + fi + else + mach="sunos" # Intel Solaris x86 + hmach="sunos" + tapecaps=0 + tapes=0 + pipes=0 + fi + ;; + + "freebsd") # FreeBSD + mach="freebsd" + hmach="freebsd" + tapecaps=0 + tapes=0 + pipes=0 + ;; + + *) + # We don't want to be limited by the CYGWIN version numbering so + # look for a truncated match here before punting. + os_mach=`ECHO $UNAME | cut -c1-6` + if [ "$os_mach" == "cygwin" ]; then + mach="cygwin" + hmach="cygwin" + shlib=0 + tapecaps=0 + tapes=0 + pipes=0 + else + ECHO 'Unable to determine platform architecture for ($MNAME).' + exit 1 + fi + ;; +esac + +############################################################################## +# END OF MACHDEP DEFINITIONS. +############################################################################## + +# Handle any command-line options. +if (( $# == 0 )); then + ECHO $mach +else + case "$1" in + "-mach") + ECHO $mach + ;; + "-actual") + ECHO $mach + ;; + "-current") + ECHO $mach + ;; + "-hsi") + ECHO $hmach + ;; + "-nbits") + ECHO $nbits + ;; + "-pipes") + ECHO $pipes + ;; + "-tapecap") + ECHO $tapecaps + ;; + "-tapes") + ECHO $tapes + ;; + "-shlib") + ECHO $shlib + ;; + "-set") + if [ -n $2 ]; then + export IRAFARCH=$2 + fi + _setmname $IRAFARCH $UNAME_M + ;; + *) + ECHO 'Invalid option '$1 + ;; + esac +fi + diff --git a/unix/hlib/irafuser.csh b/unix/hlib/irafuser.csh new file mode 100755 index 00000000..b150100d --- /dev/null +++ b/unix/hlib/irafuser.csh @@ -0,0 +1,215 @@ +#!/bin/csh -f +# +# IRAF definitions for the UNIX/csh user. The additional variables iraf$ and +# home$ should be defined in the user's .login file. + + +set old_method = 0 + +if ($old_method == 1) then + +setenv OS_MACH `uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + +if (`uname -m` == "x86_64") then + if ($OS_MACH == "darwin") then + setenv MACH darwin + setenv IRAFARCH darwin + else + setenv MACH linux64 + setenv IRAFARCH linux64 + endif +else if (-f /etc/redhat-release) then + setenv MACH redhat +else + setenv MACH `uname -s | tr '[A-Z]' '[a-z]'` +endif + +if ($MACH == "darwin") then + # Let the IRAFARCH override the machine to support cross compilation. + if ($?IRAFARCH) then + if ("$IRAFARCH" == "macosx") then + setenv MACH macosx + else if ("$IRAFARCH" == "macintel") then + setenv MACH macintel + endif + else + if ("`uname -m`" == "i386") then + setenv MACH macosx + setenv IRAFARCH macosx + else if ("`uname -m`" == "x86_64") then + setenv MACH macintel + setenv IRAFARCH macintel + else + setenv MACH ipad + setenv IRAFARCH ipad + endif + endif +else if ($OS_MACH == "cygwin") then + setenv MACH cygwin +endif + +else # old_method + + set a = `$iraf/unix/hlib/irafarch.csh` + if ($status == 0) then + setenv MACH $a + setenv IRAFARCH $a + else + echo "Error: "$a + exit 1 + endif + +endif # old_method + + +setenv hostid unix +setenv host ${iraf}unix/ +setenv hlib ${iraf}unix/hlib/ +setenv hbin ${iraf}unix/bin.$MACH/ +setenv tmp /tmp/ + +# Default to GCC for compilation. +setenv CC gcc +setenv F77 $hlib/f77.sh +setenv F2C $hbin/f2c.e +setenv RANLIB ranlib + +switch ($MACH) +case freebsd: + setenv HSI_CF "-O -DBSD -DPOSIX -w -Wunused -m32" + setenv HSI_XF "-Inolibc -/DBSD -w -/Wunused -/m32" + setenv HSI_FF "-O -DBLD_KERNEL -m32" + setenv HSI_LF "-static -m32 -B/usr/lib32 -L/usr/lib32" + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "" + setenv HSI_OSLIBS "-lcompat" + set mkzflags = "'lflags=-z' -/static" + breaksw + +case macosx: + setenv HSI_CF "-O -DMACOSX -w -Wunused -arch i386 -m32 -mmacosx-version-min=10.4" + setenv HSI_XF "-Inolibc -/DMACOSX -w -/Wunused -/m32 -/arch -//i386" + setenv HSI_FF "-O -arch i386 -m32 -DBLD_KERNEL -mmacosx-version-min=10.4" + setenv HSI_LF "-arch i386 -m32 -mmacosx-version-min=10.4" + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "" + setenv HSI_OSLIBS "" + set mkzflags = "'lflags=-z'" + breaksw + +case macintel: + setenv HSI_CF "-O -DMACOSX -DMACINTEL -DMACH64 -w -Wunused -m64 -g" + setenv HSI_XF "-Inolibc -/DMACOSX -/DMACINTEL -w -/Wunused -/DMACH64 -/m64" + setenv HSI_FF "-O -m64 -DMACH64 -DBLD_KERNEL" + setenv HSI_LF "-m64 -DMACH64" + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "" + setenv HSI_OSLIBS "" + set mkzflags = "'lflags=-z'" + breaksw + +case ipad: + setenv XC_CFLAGS "-I/var/include" + setenv HSI_CF "-O -I/var/include -DMACOSX -DMACINTEL -DIPAD -w -Wunused" + setenv HSI_XF "-Inolibc -/DMACOSX -/DMACINTEL -/DIPAD -w -/Wunused" + setenv HSI_FF "-O -DBLD_KERNEL" + setenv HSI_LF "" + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "" + setenv HSI_OSLIBS "" + set mkzflags = "'lflags=-z'" + breaksw + +case linux64: + setenv HSI_CF "-g -DLINUX -DREDHAT -DPOSIX -DSYSV -DLINUX64 -DMACH64 -w -m64" + setenv HSI_XF "-g -Inolibc -w -/m64 -/Wunused" + setenv HSI_FF "-g -m64 -DBLD_KERNEL" + setenv HSI_LF "-m64 " + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "" + setenv HSI_OSLIBS "" + set mkzflags = "'lflags=-Nxz -/Wl,-Bstatic'" + breaksw + +case linux: +case redhat: + setenv HSI_CF "-O -DLINUX -DREDHAT -DPOSIX -DSYSV -w -m32 -Wunused" + setenv HSI_XF "-Inolibc -w -/Wunused -/m32" + setenv HSI_FF "-O -DBLD_KERNEL -m32" + setenv HSI_LF "-m32" + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "" + setenv HSI_OSLIBS "" + set mkzflags = "'lflags=-Nxz -/Wl,-Bstatic'" + breaksw + +case sunos: + setenv HSI_CF "-O -DSOLARIS -DX86 -DPOSIX -DSYSV -w -Wunused" + setenv HSI_XF "-Inolibc -w -/Wunused" + setenv HSI_FF "-O" + #setenv HSI_LF "-t -Wl,-Bstatic" + #setenv HSI_LFLAGS "-t -Wl,-Bstatic" + #setenv HSI_OSLIBS \ + # "-lsocket -lnsl -lintl -Wl,-Bdynamic -ldl -Wl,-Bstatic -lelf" + setenv HSI_LF "-t" + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "-t" + setenv HSI_OSLIBS "-lsocket -lnsl -lintl -ldl -lelf" + set mkzflags = "'lflags=-Nxz -/Wl,-Bstatic'" + breaksw + +case cygwin: + setenv HSI_CF "-O -DCYGWIN -DLINUX -DREDHAT -DPOSIX -DSYSV -w -Wunused" + setenv HSI_XF "-Inolibc -w -/Wunused -/DCYGWIN" + setenv HSI_FF "-O" + #setenv HSI_LF "-Wl,-Bstatic" + setenv HSI_LF "" + setenv HSI_F77LIBS "" + setenv HSI_LFLAGS "" + setenv HSI_OSLIBS "${iraf}unix/bin.cygwin/libcompat.a" + set mkzflags = "'lflags=-Nxz -/Wl,-Bstatic'" + breaksw + +default: + echo 'Warning in hlib$irafuser.csh: unknown platform '"$MACH" + exit 1 + breaksw +endsw + + +# Prepend a user file to the compile flags in case we don't +# install as root. +# +set FAKEHOME="$iraf/fakehome" +setenv HSI_CF "-I${FAKEHOME}/.iraf/ $HSI_CF" +setenv HSI_FF "-I${FAKEHOME}/.iraf/ $HSI_FF" +setenv HSI_LF "-I${FAKEHOME}/.iraf/ $HSI_LF" +setenv HSI_XF "-I${FAKEHOME}/.iraf/ $HSI_XF" +setenv XC_CFLAGS "-I${FAKEHOME}/.iraf/" +unset FAKEHOME + + +# The following determines whether or not the VOS is used for filename mapping. +if (-f ${iraf}lib/libsys.a) then + setenv HSI_LIBS\ + "${hlib}libboot.a ${iraf}lib/libsys.a ${iraf}lib/libvops.a ${hlib}libos.a ${hbin}libf2c.a -lm" +else + setenv HSI_CF "$HSI_CF -DNOVOS" + setenv HSI_LIBS "${hlib}libboot.a ${hlib}libos.a" +endif + +setenv HSI_LIBS "$HSI_LIBS $HSI_OSLIBS" + +alias mkiraf ${hlib}mkiraf.csh +alias mkmlist ${hlib}mkmlist.csh +alias mkz ${hbin}mkpkg.e "$mkzflags" + +alias edsym ${hbin}edsym.e +alias generic ${hbin}generic.e +alias mkpkg ${hbin}mkpkg.e +alias rmbin ${hbin}rmbin.e +alias rmfiles ${hbin}rmfiles.e +alias rtar ${hbin}rtar.e +alias wtar ${hbin}wtar.e +alias xc ${hbin}xc.e +alias xyacc ${hbin}xyacc.e diff --git a/unix/hlib/irafuser.sh b/unix/hlib/irafuser.sh new file mode 100755 index 00000000..a4d036cc --- /dev/null +++ b/unix/hlib/irafuser.sh @@ -0,0 +1,158 @@ +#!/bin/bash +# +# IRAF definitions for the UNIX/bash user. The additional variables iraf$ and +# home$ should be defined in the user's .login file. + + +export MACH=`$iraf/unix/hlib/irafarch.sh` +export IRAFARCH=`$iraf/unix/hlib/irafarch.sh` + + + +export hostid=unix +export host=${iraf}unix/ +export hlib=${iraf}unix/hlib/ +export hbin=${iraf}unix/bin.$MACH/ +export tmp=/tmp/ + +# Default to GCC for compilation. +export CC=gcc +export F77=$hlib/f77.sh +export F2C=$hbin/f2c.e +export RANLIB=ranlib + +case "$MACH" in + "freebsd") + export HSI_CF="-O -DBSD -DPOSIX -Wall -Wunused -m32" + export HSI_XF="-Inolibc -/DBSD -w -/Wunused -/m32" + export HSI_FF="-O -DBLD_KERNEL -m32" + export HSI_LF="-static -m32 -B/usr/lib32 -L/usr/lib32" + export HSI_F77LIBS="" + export HSI_LFLAGS="" + export HSI_OSLIBS="-lcompat" + #mkzflags="'lflags=-z' -/static" + ;; + + "macosx") + export HSI_CF="-O -DMACOSX -Wall -Wunused -arch i386 -m32 -mmacosx-version-min=10.4" + export HSI_XF="-Inolibc -/DMACOSX -w -/Wunused -/m32 -/arch -//i386" + export HSI_FF="-O -arch i386 -m32 -DBLD_KERNEL -mmacosx-version-min=10.4" + export HSI_LF="-arch i386 -m32 -mmacosx-version-min=10.4" + export HSI_F77LIBS="" + export HSI_LFLAGS="" + export HSI_OSLIBS="" + #mkzflags="lflags=-z" + ;; + + "macintel") + export HSI_CF="-O -DMACOSX -DMACINTEL -DMACH64 -Wall -Wunused -m64 -g" + export HSI_XF="-Inolibc -/DMACOSX -/DMACINTEL -w -/Wunused -/DMACH64 -/m64" + export HSI_FF="-O -m64 -DMACH64 -DBLD_KERNEL" + export HSI_LF="-m64 -DMACH64" + export HSI_F77LIBS="" + export HSI_LFLAGS="" + export HSI_OSLIBS="" + #mkzflags="lflags=-z" + ;; + + "ipad") + export XC_CFLAGS="-I/var/include" + export HSI_CF="-O -I/var/include -DMACOSX -DMACINTEL -DIPAD -Wall -Wunused" + export HSI_XF="-Inolibc -/DMACOSX -/DMACINTEL -/DIPAD -w -/Wunused" + export HSI_FF="-O -DBLD_KERNEL" + export HSI_LF="" + export HSI_F77LIBS="" + export HSI_LFLAGS="" + export HSI_OSLIBS="" + #mkzflags="lflags=-z" + ;; + + "linux64") + export HSI_CF="-g -DLINUX -DREDHAT -DPOSIX -DSYSV -DLINUX64 -DMACH64 -Wall -m64" + export HSI_XF="-g -Inolibc -w -/m64 -/Wunused" + export HSI_FF="-g -m64 -DBLD_KERNEL" + export HSI_LF="-m64 " + export HSI_F77LIBS="" + export HSI_LFLAGS="" + export HSI_OSLIBS="" + #mkzflags="lflags=-Nxz -/Wl,-Bstatic" + ;; + + "linux" | "redhat") + export HSI_CF="-O -DLINUX -DREDHAT -DPOSIX -DSYSV -w -m32 -Wunused" + export HSI_XF="-Inolibc -w -/Wunused -/m32" + export HSI_FF="-O -DBLD_KERNEL -m32" + export HSI_LF="-m32" + export HSI_F77LIBS="" + export HSI_LFLAGS="" + export HSI_OSLIBS="" + #mkzflags="lflags=-Nxz -/Wl,-Bstatic" + ;; + + "sunos") + export HSI_CF="-O -DSOLARIS -DX86 -DPOSIX -DSYSV -w -Wunused" + export HSI_XF="-Inolibc -w -/Wunused" + export HSI_FF="-O" + #export HSI_LF="-t -Wl,-Bstatic" + #export HSI_LFLAGS="-t -Wl,-Bstatic" + #export HSI_OSLIBS=\ + # "-lsocket -lnsl -lintl -Wl,-Bdynamic -ldl -Wl,-Bstatic -lelf" + export HSI_LF="-t" + export HSI_F77LIBS="" + export HSI_LFLAGS="-t" + export HSI_OSLIBS="-lsocket -lnsl -lintl -ldl -lelf" + #mkzflags="lflags=-Nxz -/Wl,-Bstatic" + ;; + + "cygwin") + export HSI_CF="-O -DCYGWIN -DLINUX -DREDHAT -DPOSIX -DSYSV -w -Wunused" + export HSI_XF="-Inolibc -w -/Wunused -/DCYGWIN" + export HSI_FF="-O" + #export HSI_LF="-Wl,-Bstatic" + export HSI_LF="" + export HSI_F77LIBS="" + export HSI_LFLAGS="" + export HSI_OSLIBS="${iraf}unix/bin.cygwin/libcompat.a" + #mkzflags="lflags=-Nxz -/Wl,-Bstatic" + ;; + +*) + echo 'Warning in hlib$irafuser.csh: unknown platform '"$MACH" + exit 1 + ;; +esac + + +# Prepend a user file to the compile flags in case we don't +# install as root. +# +FAKEHOME=$iraf/fakehome +export HSI_CF="-I${FAKEHOME}/.iraf/ $HSI_CF" +export HSI_FF="-I${FAKEHOME}/.iraf/ $HSI_FF" +export HSI_LF="-I${FAKEHOME}/.iraf/ $HSI_LF" +export HSI_XF="-I${FAKEHOME}/.iraf/ $HSI_XF" +unset FAKEHOME + +# The following determines whether or not the VOS is used for filename mapping. +if [ -f ${iraf}lib/libsys.a ]; then + export HSI_LIBS="${hlib}libboot.a ${iraf}lib/libsys.a ${iraf}lib/libvops.a ${hlib}libos.a ${hbin}libf2c.a -lm" +else + export HSI_CF="$HSI_CF -DNOVOS" + export HSI_LIBS="${hlib}libboot.a ${hlib}libos.a" +fi + +export HSI_LIBS="$HSI_LIBS $HSI_OSLIBS" + +alias mkiraf=${hlib}mkiraf.sh +alias mkmlist=${hlib}mkmlist.sh +#alias mkz=${hbin}mkpkg.e "$mkzflags" + +alias edsym=${hbin}edsym.e +alias generic=${hbin}generic.e +alias mkpkg=${hbin}mkpkg.e +alias rmbin=${hbin}rmbin.e +alias rmfiles=${hbin}rmfiles.e +alias rtar=${hbin}rtar.e +alias wtar=${hbin}wtar.e +alias xc=${hbin}xc.e +alias xyacc=${hbin}xyacc.e diff --git a/unix/hlib/knet.h b/unix/hlib/knet.h new file mode 100644 index 00000000..f1555162 --- /dev/null +++ b/unix/hlib/knet.h @@ -0,0 +1,93 @@ +# KNET.H -- Include in source files which access the IRAF kernel if network +# capabilities are desired. This include file should be permanently referenced +# in such source files. If a system is to be configured without networking +# capabilities, define KNET to be false and comment out the remaining defines +# before compilation of the system libraries. + +define KNET true + +define zardbf kardbf +define zardgd kardgd +define zardlp kardlp +define zardpl kardpl +define zardpr kardpr +define zardsf kardsf +define zawrbf kawrbf +define zawrgd kawrgd +define zawrlp kawrlp +define zawrpl kawrpl +define zawrpr kawrpr +define zawrsf kawrsf +define zawtbf kawtbf +define zawtgd kawtgd +define zawtlp kawtlp +define zawtpl kawtpl +define zawtpr kawtpr +define zawtsf kawtsf +define zclcpr kclcpr +define zcldir kcldir +define zcldpr kcldpr +define zclsbf kclsbf +define zclsgd kclsgd +define zclslp kclslp +define zclspl kclspl +define zclspr kclspr +define zclssf kclssf +define zclstx kclstx +define zclsty kclsty +define zdvall kdvall +define zdvown kdvown +define zfacss kfacss +define zfaloc kfaloc +define zfchdr kfchdr +define zfdele kfdele +define zfgcwd kfgcwd +define zfinfo kfinfo +define zflstx kflstx +define zflsty kflsty +define zfmkcp kfmkcp +define zfmkdr kfmkdr +define zfpath kfpath +define zfprot kfprot +define zfrnam kfrnam +define zfrmdr kfrmdr +define zfsubd kfsubd +define zfutim kfutim +define zfxdir kfxdir +define zgettx kgettx +define zgetty kgetty +define zgfdir kgfdir +define zintpr kintpr +define znottx knottx +define znotty knotty +define zopcpr kopcpr +define zopdir kopdir +define zopdpr kopdpr +define zopnbf kopnbf +define zopngd kopngd +define zopnlp kopnlp +define zopnpl kopnpl +define zopnpr kopnpr +define zopnsf kopnsf +define zopntx kopntx +define zopnty kopnty +define zoscmd koscmd +define zputtx kputtx +define zputty kputty +define zsektx ksektx +define zsekty ksekty +define zsttbf ksttbf +define zsttgd ksttgd +define zsttlp ksttlp +define zsttpl ksttpl +define zsttpr ksttpr +define zsttsf ksttsf +define zstttx kstttx +define zsttty ksttty +define zzclmt kzclmt +define zzopmt kzopmt +define zzrdmt kzrdmt +define zzrwmt kzrwmt +define zzstmt kzstmt +define zzwrmt kzwrmt +define zzwtmt kzwtmt diff --git a/unix/hlib/libboot.a b/unix/hlib/libboot.a new file mode 120000 index 00000000..3083e005 --- /dev/null +++ b/unix/hlib/libboot.a @@ -0,0 +1 @@ +../bin/libboot.a \ No newline at end of file diff --git a/unix/hlib/libc/README b/unix/hlib/libc/README new file mode 100644 index 00000000..a95c47eb --- /dev/null +++ b/unix/hlib/libc/README @@ -0,0 +1,25 @@ +LIBC (C library) include files + + ctype character classes, conversions + error c_erract actions + finfo c_finfo data structure + fset FIO set/stat parameter + knames external kernel names + libc must be included by all files which use libc + math UNIX math functions + spp SPP language definitions + stdio UNIX standard i/o + xnames SPP external names + xwhen c_xwhen (exception handling) + kernel kernel constants, tables + protect file protection + prtype process types + setjmp non-local goto + zfstat FIO driver file status codes + +The file "iraf.h" is referenced as in IRAF C source files, and is used +to load all other IRAF/LIBC C header files via "#define import_XXX" defines in +these files. In order for the C compiler to find , one should either +[1] add the directory $hlib/libc to the list of directories to be searched by +the C compiler for include files, or [2] make a link to, or copy of, +libc/iraf.h in the system directory /usr/include. diff --git a/unix/hlib/libc/alloc.h b/unix/hlib/libc/alloc.h new file mode 100644 index 00000000..e40ca1be --- /dev/null +++ b/unix/hlib/libc/alloc.h @@ -0,0 +1,8 @@ +/* ALLOC.H -- Status returns for ZDVALL, ZDVOWN. + */ +#define DV_DEVFREE 1 /* device is free and can be allocated */ +#define DV_DEVALLOC 2 /* device is already allocated */ +#define DV_DEVINUSE 3 /* device is in use by someone else */ +#define DV_ERROR 9 /* software error from alloc.e */ + +#define D_alloc diff --git a/unix/hlib/libc/ctype.h b/unix/hlib/libc/ctype.h new file mode 100644 index 00000000..e2d3fb59 --- /dev/null +++ b/unix/hlib/libc/ctype.h @@ -0,0 +1,32 @@ +#define _U 01 +#define _L 02 +#define _N 04 +#define _S 010 +#define _P 020 +#define _C 040 +#define _X 0100 + +#ifdef vms +globalvalue vms_ctype_defs; +#endif +extern char u_ctype_[]; + +#define isalpha(c) ((u_ctype_+1)[(unsigned int)(c)]&(_U|_L)) +#define isupper(c) ((u_ctype_+1)[(unsigned int)(c)]&_U) +#define islower(c) ((u_ctype_+1)[(unsigned int)(c)]&_L) +#define isdigit(c) ((u_ctype_+1)[(unsigned int)(c)]&_N) +#define isxdigit(c) ((u_ctype_+1)[(unsigned int)(c)]&(_N|_X)) +#define isspace(c) ((u_ctype_+1)[(unsigned int)(c)]&_S) +#define ispunct(c) ((u_ctype_+1)[(unsigned int)(c)]&_P) +#define isalnum(c) ((u_ctype_+1)[(unsigned int)(c)]&(_U|_L|_N)) +#define isprint(c) ((u_ctype_+1)[(unsigned int)(c)]&(_P|_U|_L|_N)) +#define iscntrl(c) ((u_ctype_+1)[(unsigned int)(c)]&_C) +#define isascii(c) ((unsigned)((int)(c))<=0177) + +#define toupper(c) ((c)-'a'+'A') +#define tolower(c) ((c)-'A'+'a') +#define toascii(c) ((c)&0177) +#define tointeg(c) ((c)-'0') +#define todigit(c) ((c)+'0') + +#define D_ctype diff --git a/unix/hlib/libc/error.h b/unix/hlib/libc/error.h new file mode 100644 index 00000000..c02e7e36 --- /dev/null +++ b/unix/hlib/libc/error.h @@ -0,0 +1,12 @@ +/* Error handling. + */ +#define EA_FATAL 1 +#define EA_ERROR 2 +#define EA_WARN 3 +#define EA_RESTART (-99) + +#define SYS_XACV 501 +#define SYS_XARITH 502 +#define SYS_XINT 503 + +#define D_error diff --git a/unix/hlib/libc/finfo.h b/unix/hlib/libc/finfo.h new file mode 100644 index 00000000..b4c57e70 --- /dev/null +++ b/unix/hlib/libc/finfo.h @@ -0,0 +1,19 @@ +/* File info structure definitions (c_finfo). + */ +#define SZ_OWNERSTR 16 +#define FI_REGULAR 1 /* file types */ +#define FI_DIRECTORY 2 +#define FI_EXECUTABLE 3 +#define FI_SPECIAL 4 + +struct _finfo { + XLONG fi_type; /* file type */ + XLONG fi_size; /* file size, machine bytes */ + XLONG fi_atime; /* time of last access */ + XLONG fi_mtime; /* time of last modify */ + XLONG fi_ctime; /* time of file creation */ + XLONG fi_perm; /* file permission bits */ + char fi_owner[SZ_OWNERSTR*sizeof(XLONG)]; +}; + +#define D_finfo diff --git a/unix/hlib/libc/fpoll.h b/unix/hlib/libc/fpoll.h new file mode 100644 index 00000000..52e6f4d5 --- /dev/null +++ b/unix/hlib/libc/fpoll.h @@ -0,0 +1,59 @@ +/* File poll structure definitions (c_fpoll). + */ +#ifndef D_fpoll +#define D_fpoll + +#define IRAF_POLLIN 0x0001 /* There is data to read */ +#define IRAF_POLLPRI 0x0002 /* There is urgent data to read */ +#define IRAF_POLLOUT 0x0004 /* Writing now will not block */ +#define IRAF_POLLERR 0x0008 /* Error condition */ +#define IRAF_POLLHUP 0x0010 /* Hung up */ +#define IRAF_POLLNVAL 0x0020 /* Invalid request: fd not open */ + +#define SZ_POLLFD 3 /* size of pollfd SPP struct */ +#define MAX_POLL_FD 32 /* max number of polling fds */ +#define INFTIM -1 /* poll indefinitely (block) */ + +struct _fpoll { + XINT fp_fd; /* file type */ + XSHORT fp_events; /* file size, machine bytes */ + XSHORT fp_revents; /* time of last access */ +} poll_fds[MAX_POLL_FD]; + +#ifndef NOLIBCNAMES +#define _IRAF_FPOLL_LIBCNAMES + + +#ifdef POLLIN +#undef POLLIN +#endif +#define POLLIN IRAF_POLLIN + +#ifdef POLLPRI +#undef POLLPRI +#endif + +#define POLLPRI IRAF_POLLPRI +#ifdef POLLOUT +#undef POLLOUT +#endif + +#define POLLOUT IRAF_POLLOUT +#ifdef POLLERR +#undef POLLERR +#endif +#define POLLERR IRAF_POLLERR + +#ifdef POLLHUP +#undef POLLHUP +#endif +#define POLLHUP IRAF_POLLHUP + +#ifdef POLLNVAL +#undef POLLNVAL +#endif +#define POLLNVAL IRAF_POLLNVAL + +#endif /* ! NOLIBCNAMES */ + +#endif diff --git a/unix/hlib/libc/fset.h b/unix/hlib/libc/fset.h new file mode 100644 index 00000000..5d5fb33e --- /dev/null +++ b/unix/hlib/libc/fset.h @@ -0,0 +1,64 @@ +/* + * FSET.H -- FSET/FSTATUS parameters (r = read_only, * = internal to FIO). + * Some of these parameters provide access to the guts of the i/o system and + * should not be used by packages outside FIO, to avoid a dependence on the + * inner workings of FIO. Parameters affecting the file buffer number, types, + * or sizes are read-only after the first i/o to the file. + */ + +#define F_ADVICE 1 /* advice on type of access (rand,seq,def) */ +#define F_ASYNC 2 /* enable asynchronous i/o [y/n] */ +#define F_BLKSIZE 3 /*r device block size, chars */ +#define F_BUFPTR 4 /** install externally created file buffer */ +#define F_BUFSIZE 5 /* file buffer size, chars */ +#define F_BUFTOP 6 /** set pointer to top of buffer */ +#define F_BUFTYPE 7 /* file buffer type (F_LOCAL or F_GLOBAL) */ +#define F_CANCEL 8 /* cancel buffered data */ +#define F_CHANNEL 9 /*r channel number */ +#define F_CLOBBER 10 /* is file clobber enabled [y/n] */ +#define F_CLOSEFD 11 /* close host channel when inactive */ +#define F_DEVCODE 12 /** device driver code (index in devtab) */ +#define F_DEVICE 13 /** address of device read/get routine */ +#define F_EOF 14 /*r is file positioned at EOF [y/n] */ +#define F_FFIOMODE 15 /*r is i/o in progress on channel */ +#define F_FILENAME 16 /*r get file name (fstats) */ +#define F_FILESIZE 17 /*r get file size (fstatl) */ +#define F_FILEWAIT 18 /* is file wait on open enabled [y/n] */ +#define F_FIODES 19 /** struct pointer to file descrip. structure */ +#define F_FIRSTBUFOFF 20 /* file offset of first FIO buf (default=1) */ +#define F_FLUSHNL 21 /* is flush on newline enabled [y/n] */ +#define F_IOMODE 22 /* raw (vs "cooked") mode for terminal i/o */ +#define F_KEEP 23 /* keep file after task completion? */ +#define F_LASTREFFILE 24 /*r get FD of last referenced (active) file */ +#define F_MAXBUFSIZE 25 /*r maximum file buffer size */ +#define F_MODE 26 /*r file access mode (ro,wo,rw) */ +#define F_NBUFS 27 /* number of file buffers */ +#define F_NCHARS 28 /*r nchars last transfer */ +#define F_ONEVERSION 29 /* keep only one version of a file */ +#define F_OPEN 30 /*r is file open */ +#define F_OPTBUFSIZE 31 /*r optimal buffer size for device (chars) */ +#define F_PBBSIZE 32 /* push back buffer size, chars */ +#define F_RAW 33 /*r set/stat raw mode (see F_IOMODE) */ +#define F_READ 34 /*r does file have read access [y/n] */ +#define F_REDIR 35 /*r i/o is redirected */ +#define F_SETREDRAW 36 /*w enable screen redraw code (suspend proc) */ +#define F_SZBBLK 37 /*r size in bytes of last dev block r|w */ +#define F_TYPE 38 /*r file type (text, binary) */ +#define F_UNREAD 39 /*r number of unread chars in FIO buffer */ +#define F_VALIDATE 40 /* validate FIO buffer contents (fseti) */ +#define F_WRITE 41 /*r does file have write access [y/n] */ + +#define F_LOCAL 1 /* allocate local file buffers */ +#define F_GLOBAL 2 /* take file buffers from global pool */ +#define F_GETPROT 2 /* is file protected? */ +#define F_FFIOINACT 0 /* no i/o in progress */ +#define F_FFIOREAD 1 /* read in progress */ +#define F_FFIOWRITE 2 /* write in progress */ + +/* Terminal mode stuff. I/O mode flags maybe combined, e.g., IO_RAW+IO_NDELAY. + */ +#define IO_NORMAL 0 /* "normal" terminal i/o */ +#define IO_RAW 001B /* enables raw mode i/o */ +#define IO_NDELAY 100B /* enables nonblocking i/o */ + +#define D_fset diff --git a/unix/hlib/libc/iraf.h b/unix/hlib/libc/iraf.h new file mode 100644 index 00000000..85c0c60a --- /dev/null +++ b/unix/hlib/libc/iraf.h @@ -0,0 +1,192 @@ +/* + * IRAF.H -- Index to the IRAF/C include files and to the major IRAF + * directories. All directory references in the IRAF system are relative + * to the root directories defined in this file. The UNIX version of IRAF + * scans this file at run time to get the logical directory definitions. + */ + +#ifndef D_iraf +/* ### Start of run time definitions */ +#define HOST "/iraf/iraf/unix/" +#define IRAF "/iraf/iraf/" +#define TMP "/tmp/" +/* ### End of run time definitions */ + +/* Compile time definitions (for C #ifdefs). + */ +/* #define BSDUNIX */ +/* #define SUNOS4 */ + +#define D_iraf +#endif + +/* Include any header files specified in "#define import_XXX" statements + * before we were called. + */ +#ifdef import_libc +#ifndef D_libc +#include "/iraf/iraf/unix/hlib/libc/libc.h" +#endif +#undef import_libc +#endif + +#ifdef import_spp +#ifndef D_spp +#include "/iraf/iraf/unix/hlib/libc/spp.h" +#endif +#undef import_spp +#endif + +#ifdef import_main +#ifndef D_main +#include "/iraf/iraf/unix/hlib/libc/main.h" +#endif +#undef import_main +#endif + +#ifdef import_stdio +#ifndef D_stdio +#include "/iraf/iraf/unix/hlib/libc/stdio.h" +#endif +#undef import_stdio +#endif + +#ifdef import_error +#ifndef D_error +#include "/iraf/iraf/unix/hlib/libc/error.h" +#endif +#undef import_error +#endif + +#ifdef import_ctype +#ifndef D_ctype +#include "/iraf/iraf/unix/hlib/libc/ctype.h" +#endif +#undef import_ctype +#endif + +#ifdef import_finfo +#ifndef D_finfo +#include "/iraf/iraf/unix/hlib/libc/finfo.h" +#endif +#undef import_finfo +#endif + +#ifdef import_fset +#ifndef D_fset +#include "/iraf/iraf/unix/hlib/libc/fset.h" +#endif +#undef import_fset +#endif + +#ifdef import_fpoll +#ifndef D_fpoll +#include "/iraf/iraf/unix/hlib/libc/fpoll.h" +#endif +#undef import_fpoll +#endif + +#ifdef import_kernel +#ifndef D_kernel +#include "/iraf/iraf/unix/hlib/libc/kernel.h" +#endif +#undef import_kernel +#endif + +#ifdef import_xnames +#ifndef D_xnames +#include "/iraf/iraf/unix/hlib/libc/xnames.h" +#endif +#undef import_xnames +#endif + +#ifdef import_knames +#ifndef D_knames +#include "/iraf/iraf/unix/hlib/libc/knames.h" +#endif +#undef import_knames +#endif + +#ifdef import_kproto +#ifndef D_kproto +#include "/iraf/iraf/unix/hlib/libc/kproto.h" +#endif +#undef import_kproto +#endif + +#ifdef import_setjmp +#ifndef D_setjmp +#include "/iraf/iraf/unix/hlib/libc/setjmp.h" +#endif +#undef import_setjmp +#endif + +#ifdef import_xwhen +#ifndef D_xwhen +#include "/iraf/iraf/unix/hlib/libc/xwhen.h" +#endif +#undef import_xwhen +#endif + +#ifdef import_protect +#ifndef D_protect +#include "/iraf/iraf/unix/hlib/libc/protect.h" +#endif +#undef import_protect +#endif + +#ifdef import_prtype +#ifndef D_prtype +#include "/iraf/iraf/unix/hlib/libc/prtype.h" +#endif +#undef import_prtype +#endif + +#ifdef import_zfstat +#ifndef D_zfstat +#include "/iraf/iraf/unix/hlib/libc/zfstat.h" +#endif +#undef import_zfstat +#endif + +#ifdef import_alloc +#ifndef D_alloc +#include "/iraf/iraf/unix/hlib/libc/alloc.h" +#endif +#undef import_alloc +#endif + +#ifdef import_math +#ifndef D_math +#include "/iraf/iraf/unix/hlib/libc/math.h" +#endif +#undef import_math +#endif + +#ifdef import_prstat +#ifndef D_prstat +#include "/iraf/iraf/unix/hlib/libc/prstat.h" +#endif +#undef import_prstat +#endif + +#ifdef import_lexnum +#ifndef D_lexnum +#include "/iraf/iraf/unix/hlib/libc/lexnum.h" +#endif +#undef import_lexnum +#endif + +#ifdef import_ttset +#ifndef D_ttset +#include "/iraf/iraf/unix/hlib/libc/ttset.h" +#endif +#undef import_ttset +#endif + +#ifdef import_stdarg +#ifndef D_stdarg +#include "/iraf/iraf/unix/hlib/libc/stdarg.h" +#endif +#undef import_stdarg +#endif diff --git a/unix/hlib/libc/kernel.h b/unix/hlib/libc/kernel.h new file mode 100644 index 00000000..3b240025 --- /dev/null +++ b/unix/hlib/libc/kernel.h @@ -0,0 +1,107 @@ +/* + * KERNEL.H -- Machine dependent definitions for the 4.1BSD UNIX IRAF Kernel. + * The UNIX include file must also be loaded by any program which + * references "kernel.h". The companion include file "language.h" defines + * the (generally) machine independent kernel definitions. + */ + +#include +#include +#include +#include + + + +#ifndef NOKNET +#define NOKNET /* no networking desired in kernel */ +#endif + +/* Tunable kernel parameters. All buffer sizes are in units of bytes. + * Buffer lengths are in units of whatever the buffer contains. + */ +#define SZ_DISKBLOCK 512 /* used in zsttbf if dev block invar. */ +#define FILE_MODEBITS 0666 /* protection bits for new files */ +#define MAXOFILES 256 /* maximum open files (see ) */ +#define MAXPROCS 20 /* maximum subprocesses per process */ +#define SZ_DEFWORKSET 67108864 /* default working set size, bytes */ +#define SZ_MAXWORKSET 268435456 /* maximum working set (max physmem) */ +#define CLKFREQ 60 /* clock frequency (see zgtime.c) */ + +#define TX_OPTBUFSIZE SZ_LINE /* optimum buffer size for text file */ +#define TX_MAXBUFSIZE 0 /* maximum buffer size for text file */ +#define BF_OPTBUFSIZE 65536 /* optimum buffer size for binary file */ +#define BF_MAXBUFSIZE 0 /* maximum buffer size for binary file */ +#define SF_OPTBUFSIZE 65536 /* optimum buffer size for static file */ +#define SF_MAXBUFSIZE 0 /* maximum buffer size for static file */ +#define KS_OPTBUFSIZE 65536 /* optimal buffer size for KS i/o */ +#define KS_MAXBUFSIZE 0 /* maximum buffer size for KS i/o */ +#define PR_OPTBUFSIZE 65536 /* optimal buffer size for IPC i/o */ +#define PR_MAXBUFSIZE 4096 /* maximum buffer size for IPC i/o */ +#define ND_OPTBUFSIZE 65536 /* optimal buffer size for ND i/o */ +#define ND_MAXBUFSIZE 0 /* maximum buffer size for ND i/o */ +#define PL_OPTBUFSIZE 1024 /* optimum buffer size for plotter */ +#define PL_MAXBUFSIZE 0 /* maximum buffer size for plotter */ +#define LP_OPTBUFSIZE 1024 /* optimum buffer size for line printer */ +#define LP_MAXBUFSIZE 0 /* maximum buffer size for line printer */ + +/* ZLOCVA style pointer to address conversions. These macros are used to + * convert host pointer addresses (in bytes) to/from iraf pointer values + * in units of XCHAR. + */ +#define ADDR_TO_LOC(addr) (((XINT)((XCHAR *)(addr)))>>(sizeof(XCHAR)-1)) +#define LOC_TO_ADDR(loc,type) ((type *)((XCHAR *)((loc)<<(sizeof(XCHAR)-1)))) + + +/* Kernel file descriptor for accessing UNIX files. A static array ZFD of + * descriptor structures is used, indexed by UNIX file descriptor numbers + * numbered beginning at 0, the standard input. + */ +struct fiodes { + FILE *fp; /* file pointer if text file */ + long fpos; /* file offset, bytes */ + long filesize; /* file size at open time */ + int nbytes; /* last nbytes r|w */ + int io_flags; /* fcntl flags */ + short flags; /* access mode flags */ + char *port; /* tty port if tty */ +}; +extern struct fiodes zfd[]; /* array of descriptors */ + +#define KF_CHARMODE 01 /* char input mode, text files */ +#define KF_NOSEEK 02 /* seeks are illegal on device */ +#define KF_NOSTTY 04 /* stty,gtty calls illegal */ +#define KF_NDELAY 010 /* nonblocking reads */ +#define KF_DIRECTIO 020 /* use direct (unbuffered) i/o */ +#define TTYNAME "/dev/tty" /* user terminal (for ZFIOTY) */ +#define U_STDIN "unix-stdin" /* special filename for stdin */ +#define U_STDOUT "unix-stdout" /* special filename for stdout */ +#define U_STDERR "unix-stderr" /* special filename for stderr */ +#define LEN_RAWCMD 5 /* nchars in rawcmd string */ +#define RAWOFF "\033-rAw" /* turn raw mode off */ +#define RAWON "\033+rAw" /* turn raw mode on */ +#define LEN_SETREDRAW 6 /* nchars in setredraw string */ +#define SETREDRAW "\033=rDw" /* set/enable screenredraw code */ + + +#ifdef AUX +#define SIGFUNC sigfunc_t +#else +typedef void (*SIGFUNC)(); +#endif + +typedef void (*PFV)(); +#ifdef MACH64 +typedef long (*PFI)(); +#else +typedef int (*PFI)(); +#endif + + +#ifdef SOLARIS +#define bzero(a,n) memset(a,0,n) +#define bcopy(a,b,n) memmove(b,a,n) +#endif + +extern char *irafpath(); + +#define D_kernel diff --git a/unix/hlib/libc/knames.h b/unix/hlib/libc/knames.h new file mode 100644 index 00000000..a67d302b --- /dev/null +++ b/unix/hlib/libc/knames.h @@ -0,0 +1,371 @@ +/* + * KNAMES.H -- External names of the kernel procedures. These are defined + * because the trailing underscore is peculiar to this version of UNIX. + * On some other system the underscore might not be necessary. UNIX uses + * the underscore to avoid name collisions between Fortran names and C/UNIX + * names. If your system does not employ such a convention, delete the _ but + * do not delete the defines - there will probably be name collisions and + * some of the names will have to be changed. To change the external name + * change the define given here. + */ + +#define IRAF_MAIN irafmn_ +#define ZZSETK zzsetk_ +#define USHLIB ushlib_ +#define VSHLIB vshlib_ +#define VSHEND vshend_ +#define VLIBINIT vlibinit_ +#define KI_CONNECT kicont_ +#define KI_GETHOSTS kigets_ +#define KI_SEND kisend_ +#define KI_RECEIVE kirece_ + +#define ZARDBF zardbf_ +#define ZARDGD zardgd_ +#define ZARDKS zardks_ +#define ZARDLP zardlp_ +#define ZARDND zardnd_ +#define ZARDPL zardpl_ +#define ZARDPR zardpr_ +#define ZARDSF zardsf_ +#define ZAWRBF zawrbf_ +#define ZAWRGD zawrgd_ +#define ZAWRKS zawrks_ +#define ZAWRLP zawrlp_ +#define ZAWRND zawrnd_ +#define ZAWRPL zawrpl_ +#define ZAWRPR zawrpr_ +#define ZAWRSF zawrsf_ +#define ZAWSET zawset_ +#define ZAWTBF zawtbf_ +#define ZAWTGD zawtgd_ +#define ZAWTKS zawtks_ +#define ZAWTLP zawtlp_ +#define ZAWTND zawtnd_ +#define ZAWTPL zawtpl_ +#define ZAWTPR zawtpr_ +#define ZAWTSF zawtsf_ +#define ZCALL0 zcall0_ +#define ZCALL1 zcall1_ +#define ZCALL2 zcall2_ +#define ZCALL3 zcall3_ +#define ZCALL4 zcall4_ +#define ZCALL5 zcall5_ +#define ZCALL6 zcall6_ +#define ZCALL7 zcall7_ +#define ZCALL8 zcall8_ +#define ZCALL9 zcall9_ +#define ZCALLA zcalla_ +#define ZCLCPR zclcpr_ +#define ZCLDIR zcldir_ +#define ZCLDPR zcldpr_ +#define ZCLSBF zclsbf_ +#define ZCLSGD zclsgd_ +#define ZCLSKS zclsks_ +#define ZCLSLP zclslp_ +#define ZCLSND zclsnd_ +#define ZCLSPL zclspl_ +#define ZCLSSF zclssf_ +#define ZCLSTX zclstx_ +#define ZCLSTY zclsty_ +#define ZDOJMP zdojmp_ +#define ZDVALL zdvall_ +#define ZDVOWN zdvown_ +#define ZFACSS zfacss_ +#define ZFALOC zfaloc_ +#define ZFCHDR zfchdr_ +#define ZFDELE zfdele_ +#define ZFGCWD zfgcwd_ +#define ZFINFO zfinfo_ +#define ZFLSTX zflstx_ +#define ZFLSTY zflsty_ +#define ZFLINK zflink_ +#define ZFMKCP zfmkcp_ +#define ZFMKDR zfmkdr_ +#define ZFNBRK zfnbrk_ +#define ZFPATH zfpath_ +#define ZFPROT zfprot_ +#define ZFPOLL zfpoll_ +#define ZFREE zfree_ +#define ZFRNAM zfrnam_ +#define ZFRMDR zfrmdr_ +#define ZFSUBD zfsubd_ +#define ZFULNK zfulnk_ +#define ZFUNC0 zfunc0_ +#define ZFUNC1 zfunc1_ +#define ZFUNC2 zfunc2_ +#define ZFUNC3 zfunc3_ +#define ZFUNC4 zfunc4_ +#define ZFUNC5 zfunc5_ +#define ZFUNC6 zfunc6_ +#define ZFUNC7 zfunc7_ +#define ZFUNC8 zfunc8_ +#define ZFUNC9 zfunc9_ +#define ZFUNCA zfunca_ +#define ZFUTIM zfutim_ +#define ZFXDIR zfxdir_ +#define ZGCMDL zgcmdl_ +#define ZGETTT zgettt_ +#define ZGETTX zgettx_ +#define ZGETTY zgetty_ +#define ZGFDIR zgfdir_ +#define ZGHOST zghost_ +#define ZGMTCO zgmtco_ +#define ZGTENV zgtenv_ +#define ZGTIME zgtime_ +#define ZGTPID zgtpid_ +#define ZINTPR zintpr_ +#define ZLOCPR zlocpr_ +#define ZLOCVA zlocva_ +#define ZMALOC zmaloc_ +#define ZMEMCK zmemck_ +#define ZMFREE zmfree_ +#define ZNOTTX znottx_ +#define ZNOTTY znotty_ +#define ZOPCPR zopcpr_ +#define ZOPDIR zopdir_ +#define ZOPDPR zopdpr_ +#define ZOPNBF zopnbf_ +#define ZOPNGD zopngd_ +#define ZOPNKS zopnks_ +#define ZOPNLP zopnlp_ +#define ZOPNND zopnnd_ +#define ZOPNPL zopnpl_ +#define ZOPNSF zopnsf_ +#define ZOPNTX zopntx_ +#define ZOPNTY zopnty_ +#define ZOSCMD zoscmd_ +#define ZPANIC zpanic_ +#define ZPUTTX zputtx_ +#define ZPUTTY zputty_ +#define ZRALOC zraloc_ +#define ZSEKTX zsektx_ +#define ZSEKTY zsekty_ +#define ZSTTBF zsttbf_ +#define ZSTTGD zsttgd_ +#define ZSTTKS zsttks_ +#define ZSTTLP zsttlp_ +#define ZSTTND zsttnd_ +#define ZSTTPL zsttpl_ +#define ZSTTPR zsttpr_ +#define ZSTTSF zsttsf_ +#define ZSTTTX zstttx_ +#define ZSTTTY zsttty_ +#define ZSVJMP zsvjmp_ +#define ZTSLEE ztslee_ +#define ZWMSEC zwmsec_ +#define ZXGMES zxgmes_ +#define ZXWHEN zxwhen_ +#define ZZCLMT zzclmt_ +#define ZZEPRO zzepro_ +#define ZZOPMT zzopmt_ +#define ZZRDMT zzrdmt_ +#define ZZRWMT zzrwmt_ +#define ZZSETK zzsetk_ +#define ZZSTMT zzstmt_ +#define ZZSTOP zzstop_ +#define ZZSTRT zzstrt_ +#define ZZWRMT zzwrmt_ +#define ZZWTMT zzwtmt_ + + + +/* If KNET name mapping is enabled selected machine level kernel names are + * mapped into procedures in the KI (kernel interface) package. This is + * necessary if the high level code is to have networking capabilities. + * Define NOKNET to disable this mapping, e.g., in the kernel itself. + */ + +#ifndef NOKNET + +#define zardnd_ kardnd_ +#define zawrnd_ kawrnd_ +#define zawtnt_ kawtnd_ +#define zclsnd_ kclsnd_ +#define zfchdr_ kfchdr_ +#define zfgcwd_ kfgcwd_ +#define zfpath_ kfpath_ +#define zfsubd_ kfsubd_ +#define zopnnd_ kopnnd_ +#define zsttnd_ ksttnd_ +#define zardbf_ kardbf_ +#define zardlp_ kardlp_ +#define zardpl_ kardpl_ +#define zardpr_ kardpr_ +#define zardsf_ kardsf_ +#define zawrbf_ kawrbf_ +#define zawrlp_ kawrlp_ +#define zawrpl_ kawrpl_ +#define zawrpr_ kawrpr_ +#define zawrsf_ kawrsf_ +#define zawtbf_ kawtbf_ +#define zawtlp_ kawtlp_ +#define zawtpl_ kawtpl_ +#define zawtpr_ kawtpr_ +#define zawtsf_ kawtsf_ +#define zclcpr_ kclcpr_ +#define zcldir_ kcldir_ +#define zcldpr_ kcldpr_ +#define zclsbf_ kclsbf_ +#define zclslp_ kclslp_ +#define zclspl_ kclspl_ +#define zclspr_ kclspr_ +#define zclssf_ kclssf_ +#define zclstx_ kclstx_ +#define zclsty_ kclsty_ +#define zdvall_ kdvall_ +#define zdvown_ kdvown_ +#define zfacss_ kfacss_ +#define zfaloc_ kfaloc_ +#define zfdele_ kfdele_ +#define zfinfo_ kfinfo_ +#define zflstx_ kflstx_ +#define zflsty_ kflsty_ +#define zfmkcp_ kfmkcp_ +#define zfmkdr_ kfmkdr_ +#define zfprot_ kfprot_ +#define zfrnam_ kfrnam_ +#define zfrmdr_ kfrmdr_ +#define zfutim_ kfutim_ +#define zgettx_ kgettx_ +#define zgetty_ kgetty_ +#define zgfdir_ kgfdir_ +#define zintpr_ kintpr_ +#define znottx_ knottx_ +#define znotty_ knotty_ +#define zopcpr_ kopcpr_ +#define zopdir_ kopdir_ +#define zopdpr_ kopdpr_ +#define zopnbf_ kopnbf_ +#define zopnlp_ kopnlp_ +#define zopnpl_ kopnpl_ +#define zopnpr_ kopnpr_ +#define zopnsf_ kopnsf_ +#define zopntx_ kopntx_ +#define zopnty_ kopnty_ +#define zoscmd_ koscmd_ +#define zputtx_ kputtx_ +#define zputty_ kputty_ +#define zsektx_ ksektx_ +#define zsekty_ ksekty_ +#define zsttbf_ ksttbf_ +#define zsttlp_ ksttlp_ +#define zsttpl_ ksttpl_ +#define zsttpr_ ksttpr_ +#define zsttsf_ ksttsf_ +#define zstttx_ kstttx_ +#define zsttty_ ksttty_ +#define zzclmt_ kzclmt_ +#define zzopmt_ kzopmt_ +#define zzrdmt_ kzrdmt_ +#define zzrwmt_ kzrwmt_ +#define zzstmt_ kzstmt_ +#define zzwrmt_ kzwrmt_ +#define zzwtmt_ kzwtmt_ + + +#endif + +/* Procedure names of miscellaneous potentially machine dependent Bit and Byte + * Primitives. + */ +#define ACLRB aclrb_ +#define ANDI andi_ +#define ANDL andl_ +#define ANDS ands_ +#define BITMOV bitmov_ +#define BITPAK bitpak_ +#define BITUPK bitupk_ +#define BSWAP2 bswap2_ +#define BSWAP4 bswap4_ +#define BSWAP8 bswap8_ +#define BYTMOV bytmov_ +#define CHRPAK chrpak_ +#define CHRUPK chrupk_ +#define D1MACH d1mach_ +#define I1MACH i1mach_ +#define MIILEN miilen_ +#define MIIPAK miipak_ +#define MIIUPK miiupk_ +#define NOTI noti_ +#define NOTL notl_ +#define NOTS nots_ +#define ORI ori_ +#define ORL orl_ +#define ORS ors_ +#define R1MACH r1mach_ +#define SHIFTI shifti_ +#define SHIFTS shifts_ +#define SHIFTL shiftl_ +#define STRPAK strpak_ +#define STRUPK strupk_ +#define XORI xori_ +#define XORL xorl_ +#define XORS xors_ +#define I32TO64 i32to4_ +#define I64TO32 i64to2_ +#define IPAK32 ipak32_ +#define IUPK32 iupk32_ +#define IPAK16 ipak16_ +#define IUPK16 iupk16_ +#define IMUL32 imul32_ +#define ISCL32 iscl32_ +#define ISCL64 iscl64_ +#define STRSUM strsum_ + +#define ACLRC aclrc_ +#define ACLRD aclrd_ +#define ACLRI aclri_ +#define ACLRL aclrl_ +#define ACLRR aclrr_ +#define ACLRS aclrs_ +#define AMOVC amovc_ +#define AMOVD amovd_ +#define AMOVI amovi_ +#define AMOVL amovl_ +#define AMOVR amovr_ +#define AMOVS amovs_ + +/* Procedure names for the potentially machine dependent VOPS vector + * primitives. The ACHT stands for change datatype, the B suffix refers + * to primitives which deal with unsigned machine bytes, and the U suffix + * refers to primitives which deal with unsigned short (16 bit) integers. + */ +#define ACHTBB achtbb_ +#define ACHTBC achtbc_ +#define ACHTBD achtbd_ +#define ACHTBI achtbi_ +#define ACHTBL achtbl_ +#define ACHTBR achtbr_ +#define ACHTBS achtbs_ +#define ACHTBU achtbu_ +#define ACHTBX achtbx_ +#define ACHTCB achtcb_ +#define ACHTCU achtcu_ +#define ACHTDB achtdb_ +#define ACHTDU achtdu_ +#define ACHTIB achtib_ +#define ACHTIU achtiu_ +#define ACHTLB achtlb_ +#define ACHTLU achtlu_ +#define ACHTRB achtrb_ +#define ACHTRU achtru_ +#define ACHTSB achtsb_ +#define ACHTSU achtsu_ +#define ACHTUB achtub_ +#define ACHTUC achtuc_ +#define ACHTUD achtud_ +#define ACHTUI achtui_ +#define ACHTUL achtul_ +#define ACHTUR achtur_ +#define ACHTUS achtus_ +#define ACHTUU achtuu_ +#define ACHTUX achtux_ +#define ACHTXB achtxb_ +#define ACHTXU achtxu_ + +/* +#define import_kproto +*/ + +#define D_knames diff --git a/unix/hlib/libc/kproto.h b/unix/hlib/libc/kproto.h new file mode 100644 index 00000000..df300f81 --- /dev/null +++ b/unix/hlib/libc/kproto.h @@ -0,0 +1,496 @@ +/* + * KPROTO.H -- IRAF Kernel prototype definitions. + */ + +#include +#include /* for time_t */ +#include /* for siginfo_t */ + +#ifndef MACH64 + + +/* alloc.c */ +extern int main(int argc, char *argv[]); +extern int alloc(char *argv[], int statonly); +extern int dealloc(char *argv[]); +extern int findsfs(char *argv[]); +/* dio.c */ +extern int directio(int fd, int advice); +/* getproc.c */ +extern int uid_executing(int uid); +/* gmttolst.c */ +extern time_t gmt_to_lst(time_t gmt); +/* irafpath.c */ +extern char *irafpath(char *fname); +/* prwait.c */ +extern void pr_enter(int pid, int inchan, int outchan); +extern int pr_wait(int pid); +extern int pr_getipc(int pid, int *inchan, int *outchan); +extern struct proctable *pr_findpid(int pid); +extern void pr_release(int pid); +/* tape.c */ +extern int main(int argc, char *argv[]); +extern void mtop(int op, int count); +extern char *nextcmd(FILE *in); +extern char *gettok(void); +extern char *prompt(void); +extern void pstatus(void); +extern void output(char *text); +extern void phelp(void); +/* zalloc.c */ +extern int zdvall_(shortint *aliases, int *allflg, int *status); +extern int zdvown_(shortint *device, shortint *owner, int *maxch, int *status); +extern int loggedin(int uid); +/* zawset.c */ +extern int zawset_(int *best_size, int *new_size, int *old_size, int *max_size); +/* zcall.c */ +extern int zcall0_(int *proc); +extern int zcall1_(int *proc, void *arg1); +extern int zcall2_(int *proc, void *arg1, void *arg2); +extern int zcall3_(int *proc, void *arg1, void *arg2, void *arg3); +extern int zcall4_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zcall5_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zcall6_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zcall7_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zcall8_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zcall9_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zcalla_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +/* zdojmp.c */ +extern void zdojmp_(int *jmpbuf, int *status); +/* zfacss.c */ +extern int zfacss_(shortint *fname, int *mode, int *type, int *status); +/* zfaloc.c */ +extern int zfaloc_(shortint *fname, int *nbytes, int *status); +/* zfchdr.c */ +extern int zfchdr_(shortint *newdir, int *status); +/* zfdele.c */ +extern int zfdele_(shortint *fname, int *status); +/* zfgcwd.c */ +extern int zfgcwd_(shortint *outstr, int *maxch, int *status); +/* zfinfo.c */ +extern int zfinfo_(shortint *fname, int *finfo_struct, int *status); +/* zfiobf.c */ +extern int zopnbf_(shortint *osfn, int *mode, int *chan); +extern int zclsbf_(int *fd, int *status); +extern int zardbf_(int *chan, shortint *buf, int *maxbytes, int *offset); +extern int zawrbf_(int *chan, shortint *buf, int *nbytes, int *offset); +extern int zawtbf_(int *fd, int *status); +extern int zsttbf_(int *fd, int *param, int *lvalue); +extern int _u_fmode(int mode); +extern int vm_access(char *fname, int mode); +extern int vm_delete(char *fname, int force); +extern int vm_reservespace(long nbytes); +extern int vm_largefile(long nbytes); +extern int vm_directio(int fd, int flag); +/* zfioks.c */ +extern int zopnks_(shortint *x_server, int *mode, int *chan); +extern int zclsks_(int *chan, int *status); +extern int zardks_(int *chan, shortint *buf, int *totbytes, int *loffset); +extern int zawrks_(int *chan, shortint *buf, int *totbytes, int *loffset); +extern int zawtks_(int *chan, int *status); +extern int zsttks_(int *chan, int *param, int *lvalue); +extern void pr_mask(char *str); +/* zfiolp.c */ +extern int zopnlp_(shortint *printer, int *mode, int *chan); +extern int zclslp_(int *chan, int *status); +extern int zardlp_(int *chan, shortint *buf, int *maxbytes, int *offset); +extern int zawrlp_(int *chan, shortint *buf, int *nbytes, int *offset); +extern int zawtlp_(int *chan, int *status); +extern int zsttlp_(int *chan, int *param, int *lvalue); +/* zfiomt.c */ +extern int zzopmt_(shortint *device, int *acmode, shortint *devcap, int *devpos, int *newfile, int *chan); +extern int zzclmt_(int *chan, int *devpos, int *o_status); +extern int zzrdmt_(int *chan, shortint *buf, int *maxbytes, int *offset); +extern int zzwrmt_(int *chan, shortint *buf, int *nbytes, int *offset); +extern int zzwtmt_(int *chan, int *devpos, int *o_status); +extern int zzstmt_(int *chan, int *param, int *lvalue); +extern int zzrwmt_(shortint *device, shortint *devcap, int *o_status); +/* zfiond.c */ +extern int zopnnd_(shortint *pk_osfn, int *mode, int *chan); +extern int zclsnd_(int *fd, int *status); +extern int zardnd_(int *chan, shortint *buf, int *maxbytes, int *offset); +extern int zawrnd_(int *chan, shortint *buf, int *nbytes, int *offset); +extern int zawtnd_(int *fd, int *status); +extern int zsttnd_(int *fd, int *param, int *lvalue); +/* zfiopl.c */ +extern int zopnpl_(shortint *plotter, int *mode, int *chan); +extern int zclspl_(int *chan, int *status); +extern int zardpl_(int *chan, shortint *buf, int *maxbytes, int *offset); +extern int zawrpl_(int *chan, shortint *buf, int *nbytes, int *offset); +extern int zawtpl_(int *chan, int *status); +extern int zsttpl_(int *chan, int *param, int *lvalue); +/* zfiopr.c */ +extern int zopcpr_(shortint *osfn, int *inchan, int *outchan, int *pid); +extern int zclcpr_(int *pid, int *exit_status); +extern int zardpr_(int *chan, shortint *buf, int *maxbytes, int *loffset); +extern int zawrpr_(int *chan, shortint *buf, int *nbytes, int *loffset); +extern int zawtpr_(int *chan, int *status); +extern int zsttpr_(int *chan, int *param, int *lvalue); +/* zfiosf.c */ +extern int zopnsf_(shortint *osfn, int *mode, int *chan); +extern int zclssf_(int *fd, int *status); +extern int zardsf_(int *chan, shortint *buf, int *maxbytes, int *offset); +extern int zawrsf_(int *chan, shortint *buf, int *nbytes, int *offset); +extern int zawtsf_(int *fd, int *status); +extern int zsttsf_(int *fd, int *param, int *lvalue); +/* zfiotx.c */ +extern int zopntx_(shortint *osfn, int *mode, int *chan); +extern int zclstx_(int *fd, int *status); +extern int zflstx_(int *fd, int *status); +extern int zgettx_(int *fd, shortint *buf, int *maxchars, int *status); +extern int znottx_(int *fd, int *offset); +extern int zputtx_(int *fd, shortint *buf, int *nchars, int *status); +extern int zsektx_(int *fd, int *znottx_offset, int *status); +extern int zstttx_(int *fd, int *param, int *value); +/* zfioty.c */ +extern int zopnty_(shortint *osfn, int *mode, int *chan); +extern int zclsty_(int *fd, int *status); +extern int zflsty_(int *fd, int *status); +extern int zgetty_(int *fd, shortint *buf, int *maxchars, int *status); +extern int znotty_(int *fd, int *offset); +extern int zputty_(int *fd, shortint *buf, int *nchars, int *status); +extern int zsekty_(int *fd, int *znotty_offset, int *status); +extern int zsttty_(int *fd, int *param, int *value); +/* zfmkcp.c */ +extern int zfmkcp_(shortint *osfn, shortint *new_osfn, int *status); +/* zfmkdr.c */ +extern int zfmkdr_(shortint *newdir, int *status); +/* zfnbrk.c */ +extern int zfnbrk_(shortint *vfn, int *uroot_offset, int *uextn_offset); +/* zfpath.c */ +extern int zfpath_(shortint *osfn, shortint *pathname, int *maxch, int *nchars); +/* zfpoll.c */ +extern int zfpoll_(int *pfds, int *nfds, int *timeout, int *npoll, int *status); +/* zfprot.c */ +extern int zfprot_(shortint *fname, int *action, int *status); +/* zfrnam.c */ +extern int zfrnam_(shortint *oldname, shortint *newname, int *status); +/* zfrmdr.c */ +extern int zfrmdr_(shortint *dir, int *status); +/* zfsubd.c */ +extern int zfsubd_(shortint *osdir, int *maxch, shortint *subdir, int *nchars); +/* zfunc.c */ +extern int zfunc0_(int *proc); +extern int zfunc1_(int *proc, void *arg1); +extern int zfunc2_(int *proc, void *arg1, void *arg2); +extern int zfunc3_(int *proc, void *arg1, void *arg2, void *arg3); +extern int zfunc4_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zfunc5_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zfunc6_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zfunc7_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zfunc8_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zfunc9_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zfunca_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +/* zfutim.c */ +extern int zfutim_(shortint *fname, int *atime, int *mtime, int *status); +/* zfxdir.c */ +extern int zfxdir_(shortint *osfn, shortint *osdir, int *maxch, int *nchars); +/* zgcmdl.c */ +extern int zgcmdl_(shortint *cmd, int *maxch, int *status); +/* zghost.c */ +extern int zghost_(shortint *outstr, int *maxch); +/* zglobl.c */ +/* zgmtco.c */ +extern int zgmtco_(int *gmtcor); +/* zgtenv.c */ +extern int zgtenv_(shortint *envvar, shortint *outstr, int *maxch, int *status); +/* zgtime.c */ +extern int zgtime_(int *clock_time, int *cpu_time); +/* zgtpid.c */ +extern int zgtpid_(int *pid); +/* zintpr.c */ +extern int zintpr_(int *pid, int *exception, int *status); +/* zlocpr.c +extern int zlocpr_(PFI proc, int *o_epa); +*/ +/* zlocva.c */ +extern int zlocva_(shortint *variable, int *location); +/* zmain.c */ +extern int main(int argc, char *argv[]); +/* zmaloc.c */ +extern int zmaloc_(int *buf, int *nbytes, int *status); +/* zmfree.c */ +extern int zmfree_(int *buf, int *status); +/* zopdir.c */ +extern int zopdir_(shortint *fname, int *chan); +extern int zcldir_(int *chan, int *status); +extern int zgfdir_(int *chan, shortint *outstr, int *maxch, int *status); +/* zopdpr.c */ +extern int zopdpr_(shortint *osfn, shortint *bkgfile, shortint *queue, int *jobcode); +extern int zcldpr_(int *jobcode, int *killflag, int *exit_status); +/* zoscmd.c */ +extern int zoscmd_(shortint *oscmd, shortint *stdin_file, shortint *stdout_file, shortint *stderr_file, int *status); +extern int pr_onint(int usig, int *hwcode, int *scp); +/* zpanic.c */ +extern int zpanic_(int *errcode, shortint *errmsg); +extern int kernel_panic(char *errmsg); +/* zraloc.c */ +extern int zraloc_(int *buf, int *nbytes, int *status); +/* zshlib.c */ +extern void vlibinit_(void); +/* zwmsec.c */ +extern int zwmsec_(int *msec); +/* zxwhen.c */ +extern int zxwhen_(int *sig_code, int *epa, int *old_epa); +extern void ex_handler(int unix_signal, siginfo_t *info, void *ucp); +extern int zxgmes_(int *os_exception, shortint *errmsg, int *maxch); +/* zzepro.c */ +extern int zzepro_(void); +/* zzexit.c */ +extern int exit_(int *code); +/* zzpstr.c */ +extern int spp_debug(void); +extern int zzpstr_(shortint *s1, shortint *s2); +extern int zzlstr_(shortint *s1, shortint *s2); +extern void spp_printstr(shortint *s); +extern void spp_printmemc(int memc_ptr); +/* zzsetk.c */ +extern int zzsetk_(char *ospn, char *osbfn, int prtype, int isatty, int in, int out); +/* zzstrt.c */ +extern int zzstrt_(void); +extern int zzstop_(void); +extern void ready_(void); +extern void mdump_(int *buf, int *nbytes); + + + +#else + + + +/* dio.c */ +extern int directio(int fd, int advice); +/* getproc.c */ +extern int uid_executing(int uid); +/* gmttolst.c */ +extern time_t gmt_to_lst(time_t gmt); +/* irafpath.c */ +extern char *irafpath(char *fname); +/* prwait.c */ +extern void pr_enter(int pid, int inchan, int outchan); +extern int pr_wait(int pid); +extern int pr_getipc(int pid, int *inchan, int *outchan); +extern struct proctable *pr_findpid(int pid); +extern void pr_release(int pid); +/* zalloc.c */ +extern int zdvall_(shortint *aliases, long *allflg, long *status); +extern int zdvown_(shortint *device, shortint *owner, long *maxch, long *status); +extern int loggedin(int uid); +/* zawset.c */ +extern int zawset_(long *best_size, long *new_size, long *old_size, long *max_size); +/* zcall.c */ +/* +extern int zcall0_(long *proc); +extern int zcall1_(long *proc, void *arg1); +extern int zcall2_(long *proc, void *arg1, void *arg2); +extern int zcall3_(long *proc, void *arg1, void *arg2, void *arg3); +extern int zcall4_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zcall5_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zcall6_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zcall7_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zcall8_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zcall9_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zcalla_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +*/ +/* zdojmp.c */ +extern void zdojmp_(long *jmpbuf, long *status); +/* zfacss.c */ +extern int zfacss_(shortint *fname, long *mode, long *type, long *status); +/* zfaloc.c */ +extern int zfaloc_(shortint *fname, long *nbytes, long *status); +/* zfchdr.c */ +extern int zfchdr_(shortint *newdir, long *status); +/* zfdele.c */ +extern int zfdele_(shortint *fname, long *status); +/* zfgcwd.c */ +extern int zfgcwd_(shortint *outstr, long *maxch, long *status); +/* zfinfo.c */ +extern int zfinfo_(shortint *fname, long *finfo_struct, long *status); +/* zfiobf.c */ +extern int zopnbf_(shortint *osfn, long *mode, long *chan); +extern int zclsbf_(long *fd, long *status); +extern int zardbf_(long *chan, shortint *buf, long *maxbytes, long *offset); +extern int zawrbf_(long *chan, shortint *buf, long *nbytes, long *offset); +extern int zawtbf_(long *fd, long *status); +extern int zsttbf_(long *fd, long *param, long *lvalue); +extern int _u_fmode(int mode); +extern int vm_access(char *fname, int mode); +extern int vm_delete(char *fname, int force); +extern int vm_reservespace(long nbytes); +extern int vm_largefile(long nbytes); +extern int vm_directio(int fd, int flag); +/* zfioks.c */ +extern int zopnks_(shortint *x_server, long *mode, long *chan); +extern int zclsks_(long *chan, long *status); +extern int zardks_(long *chan, shortint *buf, long *totbytes, long *loffset); +extern int zawrks_(long *chan, shortint *buf, long *totbytes, long *loffset); +extern int zawtks_(long *chan, long *status); +extern int zsttks_(long *chan, long *param, long *lvalue); +extern void pr_mask(char *str); +/* zfiolp.c */ +extern int zopnlp_(shortint *printer, long *mode, long *chan); +extern int zclslp_(long *chan, long *status); +extern int zardlp_(long *chan, shortint *buf, long *maxbytes, long *offset); +extern int zawrlp_(long *chan, shortint *buf, long *nbytes, long *offset); +extern int zawtlp_(long *chan, long *status); +extern int zsttlp_(long *chan, long *param, long *lvalue); +/* zfiomt.c */ +extern int zzopmt_(shortint *device, long *acmode, shortint *devcap, long *devpos, long *newfile, long *chan); +extern int zzclmt_(long *chan, long *devpos, long *o_status); +extern int zzrdmt_(long *chan, shortint *buf, long *maxbytes, long *offset); +extern int zzwrmt_(long *chan, shortint *buf, long *nbytes, long *offset); +extern int zzwtmt_(long *chan, long *devpos, long *o_status); +extern int zzstmt_(long *chan, long *param, long *lvalue); +extern int zzrwmt_(shortint *device, shortint *devcap, long *o_status); +/* zfiond.c */ +extern int zopnnd_(shortint *pk_osfn, long *mode, long *chan); +extern int zclsnd_(long *fd, long *status); +extern int zardnd_(long *chan, shortint *buf, long *maxbytes, long *offset); +extern int zawrnd_(long *chan, shortint *buf, long *nbytes, long *offset); +extern int zawtnd_(long *fd, long *status); +extern int zsttnd_(long *fd, long *param, long *lvalue); +/* zfiopl.c */ +extern int zopnpl_(shortint *plotter, long *mode, long *chan); +extern int zclspl_(long *chan, long *status); +extern int zardpl_(long *chan, shortint *buf, long *maxbytes, long *offset); +extern int zawrpl_(long *chan, shortint *buf, long *nbytes, long *offset); +extern int zawtpl_(long *chan, long *status); +extern int zsttpl_(long *chan, long *param, long *lvalue); +/* zfiopr.c */ +extern int zopcpr_(shortint *osfn, long *inchan, long *outchan, long *pid); +extern int zclcpr_(long *pid, long *exit_status); +extern int zardpr_(long *chan, shortint *buf, long *maxbytes, long *loffset); +extern int zawrpr_(long *chan, shortint *buf, long *nbytes, long *loffset); +extern int zawtpr_(long *chan, long *status); +extern int zsttpr_(long *chan, long *param, long *lvalue); +/* zfiosf.c */ +extern int zopnsf_(shortint *osfn, long *mode, long *chan); +extern int zclssf_(long *fd, long *status); +extern int zardsf_(long *chan, shortint *buf, long *maxbytes, long *offset); +extern int zawrsf_(long *chan, shortint *buf, long *nbytes, long *offset); +extern int zawtsf_(long *fd, long *status); +extern int zsttsf_(long *fd, long *param, long *lvalue); +/* zfiotx.c */ +extern int zopntx_(shortint *osfn, long *mode, long *chan); +extern int zclstx_(long *fd, long *status); +extern int zflstx_(long *fd, long *status); +extern int zgettx_(long *fd, shortint *buf, long *maxchars, long *status); +extern int znottx_(long *fd, long *offset); +extern int zputtx_(long *fd, shortint *buf, long *nchars, long *status); +extern int zsektx_(long *fd, long *znottx_offset, long *status); +extern int zstttx_(long *fd, long *param, long *value); +/* zfioty.c */ +extern int zopnty_(shortint *osfn, long *mode, long *chan); +extern int zclsty_(long *fd, long *status); +extern int zflsty_(long *fd, long *status); +extern int zgetty_(long *fd, shortint *buf, long *maxchars, long *status); +extern int znotty_(long *fd, long *offset); +extern int zputty_(long *fd, shortint *buf, long *nchars, long *status); +extern int zsekty_(long *fd, long *znotty_offset, long *status); +extern int zsttty_(long *fd, long *param, long *value); +/* zfmkcp.c */ +extern int zfmkcp_(shortint *osfn, shortint *new_osfn, long *status); +/* zfmkdr.c */ +extern int zfmkdr_(shortint *newdir, long *status); +/* zfnbrk.c */ +extern int zfnbrk_(shortint *vfn, long *uroot_offset, long *uextn_offset); +/* zfpath.c */ +extern int zfpath_(shortint *osfn, shortint *pathname, long *maxch, long *nchars); +/* zfpoll.c */ +extern int zfpoll_(long *pfds, long *nfds, long *timeout, long *npoll, long *status); +/* zfprot.c */ +extern int zfprot_(shortint *fname, long *action, long *status); +/* zfrnam.c */ +extern int zfrnam_(shortint *oldname, shortint *newname, long *status); +/* zfsubd.c */ +extern int zfsubd_(shortint *osdir, long *maxch, shortint *subdir, long *nchars); +/* zfunc.c */ +extern long zfunc0_(long *proc); +extern long zfunc1_(long *proc, void *arg1); +extern long zfunc2_(long *proc, void *arg1, void *arg2); +extern long zfunc3_(long *proc, void *arg1, void *arg2, void *arg3); +extern long zfunc4_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern long zfunc5_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern long zfunc6_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern long zfunc7_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern long zfunc8_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern long zfunc9_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern long zfunca_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +/* zfutim.c */ +extern int zfutim_(shortint *fname, long *atime, long *mtime, long *status); +/* zfxdir.c */ +extern int zfxdir_(shortint *osfn, shortint *osdir, long *maxch, long *nchars); +/* zgcmdl.c */ +extern int zgcmdl_(shortint *cmd, long *maxch, long *status); +/* zghost.c */ +extern int zghost_(shortint *outstr, long *maxch); +/* zglobl.c */ +/* zgmtco.c */ +extern int zgmtco_(long *gmtcor); +/* zgtenv.c */ +extern int zgtenv_(shortint *envvar, shortint *outstr, long *maxch, long *status); +/* zgtime.c */ +extern int zgtime_(long *clock_time, long *cpu_time); +/* zgtpid.c */ +extern int zgtpid_(long *pid); +/* zintpr.c */ +extern int zintpr_(long *pid, long *exception, long *status); +/* zlocpr.c */ +/* +extern int zlocpr_(PFI proc, long *o_epa); +*/ +/* zlocva.c */ +extern int zlocva_(shortint *variable, long *location); +/* zmain.c */ +extern int main(int argc, char *argv[]); +/* zmaloc.c */ +extern int zmaloc_(long *buf, long *nbytes, long *status); +/* zmfree.c */ +extern int zmfree_(long *buf, long *status); +/* zopdir.c */ +extern int zopdir_(shortint *fname, long *chan); +extern int zcldir_(long *chan, long *status); +extern int zgfdir_(long *chan, shortint *outstr, long *maxch, long *status); +/* zopdpr.c */ +extern int zopdpr_(shortint *osfn, shortint *bkgfile, shortint *queue, long *jobcode); +extern int zcldpr_(long *jobcode, long *killflag, long *exit_status); +/* zoscmd.c */ +extern int zoscmd_(shortint *oscmd, shortint *stdin_file, shortint *stdout_file, shortint *stderr_file, long *status); +extern int pr_onint(int usig, int *hwcode, int *scp); +/* zpanic.c */ +extern int zpanic_(long *errcode, shortint *errmsg); +extern int kernel_panic(char *errmsg); +/* zraloc.c */ +extern int zraloc_(long *buf, long *nbytes, long *status); +/* zshlib.c */ +extern void vlibinit_(void); +/* zwmsec.c */ +extern int zwmsec_(long *msec); +/* zxwhen.c */ +extern int zxwhen_(long *sig_code, long *epa, long *old_epa); +extern void ex_handler(int unix_signal, siginfo_t *info, void *ucp); +extern int zxgmes_(long *os_exception, shortint *errmsg, long *maxch); +extern int gfpucw_(long *xcw); +extern int sfpucw_(long *xcw); +/* zzepro.c */ +/* +extern int zzepro_(void); +*/ +/* zzexit.c */ +extern int exit_(long *code); +/* zzpstr.c */ +extern int spp_debug(void); +extern int zzpstr_(shortint *s1, shortint *s2); +extern int zzlstr_(shortint *s1, shortint *s2); +extern void spp_printstr(shortint *s); +extern void spp_printmemc(int memc_ptr); +/* zzsetk.c */ +extern int zzsetk_(char *ospn, char *osbfn, int prtype, int isatty, int in, int out); +/* zzstrt.c */ +extern int zzstrt_(void); +extern int zzstop_(void); +extern void ready_(void); +extern void mdump_(long *buf, long *nbytes); + + +#endif diff --git a/unix/hlib/libc/kproto.h.bak b/unix/hlib/libc/kproto.h.bak new file mode 100644 index 00000000..adde5ecd --- /dev/null +++ b/unix/hlib/libc/kproto.h.bak @@ -0,0 +1,494 @@ +/* + * KPROTO.H -- IRAF Kernel prototype definitions. + */ + +#include +#include /* for time_t */ +#include /* for siginfo_t */ + +#ifndef MACH64 + + +/* alloc.c */ +extern int main(int argc, char *argv[]); +extern int alloc(char *argv[], int statonly); +extern int dealloc(char *argv[]); +extern int findsfs(char *argv[]); +/* dio.c */ +extern int directio(int fd, int advice); +/* getproc.c */ +extern int uid_executing(int uid); +/* gmttolst.c */ +extern time_t gmt_to_lst(time_t gmt); +/* irafpath.c */ +extern char *irafpath(char *fname); +/* prwait.c */ +extern void pr_enter(int pid, int inchan, int outchan); +extern int pr_wait(int pid); +extern int pr_getipc(int pid, int *inchan, int *outchan); +extern struct proctable *pr_findpid(int pid); +extern void pr_release(int pid); +/* tape.c */ +extern int main(int argc, char *argv[]); +extern void mtop(int op, int count); +extern char *nextcmd(FILE *in); +extern char *gettok(void); +extern char *prompt(void); +extern void pstatus(void); +extern void output(char *text); +extern void phelp(void); +/* zalloc.c */ +extern int zdvall_(short *aliases, int *allflg, int *status); +extern int zdvown_(short *device, short *owner, int *maxch, int *status); +extern int loggedin(int uid); +/* zawset.c */ +extern int zawset_(int *best_size, int *new_size, int *old_size, int *max_size); +/* zcall.c */ +extern int zcall0_(int *proc); +extern int zcall1_(int *proc, void *arg1); +extern int zcall2_(int *proc, void *arg1, void *arg2); +extern int zcall3_(int *proc, void *arg1, void *arg2, void *arg3); +extern int zcall4_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zcall5_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zcall6_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zcall7_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zcall8_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zcall9_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zcalla_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +/* zdojmp.c */ +extern void zdojmp_(int *jmpbuf, int *status); +/* zfacss.c */ +extern int zfacss_(short *fname, int *mode, int *type, int *status); +/* zfaloc.c */ +extern int zfaloc_(short *fname, int *nbytes, int *status); +/* zfchdr.c */ +extern int zfchdr_(short *newdir, int *status); +/* zfdele.c */ +extern int zfdele_(short *fname, int *status); +/* zfgcwd.c */ +extern int zfgcwd_(short *outstr, int *maxch, int *status); +/* zfinfo.c */ +extern int zfinfo_(short *fname, int *finfo_struct, int *status); +/* zfiobf.c */ +extern int zopnbf_(short *osfn, int *mode, int *chan); +extern int zclsbf_(int *fd, int *status); +extern int zardbf_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrbf_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtbf_(int *fd, int *status); +extern int zsttbf_(int *fd, int *param, int *lvalue); +extern int _u_fmode(int mode); +extern int vm_access(char *fname, int mode); +extern int vm_delete(char *fname, int force); +extern int vm_reservespace(long nbytes); +extern int vm_largefile(long nbytes); +extern int vm_directio(int fd, int flag); +/* zfioks.c */ +extern int zopnks_(short *x_server, int *mode, int *chan); +extern int zclsks_(int *chan, int *status); +extern int zardks_(int *chan, short *buf, int *totbytes, int *loffset); +extern int zawrks_(int *chan, short *buf, int *totbytes, int *loffset); +extern int zawtks_(int *chan, int *status); +extern int zsttks_(int *chan, int *param, int *lvalue); +extern void pr_mask(char *str); +/* zfiolp.c */ +extern int zopnlp_(short *printer, int *mode, int *chan); +extern int zclslp_(int *chan, int *status); +extern int zardlp_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrlp_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtlp_(int *chan, int *status); +extern int zsttlp_(int *chan, int *param, int *lvalue); +/* zfiomt.c */ +extern int zzopmt_(short *device, int *acmode, short *devcap, int *devpos, int *newfile, int *chan); +extern int zzclmt_(int *chan, int *devpos, int *o_status); +extern int zzrdmt_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zzwrmt_(int *chan, short *buf, int *nbytes, int *offset); +extern int zzwtmt_(int *chan, int *devpos, int *o_status); +extern int zzstmt_(int *chan, int *param, int *lvalue); +extern int zzrwmt_(short *device, short *devcap, int *o_status); +/* zfiond.c */ +extern int zopnnd_(short *pk_osfn, int *mode, int *chan); +extern int zclsnd_(int *fd, int *status); +extern int zardnd_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrnd_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtnd_(int *fd, int *status); +extern int zsttnd_(int *fd, int *param, int *lvalue); +/* zfiopl.c */ +extern int zopnpl_(short *plotter, int *mode, int *chan); +extern int zclspl_(int *chan, int *status); +extern int zardpl_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrpl_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtpl_(int *chan, int *status); +extern int zsttpl_(int *chan, int *param, int *lvalue); +/* zfiopr.c */ +extern int zopcpr_(short *osfn, int *inchan, int *outchan, int *pid); +extern int zclcpr_(int *pid, int *exit_status); +extern int zardpr_(int *chan, short *buf, int *maxbytes, int *loffset); +extern int zawrpr_(int *chan, short *buf, int *nbytes, int *loffset); +extern int zawtpr_(int *chan, int *status); +extern int zsttpr_(int *chan, int *param, int *lvalue); +/* zfiosf.c */ +extern int zopnsf_(short *osfn, int *mode, int *chan); +extern int zclssf_(int *fd, int *status); +extern int zardsf_(int *chan, short *buf, int *maxbytes, int *offset); +extern int zawrsf_(int *chan, short *buf, int *nbytes, int *offset); +extern int zawtsf_(int *fd, int *status); +extern int zsttsf_(int *fd, int *param, int *lvalue); +/* zfiotx.c */ +extern int zopntx_(short *osfn, int *mode, int *chan); +extern int zclstx_(int *fd, int *status); +extern int zflstx_(int *fd, int *status); +extern int zgettx_(int *fd, short *buf, int *maxchars, int *status); +extern int znottx_(int *fd, int *offset); +extern int zputtx_(int *fd, short *buf, int *nchars, int *status); +extern int zsektx_(int *fd, int *znottx_offset, int *status); +extern int zstttx_(int *fd, int *param, int *value); +/* zfioty.c */ +extern int zopnty_(short *osfn, int *mode, int *chan); +extern int zclsty_(int *fd, int *status); +extern int zflsty_(int *fd, int *status); +extern int zgetty_(int *fd, short *buf, int *maxchars, int *status); +extern int znotty_(int *fd, int *offset); +extern int zputty_(int *fd, short *buf, int *nchars, int *status); +extern int zsekty_(int *fd, int *znotty_offset, int *status); +extern int zsttty_(int *fd, int *param, int *value); +/* zfmkcp.c */ +extern int zfmkcp_(short *osfn, short *new_osfn, int *status); +/* zfmkdr.c */ +extern int zfmkdr_(short *newdir, int *status); +/* zfnbrk.c */ +extern int zfnbrk_(short *vfn, int *uroot_offset, int *uextn_offset); +/* zfpath.c */ +extern int zfpath_(short *osfn, short *pathname, int *maxch, int *nchars); +/* zfpoll.c */ +extern int zfpoll_(int *pfds, int *nfds, int *timeout, int *npoll, int *status); +/* zfprot.c */ +extern int zfprot_(short *fname, int *action, int *status); +/* zfrnam.c */ +extern int zfrnam_(short *oldname, short *newname, int *status); +/* zfsubd.c */ +extern int zfsubd_(short *osdir, int *maxch, short *subdir, int *nchars); +/* zfunc.c */ +extern int zfunc0_(int *proc); +extern int zfunc1_(int *proc, void *arg1); +extern int zfunc2_(int *proc, void *arg1, void *arg2); +extern int zfunc3_(int *proc, void *arg1, void *arg2, void *arg3); +extern int zfunc4_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zfunc5_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zfunc6_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zfunc7_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zfunc8_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zfunc9_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zfunca_(int *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +/* zfutim.c */ +extern int zfutim_(short *fname, int *atime, int *mtime, int *status); +/* zfxdir.c */ +extern int zfxdir_(short *osfn, short *osdir, int *maxch, int *nchars); +/* zgcmdl.c */ +extern int zgcmdl_(short *cmd, int *maxch, int *status); +/* zghost.c */ +extern int zghost_(short *outstr, int *maxch); +/* zglobl.c */ +/* zgmtco.c */ +extern int zgmtco_(int *gmtcor); +/* zgtenv.c */ +extern int zgtenv_(short *envvar, short *outstr, int *maxch, int *status); +/* zgtime.c */ +extern int zgtime_(int *clock_time, int *cpu_time); +/* zgtpid.c */ +extern int zgtpid_(int *pid); +/* zintpr.c */ +extern int zintpr_(int *pid, int *exception, int *status); +/* zlocpr.c +extern int zlocpr_(PFI proc, int *o_epa); +*/ +/* zlocva.c */ +extern int zlocva_(short *variable, int *location); +/* zmain.c */ +extern int main(int argc, char *argv[]); +/* zmaloc.c */ +extern int zmaloc_(int *buf, int *nbytes, int *status); +/* zmfree.c */ +extern int zmfree_(int *buf, int *status); +/* zopdir.c */ +extern int zopdir_(short *fname, int *chan); +extern int zcldir_(int *chan, int *status); +extern int zgfdir_(int *chan, short *outstr, int *maxch, int *status); +/* zopdpr.c */ +extern int zopdpr_(short *osfn, short *bkgfile, short *queue, int *jobcode); +extern int zcldpr_(int *jobcode, int *killflag, int *exit_status); +/* zoscmd.c */ +extern int zoscmd_(short *oscmd, short *stdin_file, short *stdout_file, short *stderr_file, int *status); +extern int pr_onint(int usig, int *hwcode, int *scp); +/* zpanic.c */ +extern int zpanic_(int *errcode, short *errmsg); +extern int kernel_panic(char *errmsg); +/* zraloc.c */ +extern int zraloc_(int *buf, int *nbytes, int *status); +/* zshlib.c */ +extern void vlibinit_(void); +/* zwmsec.c */ +extern int zwmsec_(int *msec); +/* zxwhen.c */ +extern int zxwhen_(int *sig_code, int *epa, int *old_epa); +extern void ex_handler(int unix_signal, siginfo_t *info, void *ucp); +extern int zxgmes_(int *os_exception, short *errmsg, int *maxch); +/* zzepro.c */ +extern int zzepro_(void); +/* zzexit.c */ +extern int exit_(int *code); +/* zzpstr.c */ +extern int spp_debug(void); +extern int zzpstr_(short *s1, short *s2); +extern int zzlstr_(short *s1, short *s2); +extern void spp_printstr(short *s); +extern void spp_printmemc(int memc_ptr); +/* zzsetk.c */ +extern int zzsetk_(char *ospn, char *osbfn, int prtype, int isatty, int in, int out); +/* zzstrt.c */ +extern int zzstrt_(void); +extern int zzstop_(void); +extern void ready_(void); +extern void mdump_(int *buf, int *nbytes); + + + +#else + + + +/* dio.c */ +extern int directio(int fd, int advice); +/* getproc.c */ +extern int uid_executing(int uid); +/* gmttolst.c */ +extern time_t gmt_to_lst(time_t gmt); +/* irafpath.c */ +extern char *irafpath(char *fname); +/* prwait.c */ +extern void pr_enter(int pid, int inchan, int outchan); +extern int pr_wait(int pid); +extern int pr_getipc(int pid, int *inchan, int *outchan); +extern struct proctable *pr_findpid(int pid); +extern void pr_release(int pid); +/* zalloc.c */ +extern int zdvall_(short *aliases, long *allflg, long *status); +extern int zdvown_(short *device, short *owner, long *maxch, long *status); +extern int loggedin(int uid); +/* zawset.c */ +extern int zawset_(long *best_size, long *new_size, long *old_size, long *max_size); +/* zcall.c */ +/* +extern int zcall0_(long *proc); +extern int zcall1_(long *proc, void *arg1); +extern int zcall2_(long *proc, void *arg1, void *arg2); +extern int zcall3_(long *proc, void *arg1, void *arg2, void *arg3); +extern int zcall4_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern int zcall5_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern int zcall6_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern int zcall7_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern int zcall8_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern int zcall9_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern int zcalla_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +*/ +/* zdojmp.c */ +extern void zdojmp_(long *jmpbuf, long *status); +/* zfacss.c */ +extern int zfacss_(short *fname, long *mode, long *type, long *status); +/* zfaloc.c */ +extern int zfaloc_(short *fname, long *nbytes, long *status); +/* zfchdr.c */ +extern int zfchdr_(short *newdir, long *status); +/* zfdele.c */ +extern int zfdele_(short *fname, long *status); +/* zfgcwd.c */ +extern int zfgcwd_(short *outstr, long *maxch, long *status); +/* zfinfo.c */ +extern int zfinfo_(short *fname, long *finfo_struct, long *status); +/* zfiobf.c */ +extern int zopnbf_(short *osfn, long *mode, long *chan); +extern int zclsbf_(long *fd, long *status); +extern int zardbf_(long *chan, short *buf, long *maxbytes, long *offset); +extern int zawrbf_(long *chan, short *buf, long *nbytes, long *offset); +extern int zawtbf_(long *fd, long *status); +extern int zsttbf_(long *fd, long *param, long *lvalue); +extern int _u_fmode(int mode); +extern int vm_access(char *fname, int mode); +extern int vm_delete(char *fname, int force); +extern int vm_reservespace(long nbytes); +extern int vm_largefile(long nbytes); +extern int vm_directio(int fd, int flag); +/* zfioks.c */ +extern int zopnks_(short *x_server, long *mode, long *chan); +extern int zclsks_(long *chan, long *status); +extern int zardks_(long *chan, short *buf, long *totbytes, long *loffset); +extern int zawrks_(long *chan, short *buf, long *totbytes, long *loffset); +extern int zawtks_(long *chan, long *status); +extern int zsttks_(long *chan, long *param, long *lvalue); +extern void pr_mask(char *str); +/* zfiolp.c */ +extern int zopnlp_(short *printer, long *mode, long *chan); +extern int zclslp_(long *chan, long *status); +extern int zardlp_(long *chan, short *buf, long *maxbytes, long *offset); +extern int zawrlp_(long *chan, short *buf, long *nbytes, long *offset); +extern int zawtlp_(long *chan, long *status); +extern int zsttlp_(long *chan, long *param, long *lvalue); +/* zfiomt.c */ +extern int zzopmt_(short *device, long *acmode, short *devcap, long *devpos, long *newfile, long *chan); +extern int zzclmt_(long *chan, long *devpos, long *o_status); +extern int zzrdmt_(long *chan, short *buf, long *maxbytes, long *offset); +extern int zzwrmt_(long *chan, short *buf, long *nbytes, long *offset); +extern int zzwtmt_(long *chan, long *devpos, long *o_status); +extern int zzstmt_(long *chan, long *param, long *lvalue); +extern int zzrwmt_(short *device, short *devcap, long *o_status); +/* zfiond.c */ +extern int zopnnd_(short *pk_osfn, long *mode, long *chan); +extern int zclsnd_(long *fd, long *status); +extern int zardnd_(long *chan, short *buf, long *maxbytes, long *offset); +extern int zawrnd_(long *chan, short *buf, long *nbytes, long *offset); +extern int zawtnd_(long *fd, long *status); +extern int zsttnd_(long *fd, long *param, long *lvalue); +/* zfiopl.c */ +extern int zopnpl_(short *plotter, long *mode, long *chan); +extern int zclspl_(long *chan, long *status); +extern int zardpl_(long *chan, short *buf, long *maxbytes, long *offset); +extern int zawrpl_(long *chan, short *buf, long *nbytes, long *offset); +extern int zawtpl_(long *chan, long *status); +extern int zsttpl_(long *chan, long *param, long *lvalue); +/* zfiopr.c */ +extern int zopcpr_(short *osfn, long *inchan, long *outchan, long *pid); +extern int zclcpr_(long *pid, long *exit_status); +extern int zardpr_(long *chan, short *buf, long *maxbytes, long *loffset); +extern int zawrpr_(long *chan, short *buf, long *nbytes, long *loffset); +extern int zawtpr_(long *chan, long *status); +extern int zsttpr_(long *chan, long *param, long *lvalue); +/* zfiosf.c */ +extern int zopnsf_(short *osfn, long *mode, long *chan); +extern int zclssf_(long *fd, long *status); +extern int zardsf_(long *chan, short *buf, long *maxbytes, long *offset); +extern int zawrsf_(long *chan, short *buf, long *nbytes, long *offset); +extern int zawtsf_(long *fd, long *status); +extern int zsttsf_(long *fd, long *param, long *lvalue); +/* zfiotx.c */ +extern int zopntx_(short *osfn, long *mode, long *chan); +extern int zclstx_(long *fd, long *status); +extern int zflstx_(long *fd, long *status); +extern int zgettx_(long *fd, short *buf, long *maxchars, long *status); +extern int znottx_(long *fd, long *offset); +extern int zputtx_(long *fd, short *buf, long *nchars, long *status); +extern int zsektx_(long *fd, long *znottx_offset, long *status); +extern int zstttx_(long *fd, long *param, long *value); +/* zfioty.c */ +extern int zopnty_(short *osfn, long *mode, long *chan); +extern int zclsty_(long *fd, long *status); +extern int zflsty_(long *fd, long *status); +extern int zgetty_(long *fd, short *buf, long *maxchars, long *status); +extern int znotty_(long *fd, long *offset); +extern int zputty_(long *fd, short *buf, long *nchars, long *status); +extern int zsekty_(long *fd, long *znotty_offset, long *status); +extern int zsttty_(long *fd, long *param, long *value); +/* zfmkcp.c */ +extern int zfmkcp_(short *osfn, short *new_osfn, long *status); +/* zfmkdr.c */ +extern int zfmkdr_(short *newdir, long *status); +/* zfnbrk.c */ +extern int zfnbrk_(short *vfn, long *uroot_offset, long *uextn_offset); +/* zfpath.c */ +extern int zfpath_(short *osfn, short *pathname, long *maxch, long *nchars); +/* zfpoll.c */ +extern int zfpoll_(long *pfds, long *nfds, long *timeout, long *npoll, long *status); +/* zfprot.c */ +extern int zfprot_(short *fname, long *action, long *status); +/* zfrnam.c */ +extern int zfrnam_(short *oldname, short *newname, long *status); +/* zfsubd.c */ +extern int zfsubd_(short *osdir, long *maxch, short *subdir, long *nchars); +/* zfunc.c */ +extern long zfunc0_(long *proc); +extern long zfunc1_(long *proc, void *arg1); +extern long zfunc2_(long *proc, void *arg1, void *arg2); +extern long zfunc3_(long *proc, void *arg1, void *arg2, void *arg3); +extern long zfunc4_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4); +extern long zfunc5_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5); +extern long zfunc6_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6); +extern long zfunc7_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7); +extern long zfunc8_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8); +extern long zfunc9_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9); +extern long zfunca_(long *proc, void *arg1, void *arg2, void *arg3, void *arg4, void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, void *arg10); +/* zfutim.c */ +extern int zfutim_(short *fname, long *atime, long *mtime, long *status); +/* zfxdir.c */ +extern int zfxdir_(short *osfn, short *osdir, long *maxch, long *nchars); +/* zgcmdl.c */ +extern int zgcmdl_(short *cmd, long *maxch, long *status); +/* zghost.c */ +extern int zghost_(short *outstr, long *maxch); +/* zglobl.c */ +/* zgmtco.c */ +extern int zgmtco_(long *gmtcor); +/* zgtenv.c */ +extern int zgtenv_(short *envvar, short *outstr, long *maxch, long *status); +/* zgtime.c */ +extern int zgtime_(long *clock_time, long *cpu_time); +/* zgtpid.c */ +extern int zgtpid_(long *pid); +/* zintpr.c */ +extern int zintpr_(long *pid, long *exception, long *status); +/* zlocpr.c */ +/* +extern int zlocpr_(PFI proc, long *o_epa); +*/ +/* zlocva.c */ +extern int zlocva_(short *variable, long *location); +/* zmain.c */ +extern int main(int argc, char *argv[]); +/* zmaloc.c */ +extern int zmaloc_(long *buf, long *nbytes, long *status); +/* zmfree.c */ +extern int zmfree_(long *buf, long *status); +/* zopdir.c */ +extern int zopdir_(short *fname, long *chan); +extern int zcldir_(long *chan, long *status); +extern int zgfdir_(long *chan, short *outstr, long *maxch, long *status); +/* zopdpr.c */ +extern int zopdpr_(short *osfn, short *bkgfile, short *queue, long *jobcode); +extern int zcldpr_(long *jobcode, long *killflag, long *exit_status); +/* zoscmd.c */ +extern int zoscmd_(short *oscmd, short *stdin_file, short *stdout_file, short *stderr_file, long *status); +extern int pr_onint(int usig, int *hwcode, int *scp); +/* zpanic.c */ +extern int zpanic_(long *errcode, short *errmsg); +extern int kernel_panic(char *errmsg); +/* zraloc.c */ +extern int zraloc_(long *buf, long *nbytes, long *status); +/* zshlib.c */ +extern void vlibinit_(void); +/* zwmsec.c */ +extern int zwmsec_(long *msec); +/* zxwhen.c */ +extern int zxwhen_(long *sig_code, long *epa, long *old_epa); +extern void ex_handler(int unix_signal, siginfo_t *info, void *ucp); +extern int zxgmes_(long *os_exception, short *errmsg, long *maxch); +extern int gfpucw_(long *xcw); +extern int sfpucw_(long *xcw); +/* zzepro.c */ +/* +extern int zzepro_(void); +*/ +/* zzexit.c */ +extern int exit_(long *code); +/* zzpstr.c */ +extern int spp_debug(void); +extern int zzpstr_(short *s1, short *s2); +extern int zzlstr_(short *s1, short *s2); +extern void spp_printstr(short *s); +extern void spp_printmemc(int memc_ptr); +/* zzsetk.c */ +extern int zzsetk_(char *ospn, char *osbfn, int prtype, int isatty, int in, int out); +/* zzstrt.c */ +extern int zzstrt_(void); +extern int zzstop_(void); +extern void ready_(void); +extern void mdump_(long *buf, long *nbytes); + + +#endif diff --git a/unix/hlib/libc/lexnum.h b/unix/hlib/libc/lexnum.h new file mode 100644 index 00000000..d83ef138 --- /dev/null +++ b/unix/hlib/libc/lexnum.h @@ -0,0 +1,9 @@ +/* Lexnum.h + */ +#define LEX_OCTAL (-4) +#define LEX_DECIMAL (-3) +#define LEX_HEX (-2) +#define LEX_REAL (-1) +#define LEX_NONNUM 0 + +#define D_lexnum diff --git a/unix/hlib/libc/libc.h b/unix/hlib/libc/libc.h new file mode 100644 index 00000000..83c2f136 --- /dev/null +++ b/unix/hlib/libc/libc.h @@ -0,0 +1,330 @@ +/* + * LIBC.H -- Definitions which should be included by all C source files which + * use the IRAF runtime C library. + */ + +#ifndef D_libc +#ifndef D_spp +#ifndef import_spp +#include "spp.h" +#endif +#endif + +#define XCHAR short +#ifdef MACH64 +#define XINT long +#define XLONG long +#else +#define XINT int +#define XLONG int +#endif +#define SZ_DEFIOBUF 1024 +#define FIO_MAXFD 4096 + +#define FIOCOM fiocom_ /* [MACHDEP] */ +#define MEMCOM mem_ +#define XERPSH xerpsh_ +#define XERPOP xerpop_ +#define XERPOPI xerpoi_ +#define c_main cmain_ + +/* Error handling. + */ +#define iferr(stmt) {XERPSH();stmt;}if(XERPOPI()) + +/* SPP/C pointer conversions. + */ +extern char MEMCOM[]; +#define Memc (((XCHAR *)MEMCOM)-1) +#define Memi (((XINT *)MEMCOM)-1) +#define Memcptr(addr) ((XCHAR *)(addr) - Memc) +#define Memiptr(addr) ((XINT *)(addr) - Memi) + +/* External names. + */ +#ifndef NOLIBCNAMES + +#define getenv envget +#define sys_nerr u_sysnerr +#define sys_errlist u_syserrlist + +#define atof u_atof +#define atoi u_atoi +#define atol u_atol +#define calloc u_calloc +#define envget u_envget +#define eprintf u_eprintf +#define fclose u_fclose +#define fdopen u_fdopen +#define fflush u_fflush +#define fgetc u_fgetc +#define fgets u_fgets +#define fopen u_fopen +#define fprintf u_fprintf +#define fputc u_fputc +#define fputs u_fputs +#define fread u_fread +#define freadline u_readline +#define free u_free +#define freopen u_freopen +#define fscanf u_fscanf +#define fseek u_fseek +#define ftell u_ftell +#define fwrite u_fwrite +#define gets u_gets +#define getw u_getw +#define index u_index +#define isatty u_isatty +#define malloc u_malloc +#define mktemp u_mktemp +#define perror u_perror +#define printf u_printf +#define puts u_puts +#define putw u_putw +#define qsort u_qsort +#define realloc u_realloc +#define rewind u_rewind +#define rindex u_rindex +#define scanf u_scanf +#define setbuf u_setbuf +#define setbuffer u_setfbf /* collision */ +#define setlinebuf u_setlinebuf +#define sprintf u_sprintf +#define sscanf u_sscanf +#define strcat u_strcat +#define strchr u_index +#define strcmp u_strcmp +#define strdup u_strdup +#define strcpy u_strcpy +#define strlen u_strlen +#define strncat u_strnt /* collision */ +#define strncmp u_strnp /* collision */ +#define strncpy u_strny /* collision */ +#define strrchr u_rindex +#define system u_system +#define ungetc u_ungetc + +/* C_SPP names not unique in the first seven characters. + */ +#define c_envgetb c_envgb +#define c_envgeti c_envgi +#define c_envgets c_envgs +#define c_ttyclear c_ttycr +#define c_ttyclearln c_ttycn +#define c_ttygetb c_ttygb +#define c_ttygeti c_ttygi +#define c_ttygetr c_ttygr +#define c_ttygets c_ttygs +#define c_ttyputline c_ttype +#define c_ttyputs c_ttyps +#define c_ungetc c_ungec +#define c_ungetstr c_unges + + +/* + * Prototype definitions for the IRAF runtime C library. + */ + +/*extern long XERPSH(), XERPOPI();*/ /* standard for iferr use */ + +extern struct _iobuf *fdopen (XINT fd, char *mode); +extern struct _iobuf *fopen (char *fname, char *modestr); +extern struct _iobuf *freopen (char *fname, char *modestr, struct _iobuf *fp); +extern char *c_cnvdate (long clktime, char *outstr, int maxch); +extern char *c_cnvtime (long clktime, char *outstr, int maxch); +extern char *c_getuid (char *outstr, int maxch); +extern char *c_salloc (unsigned nbytes); +extern char *c_strpak (short *sppstr, char *cstr, int maxch); +extern char *calloc (unsigned int nelems, unsigned int elsize); +extern char *envget (char *var); +extern char *fgets (char *buf, int maxch, struct _iobuf *fp); +extern char *gets (char *buf); +extern char *index (char *str, int ch); +extern char *malloc (unsigned nbytes); +extern char *mktemp (char *template); +extern char *freadline (char *prompt); +extern char *realloc (char *buf, unsigned newsize); +extern char *rindex (char *str, int ch); +extern char *sprintf (char *str, char *format, ...); +extern char *strcat (char *s1, char *s2); +extern char *strdup (char *str); +extern char *strcpy (char *s1, char *s2); +extern char *strncat (char *s1, char *s2, int n); +extern char *strncpy (char *s1, char *s2, int n); +extern int strncmp (char *s1, char *s2, int n); + +extern double atof (char *str); +extern float c_ttygr (XINT tty, char *cap); +extern int atoi (char *str); +extern int c_access (char *fname, int mode, int type); +extern int c_allocate (char *device); +extern int c_close (XINT fd); +extern int c_deallocate (char *device, int rewind); +extern int c_delete (char *fname); +extern int c_devowner (char *device, char *owner, int maxch); +extern int c_envfind (char *var, char *outstr, int maxch); +extern int c_envfree (int envp, int userfcn); +extern int c_envgb (char *var); +extern int c_envgi (char *var); +extern int c_envgs (char *var, char *outstr, int maxch); +extern int c_envscan (char *input_source); +extern int c_errcode (void); +extern int c_errget (char *outstr, int maxch); +extern int c_fchdir (char *newdir); +extern int c_filbuf (struct _iobuf *fp); +extern int c_flsbuf (unsigned int ch, struct _iobuf *fp); +extern int c_fmapfn (char *vfn, char *osfn, int maxch); +extern int c_fmkdir (char *newdir); +extern int c_fnextn (char *vfn, char *extn, int maxch); +extern int c_fnldir (char *vfn, char *ldir, int maxch); +extern int c_fnroot (char *vfn, char *root, int maxch); +extern int c_fpathname (char *vfn, char *osfn, int maxch); +extern int c_fprintf (XINT fd, char *format); +extern int c_fredir (XINT fd, char *fname, int mode, int type); +extern int c_frediro (XINT fd, XINT newfd); +extern int c_fstati (XINT fd, int param); +extern int c_getpid (void); +extern int c_imaccess (char *imname, int mode); +extern int c_imdrcur (char *device, float *x, float *y, int *wcs, + int *key, char *strval, int maxch, int d_wcs, int pause); +extern int c_kimapchan (int chan, char *nodename, int maxch); +extern int c_lexnum (char *str, int *toklen); +extern int c_mktemp (char *root, char *temp_filename, int maxch); +extern int c_ndopen (char *fname, int mode); +extern int c_open (char *fname, int mode, int type); +extern int c_oscmd (char *cmd, char *infile, char *outfile, char *errfile); +extern int c_poll (XINT fds, int nfds, int timeout); +extern int c_poll_get_nfds (XINT fds); +extern XINT c_poll_open (void); +extern int c_poll_test (XINT fds, XINT fd, int type); +extern int c_prchdir (int pid, char *newdir); +extern int c_prcldpr (unsigned job); +extern int c_prclose (unsigned int pid); +extern int c_prdone (unsigned job); +extern int c_prenvfree (int pid, int envp); +extern int c_prenvset (int pid, char *envvar, char *value); +extern int c_printf (char *format); +extern int c_prkill (unsigned job); +extern int c_prredir (unsigned pid, int stream, int new_fd); +extern int c_prsignal (unsigned pid, int signal); +extern int c_prstati (int pid, int param); +extern int c_rcursor (int fd, char *outstr, int maxch); +extern int c_rdukey (char *obuf, int maxch); +extern int c_read (XINT fd, char *buf, int maxbytes); +extern int c_rename (char *old_fname, char *new_fname); +extern int c_reopen (XINT fd, int mode); +extern int c_seek (XINT fd, long offset); +extern int c_stggetline (XINT fd, char *buf, int maxch); +extern int c_stgputline (XINT fd, char *buf); +extern int c_stropen (short *obuf, int maxch, int mode); +extern int c_ttstati (XINT fd, int param); +extern int c_ttstats (XINT fd, int param, char *outstr, int maxch); +extern int c_ttyctrl (XINT fd, XINT tty, char *cap, int afflncnt); +extern int c_ttygb (XINT tty, char *cap); +extern XINT c_ttygi (XINT tty, char *cap); +extern int c_ttygs (XINT tty, char *cap, char *outstr, int maxch); +extern XINT c_ttyodes (char *ttyname); +extern int c_ttyps (XINT fd, XINT tty, char *cap, int afflncnt); +extern XINT c_ttystati (XINT tty, int param); +extern int c_ungec (XINT fd, int ch); +extern int c_ungetline (XINT fd, char *str); +extern int c_write (XINT fd, char *buf, int nbytes); +extern int fclose (struct _iobuf *fp); +extern int fflush (struct _iobuf *fp); +extern int fgetc (struct _iobuf *fp); +extern int fputc (char ch, struct _iobuf *fp); +extern int fread (char *bp, int szelem, int nelem, struct _iobuf *fp); +extern int fscanf (struct _iobuf *fp, char *format, ...); +extern int fseek (struct _iobuf *fp, long offset, int mode); +extern int fwrite (char *bp, int szelem, int nelem, struct _iobuf *fp); +extern int getw (struct _iobuf *fp); +extern int isatty (XINT fd); +extern int puts (char *str); +extern int putw (int word, struct _iobuf *fp); +extern int scanf (char *format, ...); +extern int spf_open (char *buf, int maxch); +extern int sscanf (char *str, char *format, ...); +extern int strcmp (char *s1, char *s2); +extern int strlen (char *s); +extern int system (char *cmd); +extern int ungetc (int ch, struct _iobuf *fp); +extern long atol (char *str); +extern long c_clktime (long reftime); +extern long c_cputime (long reftime); +extern long c_note (XINT fd); +extern long ftell (struct _iobuf *fp); +extern long rewind (struct _iobuf *fp); +extern short *c_sppstr (char *str); +extern short *c_strupk (char *str, short *outstr, int maxch); +extern unsigned int c_propdpr (char *process, char *bkgfile, char *bkgmsg); +extern unsigned int c_propen (char *process, int *in, int *out); +extern void c_devstatus (char *device, int out); +extern void c_envlist (XINT fd, char *prefix, int show_redefs); +extern void c_envmark (XINT *envp); +extern void c_envputs (char *var, char *value); +extern void c_envreset (char *var, char *value); +extern void c_erract (int action); +extern void c_error (int errcode, char *errmsg); +extern void c_flush (XINT fd); +extern void c_fseti (XINT fd, int param, int value); +extern void c_gflush (int stream); +extern void c_pargb (int ival); +extern void c_pargc (int ival); +extern void c_pargd (double dval); +extern void c_pargi (int ival); +extern void c_pargl (long lval); +extern void c_pargr (float rval); +extern void c_pargs (short sval); +extern void c_pargstr (char *strval); +extern void c_poll_clear (XINT fds, XINT fd, int type); +extern void c_poll_close (XINT fds); +extern void c_poll_print (XINT fds); +extern void c_poll_set (XINT fds, XINT fd, int type); +extern void c_poll_zero (XINT fds); +extern void c_sfree (int sp); +extern void c_smark (int *sp); +extern void c_sttyco (char *args, XINT ttin, XINT ttout, XINT outfd); +extern void c_tsleep (int nseconds); +extern void c_ttseti (XINT fd, int param, int value); +extern void c_ttsets (XINT fd, int param, char *value); +extern void c_ttycdes (XINT tty); +extern void c_ttycn (XINT fd, XINT tty); +extern void c_ttycr (XINT fd, XINT tty); +extern void c_ttygoto (XINT fd, XINT tty, int col, int line); +extern void c_ttyinit (XINT fd, XINT tty); +extern void c_ttype (XINT fd, XINT tty, char *line, int map_cc); +extern void c_ttyseti (XINT tty, int param, int value); +extern void c_ttyso (XINT fd, XINT tty, int onoff); +extern void c_vfnbrk (char *vfn, int *root, int *extn); +extern void c_wmsec (int msec); +extern void c_xgmes (int *oscode, char *oserrmsg, int maxch); +extern void c_xonerr (int errcode); +extern void c_xttysize (int *ncols, int *nlines); +extern void eprintf (char *format, ...); +extern void fprintf (struct _iobuf *fp, char *format, ...); +extern void fputs (char *str, struct _iobuf *fp); +extern void free (char *buf); +extern void perror (char *prefix); +extern void printf (char *format, ...); +extern void qsort (char *base, int n, int size, int (*compar) (void)); +extern void setbuf (struct _iobuf *fp, char *buf); +extern void setfbf (struct _iobuf *fp, char *buf, int size); +extern void setlinebuf (struct _iobuf *fp); +extern void spf_close (XINT fd); + +/* The following have conflicts because of the order in which the +** include files are done in iraf.h. Commented out for now. +extern int c_finfo (char *fname, struct _finfo *fi); +extern void c_xwhen (int exception, PFI new_handler, PFI *old_handler); +*/ + +#endif + +/* +*/ +#include "/iraf/iraf/unix/bin/f2c.h" +#include "/iraf/iraf/unix/hlib/libc/vosproto.h" + +#define D_libc +#define D_libc_proto +#endif diff --git a/unix/hlib/libc/main.h b/unix/hlib/libc/main.h new file mode 100644 index 00000000..ad5fe71e --- /dev/null +++ b/unix/hlib/libc/main.h @@ -0,0 +1,6 @@ +/* MAIN.H -- For files which have a c_main. + */ +#define PR_NOEXIT 0 /* run interpreter */ +#define PR_EXIT 1 /* skip interpreter */ + +#define D_main diff --git a/unix/hlib/libc/math.h b/unix/hlib/libc/math.h new file mode 100644 index 00000000..6d151faf --- /dev/null +++ b/unix/hlib/libc/math.h @@ -0,0 +1,24 @@ +/* + * MATH.H -- Math functions for C. + */ + +double XEXP(), XLOG(), XLOG10(), XPOW(), XSQRT(); +double XSIN(), XCOS(), XASIN(), XACOS(), XTAN(), XATAN(), XATAN2(); + +static double um_x, um_y; + +#define nint(x) XNINT((um_x=(x),&um_x)) +#define exp(x) XEXP((um_x=(x),&um_x)) +#define log(x) XLOG((um_x=(x),&um_x)) +#define log10(x) XLOG10((um_x=(x),&um_x)) +#define pow(x,y) XPOW((um_x=(x),&um_x),(um_y=(y),&um_y)) +#define sqrt(x) XSQRT((um_x=(x),&um_x)) +#define sin(x) XSIN((um_x=(x),&um_x)) +#define cos(x) XCOS((um_x=(x),&um_x)) +#define tan(x) XTAN((um_x=(x),&um_x)) +#define asin(x) XASIN((um_x=(x),&um_x)) +#define acos(x) XACOS((um_x=(x),&um_x)) +#define atan(x) XATAN((um_x=(x),&um_x)) +#define atan2(x,y) XATAN2((um_x=(x),&um_x),(um_y=(y),&um_y)) + +#define D_math diff --git a/unix/hlib/libc/protect.h b/unix/hlib/libc/protect.h new file mode 100644 index 00000000..fe9c1a31 --- /dev/null +++ b/unix/hlib/libc/protect.h @@ -0,0 +1,7 @@ +/* File protection. + */ +#define REMOVE_PROTECTION 0 +#define SET_PROTECTION 1 +#define QUERY_PROTECTION 2 + +#define D_protect diff --git a/unix/hlib/libc/prstat.h b/unix/hlib/libc/prstat.h new file mode 100644 index 00000000..3bd5dbf3 --- /dev/null +++ b/unix/hlib/libc/prstat.h @@ -0,0 +1,19 @@ +/* PRSTAT parameters. + */ +#define PR_STATUS 1 /* process status (OK, P_DEAD) */ +#define PR_INCHAN 2 /* input channel */ +#define PR_INFD 3 /* FD of input stream */ +#define PR_OUTCHAN 4 /* output channel */ +#define PR_OUTFD 5 /* FD of output stream */ +#define PR_STDIN 7 /* FD's assigned to pseudofile streams */ +#define PR_STDERR 8 +#define PR_STDOUT 9 +#define PR_STDGRAPH 10 +#define PR_STDIMAGE 11 + +#define P_RUNNING 0 /* process status */ +#define P_BUSY 1 /* process is busy */ +#define P_DONE 2 /* process terminated normally */ +#define P_DEAD 3 /* process died and sent us X_IPC */ + +#define D_prstat diff --git a/unix/hlib/libc/prtype.h b/unix/hlib/libc/prtype.h new file mode 100644 index 00000000..04433abc --- /dev/null +++ b/unix/hlib/libc/prtype.h @@ -0,0 +1,7 @@ +/* Process control. + */ +#define PR_CONNECTED 1 /* types of processes */ +#define PR_DETACHED 2 +#define PR_HOST 3 + +#define D_prtype diff --git a/unix/hlib/libc/setjmp.h b/unix/hlib/libc/setjmp.h new file mode 100644 index 00000000..a92d6b47 --- /dev/null +++ b/unix/hlib/libc/setjmp.h @@ -0,0 +1,25 @@ +/* SETJMP, LONGJMP -- Non local goto. Requires libc.h and knames.h. + * Note that jmp_buf must be at least one int larger than necessary to + */ +#ifndef D_libc +#ifndef import_libc +#include "libc.h" +#endif +#ifndef import_knames +#include "knames.h" +#endif +#endif + +typedef int jmp_buf[LEN_JUMPBUF]; +static int u_jmpstat; + +#define setjmp(e) (ZSVJMP((e),&u_jmpstat),u_jmpstat) +#define longjmp(e,v) (u_jmpstat=(v),ZDOJMP((e),&u_jmpstat)) + +/* The following is necessary to prevent to prevent the optimizer from + * doing unwise things with setjmp on a Sun-4. + */ +extern int zsvjmp_(); +#pragma unknown_control_flow(zsvjmp_) + +#define D_setjmp diff --git a/unix/hlib/libc/spp.h b/unix/hlib/libc/spp.h new file mode 100644 index 00000000..23005007 --- /dev/null +++ b/unix/hlib/libc/spp.h @@ -0,0 +1,161 @@ +/* + * SPP.H -- Language definitions for interfacing SPP to C and C to UNIX. + * Note that many of the definitions must agree with those in the SPP + * compiler and with and . + */ + +#ifndef D_spp + +/* Assorted machine constants. [MACHDEP] + * Use osb$zzeps.f to compute the machine epsilon. + */ +#define OSOK 0 /* normal successful completion */ +#define LEN_JUMPBUF 1024 /* C "jmp_buf" len + 1 (or larger) */ +#define EPSILON (1.192e-7) /* smallest real E s.t. (1.0+E > 1.0) */ +#define EPSILOND (2.220d-16) /* double precision epsilon */ +#define MAX_LONG 2147483647 +#define FNNODE_CHAR '!' /* node name delimiter character */ + + +/* Indefinite valued numbers. (potentially MACHDEP) + */ +#define INDEFS (-32767) +#define INDEFL (0x80000001) +#define INDEFI INDEFL +#define INDEFR 1.6e38 +#define INDEFD 1.6e308 +#define INDEFX (INDEF,INDEF) +#define INDEF INDEFR + + +/* Oft used constants. + */ +#define SZ_LINE 1023 +#define SZ_FNAME 255 +#define SZ_PATHNAME 511 +#define SZ_COMMAND 2047 +#define EOS '\0' +#define ERR (-1) +#define OK 0 +#define YES 1 +#define NO 0 +#define MAX_DIGITS 25 + +#ifndef min +#define min(a,b) (((a)<(b))?(a):(b)) +#endif +#ifndef max +#define max(a,b) (((a)>(b))?(a):(b)) +#endif + +#ifndef NULL +#define NULL 0 +#endif + +#ifndef EOF +#define EOF (-1) +#endif + +/* SPP constants. + */ +#define XEOS 0 +#define XERR (-1) +#define XEOF (-2) +#define XBOF (-3) +#define XOK 0 +#define XNO 0 +#define XYES 1 + +#define BOFL (-3L) +#define EOFL (-2L) + + +/* SPP datatypes. (potentially MACHDEP) + * Must match sizes in hlib$iraf.h + */ +#ifndef XCHAR +#define XCHAR short +#endif + +#ifdef MACH64 +#define XINT long /* ILP64 */ +#define XLONG long +#define XSTRUCT long +#define XPOINTER long +#define XBOOL long +#else +#define XINT int /* ILP32 */ +#define XLONG int +#define XSTRUCT int +#define XPOINTER int +#define XBOOL int +#endif + +#define PKCHAR XCHAR +#define XUBYTE unsigned char +#define XSHORT short +#define XUSHORT unsigned short +#define XREAL float +#define XDOUBLE double +#define XCOMPLEX struct cplx + +struct cplx { + float r; + float i; +}; + +#define TY_BOOL 1 /* SPP datatype codes */ +#define TY_CHAR 2 +#define TY_SHORT 3 +#define TY_INT 4 +#define TY_LONG 5 +#define TY_REAL 6 +#define TY_DOUBLE 7 +#define TY_COMPLEX 8 +#define TY_STRUCT 9 +#define TY_POINTER 10 + + +/* File I/O constants. + */ +#define READ_ONLY 1 /* file access modes */ +#define READ_WRITE 2 +#define WRITE_ONLY 3 +#define APPEND 4 +#define NEW_FILE 5 + +#define TEXT_FILE 11 /* file types */ +#define BINARY_FILE 12 +#define DIRECTORY_FILE 13 +#define STATIC_FILE 14 +#define SYMLINK_FILE 15 +#define SPOOL_FILE (-2) + +#define CLIN 1 +#define CLOUT 2 +#define STDIN 3 +#define STDOUT 4 +#define STDERR 5 +#define STDGRAPH 6 +#define STDIMAGE 7 +#define STDPLOT 8 +#define PSIOCTRL 9 + +/* Filename Mapping definitions. + */ + +#define VFN_READ 1 /* VFN access modes for VFNOPEN */ +#define VFN_WRITE 2 +#define VFN_UNMAP 3 + +#define VFN_NOUPDATE 0 /* update flag for VFNCLOSE */ +#define VFN_UPDATE 1 + +/* Oft referenced functions. + */ +XCHAR *c_sppstr(); +XCHAR *c_strupk(); +char *c_strpak(); + +#define D_spp +#endif diff --git a/unix/hlib/libc/stdarg-cygwin.h b/unix/hlib/libc/stdarg-cygwin.h new file mode 100755 index 00000000..965c2aa7 --- /dev/null +++ b/unix/hlib/libc/stdarg-cygwin.h @@ -0,0 +1,135 @@ +/* Copyright (C) 1989, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC 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. + +GCC 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 GCC; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* As a special exception, if you include this header file into source + files compiled by GCC, this header file does not by itself cause + the resulting executable to be covered by the GNU General Public + License. This exception does not however invalidate any other + reasons why the executable file might be covered by the GNU General + Public License. */ + +/* + * ISO C Standard: 7.15 Variable arguments + */ + +#ifndef _STDARG_H +#ifndef _ANSI_STDARG_H_ +#ifndef RC_INVOKED +#ifndef __need___va_list +#define _STDARG_H +#define _ANSI_STDARG_H_ +#endif /* not __need___va_list */ +#undef __need___va_list + +/* Define __gnuc_va_list. */ + +#ifndef __GNUC_VA_LIST +#define __GNUC_VA_LIST +typedef __builtin_va_list __gnuc_va_list; +#endif + +/* Define the standard macros for the user, + if this invocation was from the user program. */ +#ifdef _STDARG_H + +#define va_start(v,l) __builtin_va_start(v,l) +#define va_end(v) __builtin_va_end(v) +#define va_arg(v,l) __builtin_va_arg(v,l) +#if !defined(__STRICT_ANSI__) || __STDC_VERSION__ + 0 >= 199900L +#define va_copy(d,s) __builtin_va_copy(d,s) +#endif +#define __va_copy(d,s) __builtin_va_copy(d,s) + +/* Define va_list, if desired, from __gnuc_va_list. */ +/* We deliberately do not define va_list when called from + stdio.h, because ANSI C says that stdio.h is not supposed to define + va_list. stdio.h needs to have access to that data type, + but must not use that name. It should use the name __gnuc_va_list, + which is safe because it is reserved for the implementation. */ + +#ifdef _HIDDEN_VA_LIST /* On OSF1, this means varargs.h is "half-loaded". */ +#undef _VA_LIST +#endif + +#ifdef _BSD_VA_LIST +#undef _BSD_VA_LIST +#endif + +#if defined(__svr4__) || (defined(_SCO_DS) && !defined(__VA_LIST)) +/* SVR4.2 uses _VA_LIST for an internal alias for va_list, + so we must avoid testing it and setting it here. + SVR4 uses _VA_LIST as a flag in stdarg.h, but we should + have no conflict with that. */ +#ifndef _VA_LIST_ +#define _VA_LIST_ +#ifdef __i860__ +#ifndef _VA_LIST +#define _VA_LIST va_list +#endif +#endif /* __i860__ */ +typedef __gnuc_va_list va_list; +#ifdef _SCO_DS +#define __VA_LIST +#endif +#endif /* _VA_LIST_ */ +#else /* not __svr4__ || _SCO_DS */ + +/* The macro _VA_LIST_ is the same thing used by this file in Ultrix. + But on BSD NET2 we must not test or define or undef it. + (Note that the comments in NET 2's ansi.h + are incorrect for _VA_LIST_--see stdio.h!) */ +#if !defined (_VA_LIST_) || defined (__BSD_NET2__) || defined (____386BSD____) || defined (__bsdi__) || defined (__sequent__) || defined (__FreeBSD__) || defined(WINNT) +/* The macro _VA_LIST_DEFINED is used in Windows NT 3.5 */ +#ifndef _VA_LIST_DEFINED +/* The macro _VA_LIST is used in SCO Unix 3.2. */ +#ifndef _VA_LIST +/* The macro _VA_LIST_T_H is used in the Bull dpx2 */ +#ifndef _VA_LIST_T_H +/* The macro __va_list__ is used by BeOS. */ +#ifndef __va_list__ +typedef __gnuc_va_list va_list; +#endif /* not __va_list__ */ +#endif /* not _VA_LIST_T_H */ +#endif /* not _VA_LIST */ +#endif /* not _VA_LIST_DEFINED */ +#if !(defined (__BSD_NET2__) || defined (____386BSD____) || defined (__bsdi__) || defined (__sequent__) || defined (__FreeBSD__)) +#define _VA_LIST_ +#endif +#ifndef _VA_LIST +#define _VA_LIST +#endif +#ifndef _VA_LIST_DEFINED +#define _VA_LIST_DEFINED +#endif +#ifndef _VA_LIST_T_H +#define _VA_LIST_T_H +#endif +#ifndef __va_list__ +#define __va_list__ +#endif + +#endif /* not _VA_LIST_, except on certain systems */ + +#endif /* not __svr4__ */ + +#endif /* _STDARG_H */ + +#endif /* not RC_INVOKED */ +#endif /* not _ANSI_STDARG_H_ */ +#endif /* not _STDARG_H */ diff --git a/unix/hlib/libc/stdarg-freebsd.h b/unix/hlib/libc/stdarg-freebsd.h new file mode 100644 index 00000000..6cf6b69d --- /dev/null +++ b/unix/hlib/libc/stdarg-freebsd.h @@ -0,0 +1,90 @@ +/*- + * Copyright (c) 2002 David E. O'Brien. All rights reserved. + * Copyright (c) 1991, 1993 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + * + * @(#)stdarg.h 8.1 (Berkeley) 6/10/93 + * $FreeBSD: src/sys/i386/include/stdarg.h,v 1.20 2005/03/02 21:33:26 joerg Exp $ + */ + +#ifndef _MACHINE_STDARG_H_ +#define _MACHINE_STDARG_H_ + +#include +#include + +#ifndef _VA_LIST_DECLARED +#define _VA_LIST_DECLARED +typedef __va_list va_list; +#endif + +#ifdef __GNUCLIKE_BUILTIN_STDARG + +#define va_start(ap, last) \ + __builtin_stdarg_start((ap), (last)) + +#define va_arg(ap, type) \ + __builtin_va_arg((ap), type) + +#if __ISO_C_VISIBLE >= 1999 +#define va_copy(dest, src) \ + __builtin_va_copy((dest), (src)) +#endif + +#define va_end(ap) \ + __builtin_va_end(ap) + +#else /* !__GNUCLIKE_BUILTIN_STDARG */ + +#define __va_size(type) \ + (((sizeof(type) + sizeof(int) - 1) / sizeof(int)) * sizeof(int)) + +#ifdef __GNUCLIKE_BUILTIN_NEXT_ARG +#define va_start(ap, last) \ + ((ap) = (va_list)__builtin_next_arg(last)) +#else /* !__GNUCLIKE_BUILTIN_NEXT_ARG */ +#define va_start(ap, last) \ + ((ap) = (va_list)&(last) + __va_size(last)) +#endif /* __GNUCLIKE_BUILTIN_NEXT_ARG */ + +#define va_arg(ap, type) \ + (*(type *)((ap) += __va_size(type), (ap) - __va_size(type))) + +#if __ISO_C_VISIBLE >= 1999 +#define va_copy(dest, src) \ + ((dest) = (src)) +#endif + +#define va_end(ap) + +#endif /* __GNUCLIKE_BUILTIN_STDARG */ + +#endif /* !_MACHINE_STDARG_H_ */ diff --git a/unix/hlib/libc/stdarg-linux.h b/unix/hlib/libc/stdarg-linux.h new file mode 100644 index 00000000..f95367b4 --- /dev/null +++ b/unix/hlib/libc/stdarg-linux.h @@ -0,0 +1,142 @@ +/* Copyright (C) 1989, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. + +This file is part of GNU CC. + +GNU CC 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. + +GNU CC 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 GNU CC; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* As a special exception, if you include this header file into source + files compiled by GCC, this header file does not by itself cause + the resulting executable to be covered by the GNU General Public + License. This exception does not however invalidate any other + reasons why the executable file might be covered by the GNU General + Public License. */ + +/* + * ISO C Standard: 7.15 Variable arguments + */ + +#ifndef _STDARG_H +#ifndef _ANSI_STDARG_H_ +#ifndef __need___va_list +#define _STDARG_H +#define _ANSI_STDARG_H_ +#endif /* not __need___va_list */ +#undef __need___va_list + +/* Define __gnuc_va_list. */ + +#ifndef __GNUC_VA_LIST +#define __GNUC_VA_LIST +typedef __builtin_va_list __gnuc_va_list; +#endif + +/* Define the standard macros for the user, + if this invocation was from the user program. */ +#ifdef _STDARG_H + +/* Note that the type used in va_arg is supposed to match the + actual type **after default promotions**. + Thus, va_arg (..., short) is not valid. */ + +#if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 4)) +#define va_start(v,l) __builtin_va_start((v),l) +#else +#define va_start(v,l) __builtin_stdarg_start((v),l) +#endif +#define va_end __builtin_va_end +#define va_arg __builtin_va_arg +#if !defined(__STRICT_ANSI__) || __STDC_VERSION__ + 0 >= 199900L +#define va_copy(d,s) __builtin_va_copy((d),(s)) +#endif +#define __va_copy(d,s) __builtin_va_copy((d),(s)) + + +/* Define va_list, if desired, from __gnuc_va_list. */ +/* We deliberately do not define va_list when called from + stdio.h, because ANSI C says that stdio.h is not supposed to define + va_list. stdio.h needs to have access to that data type, + but must not use that name. It should use the name __gnuc_va_list, + which is safe because it is reserved for the implementation. */ + +#ifdef _HIDDEN_VA_LIST /* On OSF1, this means varargs.h is "half-loaded". */ +#undef _VA_LIST +#endif + +#ifdef _BSD_VA_LIST +#undef _BSD_VA_LIST +#endif + +#if defined(__svr4__) || (defined(_SCO_DS) && !defined(__VA_LIST)) +/* SVR4.2 uses _VA_LIST for an internal alias for va_list, + so we must avoid testing it and setting it here. + SVR4 uses _VA_LIST as a flag in stdarg.h, but we should + have no conflict with that. */ +#ifndef _VA_LIST_ +#define _VA_LIST_ +#ifdef __i860__ +#ifndef _VA_LIST +#define _VA_LIST va_list +#endif +#endif /* __i860__ */ +typedef __gnuc_va_list va_list; +#ifdef _SCO_DS +#define __VA_LIST +#endif +#endif /* _VA_LIST_ */ +#else /* not __svr4__ || _SCO_DS */ + +/* The macro _VA_LIST_ is the same thing used by this file in Ultrix. + But on BSD NET2 we must not test or define or undef it. + (Note that the comments in NET 2's ansi.h + are incorrect for _VA_LIST_--see stdio.h!) */ +#if !defined (_VA_LIST_) || defined (__BSD_NET2__) || defined (____386BSD____) || defined (__bsdi__) || defined (__sequent__) || defined (__FreeBSD__) || defined(WINNT) +/* The macro _VA_LIST_DEFINED is used in Windows NT 3.5 */ +#ifndef _VA_LIST_DEFINED +/* The macro _VA_LIST is used in SCO Unix 3.2. */ +#ifndef _VA_LIST +/* The macro _VA_LIST_T_H is used in the Bull dpx2 */ +#ifndef _VA_LIST_T_H +/* The macro __va_list__ is used by BeOS. */ +#ifndef __va_list__ +typedef __gnuc_va_list va_list; +#endif /* not __va_list__ */ +#endif /* not _VA_LIST_T_H */ +#endif /* not _VA_LIST */ +#endif /* not _VA_LIST_DEFINED */ +#if !(defined (__BSD_NET2__) || defined (____386BSD____) || defined (__bsdi__) || defined (__sequent__) || defined (__FreeBSD__)) +#define _VA_LIST_ +#endif +#ifndef _VA_LIST +#define _VA_LIST +#endif +#ifndef _VA_LIST_DEFINED +#define _VA_LIST_DEFINED +#endif +#ifndef _VA_LIST_T_H +#define _VA_LIST_T_H +#endif +#ifndef __va_list__ +#define __va_list__ +#endif + +#endif /* not _VA_LIST_, except on certain systems */ + +#endif /* not __svr4__ */ + +#endif /* _STDARG_H */ + +#endif /* not _ANSI_STDARG_H_ */ +#endif /* not _STDARG_H */ diff --git a/unix/hlib/libc/stdarg-osx.h b/unix/hlib/libc/stdarg-osx.h new file mode 100644 index 00000000..f178505e --- /dev/null +++ b/unix/hlib/libc/stdarg-osx.h @@ -0,0 +1,133 @@ +/* Copyright (C) 1989, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC 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. + +GCC 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 GCC; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* As a special exception, if you include this header file into source + files compiled by GCC, this header file does not by itself cause + the resulting executable to be covered by the GNU General Public + License. This exception does not however invalidate any other + reasons why the executable file might be covered by the GNU General + Public License. */ + +/* + * ISO C Standard: 7.15 Variable arguments + */ + +#ifndef _STDARG_H +#ifndef _ANSI_STDARG_H_ +#ifndef __need___va_list +#define _STDARG_H +#define _ANSI_STDARG_H_ +#endif /* not __need___va_list */ +#undef __need___va_list + +/* Define __gnuc_va_list. */ + +#ifndef __GNUC_VA_LIST +#define __GNUC_VA_LIST +typedef __builtin_va_list __gnuc_va_list; +#endif + +/* Define the standard macros for the user, + if this invocation was from the user program. */ +#ifdef _STDARG_H + +#define va_start(v,l) __builtin_va_start(v,l) +#define va_end(v) __builtin_va_end(v) +#define va_arg(v,l) __builtin_va_arg(v,l) +#if !defined(__STRICT_ANSI__) || __STDC_VERSION__ + 0 >= 199900L +#define va_copy(d,s) __builtin_va_copy(d,s) +#endif +#define __va_copy(d,s) __builtin_va_copy(d,s) + +/* Define va_list, if desired, from __gnuc_va_list. */ +/* We deliberately do not define va_list when called from + stdio.h, because ANSI C says that stdio.h is not supposed to define + va_list. stdio.h needs to have access to that data type, + but must not use that name. It should use the name __gnuc_va_list, + which is safe because it is reserved for the implementation. */ + +#ifdef _HIDDEN_VA_LIST /* On OSF1, this means varargs.h is "half-loaded". */ +#undef _VA_LIST +#endif + +#ifdef _BSD_VA_LIST +#undef _BSD_VA_LIST +#endif + +#if defined(__svr4__) || (defined(_SCO_DS) && !defined(__VA_LIST)) +/* SVR4.2 uses _VA_LIST for an internal alias for va_list, + so we must avoid testing it and setting it here. + SVR4 uses _VA_LIST as a flag in stdarg.h, but we should + have no conflict with that. */ +#ifndef _VA_LIST_ +#define _VA_LIST_ +#ifdef __i860__ +#ifndef _VA_LIST +#define _VA_LIST va_list +#endif +#endif /* __i860__ */ +typedef __gnuc_va_list va_list; +#ifdef _SCO_DS +#define __VA_LIST +#endif +#endif /* _VA_LIST_ */ +#else /* not __svr4__ || _SCO_DS */ + +/* The macro _VA_LIST_ is the same thing used by this file in Ultrix. + But on BSD NET2 we must not test or define or undef it. + (Note that the comments in NET 2's ansi.h + are incorrect for _VA_LIST_--see stdio.h!) */ +#if !defined (_VA_LIST_) || defined (__BSD_NET2__) || defined (____386BSD____) || defined (__bsdi__) || defined (__sequent__) || defined (__FreeBSD__) || defined(WINNT) +/* The macro _VA_LIST_DEFINED is used in Windows NT 3.5 */ +#ifndef _VA_LIST_DEFINED +/* The macro _VA_LIST is used in SCO Unix 3.2. */ +#ifndef _VA_LIST +/* The macro _VA_LIST_T_H is used in the Bull dpx2 */ +#ifndef _VA_LIST_T_H +/* The macro __va_list__ is used by BeOS. */ +#ifndef __va_list__ +typedef __gnuc_va_list va_list; +#endif /* not __va_list__ */ +#endif /* not _VA_LIST_T_H */ +#endif /* not _VA_LIST */ +#endif /* not _VA_LIST_DEFINED */ +#if !(defined (__BSD_NET2__) || defined (____386BSD____) || defined (__bsdi__) || defined (__sequent__) || defined (__FreeBSD__)) +#define _VA_LIST_ +#endif +#ifndef _VA_LIST +#define _VA_LIST +#endif +#ifndef _VA_LIST_DEFINED +#define _VA_LIST_DEFINED +#endif +#ifndef _VA_LIST_T_H +#define _VA_LIST_T_H +#endif +#ifndef __va_list__ +#define __va_list__ +#endif + +#endif /* not _VA_LIST_, except on certain systems */ + +#endif /* not __svr4__ */ + +#endif /* _STDARG_H */ + +#endif /* not _ANSI_STDARG_H_ */ +#endif /* not _STDARG_H */ diff --git a/unix/hlib/libc/stdarg-solaris.h b/unix/hlib/libc/stdarg-solaris.h new file mode 100644 index 00000000..c35c5ce2 --- /dev/null +++ b/unix/hlib/libc/stdarg-solaris.h @@ -0,0 +1,64 @@ +/* Copyright (c) 1988 AT&T */ +/* All Rights Reserved */ + +/* THIS IS UNPUBLISHED PROPRIETARY SOURCE CODE OF AT&T */ +/* The copyright notice above does not evidence any */ +/* actual or intended publication of such source code. */ + +/* + * Copyright 2004 Sun Microsystems, Inc. All rights reserved. + * Use is subject to license terms. + */ + +/* + * An application should not include this header directly. Instead it + * should be included only through the inclusion of other Sun headers. + * + * The contents of this header is limited to identifiers specified in the + * C Standard. Any new identifiers specified in future amendments to the + * C Standard must be placed in this header. If these new identifiers + * are required to also be in the C++ Standard "std" namespace, then for + * anything other than macro definitions, corresponding "using" directives + * must also be added to . + */ + +#ifndef _ISO_STDARG_ISO_H +#define _ISO_STDARG_ISO_H + +#pragma ident "@(#)stdarg_iso.h 1.4 04/11/19 SMI" /* SVr4.0 1.8 */ + +/* + * This header defines the ISO C 1989 and ISO C++ 1998 variable + * argument definitions. + * + * The varargs definitions within this header are defined in terms of + * implementation definitions. These implementation definitions reside + * in . This organization enables protected use of + * the implementation by other standard headers without introducing + * names into the users' namespace. + */ + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +#if __cplusplus >= 199711L +namespace std { +typedef __va_list va_list; +} +#elif !defined(_VA_LIST) +#define _VA_LIST +typedef __va_list va_list; +#endif + +#define va_start(list, name) __va_start(list, name) +#define va_arg(list, type) __va_arg(list, type) +#define va_end(list) __va_end(list) + +#ifdef __cplusplus +} +#endif + +#endif /* _ISO_STDARG_ISO_H */ diff --git a/unix/hlib/libc/stdarg.h b/unix/hlib/libc/stdarg.h new file mode 100644 index 00000000..a52889d8 --- /dev/null +++ b/unix/hlib/libc/stdarg.h @@ -0,0 +1,40 @@ +/* STDARG.H -- Interface to the Unix variable argument-list interface. + * This version replaces , but is NOT backwards compatible. + * + * We pick up the local UNIX definitions for dealing with a variable + * number of arguments. This is done via indirection through this file so + * that any problems can be dealt with by changing only this file. + * + * Usage: Include this file using import_stdarg. If USE_STDARG is + * defined use the stdarg interface, otherwise use the varargs + * interface (ifdef the code accordingly). Old code which uses + * varargs directly is unaffected. + */ +#ifndef D_stdarg + + +#ifdef MACOSX +#include "stdarg-osx.h" +#else +#ifdef __CYGWIN__ +#include "stdarg-cygwin.h" +#else +#ifdef LINUX +#include "stdarg-linux.h" +#else +#ifdef SOLARIS +#include "stdarg-solaris.h" +#else +#ifdef BSD +#include "stdarg-freebsd.h" +#else +#include +#endif +#endif +#endif +#endif +#endif + + +#define D_stdarg +#endif diff --git a/unix/hlib/libc/stdio.h b/unix/hlib/libc/stdio.h new file mode 100644 index 00000000..c3cc0bd6 --- /dev/null +++ b/unix/hlib/libc/stdio.h @@ -0,0 +1,99 @@ +/* + * U_STDIO.H -- C defines used to emulate the UNIX standard i/o package upon + * IRAF file i/o. These definitions are portable, but highly dependent on + * the guts of IRAF FIO. + */ + +#ifndef D_libc +#ifndef import_libc +#include "libc.h" +#endif +#endif + +#define BUFSIZ SZ_DEFIOBUF +#define _NFILE FIO_MAXFD +#define FILE struct _iobuf + +# ifndef NULL +#define NULL 0 +# endif +# ifndef EOF +#define EOF (-1) +# endif + +/* Filler space is defined here to reduce clutter in the struct def below. + */ +#define _F1 _filler1[_NFILE-1] +#define _F2 _filler2[_NFILE-1] +#define _F3 _filler3[_NFILE-1] +#define _F4 _filler4[_NFILE-1] +#define _F5 _filler5[_NFILE-1] +#define _F6 _filler6[_NFILE-1] +#define _F7 _filler7[_NFILE-1] + +/* The _iobuf structure is the C version of the FIO common /fiocom/, which + * contains all the FIO buffer and i/o pointers. Each structure field is + * maintained in the common as an array of length _NFILE, hence in terms of + * C the structures are interleaved. The file pointers are indices into + * the array Memc, an array of XCHAR. + */ +struct _iobuf { + XLONG _boffset, _F1; /* XCHAR file offset of buffer */ + XINT _bufptr, _F2; /* buffer pointer */ + XINT _buftop, _F3; /* pointer to top of buffer + 1 */ + XINT _iop, _F4; /* pointer to next XCHAR */ + XINT _itop, _F5; /* call filbuf when _iop >= */ + XINT _otop, _F6; /* call flsbuf when _iop >= */ + XINT _fiodes, _F7; /* FIO file descriptor */ + XINT _fflags; /* bit flags */ +}; + +extern XINT FIOCOM[]; /* the FIO common */ + +#define _FFLUSHNL 01 /* flush buffer on newline */ +#define _FREAD 02 /* read perm on file */ +#define _FWRITE 04 /* read perm on file */ +#define _FEOF 010 /* file positioned to EOF */ +#define _FERR 020 /* i/o error on file */ +#define _FKEEP 040 /* keep file open at exit */ +#define _FFLUSH 0100 /* write to device on newline */ +#define _FRAW 0200 /* raw input mode */ +#define _FNDELAY 0400 /* nonblocking i/o */ +#define _FPUSH 01000 /* data is pushed back */ +#define _FIPC 02000 /* file is an IPC channel */ + +/* Convert FILE pointers to and from FIO integer file descriptors. + */ +#define FDTOFP(fd) ((FILE *)(&FIOCOM[(fd)-1])) +#define FPTOFD(fp) ((XINT)((XINT *)(fp) - FIOCOM + 1)) + +#define stdin (FDTOFP(3)) +#define stdout (FDTOFP(4)) +#define stderr (FDTOFP(5)) + + +/* I/O macro defines. I/O is assumed to be sequential, i.e., we do not check + * for _iop < _bufptr. This is consistent with UNIX usage. The getc and putc + * macros are quite efficient despite their complex appearance. + */ +#define getchar() fgetc(stdin) +#define getc(fp) \ +(((fp)->_iop >= (fp)->_itop) ? c_filbuf((fp)) : Memc[(fp)->_iop++] & 0377) + +#define putchar(ch) fputc((ch),stdout) +#define putc(ch,fp) \ +(((fp)->_iop >= (fp)->_otop || ((ch) == '\n' && (fp)->_fflags&_FFLUSH)) ? \ +c_flsbuf((unsigned)(ch),(fp)) : ((int)(Memc[(fp)->_iop++] = (unsigned)(ch)))) + +#define fileno(fp) (FPTOFD((fp))) +#define feof(fp) ((fp)->_fflags & _FEOF) +#define ferror(fp) ((fp)->_fflags & _FERR) +#define clearerr(fp) ((fp)->_fflags &= ~_FERR) + + +FILE *fopen(); +FILE *fdopen(); +char *fgets(); +char *gets(); + +#define D_stdio diff --git a/unix/hlib/libc/ttset.h b/unix/hlib/libc/ttset.h new file mode 100644 index 00000000..a70e5c99 --- /dev/null +++ b/unix/hlib/libc/ttset.h @@ -0,0 +1,27 @@ +/* TTSET.H -- Set terminal control options (TT logical terminal driver). + */ +#define TT_INITIALIZE 0 /* initialize TT driver status */ +#define TT_KINCHAN 101 /* kernel tty input channel */ +#define TT_KOUTCHAN 102 /* kernel tty output channel */ +#define TT_LOGINCHAN 103 /* login spoolfile channel */ +#define TT_LOGOUTCHAN 104 /* logout spoolfile channel */ +#define TT_PBINCHAN 105 /* playback spoolfile channel */ +#define TT_UCASEIN 106 /* map input to lower case */ +#define TT_UCASEOUT 107 /* map output to upper case */ +#define TT_SHIFTLOCK 108 /* software shiftlock */ +#define TT_RAWMODE 109 /* raw mode in effect */ +#define TT_LOGIO 110 /* log terminal i/o */ +#define TT_LOGIN 111 /* log terminal input */ +#define TT_LOGOUT 112 /* log terminal output */ +#define TT_PLAYBACK 113 /* take input from a spool file */ +#define TT_PBVERIFY 114 /* pause at \n during playback */ +#define TT_PBDELAY 115 /* msec delay/per record during playback */ +#define TT_PASSTHRU 116 /* passthru mode (direct i/o to device) */ +#define TT_IOFILE 117 /* logio file name */ +#define TT_INFILE 118 /* login file name */ +#define TT_OUTFILE 119 /* logout file name */ +#define TT_PBFILE 120 /* playback file name */ +#define TT_TDEVICE 121 /* terminal device at record time */ +#define TT_GDEVICE 122 /* stdgraph device at record time */ + +#define D_ttset diff --git a/unix/hlib/libc/vosproto.h b/unix/hlib/libc/vosproto.h new file mode 100644 index 00000000..031efd39 --- /dev/null +++ b/unix/hlib/libc/vosproto.h @@ -0,0 +1,4035 @@ +extern C_f ahivx_(complex * ret_val, complex *a, integer *npix); +extern C_f alovx_(complex * ret_val, complex *a, integer *npix); +extern C_f amedx_(complex * ret_val, complex *a, integer *npix); +extern C_f asokx_(complex * ret_val, complex *a, integer *npix, integer *ksel); +extern C_f assqx_(complex * ret_val, complex *a, integer *npix); +extern C_f asumx_(complex * ret_val, complex *a, integer *npix); +extern C_f clgetx_(complex * ret_val, shortint *param); +extern C_f clgpsx_(complex * ret_val, integer *pp, shortint *parnae); +extern C_f qpgetx_(complex * ret_val, integer *qp, shortint *param); +extern H_f agbnch_(char *ret_val, ftnlen ret_val_len, integer *idsh); +extern H_f agdshn_(char *ret_val, ftnlen ret_val_len, integer *idsh); +extern doublereal adotd_(doublereal *a, doublereal *b, integer *npix); +extern doublereal adotl_(integer *a, integer *b, integer *npix); +extern doublereal aelogd_(doublereal *x); +extern doublereal ahivd_(doublereal *a, integer *npix); +extern doublereal alovd_(doublereal *a, integer *npix); +extern doublereal amedd_(doublereal *a, integer *npix); +extern doublereal apold_(doublereal *x, doublereal *coeff, integer *ncoeff); +extern doublereal asokd_(doublereal *a, integer *npix, integer *ksel); +extern doublereal assqd_(doublereal *a, integer *npix); +extern doublereal assql_(integer *a, integer *npix); +extern doublereal asumd_(doublereal *a, integer *npix); +extern doublereal asuml_(integer *a, integer *npix); +extern doublereal clgetd_(shortint *param); +extern doublereal clgpsd_(integer *pp, shortint *parnae); +extern doublereal cqdged_(integer *cq, integer *record, shortint *field); +extern doublereal cqfged_(integer *cq, shortint *field); +extern doublereal cqistd_(integer *res, integer *param); +extern doublereal cqrstd_(integer *res, integer *param); +extern doublereal dtgetd_(integer *dt, integer *record, shortint *field); +extern doublereal dtmday_(integer *year, integer *month, integer *day, doublereal *t); +extern doublereal elogd_(doublereal *x); +extern doublereal envged_(shortint *varnae); +extern doublereal fpfixd_(doublereal *x); +extern doublereal icrmsd_(doublereal *x, doublereal *y, doublereal *fit, doublereal *wts, integer *npts); +extern doublereal imgetd_(integer *im, shortint *key); +extern doublereal ingdvd_(doublereal *x); +extern doublereal ingetd_(integer *in, integer *param); +extern doublereal inrmsd_(doublereal *y, doublereal *fit, doublereal *wts, integer *npts); +extern doublereal mefged_(integer *mef, shortint *key); +extern doublereal mwc1td_(integer *act, doublereal *x); +extern doublereal obsged_(integer *obs, shortint *param); +extern doublereal qpgetd_(integer *qp, shortint *param); +extern doublereal qpmaxd_(doublereal *x, doublereal *y); +extern doublereal qpmind_(doublereal *x, doublereal *y); +extern doublereal skstad_(integer *coo, integer *param); +extern doublereal wfgsdr_(integer *sf1, doublereal *x, doublereal *y, integer *nxd, integer *nyd); +extern doublereal wfgsel_(integer *sf, doublereal *x, doublereal *y); +extern doublereal wfmspi_(doublereal *coeff, doublereal *y, doublereal *x, doublereal *dydx); +extern doublereal wfmspl_(doublereal *coeff, doublereal *xin); +extern doublereal wlange_(integer *wd, integer *labels, integer *nlabes); +extern doublereal wlched_(doublereal *ex, doublereal *arr, integer *n); +extern doublereal wlcoon_(integer *wlct, integer *flip, doublereal *wx1, doublereal *wy1, doublereal *wx2, doublereal *wy2); +extern doublereal wldisd_(doublereal *x1, doublereal *y1, doublereal *x2, doublereal *y2); +extern doublereal wlroud_(doublereal *x, doublereal *y); +extern doublereal wlstre_(doublereal *angle, integer *rightp); +extern doublereal wlstrl_(shortint *input, integer *axiste, integer *whichs); +extern doublereal wlvece_(integer *gp, doublereal *x1, doublereal *y1, doublereal *x2, doublereal *y2); +extern doublereal xacos_(doublereal *x); +extern doublereal xasin_(doublereal *x); +extern doublereal xatan2_(doublereal *x, doublereal *y); +extern doublereal xatan_(doublereal *x); +extern doublereal xcos_(doublereal *x); +extern doublereal xexp_(doublereal *x); +extern doublereal xlog10_(doublereal *x); +extern doublereal xlog_(doublereal *x); +extern doublereal xpow_(doublereal *x, doublereal *y); +extern doublereal xsin_(doublereal *x); +extern doublereal xsqrt_(doublereal *x); +extern doublereal xtan_(doublereal *x); +extern doublereal xtargd_(integer *stp, shortint *key); +extern integer aabsd_(doublereal *a, doublereal *b, integer *npix); +extern integer aabsi_(integer *a, integer *b, integer *npix); +extern integer aabsl_(integer *a, integer *b, integer *npix); +extern integer aabsr_(real *a, real *b, integer *npix); +extern integer aabss_(shortint *a, shortint *b, integer *npix); +extern integer aabsx_(complex *a, complex *b, integer *npix); +extern integer aaddd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer aaddi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aaddkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer aaddki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aaddkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aaddkr_(real *a, real *b, real *c__, integer *npix); +extern integer aaddks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aaddkx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer aaddl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aaddr_(real *a, real *b, real *c__, integer *npix); +extern integer aadds_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aaddx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer aandi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aandki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aandkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aandks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aandl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aands_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aavgd_(doublereal *a, integer *npix, doublereal *mean, doublereal *sigma); +extern integer aavgi_(integer *a, integer *npix, real *mean, real *sigma); +extern integer aavgl_(integer *a, integer *npix, doublereal *mean, doublereal *sigma); +extern integer aavgr_(real *a, integer *npix, real *mean, real *sigma); +extern integer aavgs_(shortint *a, integer *npix, real *mean, real *sigma); +extern integer aavgx_(complex *a, integer *npix, real *mean, real *sigma); +extern integer abavd_(doublereal *a, doublereal *b, integer *nblocs, integer *npixpk); +extern integer abavi_(integer *a, integer *b, integer *nblocs, integer *npixpk); +extern integer abavl_(integer *a, integer *b, integer *nblocs, integer *npixpk); +extern integer abavr_(real *a, real *b, integer *nblocs, integer *npixpk); +extern integer abavs_(shortint *a, shortint *b, integer *nblocs, integer *npixpk); +extern integer abavx_(complex *a, complex *b, integer *nblocs, integer *npixpk); +extern integer abeqc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abeqd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abeqi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abeqkc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abeqkd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abeqki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abeqkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abeqkr_(real *a, real *b, integer *c__, integer *npix); +extern integer abeqks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abeqkx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abeql_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abeqr_(real *a, real *b, integer *c__, integer *npix); +extern integer abeqs_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abeqx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abgec_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abged_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abgei_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abgekc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abgekd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abgeki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abgekl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abgekr_(real *a, real *b, integer *c__, integer *npix); +extern integer abgeks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abgekx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abgel_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abger_(real *a, real *b, integer *c__, integer *npix); +extern integer abges_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abgex_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abgtc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abgtd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abgti_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abgtkc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abgtkd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abgtki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abgtkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abgtkr_(real *a, real *b, integer *c__, integer *npix); +extern integer abgtks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abgtkx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abgtl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abgtr_(real *a, real *b, integer *c__, integer *npix); +extern integer abgts_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abgtx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer ablec_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abled_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer ablei_(integer *a, integer *b, integer *c__, integer *npix); +extern integer ablekc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer ablekd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer ableki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer ablekl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer ablekr_(real *a, real *b, integer *c__, integer *npix); +extern integer ableks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer ablekx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer ablel_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abler_(real *a, real *b, integer *c__, integer *npix); +extern integer ables_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer ablex_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abltc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abltd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer ablti_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abltkc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abltkd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abltki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abltkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abltkr_(real *a, real *b, integer *c__, integer *npix); +extern integer abltks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abltkx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abltl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abltr_(real *a, real *b, integer *c__, integer *npix); +extern integer ablts_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abltx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abnec_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abned_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abnei_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abnekc_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abnekd_(doublereal *a, doublereal *b, integer *c__, integer *npix); +extern integer abneki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abnekl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abnekr_(real *a, real *b, integer *c__, integer *npix); +extern integer abneks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abnekx_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abnel_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abner_(real *a, real *b, integer *c__, integer *npix); +extern integer abnes_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer abnex_(complex *a, complex *b, integer *c__, integer *npix); +extern integer abori_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aborki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aborkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aborks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aborl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer abors_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer absud_(doublereal *a, doublereal *b, integer *nblocs, integer *npixpk); +extern integer absui_(integer *a, integer *b, integer *nblocs, integer *npixpk); +extern integer absul_(integer *a, integer *b, integer *nblocs, integer *npixpk); +extern integer absur_(real *a, real *b, integer *nblocs, integer *npixpk); +extern integer absus_(shortint *a, shortint *b, integer *nblocs, integer *npixpk); +extern integer acht_(shortint *a, shortint *b, integer *nelem, integer *tya, integer *tyb); +extern integer achtb_(shortint *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtc_(shortint *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtcc_(shortint *a, shortint *b, integer *npix); +extern integer achtcd_(shortint *a, doublereal *b, integer *npix); +extern integer achtci_(shortint *a, integer *b, integer *npix); +extern integer achtcl_(shortint *a, integer *b, integer *npix); +extern integer achtcr_(shortint *a, real *b, integer *npix); +extern integer achtcs_(shortint *a, shortint *b, integer *npix); +extern integer achtcx_(shortint *a, complex *b, integer *npix); +extern integer achtd_(doublereal *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtdc_(doublereal *a, shortint *b, integer *npix); +extern integer achtdd_(doublereal *a, doublereal *b, integer *npix); +extern integer achtdi_(doublereal *a, integer *b, integer *npix); +extern integer achtdl_(doublereal *a, integer *b, integer *npix); +extern integer achtdr_(doublereal *a, real *b, integer *npix); +extern integer achtds_(doublereal *a, shortint *b, integer *npix); +extern integer achtdx_(doublereal *a, complex *b, integer *npix); +extern integer achti_(integer *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtic_(integer *a, shortint *b, integer *npix); +extern integer achtid_(integer *a, doublereal *b, integer *npix); +extern integer achtii_(integer *a, integer *b, integer *npix); +extern integer achtil_(integer *a, integer *b, integer *npix); +extern integer achtir_(integer *a, real *b, integer *npix); +extern integer achtis_(integer *a, shortint *b, integer *npix); +extern integer achtix_(integer *a, complex *b, integer *npix); +extern integer achtl_(integer *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtlc_(integer *a, shortint *b, integer *npix); +extern integer achtld_(integer *a, doublereal *b, integer *npix); +extern integer achtli_(integer *a, integer *b, integer *npix); +extern integer achtll_(integer *a, integer *b, integer *npix); +extern integer achtlr_(integer *a, real *b, integer *npix); +extern integer achtls_(integer *a, shortint *b, integer *npix); +extern integer achtlx_(integer *a, complex *b, integer *npix); +extern integer achtr_(real *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtrc_(real *a, shortint *b, integer *npix); +extern integer achtrd_(real *a, doublereal *b, integer *npix); +extern integer achtri_(real *a, integer *b, integer *npix); +extern integer achtrl_(real *a, integer *b, integer *npix); +extern integer achtrr_(real *a, real *b, integer *npix); +extern integer achtrs_(real *a, shortint *b, integer *npix); +extern integer achtrx_(real *a, complex *b, integer *npix); +extern integer achts_(shortint *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtsc_(shortint *a, shortint *b, integer *npix); +extern integer achtsd_(shortint *a, doublereal *b, integer *npix); +extern integer achtsi_(shortint *a, integer *b, integer *npix); +extern integer achtsl_(shortint *a, integer *b, integer *npix); +extern integer achtsr_(shortint *a, real *b, integer *npix); +extern integer achtss_(shortint *a, shortint *b, integer *npix); +extern integer achtsx_(shortint *a, complex *b, integer *npix); +extern integer achtu_(shortint *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtx_(complex *a, shortint *b, integer *nelem, integer *tyb); +extern integer achtxc_(complex *a, shortint *b, integer *npix); +extern integer achtxd_(complex *a, doublereal *b, integer *npix); +extern integer achtxi_(complex *a, integer *b, integer *npix); +extern integer achtxl_(complex *a, integer *b, integer *npix); +extern integer achtxr_(complex *a, real *b, integer *npix); +extern integer achtxs_(complex *a, shortint *b, integer *npix); +extern integer achtxx_(complex *a, complex *b, integer *npix); +extern integer acjgx_(complex *a, complex *b, integer *npix); +extern integer acjgx_(complex *a, complex *b, integer *npix); +extern integer aclrc_(shortint *a, integer *npix); +extern integer aclrd_(doublereal *a, integer *npix); +extern integer aclri_(integer *a, integer *npix); +extern integer aclrl_(integer *a, integer *npix); +extern integer aclrr_(real *a, integer *npix); +extern integer aclrs_(shortint *a, integer *npix); +extern integer aclrx_(complex *a, integer *npix); +extern integer acnvd_(doublereal *in, doublereal *out, integer *npix, doublereal *kernel, integer *knpix); +extern integer acnvi_(integer *in, integer *out, integer *npix, integer *kernel, integer *knpix); +extern integer acnvl_(integer *in, integer *out, integer *npix, integer *kernel, integer *knpix); +extern integer acnvr_(real *in, real *out, integer *npix, real *kernel, integer *knpix); +extern integer acnvrd_(doublereal *in, doublereal *out, integer *npix, real *kernel, integer *knpix); +extern integer acnvri_(integer *in, integer *out, integer *npix, real *kernel, integer *knpix); +extern integer acnvrl_(integer *in, integer *out, integer *npix, real *kernel, integer *knpix); +extern integer acnvrr_(real *in, real *out, integer *npix, real *kernel, integer *knpix); +extern integer acnvrs_(shortint *in, shortint *out, integer *npix, real *kernel, integer *knpix); +extern integer acnvs_(shortint *in, shortint *out, integer *npix, shortint *kernel, integer *knpix); +extern integer adivd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer adivi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer adivkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer adivki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer adivkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer adivkr_(real *a, real *b, real *c__, integer *npix); +extern integer adivks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer adivkx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer adivl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer adivr_(real *a, real *b, real *c__, integer *npix); +extern integer adivs_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer adivx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer advzd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix, D_fp errfcn); +extern integer advzi_(integer *a, integer *b, integer *c__, integer *npix, I_fp errfcn); +extern integer advzl_(integer *a, integer *b, integer *c__, integer *npix, I_fp errfcn); +extern integer advzr_(real *a, real *b, real *c__, integer *npix, R_fp errfcn); +extern integer advzs_(shortint *a, shortint *b, shortint *c__, integer *npix, J_fp errfcn); +extern integer advzx_(complex *a, complex *b, complex *c__, integer *npix, C_fp errfcn); +extern integer aexpd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer aexpi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aexpkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer aexpki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aexpkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aexpkr_(real *a, real *b, real *c__, integer *npix); +extern integer aexpks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aexpkx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer aexpl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aexpr_(real *a, real *b, real *c__, integer *npix); +extern integer aexps_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aexpx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer afftrr_(real *sr, real *si, real *fr, real *fi, integer *npix); +extern integer afftrr_(real *sr, real *si, real *fr, real *fi, integer *npix); +extern integer afftrx_(real *a, complex *b, integer *npix); +extern integer afftrx_(real *a, complex *b, integer *npix); +extern integer afftxr_(real *sr, real *si, real *fr, real *fi, integer *npix); +extern integer afftxr_(real *sr, real *si, real *fr, real *fi, integer *npix); +extern integer afftxx_(complex *a, complex *b, integer *npix); +extern integer afftxx_(complex *a, complex *b, integer *npix); +extern integer agaxis_(integer *iaxs, real *qtst, real *qspa, real *wcwp, real *hcwp, real *xbga, real *ybga, real *xnda, real *ynda, real *qlua, real *ubga, real *unda, real *funs, real *qbtp, real *base, real *qjdp, real *wmjl, real *wmjr, real *qmnt, real *qndp, real *wmnl, real *wmnr, real *qltp, real *qlex, real *qlfl, real *qlof, real *qlos, real *dnla, real *wclm, real *wcle, real *rfnl, real *qcim, real *qcie, real *wnll, real *wnlr, real *wnlb, real *wnle); +extern integer agback_(void); +extern integer agchax_(integer *iflg, integer *iaxs, integer *iprt, real *vils); +extern integer agchcu_(integer *iflg, integer *kdsh); +extern integer agchil_(integer *iflg, char *lbnm, integer *lnno, ftnlen lbnm_len); +extern integer agchnl_(integer *iaxs, real *vils, char *chrm, integer *mcim, integer *ncim, integer *ipxm, char *chre, integer *mcie, integer *ncie, ftnlen chrm_len, ftnlen chre_len); +extern integer agchnl_(integer *iaxs, real *vils, char *chrm, integer *mcim, integer *ncim, integer *ipxm, char *chre, integer *mcie, integer *ncie, ftnlen chrm_len, ftnlen chre_len); +extern integer agcorn_(integer *ntgr, char *bcrn, integer *ncrn, ftnlen bcrn_len); +extern integer agctcs_(char *tpid, integer *itcs, ftnlen tpid_len); +extern integer agctko_(real *xbga, real *ybga, real *xdca, real *ydca, real *cfax, real *cfay, real *csfa, integer *jaor, integer *nmmt, real *qmdp, real *wmml, real *wmmr, real *fnll, real *fnlr, integer *mm12, integer *mm34, real *xmmt, real *ymmt); +extern integer agcurv_(real *xvec, integer *iiex, real *yvec, integer *iiey, integer *nexy, integer *kdsh); +extern integer agdash_(real *dash, real *wodq, real *wocd, real *scwp); +extern integer agdflt_(void); +extern integer agdlch_(integer *idcs); +extern integer agexax_(integer *iaxs, real *sval, real *umin, real *umax, integer *nice, real *qlua, real *funs, real *qbtp, real *basd, real *base, real *qmjd, real *qmnd, real *qmnt, real *qltd, real *qltp, real *qled, real *qlex, real *qlfd, real *qlfl, real *qmin, real *qmax); +extern integer agexus_(real *sval, real *zmin, real *zmax, real *zlow, real *zhgh, real *zdra, integer *nviz, integer *iivz, integer *nevz, integer *iiez, real *umin, real *umax); +extern integer agezsu_(integer *itoc, real *xdra, real *ydra, integer *idxy, integer *many, integer *npts, char *labg, integer *iivx, integer *iiex, integer *iivy, integer *iiey, ftnlen labg_len); +extern integer agftol_(integer *iaxs, integer *idma, real *vinp, real *votp, real *vlcs, integer *llua, real *ubeg, real *udif, real *funs, integer *nbtp, real *sbse); +extern integer aggetc_(char *tpid, char *cusr, ftnlen tpid_len, ftnlen cusr_len); +extern integer aggetf_(char *tpid, real *fusr, ftnlen tpid_len); +extern integer aggeti_(char *tpid, integer *iusr, ftnlen tpid_len); +extern integer aggetp_(char *tpid, real *fura, integer *lura, ftnlen tpid_len); +extern integer aggtch_(integer *idcs, char *chst, integer *lncs, ftnlen chst_len); +extern integer aginit_(void); +extern integer agkurv_(real *xvec, integer *iiex, real *yvec, integer *iiey, integer *nexy, real *sval); +extern integer aglbls_(integer *itst, real *wcwp, real *hcwp, real *fllb, integer *lbim, real *flln, real *dbox, real *sbox, real *rbox); +extern integer agltc_(shortint *a, shortint *b, integer *npix, shortint *low, shortint *high, real *kmul, real *kadd, integer *nrange); +extern integer agltd_(doublereal *a, doublereal *b, integer *npix, doublereal *low, doublereal *high, doublereal *kmul, doublereal *kadd, integer *nrange); +extern integer aglti_(integer *a, integer *b, integer *npix, integer *low, integer *high, real *kmul, real *kadd, integer *nrange); +extern integer agltl_(integer *a, integer *b, integer *npix, integer *low, integer *high, doublereal *kmul, doublereal *kadd, integer *nrange); +extern integer agltr_(real *a, real *b, integer *npix, real *low, real *high, real *kmul, real *kadd, integer *nrange); +extern integer aglts_(shortint *a, shortint *b, integer *npix, shortint *low, shortint *high, real *kmul, real *kadd, integer *nrange); +extern integer agltx_(complex *a, complex *b, integer *npix, complex *low, complex *high, real *kmul, real *kadd, integer *nrange); +extern integer agnumb_(integer *nbtp, real *sbse, real *exmu, integer *nltp, integer *nlex, integer *nlfl, char *bfrm, integer *mcim, integer *ncim, integer *ipxm, char *bfre, integer *mcie, integer *ncie, ftnlen bfrm_len, ftnlen bfre_len); +extern integer agppid_(char *tpid, ftnlen tpid_len); +extern integer agpwrt_(real *xpos, real *ypos, char *chrs, integer *nchs, integer *isiz, integer *iori, integer *icen, ftnlen chrs_len); +extern integer agqurv_(real *xvec, integer *iiex, real *yvec, integer *iiey, integer *nexy, real *sval); +extern integer agrpch_(char *chst, integer *lncs, integer *idcs, ftnlen chst_len); +extern integer agrstr_(integer *ifno); +extern integer agsave_(integer *ifno); +extern integer agscan_(char *tpid, integer *lopa, integer *nipa, integer *iipa, ftnlen tpid_len); +extern integer agsetc_(char *tpid, char *cusr, ftnlen tpid_len, ftnlen cusr_len); +extern integer agsetf_(char *tpid, real *fusr, ftnlen tpid_len); +extern integer agseti_(char *tpid, integer *iusr, ftnlen tpid_len); +extern integer agsetp_(char *tpid, real *fura, integer *lura, ftnlen tpid_len); +extern integer agstch_(char *chst, integer *lncs, integer *idcs, ftnlen chst_len); +extern integer agstup_(real *xdra, integer *nvix, integer *iivx, integer *nevx, integer *iiex, real *ydra, integer *nviy, integer *iivy, integer *nevy, integer *iiey); +extern integer agutol_(integer *iaxs, real *funs, integer *idma, real *vinp, real *votp); +extern integer ahgmc_(shortint *data, integer *npix, integer *hgm, integer *nbins, shortint *z1, shortint *z2); +extern integer ahgmd_(doublereal *data, integer *npix, integer *hgm, integer *nbins, doublereal *z1, doublereal *z2); +extern integer ahgmi_(integer *data, integer *npix, integer *hgm, integer *nbins, integer *z1, integer *z2); +extern integer ahgml_(integer *data, integer *npix, integer *hgm, integer *nbins, integer *z1, integer *z2); +extern integer ahgmr_(real *data, integer *npix, integer *hgm, integer *nbins, real *z1, real *z2); +extern integer ahgms_(shortint *data, integer *npix, integer *hgm, integer *nbins, shortint *z1, shortint *z2); +extern integer aiftrr_(real *fr, real *fi, real *sr, real *si, integer *npix); +extern integer aiftrr_(real *fr, real *fi, real *sr, real *si, integer *npix); +extern integer aiftrx_(complex *a, real *b, integer *npix); +extern integer aiftrx_(complex *a, real *b, integer *npix); +extern integer aiftxr_(real *fr, real *fi, real *sr, real *si, integer *npix); +extern integer aiftxr_(real *fr, real *fi, real *sr, real *si, integer *npix); +extern integer aiftxx_(complex *a, complex *b, integer *npix); +extern integer aiftxx_(complex *a, complex *b, integer *npix); +extern integer aimgd_(complex *a, doublereal *b, integer *npix); +extern integer aimgi_(complex *a, integer *b, integer *npix); +extern integer aimgl_(complex *a, integer *b, integer *npix); +extern integer aimgr_(complex *a, real *b, integer *npix); +extern integer aimgs_(complex *a, shortint *b, integer *npix); +extern integer alani_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alanki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alankl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alanks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer alanl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alans_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer alimc_(shortint *a, integer *npix, shortint *minval, shortint *maxval); +extern integer alimd_(doublereal *a, integer *npix, doublereal *minval, doublereal *maxval); +extern integer alimi_(integer *a, integer *npix, integer *minval, integer *maxval); +extern integer aliml_(integer *a, integer *npix, integer *minval, integer *maxval); +extern integer alimr_(real *a, integer *npix, real *minval, real *maxval); +extern integer alims_(shortint *a, integer *npix, shortint *minval, shortint *maxval); +extern integer alimx_(complex *a, integer *npix, complex *minval, complex *maxval); +extern integer allnd_(doublereal *a, doublereal *b, integer *npix, D_fp errfcn); +extern integer allni_(integer *a, integer *b, integer *npix, I_fp errfcn); +extern integer allnl_(integer *a, integer *b, integer *npix, I_fp errfcn); +extern integer allnr_(real *a, real *b, integer *npix, R_fp errfcn); +extern integer allns_(shortint *a, shortint *b, integer *npix, J_fp errfcn); +extern integer allnx_(complex *a, complex *b, integer *npix, C_fp errfcn); +extern integer alogd_(doublereal *a, doublereal *b, integer *npix, D_fp errfcn); +extern integer alogi_(integer *a, integer *b, integer *npix, I_fp errfcn); +extern integer alogl_(integer *a, integer *b, integer *npix, I_fp errfcn); +extern integer alogr_(real *a, real *b, integer *npix, R_fp errfcn); +extern integer alogs_(shortint *a, shortint *b, integer *npix, J_fp errfcn); +extern integer alogx_(complex *a, complex *b, integer *npix, C_fp errfcn); +extern integer alori_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alorki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alorkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alorks_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer alorl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer alors_(shortint *a, shortint *b, integer *c__, integer *npix); +extern integer altad_(doublereal *a, doublereal *b, integer *npix, doublereal *k1, doublereal *k2); +extern integer altai_(integer *a, integer *b, integer *npix, real *k1, real *k2); +extern integer altal_(integer *a, integer *b, integer *npix, doublereal *k1, doublereal *k2); +extern integer altar_(real *a, real *b, integer *npix, real *k1, real *k2); +extern integer altas_(shortint *a, shortint *b, integer *npix, real *k1, real *k2); +extern integer altax_(complex *a, complex *b, integer *npix, real *k1, real *k2); +extern integer altmd_(doublereal *a, doublereal *b, integer *npix, doublereal *k1, doublereal *k2); +extern integer altmi_(integer *a, integer *b, integer *npix, real *k1, real *k2); +extern integer altml_(integer *a, integer *b, integer *npix, doublereal *k1, doublereal *k2); +extern integer altmr_(real *a, real *b, integer *npix, real *k1, real *k2); +extern integer altms_(shortint *a, shortint *b, integer *npix, real *k1, real *k2); +extern integer altmx_(complex *a, complex *b, integer *npix, real *k1, real *k2); +extern integer altrd_(doublereal *a, doublereal *b, integer *npix, doublereal *k1, doublereal *k2, doublereal *k3); +extern integer altri_(integer *a, integer *b, integer *npix, real *k1, real *k2, real *k3); +extern integer altrl_(integer *a, integer *b, integer *npix, doublereal *k1, doublereal *k2, doublereal *k3); +extern integer altrr_(real *a, real *b, integer *npix, real *k1, real *k2, real *k3); +extern integer altrs_(shortint *a, shortint *b, integer *npix, real *k1, real *k2, real *k3); +extern integer altrx_(complex *a, complex *b, integer *npix, real *k1, real *k2, real *k3); +extern integer aluid_(doublereal *a, doublereal *b, real *x, integer *npix); +extern integer aluii_(integer *a, integer *b, real *x, integer *npix); +extern integer aluil_(integer *a, integer *b, real *x, integer *npix); +extern integer aluir_(real *a, real *b, real *x, integer *npix); +extern integer aluis_(shortint *a, shortint *b, real *x, integer *npix); +extern integer alutc_(shortint *a, shortint *b, integer *npix, shortint *lut); +extern integer alutd_(integer *a, doublereal *b, integer *npix, doublereal *lut); +extern integer aluti_(integer *a, integer *b, integer *npix, integer *lut); +extern integer alutl_(integer *a, integer *b, integer *npix, integer *lut); +extern integer alutr_(integer *a, real *b, integer *npix, real *lut); +extern integer aluts_(shortint *a, shortint *b, integer *npix, shortint *lut); +extern integer amagd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amagi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amagl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amagr_(real *a, real *b, real *c__, integer *npix); +extern integer amags_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amagx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer amapd_(doublereal *a, doublereal *b, integer *npix, doublereal *a1, doublereal *a2, doublereal *b1, doublereal *b2); +extern integer amapi_(integer *a, integer *b, integer *npix, integer *a1, integer *a2, integer *b1, integer *b2); +extern integer amapl_(integer *a, integer *b, integer *npix, integer *a1, integer *a2, integer *b1, integer *b2); +extern integer amapr_(real *a, real *b, integer *npix, real *a1, real *a2, real *b1, real *b2); +extern integer amaps_(shortint *a, shortint *b, integer *npix, shortint *a1, shortint *a2, shortint *b1, shortint *b2); +extern integer amaxc_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amaxd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amaxi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amaxkc_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amaxkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amaxki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amaxkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amaxkr_(real *a, real *b, real *c__, integer *npix); +extern integer amaxks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amaxkx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer amaxl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amaxr_(real *a, real *b, real *c__, integer *npix); +extern integer amaxs_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amaxx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer amed3c_(shortint *a, shortint *b, shortint *c__, shortint *m, integer *npix); +extern integer amed3d_(doublereal *a, doublereal *b, doublereal *c__, doublereal *m, integer *npix); +extern integer amed3i_(integer *a, integer *b, integer *c__, integer *m, integer *npix); +extern integer amed3l_(integer *a, integer *b, integer *c__, integer *m, integer *npix); +extern integer amed3r_(real *a, real *b, real *c__, real *m, integer *npix); +extern integer amed3s_(shortint *a, shortint *b, shortint *c__, shortint *m, integer *npix); +extern integer amed4c_(shortint *a, shortint *b, shortint *c__, shortint *d__, shortint *m, integer *npix); +extern integer amed4d_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *m, integer *npix); +extern integer amed4i_(integer *a, integer *b, integer *c__, integer *d__, integer *m, integer *npix); +extern integer amed4l_(integer *a, integer *b, integer *c__, integer *d__, integer *m, integer *npix); +extern integer amed4r_(real *a, real *b, real *c__, real *d__, real *m, integer *npix); +extern integer amed4s_(shortint *a, shortint *b, shortint *c__, shortint *d__, shortint *m, integer *npix); +extern integer amed5c_(shortint *a, shortint *b, shortint *c__, shortint *d__, shortint *e, shortint *m, integer *npix); +extern integer amed5d_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *e, doublereal *m, integer *npix); +extern integer amed5i_(integer *a, integer *b, integer *c__, integer *d__, integer *e, integer *m, integer *npix); +extern integer amed5l_(integer *a, integer *b, integer *c__, integer *d__, integer *e, integer *m, integer *npix); +extern integer amed5r_(real *a, real *b, real *c__, real *d__, real *e, real *m, integer *npix); +extern integer amed5s_(shortint *a, shortint *b, shortint *c__, shortint *d__, shortint *e, shortint *m, integer *npix); +extern integer amgsd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amgsi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amgsl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amgsr_(real *a, real *b, real *c__, integer *npix); +extern integer amgss_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amgsx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer aminc_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amind_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amini_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aminkc_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aminkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer aminki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aminkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aminkr_(real *a, real *b, real *c__, integer *npix); +extern integer aminks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aminkx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer aminl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer aminr_(real *a, real *b, real *c__, integer *npix); +extern integer amins_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer aminx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer amodd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amodi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amodkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amodki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amodkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amodkr_(real *a, real *b, real *c__, integer *npix); +extern integer amodks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amodl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amodr_(real *a, real *b, real *c__, integer *npix); +extern integer amods_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amovc_(shortint *a, shortint *b, integer *npix); +extern integer amovd_(doublereal *a, doublereal *b, integer *npix); +extern integer amovi_(integer *a, integer *b, integer *npix); +extern integer amovkc_(shortint *a, shortint *b, integer *npix); +extern integer amovkd_(doublereal *a, doublereal *b, integer *npix); +extern integer amovki_(integer *a, integer *b, integer *npix); +extern integer amovkl_(integer *a, integer *b, integer *npix); +extern integer amovkr_(real *a, real *b, integer *npix); +extern integer amovks_(shortint *a, shortint *b, integer *npix); +extern integer amovkx_(complex *a, complex *b, integer *npix); +extern integer amovl_(integer *a, integer *b, integer *npix); +extern integer amovr_(real *a, real *b, integer *npix); +extern integer amovs_(shortint *a, shortint *b, integer *npix); +extern integer amovx_(complex *a, complex *b, integer *npix); +extern integer amuld_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amuli_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amulkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer amulki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amulkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amulkr_(real *a, real *b, real *c__, integer *npix); +extern integer amulks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amulkx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer amull_(integer *a, integer *b, integer *c__, integer *npix); +extern integer amulr_(real *a, real *b, real *c__, integer *npix); +extern integer amuls_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer amulx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer anegd_(doublereal *a, doublereal *b, integer *npix); +extern integer anegi_(integer *a, integer *b, integer *npix); +extern integer anegl_(integer *a, integer *b, integer *npix); +extern integer anegr_(real *a, real *b, integer *npix); +extern integer anegs_(shortint *a, shortint *b, integer *npix); +extern integer anegx_(complex *a, complex *b, integer *npix); +extern integer anirs_(real *a, shortint *b, integer *n); +extern integer anotat_(char *labx, char *laby, integer *lbac, integer *lset, integer *ndsh, char *dshl, ftnlen labx_len, ftnlen laby_len, ftnlen dshl_len); +extern integer anoti_(integer *a, integer *b, integer *npix); +extern integer anotl_(integer *a, integer *b, integer *npix); +extern integer anots_(shortint *a, shortint *b, integer *npix); +extern integer apkxd_(doublereal *a, doublereal *b, complex *c__, integer *npix); +extern integer apkxi_(integer *a, integer *b, complex *c__, integer *npix); +extern integer apkxl_(integer *a, integer *b, complex *c__, integer *npix); +extern integer apkxr_(real *a, real *b, complex *c__, integer *npix); +extern integer apkxs_(shortint *a, shortint *b, complex *c__, integer *npix); +extern integer apkxx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer apowd_(doublereal *a, integer *b, doublereal *c__, integer *npix); +extern integer apowi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer apowkd_(doublereal *a, integer *b, doublereal *c__, integer *npix); +extern integer apowki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer apowkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer apowkr_(real *a, integer *b, real *c__, integer *npix); +extern integer apowks_(shortint *a, integer *b, shortint *c__, integer *npix); +extern integer apowkx_(complex *a, integer *b, complex *c__, integer *npix); +extern integer apowl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer apowr_(real *a, integer *b, real *c__, integer *npix); +extern integer apows_(shortint *a, integer *b, shortint *c__, integer *npix); +extern integer apowx_(complex *a, integer *b, complex *c__, integer *npix); +extern integer arcpd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer arcpi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer arcpl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer arcpr_(real *a, real *b, real *c__, integer *npix); +extern integer arcps_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer arcpx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer arczd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix, D_fp errfcn); +extern integer arczi_(integer *a, integer *b, integer *c__, integer *npix, I_fp errfcn); +extern integer arczl_(integer *a, integer *b, integer *c__, integer *npix, I_fp errfcn); +extern integer arczr_(real *a, real *b, real *c__, integer *npix, R_fp errfcn); +extern integer arczs_(shortint *a, shortint *b, shortint *c__, integer *npix, J_fp errfcn); +extern integer arczx_(complex *a, complex *b, complex *c__, integer *npix, C_fp errfcn); +extern integer aread_(integer *fd, shortint *buffer, integer *maxchs, integer *charot); +extern integer areadb_(integer *fd, shortint *buffer, integer *maxbys, integer *byteot); +extern integer argtd_(doublereal *a, integer *npix, doublereal *ceil, doublereal *newval); +extern integer argti_(integer *a, integer *npix, integer *ceil, integer *newval); +extern integer argtl_(integer *a, integer *npix, integer *ceil, integer *newval); +extern integer argtr_(real *a, integer *npix, real *ceil, real *newval); +extern integer argts_(shortint *a, integer *npix, shortint *ceil, shortint *newval); +extern integer argtx_(complex *a, integer *npix, complex *ceil, complex *newval); +extern integer arltd_(doublereal *a, integer *npix, doublereal *floor, doublereal *newval); +extern integer arlti_(integer *a, integer *npix, integer *floor, integer *newval); +extern integer arltl_(integer *a, integer *npix, integer *floor, integer *newval); +extern integer arltr_(real *a, integer *npix, real *floor, real *newval); +extern integer arlts_(shortint *a, integer *npix, shortint *floor, shortint *newval); +extern integer arltx_(complex *a, integer *npix, complex *floor, complex *newval); +extern integer aselc_(shortint *a, shortint *b, shortint *c__, integer *sel, integer *npix); +extern integer aseld_(doublereal *a, doublereal *b, doublereal *c__, integer *sel, integer *npix); +extern integer aseli_(integer *a, integer *b, integer *c__, integer *sel, integer *npix); +extern integer aselkc_(shortint *a, shortint *b, shortint *c__, integer *sel, integer *npix); +extern integer aselkd_(doublereal *a, doublereal *b, doublereal *c__, integer *sel, integer *npix); +extern integer aselki_(integer *a, integer *b, integer *c__, integer *sel, integer *npix); +extern integer aselkl_(integer *a, integer *b, integer *c__, integer *sel, integer *npix); +extern integer aselkr_(real *a, real *b, real *c__, integer *sel, integer *npix); +extern integer aselks_(shortint *a, shortint *b, shortint *c__, integer *sel, integer *npix); +extern integer aselkx_(complex *a, complex *b, complex *c__, integer *sel, integer *npix); +extern integer asell_(integer *a, integer *b, integer *c__, integer *sel, integer *npix); +extern integer aselr_(real *a, real *b, real *c__, integer *sel, integer *npix); +extern integer asels_(shortint *a, shortint *b, shortint *c__, integer *sel, integer *npix); +extern integer aselx_(complex *a, complex *b, complex *c__, integer *sel, integer *npix); +extern integer asqrd_(doublereal *a, doublereal *b, integer *npix, D_fp errfcn); +extern integer asqri_(integer *a, integer *b, integer *npix, I_fp errfcn); +extern integer asqrl_(integer *a, integer *b, integer *npix, I_fp errfcn); +extern integer asqrr_(real *a, real *b, integer *npix, R_fp errfcn); +extern integer asqrs_(shortint *a, shortint *b, integer *npix, J_fp errfcn); +extern integer asqrx_(complex *a, complex *b, integer *npix, C_fp errfcn); +extern integer asrtc_(shortint *a, shortint *b, integer *npix); +extern integer asrtd_(doublereal *a, doublereal *b, integer *npix); +extern integer asrti_(integer *a, integer *b, integer *npix); +extern integer asrtl_(integer *a, integer *b, integer *npix); +extern integer asrtr_(real *a, real *b, integer *npix); +extern integer asrts_(shortint *a, shortint *b, integer *npix); +extern integer asrtx_(complex *a, complex *b, integer *npix); +extern integer asubd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer asubi_(integer *a, integer *b, integer *c__, integer *npix); +extern integer asubkd_(doublereal *a, doublereal *b, doublereal *c__, integer *npix); +extern integer asubki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer asubkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer asubkr_(real *a, real *b, real *c__, integer *npix); +extern integer asubks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer asubkx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer asubl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer asubr_(real *a, real *b, real *c__, integer *npix); +extern integer asubs_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer asubx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer aupxd_(complex *a, doublereal *b, doublereal *c__, integer *npix); +extern integer aupxi_(complex *a, integer *b, integer *c__, integer *npix); +extern integer aupxl_(complex *a, integer *b, integer *c__, integer *npix); +extern integer aupxr_(complex *a, real *b, real *c__, integer *npix); +extern integer aupxs_(complex *a, shortint *b, shortint *c__, integer *npix); +extern integer aupxx_(complex *a, complex *b, complex *c__, integer *npix); +extern integer awritb_(integer *fd, shortint *buffer, integer *nbytes, integer *byteot); +extern integer awrite_(integer *fd, shortint *buffer, integer *nchars, integer *charot); +extern integer awsud_(doublereal *a, doublereal *b, doublereal *c__, integer *npix, doublereal *k1, doublereal *k2); +extern integer awsui_(integer *a, integer *b, integer *c__, integer *npix, real *k1, real *k2); +extern integer awsul_(integer *a, integer *b, integer *c__, integer *npix, real *k1, real *k2); +extern integer awsur_(real *a, real *b, real *c__, integer *npix, real *k1, real *k2); +extern integer awsus_(shortint *a, shortint *b, shortint *c__, integer *npix, real *k1, real *k2); +extern integer awsux_(complex *a, complex *b, complex *c__, integer *npix, complex *k1, complex *k2); +extern integer axori_(integer *a, integer *b, integer *c__, integer *npix); +extern integer axorki_(integer *a, integer *b, integer *c__, integer *npix); +extern integer axorkl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer axorks_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer axorl_(integer *a, integer *b, integer *c__, integer *npix); +extern integer axors_(shortint *a, shortint *b, shortint *c__, integer *npix); +extern integer bndary_(void); +extern integer bound_(real *z__, integer *mx, integer *nnx, integer *nny, real *ssp); +extern integer brktie_(integer *ltime, integer *tm); +extern integer c1dpas_(integer *interp, real *eps); +extern integer calcnt_(real *z__, integer *m, integer *n, real *a1, real *a2, real *a3, integer *i1, integer *i2, integer *i3); +extern integer ccpcag_(shortint *p, integer *npts, integer *ltype, integer *curplt, integer *segsie, integer *xseg, integer *yseg, integer *nsegps); +extern integer ccpcle_(void); +extern integer ccpclr_(integer *dummy); +extern integer ccpcls_(shortint *devnae, integer *n); +extern integer ccpcor_(integer *index); +extern integer ccpdrg_(real *xseg, real *yseg, integer *nsegps, integer *lwidth); +extern integer ccpdrr_(shortint *ch, integer *x, integer *y, integer *xsize, integer *ysize, integer *orien, integer *font, integer *qualiy); +extern integer ccpese_(integer *fn, shortint *instrn, integer *nwords); +extern integer ccpfat_(shortint *gki); +extern integer ccpfia_(shortint *p, integer *npts); +extern integer ccpfot_(integer *font); +extern integer ccpint_(integer *tty, shortint *devnae); +extern integer ccplie_(integer *index); +extern integer ccplwh_(integer *index); +extern integer ccpopn_(shortint *devnae, integer *dd); +extern integer ccpops_(shortint *devnae, integer *n, integer *mode); +extern integer ccpplt_(shortint *gki); +extern integer ccppmt_(shortint *gki); +extern integer ccppoe_(shortint *p, integer *npts); +extern integer ccppor_(shortint *p, integer *npts); +extern integer ccpret_(void); +extern integer ccptet_(integer *xc, integer *yc, shortint *text, integer *n); +extern integer ccptxt_(shortint *gki); +extern integer ccxadt_(real *x, real *y, integer *xseg, integer *yseg, integer *curset, integer *segsie); +extern integer ccxdah_(shortint *p, integer *npts, integer *curplt, real *cursen, integer *curset, integer *segsie, integer *xseg, integer *yseg, real *lastpx, real *lastpy); +extern integer ccxgap_(shortint *p, integer *npts, integer *curplt, real *cursen, real *matchn, real *lastpx, real *lastpy); +extern integer ccxinl_(real *x, real *y, real *xsize, real *ysize, shortint *ch, real *orien); +extern integer ccxiny_(real *x, real *y, integer *npts, integer *qualiy); +extern integer ccxofs_(real *p1x, real *p1y, real *p2x, real *p2y, real *p3x, real *p3y, real *delx, real *dely); +extern integer ccxpas_(integer *xc, integer *yc, integer *totlen, integer *x0, integer *y0, integer *dx, integer *dy, integer *polytt, integer *orien); +extern integer cfvld_(integer *ientry, integer *iix, integer *iiy); +extern integer chdept_(shortint *ch, shortint *str, integer *maxch, integer *op); +extern integer chkcyc_(real *u, real *v, integer *imax, integer *jptsy, integer *ier); +extern integer chstr_(char *label, integer *first, integer *last, ftnlen label_len); +extern integer clccos_(void); +extern integer clcenr_(shortint *param, shortint *value); +extern integer clcfre_(integer *marker); +extern integer clcint_(void); +extern integer clclit_(integer *fd, shortint *pset, shortint *format); +extern integer clcloe_(void); +extern integer clcmak_(integer *marker); +extern integer clcmd_(shortint *cmd); +extern integer clcmdw_(shortint *cmd); +extern integer clcnek_(shortint *taskne); +extern integer clcpst_(integer *pp); +extern integer clcscn_(shortint *cmd); +extern integer clepst_(integer *pp); +extern integer clgcut_(shortint *promp1, shortint *promp2, integer *curvee, integer *order); +extern integer clgen_(real *z__, integer *mx, integer *nx, integer *nny, real *cclo, real *chi, real *cinc, integer *nla, integer *nlm, real *cl, integer *ncl, integer *icnst); +extern integer clgpsa_(integer *pp, shortint *pname, shortint *outstr, integer *maxch); +extern integer clgpst_(integer *pp, shortint *pname, shortint *outstr, integer *maxch); +extern integer clgsec_(shortint *prompt, shortint *sectin, integer *x1, integer *x2, integer *step, integer *nsubss); +extern integer clgstr_(shortint *param, shortint *outstr, integer *maxch); +extern integer cllpst_(integer *pp, integer *fd, shortint *format); +extern integer clopen_(integer *stdinn, integer *stdoun, integer *stdern, integer *device, integer *devtye); +extern integer clpcls_(integer *list); +extern integer clppsa_(integer *pp, shortint *pname, shortint *sval); +extern integer clppsb_(integer *pp, shortint *parnae, logical *bval); +extern integer clppsc_(integer *pp, shortint *parnae, shortint *cval); +extern integer clppsd_(integer *pp, shortint *parnae, doublereal *dval); +extern integer clppsi_(integer *pp, shortint *parnae, integer *ival); +extern integer clppsl_(integer *pp, shortint *parnae, integer *lval); +extern integer clppsr_(integer *pp, shortint *parnae, real *rval); +extern integer clppss_(integer *pp, shortint *parnae, shortint *sval); +extern integer clppst_(integer *pp, shortint *pname, shortint *sval); +extern integer clppsx_(integer *pp, shortint *parnae, complex *xval); +extern integer clprew_(integer *list); +extern integer clprif_(shortint *param, shortint *formag); +extern integer clpstr_(shortint *param, shortint *value); +extern integer clputb_(shortint *param, logical *bval); +extern integer clputc_(shortint *param, shortint *cval); +extern integer clputd_(shortint *param, doublereal *dval); +extern integer clputi_(shortint *param, integer *value); +extern integer clputl_(shortint *param, integer *lval); +extern integer clputr_(shortint *param, real *rval); +extern integer clputs_(shortint *param, shortint *value); +extern integer clputx_(shortint *param, complex *xval); +extern integer clreqr_(shortint *param); +extern integer clset_(real *z__, integer *mx, integer *nx, integer *ny, real *chi, real *clo, real *cinc, integer *nla, integer *nlm, real *cl, integer *ncl, integer *icnst, integer *ioffp, real *spval, real *bigest); +extern integer clseti_(integer *paramr, integer *value); +extern integer clsgks_(void); +extern integer cnvdae_(integer *ltime, shortint *outstr, integer *maxch); +extern integer cnvtie_(integer *ltime, shortint *outstr, integer *maxch); +extern integer conbd_(void); +extern integer conbdn_(void); +extern integer concal_(real *xd, real *yd, real *zd, integer *nt, integer *ipt, integer *nl, integer *ipl, real *pdd, integer *iti, real *xii, real *yii, real *zii, integer *itpv); +extern integer concld_(integer *icase, integer *ioop); +extern integer concls_(real *zd, integer *ndp); +extern integer condet_(integer *ndp, real *xd, real *yd, integer *ncp, integer *ipc); +extern integer condrw_(real *scrarr); +extern integer condsd_(void); +extern integer conecd_(real *val, char *iout, integer *nused, ftnlen iout_len); +extern integer congen_(real *xi, real *yi, integer *ipack, real *scrarr, integer *ica); +extern integer conint_(integer *ndp, real *xd, real *yd, real *zd, integer *ncp, integer *ipc, real *pd); +extern integer conlin_(real *xd, real *yd, real *zd, integer *nt, integer *iwk, real *wk); +extern integer conloc_(integer *ndp, real *xd, real *yd, integer *nt, integer *ipt, integer *nl, integer *ipl, real *xii, real *yii, integer *iti, integer *iwk, real *wk); +extern integer conlod_(real *xd, real *yd, real *zd, integer *ndp, real *wk, integer *iwk, real *scrarr); +extern integer conop1_(char *iopt, ftnlen iopt_len); +extern integer conop2_(char *iopt, integer *isize, ftnlen iopt_len); +extern integer conop3_(char *iopt, real *array, integer *isize, ftnlen iopt_len); +extern integer conop4_(char *iopt, char *array, integer *isize, integer *ifort, ftnlen iopt_len, ftnlen array_len); +extern integer conot2_(integer *iver, integer *iunit); +extern integer conout_(integer *iver); +extern integer conpdv_(real *xd, real *yd, real *zd, integer *ndp); +extern integer conpmm_(real *scrarr); +extern integer conran_(real *xd, real *yd, real *zd, integer *ndp, real *wk, integer *iwk, real *scrarr); +extern integer conrec_(real *z__, integer *l, integer *m, integer *n, real *flo, real *hi, real *finc, integer *nset, integer *nhi, integer *ndot); +extern integer conreo_(integer *majlns); +extern integer consld_(real *scrarr); +extern integer conssd_(real *x, real *y, integer *ic); +extern integer constp_(real *xd, real *yd, integer *ndp); +extern integer contlk_(real *xd, real *yd, integer *ndp, integer *ipt); +extern integer contng_(integer *ndp, real *xd, real *yd, integer *nt, integer *ipt, integer *nl, integer *ipl, integer *iwl, integer *iwp, real *wk); +extern integer counmp_(integer *co); +extern integer cqccfe_(integer *cq); +extern integer cqccit_(integer *cq, integer *catno); +extern integer cqdgad_(integer *cq, integer *record, shortint *field, doublereal *array, integer *lenary, integer *npts); +extern integer cqdgai_(integer *cq, integer *record, shortint *field, integer *array, integer *lenary, integer *npts); +extern integer cqdgar_(integer *cq, integer *record, shortint *field, real *array, integer *lenary, integer *npts); +extern integer cqdgat_(integer *cq, integer *record, shortint *field, shortint *str, integer *maxchr, integer *nlines); +extern integer cqdgsr_(integer *cq, integer *record, shortint *field, shortint *str, integer *maxchr); +extern integer cqdgwd_(integer *cq, integer *record, shortint *field, shortint *str, integer *maxchr); +extern integer cqffms_(integer *res, shortint *field, shortint *format, integer *szfort); +extern integer cqfgsr_(integer *cq, shortint *field, shortint *str, integer *maxch); +extern integer cqfgwd_(integer *cq, shortint *field, shortint *str, integer *maxch); +extern integer cqfins_(shortint *linebf, integer *fields, integer *maxfis, integer *nfiels); +extern integer cqfuns_(integer *res, shortint *field, shortint *units, integer *szunis); +extern integer cqimce_(integer *res); +extern integer cqirfe_(integer *res); +extern integer cqists_(integer *res, integer *param, shortint *str, integer *maxch); +extern integer cqrcle_(integer *res); +extern integer cqrfre_(integer *res); +extern integer cqrsts_(integer *res, integer *param, shortint *str, integer *maxch); +extern integer cqstas_(integer *cq, integer *param, shortint *str, integer *maxch); +extern integer cqunmp_(integer *cq); +extern integer ctcell_(real *z__, integer *mx, integer *nx, integer *ny, integer *m, integer *i0, integer *j0); +extern integer curve3_(real *u, real *v, real *w, integer *n); +extern integer curve_(real *px, real *py, integer *np); +extern integer curved_(real *x, real *y, integer *n); +extern integer dashbd_(void); +extern integer dashdb_(integer *ipat); +extern integer dashdc_(char *ipat, integer *jcrt, integer *jsize, ftnlen ipat_len); +extern integer deletg_(shortint *fname, integer *versis, integer *subfis); +extern integer displa_(integer *lfra, integer *lrow, integer *ltyp); +extern integer drawi_(integer *ixa, integer *iya, integer *ixb, integer *iyb); +extern integer drawpv_(integer *ix, integer *iy, integer *ind); +extern integer draws_(integer *mx1, integer *my1, integer *mx2, integer *my2, integer *idraw, integer *imark); +extern integer drawt_(integer *ixa, integer *iya, integer *ixb, integer *iyb); +extern integer drcntr_(real *z__, integer *l, integer *mm, integer *nn); +extern integer drline_(real *z__, integer *l, integer *mm, integer *nn); +extern integer drwstr_(real *u, real *v, real *ux, real *vy, integer *imax, integer *jptsy); +extern integer drwvec_(integer *m1, integer *m2, integer *m3, integer *m4, char *label, integer *nc, ftnlen label_len); +extern integer dsulud_(shortint *utab, real *x, real *y, integer *nvalus); +extern integer dsulue_(integer *lut); +extern integer dsulut_(real *xvals, real *yvals, integer *nvals); +extern integer dtcscl_(doublereal *v, integer *e, integer *sense); +extern integer dtgad_(integer *dt, integer *record, shortint *field, doublereal *array, integer *lenary, integer *npts); +extern integer dtgar_(integer *dt, integer *record, shortint *field, real *array, integer *lenary, integer *npts); +extern integer dtgstr_(integer *dt, integer *record, shortint *field, shortint *str, integer *maxchr); +extern integer dtptie_(integer *dt); +extern integer dtput_(integer *dt, shortint *format); +extern integer dtremp_(integer *dt, shortint *dname, shortint *fname, integer *mode); +extern integer dtstrg_(integer *datate, shortint *str, integer *maxchr); +extern integer dtunmp_(integer *dt); +extern integer e9rin_(char *messg, integer *nerr, logical *save, ftnlen messg_len); +extern integer encd_(real *valu, real *ash, char *iout, integer *nc, integer *ioffd, ftnlen iout_len); +extern integer encode_(integer *nchars, char *ftnfmt, char *ftnout, real *rval, ftnlen ftnfmt_len, ftnlen ftnout_len); +extern integer entsr_(integer *irold, integer *irnew); +extern integer envinr_(shortint *envvar, shortint *outstr, integer *maxch); +extern integer envint_(void); +extern integer envlit_(integer *fd, shortint *prefix, integer *prints); +extern integer envmak_(integer *oldtop); +extern integer envret_(shortint *key, shortint *value); +extern integer eprin_(void); +extern integer eprinf_(shortint *formag); +extern integer erract_(integer *severy); +extern integer errof_(void); +extern integer evvfre_(integer *o); +extern integer exmpl1_(void); +extern integer exmpl2_(void); +extern integer exmpl3_(void); +extern integer exmpl4_(void); +extern integer exmpl5_(void); +extern integer exmpl6_(void); +extern integer exmpl7_(void); +extern integer exmpl8_(void); +extern integer exmplf_(void); +extern integer expand_(real *maxw); +extern integer ezcntr_(real *z__, integer *m, integer *n); +extern integer ezhftn_(real *z__, integer *m, integer *n); +extern integer ezisos_(real *t, integer *mu, integer *mv, integer *mw, real *eye, real *slab, real *tiso); +extern integer ezsrfc_(real *z__, integer *m, integer *n, real *angh, real *angv, real *work); +extern integer ezstrm_(real *u, real *v, real *work, integer *imax, integer *jmax); +extern integer ezvec_(real *u, real *v, integer *m, integer *n); +extern integer falloc_(shortint *fname, integer *filese); +extern integer fcanpb_(integer *fd); +extern integer fcldir_(integer *channl, integer *status); +extern integer fclobr_(shortint *fname); +extern integer fcopy_(shortint *oldfie, shortint *newfie); +extern integer fcopyo_(integer *in, integer *out); +extern integer fdebug_(integer *out, integer *fd1arg, integer *fd2arg); +extern integer fdirne_(shortint *vfn, shortint *path, integer *maxch); +extern integer fdum_(void); +extern integer fdvdld_(integer *ientry, integer *iix, integer *iiy); +extern integer fencd_(integer *nchars, shortint *fformt, shortint *sppour, real *rval); +extern integer fence3_(real *u, real *v, real *w, integer *n, integer *ior, real *bot); +extern integer fexbuf_(integer *fd); +extern integer ffilbf_(integer *fd, integer *bp, integer *bufsie, integer *buffet); +extern integer ffldir_(integer *chan, integer *status); +extern integer fflsbf_(integer *fd, integer *bp, integer *maxchs, integer *buffet); +extern integer fgdevm_(integer *fd); +extern integer fgtdir_(integer *chan, shortint *outlie, integer *maxch, integer *status); +extern integer filerr_(shortint *fname, integer *errcoe); +extern integer fillin_(void); +extern integer findz_(integer *im, real *z1, real *z2, real *zfrac, integer *maxcos, integer *nsamps); +extern integer finit_(void); +extern integer fioclp_(integer *status); +extern integer fioqfh_(integer *fd, integer *status); +extern integer fixmem_(integer *oldsie); +extern integer fl2int_(real *px, real *py, integer *ix, integer *iy); +extern integer flsbuf_(integer *fd, integer *nresee); +extern integer fmapfn_(shortint *vfn, shortint *osfn, integer *maxch); +extern integer fmcloe_(integer *fm); +extern integer fmcopo_(integer *old, integer *new__); +extern integer fmcopy_(shortint *dfname, shortint *newnae); +extern integer fmdebg_(integer *fm, integer *out, integer *what); +extern integer fmdele_(shortint *dfname); +extern integer fmfcdg_(integer *fm, integer *out, integer *what); +extern integer fmfcfe_(integer *fm); +extern integer fmfcit_(integer *fm, integer *cachee); +extern integer fmfcsc_(integer *fm); +extern integer fmiobd_(integer *fm); +extern integer fmioek_(integer *fm); +extern integer fmiopr_(integer *fm, integer *errcoe, shortint *opstr); +extern integer fmiorr_(integer *fm); +extern integer fmiosf_(integer *fm); +extern integer fmiotk_(integer *fm); +extern integer fmkbfs_(integer *fd); +extern integer fmkcoy_(shortint *oldfie, shortint *newfie); +extern integer fmkdir_(shortint *newdir); +extern integer fmkpbf_(integer *fd); +extern integer fmlfad_(integer *lf, shortint *buf, integer *maxbys, integer *offset); +extern integer fmlfae_(integer *lf, shortint *buf, integer *nbytes, integer *offset); +extern integer fmlfat_(integer *lf, integer *status); +extern integer fmlfbd_(integer *lf, shortint *buf, integer *maxbys, integer *offset); +extern integer fmlfbe_(integer *lf, shortint *buf, integer *nbytes, integer *offset); +extern integer fmlfbt_(integer *lf, integer *status); +extern integer fmlfce_(integer *lf, integer *status); +extern integer fmlfcy_(integer *old, integer *olfile, integer *new__, integer *nlfile); +extern integer fmlfde_(integer *fm, integer *lfile); +extern integer fmlfne_(integer *fm, integer *lfile, integer *type__, shortint *lfname, integer *maxch); +extern integer fmlfon_(shortint *pklfne, integer *mode, integer *chan); +extern integer fmlfsi_(integer *lf, integer *param, integer *lvalue); +extern integer fmlfue_(integer *fm, integer *lfile); +extern integer fmloct_(integer *fm, integer *lfile); +extern integer fmrebd_(shortint *dfname); +extern integer fmrene_(shortint *old, shortint *new__); +extern integer fmretd_(integer *fm, integer *lfile); +extern integer fmseti_(integer *fm, integer *param, integer *value); +extern integer fmsync_(integer *fm); +extern integer fmterr_(shortint *preame, shortint *format, integer *index); +extern integer fmtint_(integer *ftype); +extern integer fmtred_(void); +extern integer fmtsel_(shortint *ch, integer *col); +extern integer fmtstr_(integer *fd, shortint *str, integer *col, shortint *fillcr, integer *leftjy, integer *maxch, integer *width); +extern integer fmunlk_(integer *fm, integer *lfile); +extern integer fntclb_(integer *list); +extern integer fntcls_(integer *pp); +extern integer fntdir_(integer *chan, integer *offset); +extern integer fntmkt_(shortint *pat, shortint *patstr, integer *maxch, integer *ep, integer *nedit); +extern integer fntreb_(integer *list); +extern integer fopdir_(shortint *osfn, integer *mode, integer *channl); +extern integer four1_(real *data, integer *nn, integer *isign); +extern integer fowner_(shortint *fname, shortint *owner, integer *maxch); +extern integer fpathe_(shortint *vfn, shortint *outpue, integer *maxchs); +extern integer fpnord_(doublereal *x, doublereal *normx, integer *expon); +extern integer fpnorr_(real *x, real *normx, integer *expon); +extern integer fpradv_(void); +extern integer fprinf_(integer *fd, shortint *formag); +extern integer fprntf_(integer *newfd, shortint *formag, integer *filete); +extern integer fptdir_(integer *chan, shortint *line, integer *nchars, integer *status); +extern integer fputtx_(integer *fd, shortint *buf, integer *nchars, integer *status); +extern integer frame_(void); +extern integer fredio_(integer *fd, integer *newfd); +extern integer fredir_(integer *fd, shortint *fname, integer *mode, integer *type__); +extern integer frenae_(shortint *oldfne, shortint *newfne); +extern integer frmbfs_(integer *fd); +extern integer frmtmp_(void); +extern integer frst3_(real *u, real *v, real *w); +extern integer frstc_(integer *mx, integer *my, integer *ient); +extern integer frstd_(real *x, real *y); +extern integer frstpt_(real *px, real *py); +extern integer frsts_(real *xx, real *yy, integer *ient); +extern integer frtnfd_(integer *fd); +extern integer fsetev_(shortint *envvar, integer *value); +extern integer fseti_(integer *fd, integer *param, integer *value); +extern integer fsfdee_(shortint *fname); +extern integer fsfgee_(shortint *fname, shortint *fsffie, integer *maxch); +extern integer fskdir_(integer *chan, integer *offset, integer *status); +extern integer fstats_(integer *fd, integer *what, shortint *outstr, integer *maxch); +extern integer fstdir_(integer *chan, integer *param, integer *lvalue); +extern integer fstrfp_(integer *newfp); +extern integer fsvtfn_(shortint *fname); +extern integer fswapd_(integer *fd1, integer *fd2); +extern integer fulib_(integer *errcoe, shortint *upkmsg, integer *msglen); +extern integer fwatio_(integer *fd); +extern integer fwtacc_(integer *fd, shortint *fname); +extern integer fxfacp_(shortint *line, integer *tpt, integer *nbkw, integer *nbl); +extern integer fxfacs_(integer *kernel, shortint *root, shortint *extn, integer *acmode, integer *status); +extern integer fxfact_(shortint *line, integer *tst, integer *nsb); +extern integer fxfadr_(integer *im, shortint *pname, integer *dtype, shortint *pval); +extern integer fxfakb_(shortint *keywod, integer *value, shortint *commet, integer *pn); +extern integer fxfakc_(shortint *keywod, shortint *value, integer *len, shortint *commet, integer *pn); +extern integer fxfakd_(shortint *keywod, doublereal *value, shortint *commet, integer *precin, integer *pn); +extern integer fxfaki_(shortint *keywod, integer *value, shortint *commet, integer *pn); +extern integer fxfakr_(shortint *keywod, real *value, shortint *commet, integer *precin, integer *pn); +extern integer fxfalc_(integer *fit); +extern integer fxfald_(integer *a, doublereal *b, integer *npix, doublereal *bscale, doublereal *bzero); +extern integer fxfalr_(integer *a, real *b, integer *npix, doublereal *bscale, doublereal *bzero); +extern integer fxfalu_(shortint *a, shortint *b, integer *npix); +extern integer fxfasr_(shortint *a, real *b, integer *npix, doublereal *bscale, doublereal *bzero); +extern integer fxfbls_(integer *nbl, integer *po); +extern integer fxfbyt_(integer *im, shortint *fname); +extern integer fxfche_(integer *im); +extern integer fxfchm_(integer *im); +extern integer fxfchp_(integer *im, shortint *ksectn, integer *acmode, integer *group, integer *ksinh); +extern integer fxfcle_(integer *im, integer *status); +extern integer fxfcll_(integer *im); +extern integer fxfcnx_(integer *im, integer *totpix, shortint *obuf, integer *nbytes, integer *boffst); +extern integer fxfcoj_(integer *im, integer *infd, integer *hdroff, integer *poff, integer *datase); +extern integer fxfcoy_(integer *kernel, shortint *oroot, shortint *oextn, shortint *nroot, shortint *nextn, integer *status); +extern integer fxfdae_(shortint *datesr, integer *limtie); +extern integer fxfdee_(integer *kernel, shortint *root, shortint *extn, integer *status); +extern integer fxfdiw_(integer *im); +extern integer fxfdur_(integer *im, integer *status); +extern integer fxfenb_(shortint *keywod, integer *param, shortint *card, shortint *commet); +extern integer fxfenc_(shortint *keywod, shortint *param, integer *maxch, shortint *card, shortint *commet); +extern integer fxfend_(shortint *keywod, doublereal *param, shortint *card, shortint *commet, integer *precin); +extern integer fxfene_(integer *ctime, shortint *datesr, integer *maxch, shortint *format, integer *cutovr); +extern integer fxfeni_(shortint *keywod, integer *param, shortint *card, shortint *commet); +extern integer fxfenl_(shortint *keywod, integer *param, shortint *card, shortint *commet); +extern integer fxfenr_(shortint *keywod, real *param, shortint *card, shortint *commet, integer *precin); +extern integer fxfens_(shortint *root, shortint *keywod, integer *axisno); +extern integer fxfexh_(integer *infd, integer *outfd, integer *nlines, integer *group, integer *nbks, integer *hdroff, integer *pixoff); +extern integer fxffac_(shortint *fname, integer *size); +extern integer fxffcr_(shortint *file); +extern integer fxffiw_(integer *im, shortint *key); +extern integer fxffog_(integer *fit, shortint *messg); +extern integer fxfgas_(integer *im, logical *fsec); +extern integer fxfgeb_(shortint *card, integer *bval); +extern integer fxfged_(shortint *card, doublereal *dval); +extern integer fxfgei_(shortint *card, integer *ival); +extern integer fxfgen_(integer *im, integer *oim, integer *acmode, shortint *outstr, integer *maxch); +extern integer fxfger_(shortint *card, real *rval); +extern integer fxfget_(shortint *card, shortint *commet, integer *maxch); +extern integer fxfglm_(shortint *time, shortint *date, integer *limtie); +extern integer fxfgsr_(shortint *card, shortint *outstr, integer *maxch); +extern integer fxfhef_(integer *im, integer *group, integer *acmode, integer *hdroff, integer *diff, integer *ualen); +extern integer fxfint_(void); +extern integer fxfkse_(integer *param, shortint *ksectn, integer *ip, integer *fit); +extern integer fxfksl_(shortint *outstr, integer *param, integer *fit); +extern integer fxfksm_(shortint *pm, integer *param, integer *fit); +extern integer fxfksn_(shortint *ksectn, integer *fit, integer *group); +extern integer fxfkss_(integer *fit, integer *acmode); +extern integer fxfkst_(integer *fit); +extern integer fxflor_(integer *in, integer *fit, integer *spool, integer *nrec10, integer *dataln); +extern integer fxfmad_(shortint *instr, integer *ip, shortint *card, integer *colout, integer *maxcos, integer *delim); +extern integer fxfmar_(integer *pat, integer *plines, integer *str, integer *slines, integer *merge, integer *po); +extern integer fxfmas_(integer *im, integer *nheads); +extern integer fxfmay_(integer *infd, integer *outfd, integer *hdroff, integer *pixoff, integer *charsa); +extern integer fxfmea_(integer *im, integer *userh, integer *fitsln); +extern integer fxfnoe_(integer *im); +extern integer fxfnul_(void); +extern integer fxfopn_(integer *kernel, integer *im, integer *oim, shortint *root, shortint *extn, shortint *ksectn, integer *group, integer *gcarg, integer *acmode, integer *status); +extern integer fxfopx_(integer *im, integer *status); +extern integer fxfove_(integer *im); +extern integer fxfovt_(integer *fit, integer *im); +extern integer fxfpaa_(shortint *ibuf, shortint *obuf, integer *npix, integer *pixtye); +extern integer fxfpld_(integer *im); +extern integer fxfple_(integer *im, integer *fd); +extern integer fxfplf_(integer *im); +extern integer fxfplo_(integer *im, integer *maxlen, integer *pcount, integer *depth); +extern integer fxfplp_(integer *im, integer *hdrfd, integer *pcount); +extern integer fxfprr_(integer *im, integer *group); +extern integer fxfree_(integer *kernel, shortint *oroot, shortint *oextn, shortint *nroot, shortint *nextn, integer *status); +extern integer fxfrek_(integer *im); +extern integer fxfren_(integer *im, integer *cfit, integer *igroup, integer *hoff, integer *poff, integer *extn, integer *extv); +extern integer fxfrep_(shortint *in, shortint *out, shortint *tmp, integer *ntry, integer *nsleep); +extern integer fxfrfr_(integer *im, integer *group, integer *poff); +extern integer fxfrhr_(integer *im, integer *group, integer *acmode); +extern integer fxfsee_(integer *im, logical *overwe); +extern integer fxfsev_(integer *im); +extern integer fxfsex_(integer *im, integer *fit); +extern integer fxfskn_(integer *im, integer *group, integer *cfit, integer *hoff, integer *poff, integer *extn, integer *extv, integer *spool); +extern integer fxfuna_(shortint *cbuf, integer *npix, integer *pixtye, doublereal *bscale, doublereal *bzero); +extern integer fxfupd_(integer *im); +extern integer fxfupr_(integer *im, integer *status); +extern integer fxfwrr_(integer *im, integer *fit, integer *hdrfd, integer *nchara, integer *group); +extern integer fxfwrs_(integer *fd, integer *size); +extern integer fxfxhd_(integer *in, integer *out, shortint *buf, integer *bufsie, integer *hoffst, integer *poffst, integer *hsize); +extern integer fxfzad_(doublereal *data, integer *npix, doublereal *bscale, doublereal *bzero); +extern integer fxfzar_(real *data, integer *npix, doublereal *bscale, doublereal *bzero); +extern integer fxfzcl_(integer *chan, integer *status); +extern integer fxfzop_(shortint *pkfn, integer *mode, integer *status); +extern integer fxfzrd_(integer *chan, shortint *obuf, integer *nbytes, integer *boffst); +extern integer fxfzst_(integer *chan, integer *param, integer *value); +extern integer fxfzwr_(integer *chan, shortint *ibuf, integer *nbytes, integer *boffst); +extern integer fxfzwt_(integer *chan, integer *status); +extern integer gactie_(integer *gp, integer *flags); +extern integer gacwk_(integer *wkid); +extern integer gadraw_(integer *gp, real *wx, real *wy); +extern integer gamove_(integer *gp, real *x, real *y); +extern integer gargb_(logical *bval); +extern integer gargc_(shortint *cval); +extern integer gargd_(doublereal *dval); +extern integer gargi_(integer *ival); +extern integer gargl_(integer *lval); +extern integer gargr_(real *rval); +extern integer gargrd_(integer *lval, integer *radix); +extern integer gargs_(shortint *sval); +extern integer gargsr_(shortint *outstr, integer *maxch); +extern integer gargtk_(integer *token, shortint *outstr, integer *maxch); +extern integer gargwd_(shortint *outstr, integer *maxch); +extern integer gargx_(complex *xval); +extern integer gascae_(integer *gp, real *v, integer *npts, integer *axis); +extern integer gaxdrw_(real *wx, real *wy); +extern integer gaxfis_(integer *w, real *wx1, real *wx2, real *wy1, real *wy2, real *x1, real *dx, integer *xt, real *y1, real *dy, integer *yt); +extern integer gaxflh_(integer *stream); +extern integer gaxndc_(real *wx, real *wy, real *sx, real *sy); +extern integer gaxstt_(real *wx, real *wy); +extern integer gaxtet_(integer *stream, real *sx, real *sy, shortint *text, integer *hjusty, integer *vjusty); +extern integer gaxtik_(real *dx, real *dy); +extern integer gbytes_(integer *bufin, integer *bufout, integer *index, integer *size, integer *skip, integer *count); +extern integer gca_(real *px, real *py, real *qx, real *qy, integer *dimx, integer *dimy, integer *ncs, integer *nrs, integer *dx, integer *dy, integer *colia); +extern integer gcancl_(integer *gp); +extern integer gcas_(real *px, real *py, real *qx, real *qy, integer *dimx, integer *dimy, integer *ncs, integer *nrs, integer *dx, integer *dy, shortint *colia); +extern integer gclear_(integer *gp); +extern integer gclks_(void); +extern integer gclose_(integer *gp); +extern integer gclrwk_(integer *wkid, integer *cofl); +extern integer gclwk_(integer *wkid); +extern integer gctran_(integer *gp, real *x1, real *y1, real *x2, real *y2, integer *wcsa, integer *wcsb); +extern integer gcurps_(integer *gp, real *x, real *y); +extern integer gdawk_(integer *wkid); +extern integer gdeace_(integer *gp, integer *flags); +extern integer gescae_(integer *gp, integer *fn, shortint *instrn, integer *nwords); +extern integer gethot_(shortint *outstr, integer *maxch); +extern integer getsen_(shortint *image, shortint *sectin, integer *maxch); +extern integer getset_(real *vl, real *vr, real *vb, real *vt, real *wl, real *wr, real *wb, real *wt, integer *lf); +extern integer getsi_(integer *ix, integer *iy); +extern integer getusv_(char *vn, integer *iv, ftnlen vn_len); +extern integer gexflr_(integer *stream); +extern integer gexfls_(void); +extern integer gexflt_(integer *stream, integer *gpvale, integer *epagfh); +extern integer gfa_(integer *n, real *px, real *py); +extern integer gfill_(integer *gp, real *x, real *y, integer *npts, integer *style); +extern integer gflush_(integer *gp); +extern integer gframe_(integer *gp); +extern integer gfrint_(integer *gp); +extern integer ggcell_(integer *gp, shortint *m, integer *nx, integer *ny, real *x1, real *y1, real *x2, real *y2); +extern integer ggscae_(integer *gp, real *x, real *y, real *dx, real *dy); +extern integer ggview_(integer *gp, real *x1, real *x2, real *y1, real *y2); +extern integer ggwind_(integer *gp, real *x1, real *x2, real *y1, real *y2); +extern integer gimcor_(integer *gp, integer *rop, integer *src, integer *st, real *sx, real *sy, real *sw, real *sh, integer *dst, integer *dt, real *dx, real *dy, real *dw, real *dh); +extern integer gimcrr_(integer *gp, integer *raster, integer *type__, integer *width, integer *height, integer *depth); +extern integer gimder_(integer *gp, integer *raster); +extern integer gimdig_(integer *gp, integer *mappig, integer *erase); +extern integer gimeng_(integer *gp, integer *mappig, integer *refreh); +extern integer gimfrg_(integer *gp, integer *mappig); +extern integer gimfrp_(integer *gp, integer *colorp); +extern integer gimins_(integer *gp); +extern integer gimiod_(integer *gp, integer *iomap, integer *first, integer *nelem); +extern integer gimioe_(integer *gp, integer *iomap, integer *first, integer *nelem); +extern integer gimlop_(integer *gp, integer *colorp, real *offset, real *slope); +extern integer gimrat_(integer *gp); +extern integer gimreg_(integer *gp, integer *mappig); +extern integer gimres_(integer *gp, integer *raster, shortint *data, integer *nbits, integer *x1, integer *y1, integer *nx, integer *ny); +extern integer gimrex_(integer *gp, integer *raster, integer *ct, real *x1, real *y1, real *width, real *height); +extern integer gimseg_(integer *gp, integer *mappig, integer *rop, integer *src, integer *st, real *sx, real *sy, real *sw, real *sh, integer *dst, integer *dt, real *dx, real *dy, real *dw, real *dh); +extern integer gimser_(integer *gp, integer *raster); +extern integer gimsex_(integer *gp, integer *raster, integer *ct, real *x1, real *y1, real *width, real *height, integer *color, integer *rop); +extern integer gimwrp_(integer *gp, integer *colorp, integer *first, integer *nelem, integer *r__, integer *g, integer *b); +extern integer gimwrs_(integer *gp, integer *raster, shortint *data, integer *nbits, integer *x1, integer *y1, integer *nx, integer *ny); +extern integer giotr_(integer *stream); +extern integer giotrt_(integer *vex, integer *nexthr); +extern integer gkical_(integer *fd); +extern integer gkiclr_(integer *fd); +extern integer gkicls_(integer *fd, shortint *device); +extern integer gkides_(integer *fd, integer *flags); +extern integer gkieof_(integer *fd); +extern integer gkiese_(integer *fd, integer *fn, shortint *instrn, integer *nwords); +extern integer gkiexe_(shortint *gki, integer *dd); +extern integer gkifat_(integer *fd, integer *ap); +extern integer gkiffh_(integer *fd); +extern integer gkifia_(integer *fd, shortint *points, integer *npts); +extern integer gkiflh_(integer *fd); +extern integer gkiger_(integer *fd, integer *cursor, integer *cn, integer *key, integer *sx, integer *sy, integer *raster, integer *rx, integer *ry); +extern integer gkiges_(integer *fd, integer *wcs, integer *lenwcs); +extern integer gkigey_(integer *fd, shortint *m, integer *nx, integer *ny, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer gkiinl_(integer *stream, integer *dd); +extern integer gkiint_(integer *stream); +extern integer gkimfe_(integer *fd, shortint *title); +extern integer gkiops_(integer *fd, shortint *device, integer *mode); +extern integer gkiplt_(integer *fd, integer *ap); +extern integer gkipmt_(integer *fd, integer *ap); +extern integer gkipoe_(integer *fd, shortint *points, integer *npts); +extern integer gkipor_(integer *fd, shortint *points, integer *npts); +extern integer gkipuy_(integer *fd, shortint *m, integer *nx, integer *ny, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer gkiree_(integer *fd, integer *cn, integer *key, integer *sx, integer *sy, integer *raster, integer *rx, integer *ry); +extern integer gkirer_(integer *stream, integer *fd, integer *oldfd, integer *oldtye); +extern integer gkires_(integer *fd, integer *flags); +extern integer gkirey_(integer *fd, shortint *m, integer *np); +extern integer gkiser_(integer *fd, integer *x, integer *y, integer *cursor); +extern integer gkises_(integer *fd, integer *wcs, integer *lenwcs); +extern integer gkisul_(integer *stream, integer *pid, integer *prpsia); +extern integer gkitet_(integer *fd, integer *x, integer *y, shortint *text); +extern integer gkitxt_(integer *fd, integer *ap); +extern integer gkiwee_(integer *fd, integer *fn, shortint *hdr, integer *hdrlen, shortint *data, integer *dataln); +extern integer gkiwre_(integer *fd, shortint *gki); +extern integer gkpcal_(integer *dummy); +extern integer gkpcle_(void); +extern integer gkpclr_(integer *dummy); +extern integer gkpcls_(shortint *devnae, integer *n); +extern integer gkpdes_(integer *flags); +extern integer gkpdup_(integer *fd, shortint *data, integer *nwords); +extern integer gkpese_(integer *fn, shortint *instrn, integer *nwords); +extern integer gkpfat_(shortint *gki); +extern integer gkpfia_(shortint *p, integer *npts); +extern integer gkpflh_(integer *dummy); +extern integer gkpger_(integer *cursor); +extern integer gkpges_(shortint *wcs, integer *nwords); +extern integer gkpgey_(integer *nx, integer *ny, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer gkpgrm_(integer *graphm); +extern integer gkpinl_(integer *dd, integer *outfd, integer *verbot, integer *usegks); +extern integer gkpmfe_(shortint *title, integer *n); +extern integer gkpops_(shortint *devnae, integer *n, integer *mode); +extern integer gkpplt_(shortint *gki); +extern integer gkppmt_(shortint *gki); +extern integer gkppoe_(shortint *p, integer *npts); +extern integer gkppor_(shortint *p, integer *npts); +extern integer gkppst_(integer *fd, shortint *p, integer *npts, shortint *label, integer *verboe, integer *gkiuns); +extern integer gkppuy_(shortint *m, integer *nx, integer *ny, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer gkpres_(integer *flags); +extern integer gkpser_(integer *x, integer *y, integer *cursor); +extern integer gkpses_(shortint *wcs, integer *nwords); +extern integer gkptet_(integer *x, integer *y, shortint *text, integer *n); +extern integer gkptxg_(shortint *code); +extern integer gkptxt_(shortint *gki); +extern integer gkpunn_(shortint *gki); +extern integer glabax_(integer *gp, shortint *title, shortint *xlabel, shortint *ylabel); +extern integer glbdrd_(integer *gp, integer *ax1, integer *ax2); +extern integer glbene_(real *x, shortint *out, integer *maxch, shortint *format, real *step); +extern integer glbfis_(integer *gp, integer *ap, integer *ax1, integer *ax2, integer *angle); +extern integer glblas_(integer *gp, integer *ax, shortint *xlabel, shortint *ylabel); +extern integer glblob_(integer *gp, real *sx, real *sy, real *val, shortint *fmt, integer *scalig); +extern integer glbple_(integer *gp, shortint *title, integer *ntitls); +extern integer glbsep_(integer *gp, integer *axes, integer *ntitls, shortint *xlabel, shortint *ylabel); +extern integer glbses_(integer *gp, integer *ap, integer *ax1, integer *ax2, integer *angle); +extern integer glbset_(integer *gp, integer *ntitls, shortint *xlabel, shortint *ylabel); +extern integer glbveg_(integer *gp); +extern integer gline_(integer *gp, real *x1, real *y1, real *x2, real *y2); +extern integer gmark_(integer *gp, real *x, real *y, integer *markte, real *xsize, real *ysize); +extern integer gmftie_(integer *gp, shortint *mftite); +extern integer gmprif_(integer *gp, shortint *object, shortint *format); +extern integer gmsg_(integer *gp, shortint *object, shortint *messae); +extern integer gmsgb_(integer *gp, shortint *object, logical *value); +extern integer gmsgc_(integer *gp, shortint *object, shortint *value); +extern integer gmsgd_(integer *gp, shortint *object, doublereal *value); +extern integer gmsgi_(integer *gp, shortint *object, integer *value); +extern integer gmsgl_(integer *gp, shortint *object, integer *value); +extern integer gmsgr_(integer *gp, shortint *object, real *value); +extern integer gmsgs_(integer *gp, shortint *object, shortint *value); +extern integer gmsgx_(integer *gp, shortint *object, complex *value); +extern integer gnewpt_(real *ux, real *vy, integer *imax, integer *jptsy); +extern integer gopks_(integer *errfil); +extern integer gopwk_(integer *wkid, integer *conid, integer *wtype); +extern integer gpagee_(integer *gp, shortint *fname, shortint *prompt); +extern integer gpcell_(integer *gp, shortint *m, integer *nx, integer *ny, real *x1, real *y1, real *x2, real *y2); +extern integer gpl_(integer *n, real *px, real *py); +extern integer gplcae_(integer *gp); +extern integer gplcal_(void); +extern integer gplclb_(integer *pen, integer *mx, integer *my); +extern integer gplcll_(integer *pen, integer *mx, integer *my); +extern integer gplclr_(integer *pen, integer *mx, integer *my); +extern integer gplclt_(integer *pen, integer *mx, integer *my); +extern integer gplflh_(void); +extern integer gpline_(integer *gp, real *x, real *y, integer *npts); +extern integer gploto_(integer *gp, real *v, integer *npts, real *x1, real *x2, shortint *title); +extern integer gplotv_(real *v, integer *npts, real *x1, real *x2, shortint *title); +extern integer gplret_(void); +extern integer gplsee_(integer *gp, integer *type__); +extern integer gplwci_(integer *gp, real *wx, real *wy, real *mx, real *my); +extern integer gpm_(integer *n, real *px, real *py); +extern integer gpmark_(integer *gp, real *x, real *y, integer *npts, integer *markte, real *xsize, real *ysize); +extern integer gptclb_(integer *pen, integer *mx, integer *my); +extern integer gptcll_(integer *pen, integer *mx, integer *my); +extern integer gptclr_(integer *pen, integer *mx, integer *my); +extern integer gptclt_(integer *pen, integer *mx, integer *my); +extern integer gptflh_(void); +extern integer gqasf_(integer *ierror, integer *lasf); +extern integer gqchh_(integer *ierror, real *chh); +extern integer gqchup_(integer *ierror, real *chupx, real *chupy); +extern integer gqclip_(integer *errind, integer *iclip, real *iar); +extern integer gqcntn_(integer *errind, integer *cntr); +extern integer gqmk_(integer *ierr, integer *mtype); +extern integer gqnt_(integer *ntnr, integer *errind, real *window, real *vport); +extern integer gqopwk_(integer *n, integer *errind, integer *ol, integer *wkid); +extern integer gqplci_(integer *errind, integer *coli); +extern integer gqpmci_(integer *errind, integer *coli); +extern integer gqpmi_(integer *errind, real *index); +extern integer gqsort_(integer *x, integer *nelem, I_fp compae, integer *arg); +extern integer gqtxal_(integer *ierror, integer *txalh, integer *txalv); +extern integer gqtxci_(integer *ierror, integer *coli); +extern integer gqtxp_(integer *ierror, integer *path); +extern integer gqwks_(integer *wkid, integer *errind, integer *state); +extern integer gray_(void); +extern integer grcaxs_(integer *stream, real *sx, real *sy, integer *raster, real *rx, real *ry); +extern integer grccle_(integer *fd, integer *rc); +extern integer grcint_(integer *rc); +extern integer grckes_(integer *rc, shortint *opstr, integer *ip, integer *onoff); +extern integer grcmee_(integer *stream, shortint *messae); +extern integer grcndr_(real *mx, real *my, real *sx, real *sy); +extern integer grcnds_(real *ct, real *mx, real *my, real *wx, real *wy); +extern integer grcpcr_(integer *stream, real *sx, real *sy, integer *raster, real *rx, real *ry); +extern integer grcpoe_(integer *stream, real *v, integer *npts); +extern integer grcred_(integer *tr, integer *stream, shortint *fname); +extern integer grcres_(integer *stream, real *x, real *y); +extern integer grcrew_(integer *rc, integer *stream, real *sx, real *sy, integer *raster, real *rx, real *ry); +extern integer grcscc_(real *sx, real *sy, real *mx, real *my); +extern integer grcscs_(integer *stream, real *sx, real *sy, integer *raster, real *rx, real *ry, real *wx, real *wy, integer *wcs); +extern integer grcsen_(integer *w, real *ct); +extern integer grcsts_(integer *fd, integer *rc); +extern integer grctet_(integer *stream, real *x, real *y, shortint *text); +extern integer grcvit_(integer *tr, integer *stream, real *sx, real *sy, integer *raster, real *rx, real *ry, shortint *opstr, integer *ip); +extern integer grcwan_(integer *fd); +extern integer grcwcc_(real *ct, real *wx, real *wy, real *mx, real *my); +extern integer grcwod_(shortint *opstr, integer *ip, shortint *outstr, integer *maxch); +extern integer grcwre_(integer *tr, integer *stream, shortint *fname, logical *clobbr, logical *fullfe); +extern integer grdraw_(integer *gp, real *x, real *y); +extern integer greace_(integer *gp, integer *flags); +extern integer greset_(integer *gp, integer *flags); +extern integer grid_(integer *majrx, integer *minrx, integer *majry, integer *minry); +extern integer gridal_(integer *majrx, integer *minrx, integer *majry, integer *minry, integer *ixlab, integer *iylab, integer *igph, real *x, real *y); +extern integer gridl_(integer *majrx, integer *minrx, integer *majry, integer *minry); +extern integer gridt_(void); +extern integer grmove_(integer *gp, real *x, real *y); +extern integer grscae_(integer *gp, real *v, integer *npts, integer *axis); +extern integer gsasf_(integer *lasf); +extern integer gsawi_(integer *param, integer *value); +extern integer gsawr_(integer *param, real *value); +extern integer gscan_(integer *gp, shortint *commad); +extern integer gschh_(real *chh); +extern integer gschup_(real *chux, real *chuy); +extern integer gsclip_(integer *iclip); +extern integer gscur_(integer *gp, real *x, real *y); +extern integer gselnt_(integer *wcs); +extern integer gseti_(integer *gp, integer *param, integer *value); +extern integer gsetr_(integer *gp, integer *param, real *rval); +extern integer gsets_(integer *gp, integer *param, shortint *value); +extern integer gsfaci_(integer *index); +extern integer gsfais_(integer *ints); +extern integer gslwsc_(real *width); +extern integer gsmk_(integer *mtype); +extern integer gsmksc_(real *width); +extern integer gsplci_(integer *coli); +extern integer gspmci_(integer *coli); +extern integer gspmi_(integer *index); +extern integer gstrsb_(integer *tabs, integer *maxtas, integer *firstp, integer *tabsie); +extern integer gstsei_(integer *newvae, integer *value, integer *state); +extern integer gstser_(real *newvae, real *value, integer *state); +extern integer gstxal_(integer *txalh, integer *txalv); +extern integer gstxci_(integer *coli); +extern integer gstxp_(integer *txp); +extern integer gsview_(integer *gp, real *x1, real *x2, real *y1, real *y2); +extern integer gsvp_(integer *wcs, real *x1, real *x2, real *y1, real *y2); +extern integer gswind_(integer *gp, real *x1, real *x2, real *y1, real *y2); +extern integer gswn_(integer *wcs, real *x1, real *x2, real *y1, real *y2); +extern integer gtasce_(integer *gp, integer *gt, real *x, real *y, integer *npts); +extern integer gtcol1_(shortint *cmdstr, integer *gp, integer *gt, integer *newgrh); +extern integer gtcoln_(shortint *cmdstr, integer *gp, integer *gt, integer *newgrh); +extern integer gtcopy_(integer *gt1, integer *gt2); +extern integer gtext_(integer *gp, real *x, real *y, shortint *text, shortint *format); +extern integer gtfree_(integer *gt); +extern integer gtgets_(integer *gt, integer *param, shortint *str, integer *szstr); +extern integer gthelp_(shortint *file); +extern integer gtickr_(real *x1, real *x2, integer *roughs, integer *logflg, real *xtick1, real *step); +extern integer gtiret_(integer *gp, integer *gt); +extern integer gtlabx_(integer *gp, integer *gt); +extern integer gtrbap_(integer *stream); +extern integer gtrcol_(integer *stream, shortint *gki, integer *sourcd); +extern integer gtrctn_(integer *mx, integer *my, integer *sx, integer *sy); +extern integer gtrdee_(integer *tr, integer *gki); +extern integer gtrdit_(integer *pid, integer *in, integer *out, integer *stream); +extern integer gtrest_(integer *gp, integer *gt); +extern integer gtrfre_(integer *tr, integer *gki, integer *stream); +extern integer gtrgfh_(integer *stream); +extern integer gtrgtn_(integer *fd, real *x1, real *x2, real *y1, real *y2); +extern integer gtrmee_(integer *fd, integer *stream, shortint *name__); +extern integer gtrops_(shortint *devspc, integer *mode, integer *stream, integer *sourcd); +extern integer gtrpae_(integer *fd, integer *stream); +extern integer gtrpon_(shortint *gki); +extern integer gtrptn_(integer *stream, real *x1, real *x2, real *y1, real *y2); +extern integer gtrret_(integer *status); +extern integer gtrrew_(integer *stream); +extern integer gtrset_(integer *fd, real *x1, real *x2, real *y1, real *y2); +extern integer gtrsts_(integer *fd); +extern integer gtrtre_(integer *tr, integer *gki); +extern integer gtruno_(integer *stream); +extern integer gtrwae_(integer *fd, integer *stream); +extern integer gtrwrr_(integer *fd, real *x, real *y); +extern integer gtrwsn_(shortint *gki); +extern integer gtseti_(integer *gt, integer *param, integer *ival); +extern integer gtsetr_(integer *gt, integer *param, real *rval); +extern integer gtsets_(integer *gt, integer *param, shortint *str); +extern integer gtswid_(integer *gp, integer *gt); +extern integer gtuivs_(integer *gp, integer *gt); +extern integer gtvplt_(integer *gp, integer *gt, real *v, integer *npts, real *x1, real *x2); +extern integer gtwin1_(integer *gt, integer *gp, real *wx, real *wy, integer *wcs, integer *key, shortint *cmd, integer *redraw); +extern integer gtwin2_(integer *gt, integer *gp, real *wx1, real *wy1, integer *wcs1, integer *key1, shortint *cmd1, real *wx2, real *wy2, integer *wcs2, integer *key2, shortint *cmd2, integer *redraw); +extern integer gtwinw_(integer *gt, integer *gp, shortint *cursor, integer *redraw); +extern integer gtx_(real *px, real *py, char *f77chars, ftnlen f77chars_len); +extern integer gtxset_(integer *tx, shortint *format, integer *ip); +extern integer gtycle_(integer *tty); +extern integer gtyfey_(integer *fd, shortint *device, integer *tty); +extern integer gtyins_(integer *tty, integer *tcapce, integer *tcapix, integer *ncaps); +extern integer gtysce_(integer *tty, shortint *termce, shortint *devnae); +extern integer gumark_(integer *gp, real *x, real *y, integer *npts, real *xcen, real *ycen, real *xsize, real *ysize, integer *fill); +extern integer gvline_(integer *gp, real *v, integer *npts, real *x1, real *x2); +extern integer gvmark_(integer *gp, real *v, integer *npts, real *x1, real *x2, integer *markte, real *xsize, real *ysize); +extern integer gwcsme_(shortint *devnae, shortint *fname, integer *maxch); +extern integer gwrwcs_(shortint *devnae, integer *wcs, integer *lenwcs); +extern integer gxgtx_(real *px, real *py, shortint *chars); +extern integer hafton_(real *z__, integer *l, integer *m, integer *n, real *flo, real *hi, integer *nlev, integer *nopt, integer *nprm, integer *ispv, real *spval); +extern integer halfax_(integer *majrx, integer *minrx, integer *majry, integer *minry, real *x, real *y, integer *ixlab, integer *iylab); +extern integer hfinit_(void); +extern integer iccled_(integer *ic, integer *cv, doublereal *x, doublereal *y, doublereal *w, integer *npts); +extern integer icclen_(integer *ic, integer *cv, real *x, real *y, real *w, integer *npts); +extern integer icclod_(integer *ic); +extern integer icclor_(integer *ic); +extern integer iccopy_(integer *icin, integer *icout); +extern integer icdevd_(integer *cv, doublereal *x, doublereal *y, doublereal *w, integer *rejpts, integer *npts, real *lowret, real *highrt, real *grow, integer *refit, integer *nrejet, integer *newret); +extern integer icdevr_(integer *cv, real *x, real *y, real *w, integer *rejpts, integer *npts, real *lowret, real *highrt, real *grow, integer *refit, integer *nrejet, integer *newret); +extern integer icdosd_(integer *ic, integer *cv, doublereal *x, doublereal *wts, integer *npts, integer *newx, integer *newwts, integer *newfun, integer *refit); +extern integer icdosr_(integer *ic, integer *cv, real *x, real *wts, integer *npts, integer *newx, integer *newwts, integer *newfun, integer *refit); +extern integer icerrd_(integer *ic, shortint *file, integer *cv, doublereal *x, doublereal *y, doublereal *wts, integer *npts); +extern integer icerrs_(integer *ic, shortint *file, integer *cv, real *x, real *y, real *wts, integer *npts); +extern integer icferd_(integer *ic, integer *cv, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *fd); +extern integer icferr_(integer *ic, integer *cv, real *x, real *y, real *wts, integer *npts, integer *fd); +extern integer icfit_(integer *ic, integer *cv, real *x, real *y, real *wts, integer *npts, integer *newx, integer *newy, integer *newwts, integer *newfun); +extern integer icfitd_(integer *ic, integer *cv, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *newx, integer *newy, integer *newwts, integer *newfun); +extern integer icfshw_(integer *ic, integer *fd); +extern integer icfvsd_(integer *ic, integer *cv, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *fd); +extern integer icfvsr_(integer *ic, integer *cv, real *x, real *y, real *wts, integer *npts, integer *fd); +extern integer icfxyd_(integer *ic, integer *cv, doublereal *x, doublereal *y, doublereal *w, integer *npts, integer *fd); +extern integer icfxyr_(integer *ic, integer *cv, real *x, real *y, real *w, integer *npts, integer *fd); +extern integer ichelp_(integer *ic); +extern integer iclisr_(integer *ic, integer *cv, real *x, real *y, real *wts, integer *npts, shortint *file); +extern integer icopen_(integer *ic); +extern integer icpkey_(integer *ic, integer *key, integer *xaxis, integer *yaxis); +extern integer icpstr_(integer *ic, shortint *param, shortint *str); +extern integer icputi_(integer *ic, shortint *param, integer *ival); +extern integer icputr_(integer *ic, shortint *param, real *rval); +extern integer icrejd_(integer *cv, doublereal *x, doublereal *y, doublereal *w, integer *rejpts, integer *npts, real *lowret, real *highrt, integer *nitere, real *grow, integer *nrejet); +extern integer icrejr_(integer *cv, real *x, real *y, real *w, integer *rejpts, integer *npts, real *lowret, real *highrt, integer *nitere, real *grow, integer *nrejet); +extern integer icshow_(integer *ic, shortint *file, integer *gt); +extern integer icvshd_(integer *ic, shortint *file, integer *cv, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *gt); +extern integer icvshr_(integer *ic, shortint *file, integer *cv, real *x, real *y, real *wts, integer *npts, integer *gt); +extern integer icxysd_(integer *ic, shortint *file, integer *cv, doublereal *x, doublereal *y, doublereal *w, integer *npts); +extern integer icxysr_(integer *ic, shortint *file, integer *cv, real *x, real *y, real *w, integer *npts); +extern integer idbcle_(integer *idb); +extern integer idiot_(real *xdra, real *ydra, integer *npts, integer *ltyp, integer *ldsh, char *labx, char *laby, char *labg, integer *lfra, ftnlen labx_len, ftnlen laby_len, ftnlen labg_len); +extern integer idkcle_(integer *fd); +extern integer idkdrw_(integer *fd, integer *ax, integer *ay); +extern integer idkflh_(integer *fd); +extern integer idkfre_(integer *fd); +extern integer idklih_(integer *fd, integer *width); +extern integer idkmoe_(integer *fd, integer *x, integer *y); +extern integer idkver_(integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer iisblk_(integer *chan1, integer *chan2, integer *chan3, integer *chan4, integer *nframs, real *rate); +extern integer iiscls_(integer *chan, integer *status); +extern integer iisers_(integer *chan); +extern integer iisgop_(integer *frame, integer *mode, integer *chan); +extern integer iishdr_(integer *id, integer *count, integer *subunt, integer *x, integer *y, integer *z__, integer *t); +extern integer iisio_(shortint *buf, integer *nbytes, integer *status); +extern integer iislpe_(shortint *y, integer *npts, integer *xc, integer *height, integer *width); +extern integer iislps_(shortint *lutb, shortint *lutg, shortint *lutr); +extern integer iismtc_(integer *chan1, integer *chan2); +extern integer iisofm_(shortint *map); +extern integer iisopn_(shortint *devino, integer *mode, integer *chan); +extern integer iispio_(shortint *buf, integer *nx, integer *ny); +extern integer iisrcr_(integer *status, integer *xcur, integer *ycur); +extern integer iisrd_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer iisrgb_(integer *redchn, integer *greenn, integer *bluecn); +extern integer iisrlt_(integer *chan, shortint *lut); +extern integer iisrm_(integer *zfactr); +extern integer iisrom_(integer *color, shortint *lut); +extern integer iissee_(integer *frame); +extern integer iisstt_(integer *chan, integer *what, integer *lvalue); +extern integer iiswcr_(integer *status, integer *xcur, integer *ycur); +extern integer iiswlt_(integer *chan, shortint *lut); +extern integer iiswn3_(integer *chan1, integer *chan2, integer *chan3); +extern integer iiswom_(integer *color, shortint *lut); +extern integer iiswr_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer iiswt_(integer *chan, integer *nbytes); +extern integer iiszm_(integer *zfactr, integer *x, integer *y); +extern integer ikicle_(integer *im); +extern integer ikicoy_(shortint *old, shortint *new__); +extern integer ikidee_(shortint *image); +extern integer ikideg_(shortint *str, integer *fd, integer *flags); +extern integer ikiint_(void); +extern integer ikimke_(shortint *root, shortint *extn, shortint *fname, integer *maxch); +extern integer ikiopn_(integer *nim, shortint *image, shortint *ksectn, integer *clindx, integer *clsize, integer *acmode, integer *oim); +extern integer ikiopx_(integer *im); +extern integer ikipae_(shortint *image, shortint *root, shortint *extn); +extern integer ikiree_(shortint *old, shortint *new__); +extern integer ikiupr_(integer *im); +extern integer imaddb_(integer *im, shortint *key, logical *value); +extern integer imaddd_(integer *im, shortint *key, doublereal *value); +extern integer imaddf_(integer *im, shortint *key, shortint *datate); +extern integer imaddi_(integer *im, shortint *key, integer *value); +extern integer imaddl_(integer *im, shortint *key, integer *value); +extern integer imaddr_(integer *im, shortint *key, real *value); +extern integer imadds_(integer *im, shortint *key, shortint *value); +extern integer imaflp_(shortint *a, integer *npix, integer *szpixl); +extern integer imakbc_(integer *im, shortint *key, logical *value, shortint *commet); +extern integer imakbi_(integer *im, shortint *key, logical *value, shortint *commet, shortint *pkey, integer *baf); +extern integer imakdc_(integer *im, shortint *key, doublereal *value, shortint *commet); +extern integer imakdi_(integer *im, shortint *key, doublereal *value, shortint *commet, shortint *pkey, integer *baf); +extern integer imakic_(integer *im, shortint *key, integer *value, shortint *commet); +extern integer imakii_(integer *im, shortint *key, integer *value, shortint *commet, shortint *pkey, integer *baf); +extern integer imaklc_(integer *im, shortint *key, integer *value, shortint *commet); +extern integer imakli_(integer *im, shortint *key, integer *value, shortint *commet, shortint *pkey, integer *baf); +extern integer imakrc_(integer *im, shortint *key, real *value, shortint *commet); +extern integer imakri_(integer *im, shortint *key, real *value, shortint *commet, shortint *pkey, integer *baf); +extern integer imaksc_(integer *im, shortint *key, shortint *value, shortint *commet); +extern integer imaksi_(integer *im, shortint *key, shortint *value, shortint *commet, shortint *pkey, integer *baf); +extern integer imalin_(integer *offset, integer *blksie); +extern integer imaplv_(integer *im, integer *lv, integer *pv, integer *ndim); +extern integer imastc_(integer *im, shortint *key, shortint *value, shortint *commet); +extern integer imasti_(integer *im, shortint *key, shortint *value, shortint *commet, shortint *pkey, integer *baf); +extern integer imastr_(integer *im, shortint *key, shortint *value); +extern integer imbln1_(integer *imdes, integer *nx); +extern integer imbln2_(integer *imdes, integer *nx, integer *ny); +extern integer imbln3_(integer *imdes, integer *nx, integer *ny, integer *nz); +extern integer imbtrn_(integer *im, integer *v1, integer *v2, integer *ndim); +extern integer imcfnl_(integer *fn); +extern integer imcopy_(shortint *old, shortint *new__); +extern integer imctrt_(integer *imdes, integer *dim, integer *x1arg, integer *x2arg, integer *step); +extern integer imdbcl_(shortint *m, integer *nx, integer *ny, integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer imdcal_(integer *dummy); +extern integer imdcle_(void); +extern integer imdclr_(integer *dummy); +extern integer imdcls_(shortint *devnae, integer *n); +extern integer imdcor_(integer *index); +extern integer imddae_(integer *gout, shortint *p, integer *npts, integer *ltype); +extern integer imddrr_(shortint *ch, integer *x, integer *y, integer *xsize, integer *ysize, integer *orien, integer *font); +extern integer imdect_(shortint *sectin, integer *ip, integer *x1, integer *x2, integer *step); +extern integer imdele_(shortint *image); +extern integer imdelf_(integer *im, shortint *key); +extern integer imdese_(integer *fn, shortint *instrn, integer *nwords); +extern integer imdfat_(shortint *gki); +extern integer imdfia_(shortint *p, integer *npts); +extern integer imdflh_(integer *dummy); +extern integer imdfot_(integer *font); +extern integer imdgey_(integer *nx, integer *ny, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer imdint_(integer *tty, shortint *devnae); +extern integer imdlie_(integer *index); +extern integer imdmcl_(shortint *m, integer *nx, integer *ny, integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer imdops_(shortint *devnae, integer *n, integer *mode); +extern integer imdopv_(shortint *devnae, integer *frame, integer *color, integer *dd); +extern integer imdplt_(shortint *gki); +extern integer imdpmt_(shortint *gki); +extern integer imdpoe_(shortint *p, integer *npts); +extern integer imdpor_(shortint *p, integer *npts); +extern integer imdpus_(integer *ds, integer *frame, shortint *str1, shortint *str2, real *a, real *b, real *c__, real *d__, real *tx, real *ty, real *z1, real *z2, integer *ztr); +extern integer imdpuy_(shortint *m, integer *nx, integer *ny, integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer imdrco_(integer *tty, shortint *outstr, integer *maxch, integer *wcs, integer *pause); +extern integer imdret_(void); +extern integer imdseg_(shortint *reg, real *sx, real *sy, integer *snx, integer *sny, integer *dx, integer *dy, integer *dnx, integer *dny, shortint *objref); +extern integer imdses_(integer *chan, shortint *wcstet); +extern integer imdtet_(integer *xc, integer *yc, shortint *text, integer *n); +extern integer imdtxt_(shortint *gki); +extern integer imerr_(shortint *imagee, integer *errcoe); +extern integer imflpl_(integer *a, integer *npix); +extern integer imflps_(shortint *a, integer *npix); +extern integer imflsd_(integer *imdes); +extern integer imflsh_(integer *im, integer *bp, integer *vs, integer *ve, integer *ndim); +extern integer imflsi_(integer *imdes); +extern integer imflsl_(integer *imdes); +extern integer imflsr_(integer *imdes); +extern integer imflss_(integer *imdes); +extern integer imflsx_(integer *imdes); +extern integer imfluh_(integer *imdes); +extern integer imfnpy_(shortint *key, integer *strp, integer *nstr, integer *nextch, integer *sbuf); +extern integer imfnss_(integer *im, shortint *patcoe, integer *strp, integer *nstr, integer *nextch, integer *sbuf); +extern integer imgclr_(shortint *imspec, shortint *clustr, integer *maxch); +extern integer imgcom_(integer *im, shortint *key, shortint *commet); +extern integer imgime_(shortint *imspec, shortint *image, integer *maxch); +extern integer imgsen_(shortint *imspec, shortint *sectin, integer *maxch); +extern integer imgstr_(integer *im, shortint *key, shortint *outstr, integer *maxch); +extern integer iminfi_(integer *im, shortint *key, shortint *pkey, shortint *datate, integer *baf); +extern integer iminie_(integer *im, integer *lenimr); +extern integer imioff_(integer *im, integer *pixoff, integer *comprs, integer *devblz); +extern integer imisec_(integer *imdes, shortint *sectin); +extern integer immaky_(integer *im, integer *oim); +extern integer imopsf_(integer *im); +extern integer impakd_(doublereal *a, integer *b, integer *npix, integer *dtype); +extern integer impaki_(integer *a, integer *b, integer *npix, integer *dtype); +extern integer impakl_(integer *a, integer *b, integer *npix, integer *dtype); +extern integer impakr_(real *a, integer *b, integer *npix, integer *dtype); +extern integer impaks_(shortint *a, integer *b, integer *npix, integer *dtype); +extern integer impakx_(complex *a, integer *b, integer *npix, integer *dtype); +extern integer impare_(shortint *imspec, shortint *clustr, integer *szclur, shortint *ksectn, integer *szksen, shortint *sectin, integer *szsecn, integer *clindx, integer *clsize); +extern integer imphis_(integer *im, shortint *key, shortint *text, shortint *pkey, integer *baf); +extern integer impkbc_(integer *im, shortint *key, logical *bval, shortint *commet); +extern integer impkdc_(integer *im, shortint *key, doublereal *dval, shortint *commet); +extern integer impkic_(integer *im, shortint *key, integer *ival, shortint *commet); +extern integer impklc_(integer *im, shortint *key, integer *lval, shortint *commet); +extern integer impkrc_(integer *im, shortint *key, real *rval, shortint *commet); +extern integer impksc_(integer *im, shortint *key, shortint *value, shortint *commet); +extern integer impmlr_(integer *im, integer *bp); +extern integer impstc_(integer *im, shortint *key, shortint *value, shortint *commet); +extern integer impstr_(integer *im, shortint *key, shortint *value); +extern integer imputb_(integer *im, shortint *key, logical *bval); +extern integer imputd_(integer *im, shortint *key, doublereal *dval); +extern integer imputf_(integer *im, shortint *file, shortint *pkey, integer *baf); +extern integer imputh_(integer *im, shortint *key, shortint *text); +extern integer imputi_(integer *im, shortint *key, integer *ival); +extern integer imputl_(integer *im, shortint *key, integer *lval); +extern integer imputr_(integer *im, shortint *key, real *rval); +extern integer imputs_(integer *im, shortint *key, shortint *value); +extern integer imrart_(integer *piv, shortint *fname, integer *nlines, integer *insert); +extern integer imrbpx_(integer *im, shortint *obuf, integer *totpix, integer *v, integer *vinc); +extern integer imrdpx_(integer *im, shortint *obuf, integer *npix, integer *v, integer *xstep); +extern integer imrene_(shortint *old, shortint *new__); +extern integer imrenf_(integer *im, shortint *oldkey, shortint *newkey); +extern integer imrmbs_(integer *im); +extern integer imsamp_(shortint *a, shortint *b, integer *npix, integer *szpixl, integer *step); +extern integer imsetf_(integer *fd, integer *im); +extern integer imseti_(integer *im, integer *param, integer *value); +extern integer imsetr_(integer *im, integer *param, real *value); +extern integer imsmpl_(integer *a, integer *b, integer *npix, integer *step); +extern integer imsmps_(shortint *a, shortint *b, integer *npix, integer *step); +extern integer imsslv_(integer *im, integer *vs, integer *ve, integer *v, integer *vinc, integer *npix); +extern integer imstas_(integer *im, integer *option, shortint *outstr, integer *maxch); +extern integer imtcle_(integer *imt); +extern integer imtrew_(integer *imt); +extern integer imunmp_(integer *im); +extern integer imupkd_(integer *a, doublereal *b, integer *npix, integer *dtype); +extern integer imupki_(integer *a, integer *b, integer *npix, integer *dtype); +extern integer imupkl_(integer *a, integer *b, integer *npix, integer *dtype); +extern integer imupkr_(integer *a, real *b, integer *npix, integer *dtype); +extern integer imupks_(integer *a, shortint *b, integer *npix, integer *dtype); +extern integer imupkx_(integer *a, complex *b, integer *npix, integer *dtype); +extern integer imwbpx_(integer *im, shortint *ibuf, integer *totpix, integer *v, integer *vinc); +extern integer imwrie_(integer *imdes, shortint *buf, integer *nchars, integer *offset); +extern integer imwrpx_(integer *im, shortint *buf, integer *npix, integer *v, integer *xstep); +extern integer inbfid_(integer *in, integer *npts, integer *nvars__); +extern integer inbfir_(integer *in, integer *npts, integer *nvars__); +extern integer incopd_(integer *insrc, integer *indst); +extern integer incopr_(integer *insrc, integer *indst); +extern integer indevd_(integer *nl, doublereal *x, doublereal *y, doublereal *w, integer *rejpts, integer *npts, integer *nvars__, doublereal *lowret, doublereal *highrt, doublereal *grow, integer *nrejet, integer *newret); +extern integer indevr_(integer *nl, real *x, real *y, real *w, integer *rejpts, integer *npts, integer *nvars__, real *lowret, real *highrt, real *grow, integer *nrejet, integer *newret); +extern integer indumd_(integer *fd, integer *in); +extern integer indumr_(integer *fd, integer *in); +extern integer inerrd_(integer *in, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__, doublereal *variae, doublereal *chisqr, doublereal *scattr, doublereal *rms, doublereal *errors); +extern integer inerrr_(integer *in, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__, real *variae, real *chisqr, real *scattr, real *rms, real *errors); +extern integer infitd_(integer *in, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__, integer *wtflag, integer *stat); +extern integer infitr_(integer *in, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__, integer *wtflag, integer *stat); +extern integer infred_(integer *in); +extern integer infrer_(integer *in); +extern integer ingaxd_(integer *in, integer *gt, integer *nl, integer *axis, doublereal *x, doublereal *y, doublereal *z__, integer *npts, integer *nvars__); +extern integer ingaxr_(integer *in, integer *gt, integer *nl, integer *axis, real *x, real *y, real *z__, integer *npts, integer *nvars__); +extern integer ingchd_(integer *in, integer *type__); +extern integer ingchr_(integer *in, integer *type__); +extern integer ingcod_(integer *in, shortint *cmdstr, integer *gp, integer *gt, integer *nl, doublereal *x, doublereal *y, doublereal *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae, integer *newgrh); +extern integer ingcor_(integer *in, shortint *cmdstr, integer *gp, integer *gt, integer *nl, real *x, real *y, real *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae, integer *newgrh); +extern integer ingd1d_(integer *in, integer *gp, doublereal *x, doublereal *y, doublereal *wts, integer *npts, real *wx, real *wy); +extern integer ingd1r_(integer *in, integer *gp, real *x, real *y, real *wts, integer *npts, real *wx, real *wy); +extern integer ingdad_(integer *in, shortint *file, doublereal *x, shortint *names, integer *npts, integer *nvars__, integer *lennae); +extern integer ingdar_(integer *in, shortint *file, real *x, shortint *names, integer *npts, integer *nvars__, integer *lennae); +extern integer ingded_(integer *in, integer *gp, integer *gt, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__, real *wx, real *wy); +extern integer ingder_(integer *in, integer *gp, integer *gt, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__, real *wx, real *wy); +extern integer ingdey_(integer *in, integer *nvars__, integer *newgrh); +extern integer ingerd_(integer *in, shortint *file, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__); +extern integer ingerr_(integer *in, shortint *file, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__); +extern integer ingfid_(integer *in, integer *gp, shortint *cursor, integer *gt, integer *nl, doublereal *x, doublereal *y, doublereal *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae, integer *wtflag, integer *stat); +extern integer ingfir_(integer *in, integer *gp, shortint *cursor, integer *gt, integer *nl, real *x, real *y, real *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae, integer *wtflag, integer *stat); +extern integer ingg1d_(integer *in, integer *gp, integer *gt, doublereal *x, doublereal *y, doublereal *wts, integer *npts); +extern integer ingg1r_(integer *in, integer *gp, integer *gt, real *x, real *y, real *wts, integer *npts); +extern integer ingg2d_(integer *in, integer *gp, integer *gt, doublereal *x, doublereal *y, integer *npts); +extern integer ingg2r_(integer *in, integer *gp, integer *gt, real *x, real *y, integer *npts); +extern integer inggel_(integer *in, integer *xtype, integer *xnum, shortint *label, shortint *units, integer *maxch); +extern integer inggfd_(integer *in, integer *gp, integer *gt, integer *nl, doublereal *xin, doublereal *wts, integer *npts, integer *nvars__); +extern integer inggfr_(integer *in, integer *gp, integer *gt, integer *nl, real *xin, real *wts, integer *npts, integer *nvars__); +extern integer inggrd_(integer *in, integer *gp, integer *gt, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__); +extern integer inggrr_(integer *in, integer *gp, integer *gt, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__); +extern integer ingkey_(integer *in, integer *key, integer *axis, integer *type__, integer *varnum); +extern integer ingpad_(integer *in, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__, integer *gt); +extern integer ingpar_(integer *in, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__, integer *gt); +extern integer ingred_(integer *in, shortint *file, integer *nl, doublereal *x, doublereal *y, doublereal *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae); +extern integer ingrer_(integer *in, shortint *file, integer *nl, real *x, real *y, real *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae); +extern integer ingshd_(integer *in, shortint *file); +extern integer ingshr_(integer *in, shortint *file); +extern integer ingstr_(integer *in, integer *param, shortint *str, integer *maxch); +extern integer ingtie_(integer *in, shortint *file, integer *gt); +extern integer ingu1d_(integer *in, integer *gp, doublereal *x, doublereal *y, doublereal *wts, doublereal *userws, integer *npts, real *wx, real *wy); +extern integer ingu1r_(integer *in, integer *gp, real *x, real *y, real *wts, real *userws, integer *npts, real *wx, real *wy); +extern integer inguad_(integer *keynum, integer *in, integer *nl, doublereal *x, doublereal *y, doublereal *z__, integer *npts, integer *nvars__); +extern integer inguar_(integer *keynum, integer *in, integer *nl, real *x, real *y, real *z__, integer *npts, integer *nvars__); +extern integer ingucd_(integer *in, integer *gp, integer *gt, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__, integer *newgrh); +extern integer ingucr_(integer *in, integer *gp, integer *gt, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__, integer *newgrh); +extern integer inguft_(integer *in, integer *gp, integer *gt, integer *nl, real *wx, real *wy, integer *wcs, integer *key, shortint *cmd); +extern integer ingund_(integer *in, integer *gp, integer *gt, integer *nl, doublereal *x, doublereal *y, doublereal *wts, doublereal *userws, integer *npts, integer *nvars__, real *wx, real *wy); +extern integer ingunr_(integer *in, integer *gp, integer *gt, integer *nl, real *x, real *y, real *wts, real *userws, integer *npts, integer *nvars__, real *wx, real *wy); +extern integer ingvad_(integer *in, shortint *file, integer *nvars__); +extern integer ingvar_(integer *in, shortint *file, integer *nvars__); +extern integer ingvsd_(integer *in, shortint *file, integer *nl, doublereal *x, doublereal *y, doublereal *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae, integer *gt); +extern integer ingvsr_(integer *in, shortint *file, integer *nl, real *x, real *y, real *wts, shortint *names, integer *npts, integer *nvars__, integer *lennae, integer *gt); +extern integer ininid_(integer *in, integer *func, integer *dfunc, doublereal *param, doublereal *dparam, integer *nparas, integer *plist, integer *nfpars); +extern integer ininir_(integer *in, integer *func, integer *dfunc, real *param, real *dparam, integer *nparas, integer *plist, integer *nfpars); +extern integer initag_(void); +extern integer initut_(void); +extern integer initzi_(integer *ix, integer *iy, integer *iz, integer *lin3, integer *itop, integer *ient); +extern integer initzs_(integer *ix, integer *iy, integer *iz, integer *lin3, integer *itop, integer *ient); +extern integer initzt_(integer *ix, integer *iy, integer *iz, integer *lin3, integer *itop, integer *ient); +extern integer inlimd_(integer *in, doublereal *x, integer *npts, integer *nvars__); +extern integer inlimr_(integer *in, real *x, integer *npts, integer *nvars__); +extern integer innlid_(integer *in, integer *nl); +extern integer innlir_(integer *in, integer *nl); +extern integer inpkey_(integer *in, integer *key, integer *axis, integer *type__, integer *varnum); +extern integer inpstr_(integer *in, integer *param, shortint *str); +extern integer inputd_(integer *in, integer *param, doublereal *dval); +extern integer inputi_(integer *in, integer *param, integer *ival); +extern integer inputp_(integer *in, integer *param, integer *pval); +extern integer inputr_(integer *in, integer *param, real *rval); +extern integer inrefd_(integer *in, integer *nl, doublereal *x, doublereal *y, doublereal *wts, integer *npts, integer *nvars__, integer *wtflag); +extern integer inrefr_(integer *in, integer *nl, real *x, real *y, real *wts, integer *npts, integer *nvars__, integer *wtflag); +extern integer inrejd_(integer *in, integer *nl, doublereal *x, doublereal *y, doublereal *w, integer *npts, integer *nvars__, integer *wtflag); +extern integer inrejr_(integer *in, integer *nl, real *x, real *y, real *w, integer *npts, integer *nvars__, integer *wtflag); +extern integer intrde_(void); +extern integer intree_(void); +extern integer intrrt_(void); +extern integer intzi_(real *xx, real *yy, real *zz, integer *lin3, integer *itop); +extern integer intzs_(real *xx, real *yy, real *zz, integer *lin3, integer *itop); +extern integer intzt_(real *xx, real *yy, real *zz, integer *lin3, integer *itop); +extern integer isosrb_(void); +extern integer isosrf_(real *t, integer *lu, integer *mu, integer *lv, integer *mv, integer *mw, real *eye, integer *muvwp2, real *slab, real *tiso, integer *iflag); +extern integer iwcfis_(integer *iw); +extern integer iwcloe_(integer *iw); +extern integer iwents_(integer *mw, integer *iw, integer *ndim); +extern integer iwfb2m_(integer *iw, real *fbx, real *fby, real *imx, real *imy); +extern integer iwim2b_(integer *iw, real *imx, real *imy, real *fbx, real *fby); +extern integer iwputr_(integer *fd, integer *iw, integer *axis, integer *ctype, shortint *fmt1, shortint *fmt2, integer *maxinx); +extern integer iwputy_(integer *iw, doublereal *new__, doublereal *old, integer *ndim, shortint *kwfort, integer *kwtype, integer *kwindx); +extern integer iwsetp_(integer *mw, integer *im); +extern integer kardbf_(integer *chan, shortint *buf, integer *maxbys, integer *offset); +extern integer kardgd_(integer *chan, shortint *buf, integer *maxbys, integer *offset); +extern integer kardlp_(integer *chan, shortint *buf, integer *maxbys, integer *offset); +extern integer kardpl_(integer *chan, shortint *buf, integer *maxbys, integer *offset); +extern integer kardpr_(integer *chan, shortint *buf, integer *maxbys, integer *offset); +extern integer kardsf_(integer *chan, shortint *buf, integer *maxbys, integer *offset); +extern integer kawrbf_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer kawrgd_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer kawrlp_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer kawrpl_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer kawrpr_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer kawrsf_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer kawtbf_(integer *chan, integer *status); +extern integer kawtgd_(integer *chan, integer *status); +extern integer kawtlp_(integer *chan, integer *status); +extern integer kawtpl_(integer *chan, integer *status); +extern integer kawtpr_(integer *chan, integer *status); +extern integer kawtsf_(integer *chan, integer *status); +extern integer kbzard_(integer *device, integer *chan, shortint *obuf, integer *maxbys, integer *loffst); +extern integer kbzawr_(integer *device, integer *chan, shortint *ibuf, integer *nbytes, integer *loffst); +extern integer kbzawt_(integer *device, integer *chan, integer *status); +extern integer kbzcls_(integer *device, integer *chan, integer *status); +extern integer kbzopn_(integer *device, shortint *osfn, integer *mode, integer *chan); +extern integer kbzstt_(integer *device, integer *chan, integer *what, integer *lvalue); +extern integer kclcpr_(integer *pid, integer *exitss); +extern integer kcldir_(integer *chan, integer *status); +extern integer kcldpr_(integer *jobcoe, integer *killfg, integer *exitss); +extern integer kclsbf_(integer *chan, integer *status); +extern integer kclsgd_(integer *chan, integer *status); +extern integer kclslp_(integer *chan, integer *status); +extern integer kclspl_(integer *chan, integer *status); +extern integer kclssf_(integer *chan, integer *status); +extern integer kclstx_(integer *chan, integer *status); +extern integer kclsty_(integer *chan, integer *status); +extern integer kdvall_(shortint *device, integer *allflg, integer *status); +extern integer kdvown_(shortint *device, shortint *owner, integer *maxch, integer *status); +extern integer kfacss_(shortint *osfn, integer *mode, integer *type__, integer *status); +extern integer kfaloc_(shortint *osfn, integer *nbytes, integer *status); +extern integer kfchdr_(shortint *dirnae, integer *status); +extern integer kfdele_(shortint *osfn, integer *status); +extern integer kfgcwd_(shortint *outstr, integer *maxch, integer *nchars); +extern integer kfinfo_(shortint *osfn, integer *fi, integer *status); +extern integer kflstx_(integer *chan, integer *status); +extern integer kflsty_(integer *chan, integer *status); +extern integer kfmkcp_(shortint *oldosn, shortint *newosn, integer *status); +extern integer kfmkdr_(shortint *osfn, integer *status); +extern integer kfpath_(shortint *vfn, shortint *osfn, integer *maxch, integer *nchars); +extern integer kfprot_(shortint *osfn, integer *protfg, integer *status); +extern integer kfrnam_(shortint *oldosn, shortint *newosn, integer *status); +extern integer kfsubd_(shortint *osdir, integer *maxch, shortint *subdir, integer *nchars); +extern integer kfutim_(shortint *osfn, integer *atime, integer *mtime, integer *status); +extern integer kfxdir_(shortint *vfn, shortint *osdir, integer *maxch, integer *nchars); +extern integer kgettx_(integer *chan, shortint *text, integer *maxch, integer *status); +extern integer kgetty_(integer *chan, shortint *text, integer *maxch, integer *status); +extern integer kgfdir_(integer *chan, shortint *osfn, integer *maxch, integer *status); +extern integer kience_(integer *data, shortint *str, integer *nchars); +extern integer kienvt_(shortint *name__, shortint *value); +extern integer kierrr_(integer *server); +extern integer kiflux_(integer *device, integer *chan, integer *status); +extern integer kifman_(shortint *vfn, shortint *pkosfn, integer *maxch); +extern integer kifren_(integer *chan); +extern integer kiinit_(integer *inchan, integer *outchn, integer *errchn, integer *device, integer *devtye); +extern integer kintpr_(integer *pid, integer *vex, integer *status); +extern integer kishot_(integer *fd); +extern integer kixnoe_(shortint *r1, shortint *r2, integer *maxch); +extern integer knottx_(integer *chan, integer *loffst); +extern integer knotty_(integer *chan, integer *loffst); +extern integer kopcpr_(shortint *proces, integer *inchan, integer *outchn, integer *pid); +extern integer kopdir_(shortint *osfn, integer *chan); +extern integer kopdpr_(shortint *proces, shortint *bkgfie, shortint *bkgmsg, integer *jobcoe); +extern integer kopnbf_(shortint *osfn, integer *mode, integer *chan); +extern integer kopngd_(shortint *osfn, integer *mode, integer *chan); +extern integer kopnlp_(shortint *osfn, integer *mode, integer *chan); +extern integer kopnpl_(shortint *osfn, integer *mode, integer *chan); +extern integer kopnsf_(shortint *osfn, integer *mode, integer *chan); +extern integer kopntx_(shortint *osfn, integer *mode, integer *chan); +extern integer kopnty_(shortint *osfn, integer *mode, integer *chan); +extern integer koscmd_(shortint *oscmd, shortint *stdine, shortint *stdoue, shortint *stdere, integer *status); +extern integer kputtx_(integer *chan, shortint *text, integer *nchars, integer *status); +extern integer kputty_(integer *chan, shortint *text, integer *nchars, integer *status); +extern integer ksared_(integer *server, shortint *buf, integer *maxbys); +extern integer ksawat_(integer *server, integer *status); +extern integer ksawre_(integer *server, shortint *buf, integer *nbytes); +extern integer ksektx_(integer *chan, integer *loffst, integer *status); +extern integer ksekty_(integer *chan, integer *loffst, integer *status); +extern integer kserrr_(integer *errcoe, shortint *errmsg); +extern integer kservr_(integer *in, integer *out, integer *buflen); +extern integer ksfman_(shortint *vfn, shortint *osfn, integer *maxch); +extern integer ksloaf_(integer *bfdd); +extern integer ksloax_(integer *txdd); +extern integer ksop2r_(integer *opcode, integer *subcoe, shortint *ostr, shortint *sstr); +extern integer ksttbf_(integer *chan, integer *what, integer *lvalue); +extern integer ksttgd_(integer *chan, integer *what, integer *lvalue); +extern integer ksttlp_(integer *chan, integer *what, integer *lvalue); +extern integer ksttpl_(integer *chan, integer *what, integer *lvalue); +extern integer ksttpr_(integer *chan, integer *what, integer *lvalue); +extern integer ksttsf_(integer *chan, integer *what, integer *lvalue); +extern integer kstttx_(integer *chan, integer *what, integer *lvalue); +extern integer ksttty_(integer *chan, integer *what, integer *lvalue); +extern integer kszfif_(integer *in, integer *out, integer *iobuf, integer *leniof, integer *bfdd); +extern integer kszfit_(integer *in, integer *out, integer *iobuf, integer *leniof); +extern integer kszfix_(integer *in, integer *out, integer *iobuf, integer *leniof, integer *txdd); +extern integer ktzcls_(integer *device, integer *chan, integer *status); +extern integer ktzfls_(integer *device, integer *chan, integer *status); +extern integer ktzget_(integer *device, integer *chan, shortint *obuf, integer *maxch, integer *status); +extern integer ktznot_(integer *device, integer *chan, integer *loffst); +extern integer ktzopn_(integer *device, shortint *osfn, integer *mode, integer *chan); +extern integer ktzput_(integer *device, integer *chan, shortint *ibuf, integer *nchars, integer *status); +extern integer ktzsek_(integer *device, integer *chan, integer *loffst, integer *status); +extern integer ktzstt_(integer *device, integer *chan, integer *what, integer *lvalue); +extern integer kurv1s_(integer *n, real *x, real *y, real *slop1, real *slopn, real *xp, real *yp, real *temp, real *s, real *sigma, integer *islpsw); +extern integer kurv2s_(real *t, real *xs, real *ys, integer *n, real *x, real *y, real *xp, real *yp, real *s, real *sigma, integer *nslpsw, real *slp); +extern integer labmod_(char *fmtx, char *fmty, integer *numx, integer *numy, integer *isizx, integer *isizy, integer *ixdec, integer *iydec, integer *ixor, ftnlen fmtx_len, ftnlen fmty_len); +extern integer lastd_(void); +extern integer line3_(real *ua, real *va, real *wa, real *ub, real *vb, real *wb); +extern integer line3w_(real *xa, real *ya, real *xb, real *yb); +extern integer line_(real *x1, real *y1, real *x2, real *y2); +extern integer lined_(real *xa, real *ya, real *xb, real *yb); +extern integer lnocle_(integer *lp); +extern integer lnosae_(integer *lp, integer *line, integer *loffst, integer *ltag); +extern integer lpzard_(integer *chan, shortint *buf, integer *maxbys, integer *offset); +extern integer lpzawe_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer lpzawt_(integer *chan, integer *nbytes); +extern integer lubksb_(real *a, integer *n, integer *np, integer *indx, real *b); +extern integer ludcmp_(real *a, integer *n, integer *np, integer *indx, real *d__); +extern integer luminv_(real *a, integer *n, integer *np); +extern integer maideh_(void); +extern integer maskce_(integer *colors); +extern integer masken_(integer *colors, integer *maskvs, integer *nmasks); +extern integer maskfc_(integer *data, shortint *func, integer *args, integer *nargs, integer *val); +extern integer maskod_(integer *op, shortint *operad, integer *o); +extern integer maxmin_(integer *im, real *zmin, real *zmax, integer *nsamps); +extern integer mcflsh_(void); +extern integer mefakb_(shortint *keywod, integer *value, shortint *commet, integer *pn); +extern integer mefakc_(shortint *keywod, shortint *value, integer *len, shortint *commet, integer *pn); +extern integer mefakd_(shortint *keywod, doublereal *value, shortint *commet, integer *precin, integer *pn); +extern integer mefaki_(shortint *keywod, integer *value, shortint *commet, integer *pn); +extern integer mefakr_(shortint *keywod, real *value, shortint *commet, integer *precin, integer *pn); +extern integer mefape_(integer *mefi, integer *mefo); +extern integer mefcle_(integer *mef); +extern integer mefcon_(integer *mefi, integer *mefo, integer *gn); +extern integer mefcpl_(integer *spool, integer *mef); +extern integer mefdur_(integer *out, shortint *hdrfne); +extern integer mefenb_(shortint *keywod, integer *param, shortint *card, shortint *commet); +extern integer mefenc_(shortint *keywod, shortint *param, integer *maxch, shortint *card, shortint *commet); +extern integer mefend_(shortint *keywod, doublereal *param, shortint *card, shortint *commet, integer *precin); +extern integer mefene_(shortint *datesr, integer *szdate); +extern integer mefeni_(shortint *keywod, integer *param, shortint *card, shortint *commet); +extern integer mefenl_(shortint *keywod, integer *param, shortint *card, shortint *commet); +extern integer mefenr_(shortint *keywod, real *param, shortint *card, shortint *commet, integer *precin); +extern integer mefens_(shortint *root, shortint *keywod, integer *axisno); +extern integer meffis_(shortint *fname, integer *acmode); +extern integer meffiw_(integer *hdrp, shortint *key, shortint *keywvl); +extern integer mefget_(shortint *card, shortint *commet, integer *maxch); +extern integer mefglm_(shortint *time, shortint *date, integer *limtie); +extern integer mefgsr_(integer *mef, shortint *key, shortint *outstr, integer *maxch); +extern integer mefgvb_(shortint *card, integer *bval); +extern integer mefgvd_(shortint *card, doublereal *dval); +extern integer mefgvi_(shortint *card, integer *ival); +extern integer mefgvr_(shortint *card, real *rval); +extern integer mefgvt_(shortint *card, shortint *outstr, integer *maxch); +extern integer mefksn_(shortint *ksectn, shortint *extnae, integer *extver); +extern integer mefkve_(shortint *outstr, integer *lextye, shortint *extnae, integer *extver); +extern integer mefpae_(integer *fd, integer *offset); +extern integer mefpar_(integer *out, shortint *card); +extern integer mefsel_(integer *versin, integer *plsize, shortint *imhdr, shortint *title, integer *ctime, integer *mtime, integer *limtie, real *minval, real *maxval, integer *mef); +extern integer mefskt_(integer *mef); +extern integer mefwcb_(shortint *kname, integer *kvalue, shortint *kcomm, integer *fd); +extern integer mefwcc_(shortint *kname, shortint *kvalue, shortint *kcomm, integer *fd); +extern integer mefwci_(shortint *kname, integer *kvalue, shortint *kcomm, integer *fd); +extern integer mefwcr_(shortint *kname, real *kvalue, shortint *kcomm, integer *fd); +extern integer mefwrk_(integer *out, integer *olines); +extern integer mefwrl_(integer *mef, shortint *title, integer *ctime, integer *mtime, integer *limtie, real *minval, real *maxval, shortint *plbuf, integer *naxis, integer *axlen); +extern integer mefwrr_(integer *mefi, integer *mefo, logical *inphdu); +extern integer mefwrt_(integer *out); +extern integer miiwrc_(integer *fd, integer *spp, integer *nchars); +extern integer miiwrd_(integer *fd, integer *spp, integer *nelem); +extern integer miiwri_(integer *fd, integer *spp, integer *nelem); +extern integer miiwrl_(integer *fd, integer *spp, integer *nelem); +extern integer miiwrr_(integer *fd, integer *spp, integer *nelem); +extern integer miiwrs_(integer *fd, integer *spp, integer *nelem); +extern integer minmax_(real *z__, integer *l, integer *mm, integer *nn, integer *issizm, real *aash, integer *joffdt); +extern integer miocle_(integer *mp); +extern integer miosee_(integer *mp, integer *vs, integer *ve, integer *ndim); +extern integer miosei_(integer *mp, integer *param, integer *value); +extern integer mmask_(void); +extern integer mrinvt_(real *a, real *b, integer *n); +extern integer mtalle_(shortint *mtname); +extern integer mtclen_(integer *level, integer *stale, integer *out); +extern integer mtclre_(void); +extern integer mtdeae_(shortint *mtname, integer *rewine); +extern integer mtence_(shortint *outstr, integer *maxch, shortint *device, integer *fileno, integer *recno, shortint *attrl); +extern integer mtfnae_(shortint *mtname, integer *fileno, shortint *outstr, integer *maxch); +extern integer mtgets_(shortint *mtname, integer *mt); +extern integer mtglok_(shortint *mtname, shortint *lockfe, integer *maxch); +extern integer mtloce_(shortint *device, shortint *lockfe, integer *maxch); +extern integer mtpare_(shortint *mtname, shortint *device, integer *szdeve, integer *file, integer *record, shortint *attrl, integer *szattl); +extern integer mtposn_(shortint *mtname, integer *file, integer *record); +extern integer mtpute_(integer *fd, shortint *text); +extern integer mtreae_(shortint *mtname, integer *mt); +extern integer mtrewd_(shortint *mtname, integer *initce); +extern integer mtsavd_(integer *fd, shortint *keywod, integer *value); +extern integer mtsavs_(integer *mt); +extern integer mtstas_(integer *out, shortint *mtname); +extern integer mtsync_(integer *status); +extern integer mtupde_(integer *mt); +extern integer mwaxtn_(doublereal *oltm, doublereal *oltv, doublereal *nltm, doublereal *nltv, integer *pdim, doublereal *ltm, doublereal *ltv, integer *ax, integer *ndim); +extern integer mwc2td_(integer *act, doublereal *x1, doublereal *y1, doublereal *x2, doublereal *y2); +extern integer mwc2tr_(integer *act, real *x1, real *y1, real *x2, real *y2); +extern integer mwcloe_(integer *mw); +extern integer mwctfe_(integer *ct); +extern integer mwctrd_(integer *act, doublereal *p1, doublereal *p2, integer *ndim); +extern integer mwctrr_(integer *act, real *p1, real *p2, integer *ndim); +extern integer mwgaxp_(integer *mw, integer *axno, integer *axval, integer *ndim); +extern integer mwgaxt_(integer *mw, integer *axbits, integer *axis, integer *naxes); +extern integer mwgltd_(integer *mw, doublereal *ltm, doublereal *ltv, integer *ndim); +extern integer mwgltr_(integer *mw, real *ltm, real *ltv, integer *ndim); +extern integer mwgsym_(integer *mw, shortint *outstr, integer *maxch); +extern integer mwgwas_(integer *mw, integer *axis, shortint *attrie, shortint *valstr, integer *maxch); +extern integer mwgwsd_(integer *mw, integer *axis, doublereal *pv, doublereal *wv, integer *npts); +extern integer mwgwsr_(integer *mw, integer *axis, real *pv, real *wv, integer *npts); +extern integer mwgwtd_(integer *mw, doublereal *r__, doublereal *w, doublereal *cd, integer *ndim); +extern integer mwgwtr_(integer *mw, real *r__, real *w, real *cd, integer *ndim); +extern integer mwinvd_(doublereal *oltm, doublereal *nltm, integer *ndim); +extern integer mwinvr_(real *oltm, real *nltm, integer *ndim); +extern integer mwload_(integer *mw, integer *bp); +extern integer mwloam_(integer *mw, integer *im); +extern integer mwltrd_(doublereal *p1, doublereal *p2, doublereal *ltm, doublereal *ltv, integer *ndim); +extern integer mwltrr_(real *p1, real *p2, real *ltm, real *ltv, integer *ndim); +extern integer mwlubb_(doublereal *a, integer *ix, doublereal *b, integer *ndim); +extern integer mwlude_(doublereal *a, integer *ix, integer *ndim); +extern integer mwmkid_(doublereal *ltm, integer *ndim); +extern integer mwmkir_(real *ltm, integer *ndim); +extern integer mwmmud_(doublereal *a, doublereal *b, doublereal *c__, integer *ndim); +extern integer mwmmur_(real *a, real *b, real *c__, integer *ndim); +extern integer mwnewm_(integer *mw, shortint *system, integer *ndim); +extern integer mwrote_(integer *mw, real *theta, real *center, integer *axbits); +extern integer mwsavm_(integer *mw, integer *im); +extern integer mwsaxp_(integer *mw, integer *axno, integer *axval, integer *ndim); +extern integer mwscae_(integer *mw, real *scale, integer *axbits); +extern integer mwsdes_(integer *mw); +extern integer mwseti_(integer *mw, integer *param, integer *value); +extern integer mwshit_(integer *mw, real *shift, integer *axbits); +extern integer mwshow_(integer *mw, integer *fd, integer *what); +extern integer mwsltd_(integer *mw, doublereal *ltm, doublereal *ltv, integer *ndim); +extern integer mwsltr_(integer *mw, real *ltm, real *ltv, integer *ndim); +extern integer mwssym_(integer *mw, shortint *system); +extern integer mwswas_(integer *mw, integer *axis, shortint *attrie, shortint *valstr); +extern integer mwswsd_(integer *mw, integer *axis, doublereal *pv, doublereal *wv, integer *npts); +extern integer mwswsr_(integer *mw, integer *axis, real *pv, real *wv, integer *npts); +extern integer mwswtd_(integer *mw, doublereal *r__, doublereal *w, doublereal *cd, integer *ndim); +extern integer mwswte_(integer *mw, integer *axis, integer *naxes, shortint *wtype, shortint *wattr); +extern integer mwswtr_(integer *mw, real *r__, real *w, real *cd, integer *ndim); +extern integer mwtrad_(integer *mw, doublereal *ltv1, doublereal *ltm, doublereal *ltv2, integer *ndim); +extern integer mwtrar_(integer *mw, real *ltv1, real *ltm, real *ltv2, integer *ndim); +extern integer mwv1td_(integer *act, doublereal *x1, doublereal *x2, integer *npts); +extern integer mwv1tr_(integer *act, real *x1, real *x2, integer *npts); +extern integer mwv2td_(integer *act, doublereal *x1, doublereal *y1, doublereal *x2, doublereal *y2, integer *npts); +extern integer mwv2tr_(integer *act, real *x1, real *y1, real *x2, real *y2, integer *npts); +extern integer mwvmud_(doublereal *a, doublereal *b, doublereal *c__, integer *ndim); +extern integer mwvmur_(real *a, real *b, real *c__, integer *ndim); +extern integer mwvtrd_(integer *ct, doublereal *v1, doublereal *v2, integer *ndim, integer *npts); +extern integer mwvtrr_(integer *ct, real *v1, real *v2, integer *ndim, integer *npts); +extern integer mxmy_(integer *ix, integer *iy); +extern integer mzscae_(integer *im, integer *zpm, integer *bpm, real *contrt, integer *maxpix, real *z1, real *z2); +extern integer newpie_(shortint *param, integer *im); +extern integer newtie_(shortint *param, integer *im); +extern integer obscle_(integer *obs); +extern integer obsgsr_(integer *obs, shortint *param, shortint *str, integer *maxchr); +extern integer obsimn_(integer *obs, integer *im, shortint *obsery, integer *verboe, logical *newobs, logical *obshed); +extern integer obsino_(integer *obs, integer *fd); +extern integer obslog_(integer *obs, shortint *task, shortint *params, integer *fd); +extern integer oifacs_(integer *kernel, shortint *root, shortint *extn, integer *acmode, integer *status); +extern integer oifcle_(integer *im, integer *status); +extern integer oifcoy_(integer *kernel, shortint *oldrot, shortint *oldexn, shortint *newrot, shortint *newexn, integer *status); +extern integer oifdee_(integer *kernel, shortint *root, shortint *extn, integer *status); +extern integer oifgpe_(shortint *pixfie, shortint *hdrfie, shortint *path, integer *maxch); +extern integer oifmke_(integer *im, shortint *pixfie, integer *maxch); +extern integer oifopn_(integer *kernel, integer *im, integer *oim, shortint *root, shortint *extn, shortint *ksectn, integer *clindx, integer *clsize, integer *acmode, integer *status); +extern integer oifopx_(integer *im, integer *status); +extern integer oifree_(integer *kernel, shortint *oldrot, shortint *oldexn, shortint *newrot, shortint *newexn, integer *status); +extern integer oiftrm_(shortint *s, integer *nchars); +extern integer oifupr_(integer *im, integer *status); +extern integer oifwrr_(integer *fd, integer *im, integer *htype); +extern integer ord1_(integer *m, real *b); +extern integer ord2_(integer *m, real *b); +extern integer osfnik_(shortint *osfn); +extern integer osfnms_(shortint *osfn, shortint *lockfe, shortint *timel1, shortint *timel2, integer *maxch); +extern integer osfnpe_(shortint *spposn, shortint *hoston, integer *maxch); +extern integer osfnrk_(shortint *osfn); +extern integer pagefe_(shortint *fname, shortint *prompt); +extern integer pagefs_(shortint *files); +extern integer pargb_(logical *bval); +extern integer pargc_(shortint *cval); +extern integer pargd_(doublereal *dval); +extern integer pargg_(doublereal *value, integer *dtype); +extern integer pargi_(integer *ival); +extern integer pargl_(integer *lval); +extern integer pargr_(real *rval); +extern integer pargs_(shortint *sval); +extern integer pargsr_(shortint *str); +extern integer pargx_(complex *xval); +extern integer patfit_(integer *delim, shortint *patstr, integer *ip, shortint *patbuf, integer *szpat, integer *op); +extern integer perim3_(integer *magr1, integer *mini1, integer *magr2, integer *mini2, integer *iwhich, real *var); +extern integer perim_(integer *majrx, integer *minrx, integer *majry, integer *minry); +extern integer periml_(integer *majrx, integer *minrx, integer *majry, integer *minry); +extern integer pggetr_(shortint *strval, integer *maxch); +extern integer pgpusd_(integer *cmd); +extern integer pgsett_(shortint *prompt, shortint *upromt, shortint *fname); +extern integer plascp_(integer *pl, integer *vs, integer *ve, integer *outfd); +extern integer plbox_(integer *pl, integer *x1, integer *y1, integer *x2, integer *y2, integer *rop); +extern integer plcire_(integer *pl, integer *x, integer *y, integer *radius, integer *rop); +extern integer plcler_(integer *pl); +extern integer plcloe_(integer *pl); +extern integer plcoms_(integer *pl); +extern integer pldebg_(integer *pl, integer *fd, integer *width, integer *what); +extern integer pldebt_(integer *fd, shortint *buf, integer *col, integer *firstl, integer *maxcol); +extern integer plfacs_(integer *kernel, shortint *root, shortint *extn, integer *acmode, integer *status); +extern integer plfcle_(integer *im, integer *status); +extern integer plfcoy_(integer *kernel, shortint *oldrot, shortint *oldexn, shortint *newrot, shortint *newexn, integer *status); +extern integer plfdee_(integer *kernel, shortint *root, shortint *extn, integer *status); +extern integer plfnul_(void); +extern integer plfopn_(integer *kernel, integer *im, integer *oim, shortint *root, shortint *extn, shortint *ksectn, integer *clindx, integer *clsize, integer *acmode, integer *status); +extern integer plfree_(integer *kernel, shortint *oldrot, shortint *oldexn, shortint *newrot, shortint *newexn, integer *status); +extern integer plfupr_(integer *im, integer *status); +extern integer plgete_(integer *pl, integer *v); +extern integer plglls_(integer *pl, integer *v, shortint *lldst, integer *lldeph, integer *npix, integer *rop); +extern integer plglpi_(integer *pl, integer *v, integer *pxdst, integer *pxdeph, integer *npix, integer *rop); +extern integer plglpl_(integer *pl, integer *v, integer *pxdst, integer *pxdeph, integer *npix, integer *rop); +extern integer plglps_(integer *pl, integer *v, shortint *pxdst, integer *pxdeph, integer *npix, integer *rop); +extern integer plglri_(integer *pl, integer *v, integer *rldst, integer *rldeph, integer *npix, integer *rop); +extern integer plglrl_(integer *pl, integer *v, integer *rldst, integer *rldeph, integer *npix, integer *rop); +extern integer plglrs_(integer *pl, integer *v, shortint *rldst, integer *rldeph, integer *npix, integer *rop); +extern integer plgsie_(integer *pl, integer *naxes, integer *axlen, integer *depth); +extern integer plline_(integer *pl, integer *x1, integer *y1, integer *x2, integer *y2, integer *width, integer *rop); +extern integer pllinl_(shortint *llsrc, integer *xs, integer *srcmal, shortint *lldst, integer *ds, integer *dstmal, shortint *llstn, integer *ss, shortint *llout, integer *npix, integer *rop); +extern integer pllinp_(shortint *llsrc, integer *xs, integer *srcmal, shortint *lldst, integer *ds, integer *dstmal, shortint *llout, integer *npix, integer *rop); +extern integer pllneg_(shortint *ll, integer *ld); +extern integer plload_(integer *pl, integer *bp); +extern integer plloaf_(integer *pl, shortint *mask, shortint *title, integer *maxch); +extern integer plloam_(integer *pl, shortint *imname, shortint *title, integer *maxch); +extern integer pllprs_(shortint *ll, integer *fd, shortint *label, integer *firstl, integer *maxcos); +extern integer plotif_(real *fx, real *fy, integer *ip); +extern integer plotit_(integer *ix, integer *iy, integer *ip); +extern integer plpixi_(integer *pxsrc, integer *xs, integer *srcmal, integer *pxdst, integer *ds, integer *dstmal, integer *npix, integer *rop); +extern integer plpixl_(integer *pxsrc, integer *xs, integer *srcmal, integer *pxdst, integer *ds, integer *dstmal, integer *npix, integer *rop); +extern integer plpixs_(shortint *pxsrc, integer *xs, integer *srcmal, shortint *pxdst, integer *ds, integer *dstmal, integer *npix, integer *rop); +extern integer plplls_(integer *pl, integer *v, shortint *llsrc, integer *lldeph, integer *npix, integer *rop); +extern integer plplpi_(integer *pl, integer *v, integer *pxsrc, integer *pxdeph, integer *npix, integer *rop); +extern integer plplpl_(integer *pl, integer *v, integer *pxsrc, integer *pxdeph, integer *npix, integer *rop); +extern integer plplps_(integer *pl, integer *v, shortint *pxsrc, integer *pxdeph, integer *npix, integer *rop); +extern integer plplri_(integer *pl, integer *v, integer *rlsrc, integer *rldeph, integer *npix, integer *rop); +extern integer plplrl_(integer *pl, integer *v, integer *rlsrc, integer *rldeph, integer *npix, integer *rop); +extern integer plplrs_(integer *pl, integer *v, shortint *rlsrc, integer *rldeph, integer *npix, integer *rop); +extern integer plpoit_(integer *pl, integer *x, integer *y, integer *rop); +extern integer plpoln_(integer *pl, integer *x, integer *y, integer *npts, integer *rop); +extern integer plrani_(integer *rlsrc, integer *xs, integer *srcmal, integer *rldst, integer *ds, integer *dstmal, integer *rlout, integer *npix, integer *rop); +extern integer plranl_(integer *rlsrc, integer *xs, integer *srcmal, integer *rldst, integer *ds, integer *dstmal, integer *rlout, integer *npix, integer *rop); +extern integer plrans_(shortint *rlsrc, integer *xs, integer *srcmal, shortint *rldst, integer *ds, integer *dstmal, shortint *rlout, integer *npix, integer *rop); +extern integer plrcle_(integer *plr); +extern integer plregp_(integer *pl, L_fp ufcn, integer *ufd, integer *y1, integer *y2, integer *rop); +extern integer plrget_(integer *plr, integer *bufp, integer *xsize, integer *ysize, integer *xblock, integer *yblock); +extern integer plrop_(integer *plsrc, integer *vssrc, integer *pldst, integer *vsdst, integer *vn, integer *rop); +extern integer plrpri_(integer *rl, integer *fd, shortint *label, integer *firstl, integer *maxcol); +extern integer plrprl_(integer *rl, integer *fd, shortint *label, integer *firstl, integer *maxcol); +extern integer plrprs_(shortint *rl, integer *fd, shortint *label, integer *firstl, integer *maxcol); +extern integer plrset_(integer *plr, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer plsavf_(integer *pl, shortint *fname, shortint *title, integer *flags); +extern integer plsavm_(integer *pl, shortint *imname, shortint *title, integer *flags); +extern integer plsete_(integer *pl, integer *v); +extern integer plseti_(integer *pl, integer *param, integer *value); +extern integer plssie_(integer *pl, integer *naxes, integer *axlen, integer *depth); +extern integer plsslv_(integer *pl, integer *vs, integer *vn, integer *v, integer *ve); +extern integer plstel_(integer *plsrc, integer *vssrc, integer *pldst, integer *vsdst, integer *plstn, integer *vsstn, integer *vn, integer *rop); +extern integer plupde_(integer *pl, integer *v, shortint *ll); +extern integer plvald_(integer *pl); +extern integer pmascp_(integer *pl, integer *vs, integer *ve, integer *outfd); +extern integer pmbox_(integer *pl, integer *x1, integer *y1, integer *x2, integer *y2, integer *rop); +extern integer pmcire_(integer *pl, integer *x, integer *y, integer *radius, integer *rop); +extern integer pmcler_(integer *pl); +extern integer pmglls_(integer *pl, integer *v, shortint *lldst, integer *lldeph, integer *npix, integer *rop); +extern integer pmglpi_(integer *pl, integer *v, integer *pxdst, integer *pxdeph, integer *npix, integer *rop); +extern integer pmglpl_(integer *pl, integer *v, integer *pxdst, integer *pxdeph, integer *npix, integer *rop); +extern integer pmglps_(integer *pl, integer *v, shortint *pxdst, integer *pxdeph, integer *npix, integer *rop); +extern integer pmglri_(integer *pl, integer *v, integer *rldst, integer *rldeph, integer *npix, integer *rop); +extern integer pmglrl_(integer *pl, integer *v, integer *rldst, integer *rldeph, integer *npix, integer *rop); +extern integer pmglrs_(integer *pl, integer *v, shortint *rldst, integer *rldeph, integer *npix, integer *rop); +extern integer pmline_(integer *pl, integer *x1, integer *y1, integer *x2, integer *y2, integer *width, integer *rop); +extern integer pmplls_(integer *pl, integer *v, shortint *llraw, integer *lldeph, integer *npix, integer *rop); +extern integer pmplpi_(integer *pl, integer *v, integer *pxsrc, integer *pxdeph, integer *npix, integer *rop); +extern integer pmplpl_(integer *pl, integer *v, integer *pxsrc, integer *pxdeph, integer *npix, integer *rop); +extern integer pmplps_(integer *pl, integer *v, shortint *pxsrc, integer *pxdeph, integer *npix, integer *rop); +extern integer pmplri_(integer *pl, integer *v, integer *rlsrc, integer *rldeph, integer *npix, integer *rop); +extern integer pmplrl_(integer *pl, integer *v, integer *rlsrc, integer *rldeph, integer *npix, integer *rop); +extern integer pmplrs_(integer *pl, integer *v, shortint *rlsrc, integer *rldeph, integer *npix, integer *rop); +extern integer pmpoit_(integer *pl, integer *x, integer *y, integer *rop); +extern integer pmpoln_(integer *pl, integer *x, integer *y, integer *npts, integer *rop); +extern integer pmrcle_(integer *pmr); +extern integer pmrop_(integer *pmsrc, integer *vssrc, integer *pmdst, integer *vsdst, integer *vn, integer *rop); +extern integer pmrset_(integer *pmr, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer pmsete_(integer *pl, integer *v); +extern integer pmseti_(integer *pl, integer *param, integer *value); +extern integer pmstel_(integer *pmsrc, integer *vssrc, integer *pmdst, integer *vsdst, integer *pmstn, integer *vsstn, integer *vn, integer *rop); +extern integer point3_(real *u, real *v, real *w); +extern integer point_(real *px, real *py); +extern integer points_(real *px, real *py, integer *np, integer *ic, integer *il); +extern integer pollce_(integer *fds); +extern integer pollcr_(integer *fds, integer *fd, integer *type__); +extern integer pollpt_(integer *fds); +extern integer pollst_(integer *fds, integer *fd, integer *type__); +extern integer pollzo_(integer *fds); +extern integer prchdr_(integer *pid, shortint *newdir); +extern integer prdumn_(shortint *osfn, integer *mode, integer *chan); +extern integer preal_(shortint *tval, real *rval); +extern integer prenvt_(integer *pid, shortint *envvar, shortint *valuer); +extern integer prkill_(integer *job); +extern integer pronic_(integer *vex, integer *nexthr); +extern integer proscd_(integer *pr, shortint *cmd); +extern integer prpsit_(void); +extern integer prredr_(integer *pid, integer *stream, integer *newfd); +extern integer prseti_(integer *pid, integer *param, integer *value); +extern integer prsigl_(integer *pid, integer *signal); +extern integer prupde_(integer *pid, shortint *messae, integer *flusht); +extern integer prvret_(shortint *name__, shortint *value); +extern integer przclr_(integer *chan, integer *status); +extern integer pscenr_(integer *ps, shortint *str); +extern integer pscloe_(integer *ps); +extern integer psdept_(integer *ps, shortint *line); +extern integer psesct_(shortint *in, shortint *out, integer *maxch); +extern integer psfone_(integer *ps, integer *fontse); +extern integer psfoor_(integer *ps, shortint *ledge, shortint *center, shortint *redge); +extern integer pshear_(integer *ps, shortint *ledge, shortint *center, shortint *redge); +extern integer psindt_(integer *ps, integer *nchars); +extern integer psioxr_(integer *fd, shortint *buf, integer *nchars); +extern integer pslink_(integer *ps, integer *fillfg); +extern integer psnewe_(integer *ps); +extern integer psoutt_(integer *ps, shortint *str, integer *fillfg); +extern integer pspage_(integer *ps, integer *page); +extern integer pspagk_(integer *ps); +extern integer psrigy_(integer *ps, shortint *str); +extern integer pssets_(integer *ps, real *left, real *right, real *top, real *bottom); +extern integer pssett_(integer *ps, integer *font); +extern integer pssety_(integer *ps, integer *justiy); +extern integer psspft_(integer *ps, integer *font); +extern integer pstese_(integer *ps, integer *nlines); +extern integer pstr_(shortint *sppstg); +extern integer pstrar_(integer *ps); +extern integer pswrig_(integer *ps); +extern integer pswrtk_(integer *ps, integer *curpos, shortint *str); +extern integer psxpos_(integer *ps, integer *xpos); +extern integer psym3_(real *u, real *v, real *w, integer *ichar, real *size, integer *idir, integer *itop, integer *iup); +extern integer psypos_(integer *ps, integer *ypos); +extern integer putcc_(integer *fd, shortint *ch); +extern integer putci_(integer *fd, integer *ch); +extern integer putlie_(integer *fd, shortint *linebf); +extern integer pwrit_(real *px, real *py, char *ch, integer *nc, integer *is, integer *io, integer *ic, ftnlen ch_len); +extern integer pwrity_(real *x, real *y, char *id, integer *n, integer *isize, integer *itheta, integer *icnt, ftnlen id_len); +extern integer pwry_(real *x, real *y, integer *id, integer *n, real *size, real *theta, integer *icnt); +extern integer pwrybd_(void); +extern integer pwrygt_(char *kchar, char *jchar, integer *index, integer *nsize, integer *ipoint, ftnlen kchar_len, ftnlen jchar_len); +extern integer pwryso_(char *jchar, integer *index, integer *nsize, ftnlen jchar_len); +extern integer pwrz_(real *x, real *y, real *z__, integer *id, integer *n, integer *isize, integer *lin3, integer *itop, integer *icnt); +extern integer pwrzgi_(char *kchar, char *jchar, integer *index, integer *nsize, integer *ipoint, ftnlen kchar_len, ftnlen jchar_len); +extern integer pwrzgs_(char *kchar, char *jchar, integer *index, integer *nsize, integer *ipoint, ftnlen kchar_len, ftnlen jchar_len); +extern integer pwrzgt_(char *kchar, char *jchar, integer *index, integer *nsize, integer *ipoint, ftnlen kchar_len, ftnlen jchar_len); +extern integer pwrzi_(real *x, real *y, real *z__, char *id, integer *n, integer *isize, integer *lin3, integer *itop, integer *icnt, ftnlen id_len); +extern integer pwrzoi_(char *jchar, integer *index, integer *nsize, ftnlen jchar_len); +extern integer pwrzos_(char *jchar, integer *index, integer *nsize, ftnlen jchar_len); +extern integer pwrzot_(char *jchar, integer *index, integer *nsize, ftnlen jchar_len); +extern integer pwrzs_(real *x, real *y, real *z__, char *id, integer *n, integer *isize, integer *lin3, integer *itop, integer *icnt, ftnlen id_len); +extern integer pwrzt_(real *x, real *y, real *z__, char *id, integer *n, integer *isize, integer *lin3, integer *itop, integer *icnt, ftnlen id_len); +extern integer q8qst4_(char *name__, char *lbrary, char *entry__, char *vrsion, ftnlen name_len, ftnlen lbrary_len, ftnlen entry_len, ftnlen vrsion_len); +extern integer qmscan_(integer *qm, shortint *fname, integer *flags); +extern integer qmscao_(integer *qm, integer *fd, integer *flags); +extern integer qmsetm_(integer *qm, shortint *param, shortint *valstr); +extern integer qmsets_(integer *qm, integer *qp); +extern integer qmupds_(integer *qm, integer *qp); +extern integer qpaddb_(integer *qp, shortint *param, logical *value, shortint *commet); +extern integer qpaddc_(integer *qp, shortint *param, shortint *value, shortint *commet); +extern integer qpaddd_(integer *qp, shortint *param, doublereal *value, shortint *commet); +extern integer qpaddf_(integer *qp, shortint *param, shortint *datate, integer *maxelm, shortint *commet, integer *flags); +extern integer qpaddi_(integer *qp, shortint *param, integer *value, shortint *commet); +extern integer qpaddl_(integer *qp, shortint *param, integer *value, shortint *commet); +extern integer qpaddr_(integer *qp, shortint *param, real *value, shortint *commet); +extern integer qpadds_(integer *qp, shortint *param, shortint *value, shortint *commet); +extern integer qpaddx_(integer *qp, shortint *param, complex *value, shortint *commet); +extern integer qpastr_(integer *qp, shortint *param, shortint *value, shortint *commet); +extern integer qpbind_(integer *qp); +extern integer qpcfnl_(integer *fl); +extern integer qpcloe_(integer *qp); +extern integer qpclot_(integer *gt); +extern integer qpcopf_(integer *oqp, shortint *oparam, integer *nqp, shortint *nparam); +extern integer qpcopy_(shortint *opoefe, shortint *npoefe); +extern integer qpdele_(shortint *poefie); +extern integer qpdelf_(integer *qp, shortint *param); +extern integer qpdsym_(integer *qp, integer *out); +extern integer qpexce_(integer *ex); +extern integer qpexde_(integer *ex, integer *etlast, integer *offset, integer *dtype); +extern integer qpexdg_(integer *ex, integer *out, integer *what); +extern integer qpexfe_(integer *ex, integer *pbsave, integer *dbsave); +extern integer qpexmk_(integer *ex, integer *pbsave, integer *dbsave); +extern integer qpexpn_(integer *ex, integer *opcode, integer *arg1, integer *arg2, integer *arg3); +extern integer qpfacs_(integer *kernel, shortint *root, shortint *extn, integer *acmode, integer *status); +extern integer qpfcle_(integer *im, integer *status); +extern integer qpfcos_(integer *im, integer *qp); +extern integer qpfcoy_(integer *kernel, shortint *oldrot, shortint *oldexn, shortint *newrot, shortint *newexn, integer *status); +extern integer qpfdee_(integer *kernel, shortint *root, shortint *extn, integer *status); +extern integer qpflur_(integer *qp); +extern integer qpfopn_(integer *kernel, integer *im, integer *oim, shortint *root, shortint *extn, shortint *ksectn, integer *clindx, integer *clsize, integer *acmode, integer *status); +extern integer qpfopx_(integer *im, integer *status); +extern integer qpfree_(integer *kernel, shortint *oldrot, shortint *oldexn, shortint *newrot, shortint *newexn, integer *status); +extern integer qpfupr_(integer *im, integer *status); +extern integer qpfwar_(integer *qpf, integer *im); +extern integer qpfwfr_(integer *qpf, integer *im); +extern integer qpfzcl_(integer *chan, integer *status); +extern integer qpfzop_(shortint *pkfn, integer *mode, integer *status); +extern integer qpfzrd_(integer *chan, shortint *obuf, integer *nbytes, integer *boffst); +extern integer qpfzst_(integer *chan, integer *param, integer *value); +extern integer qpfzwr_(integer *chan, shortint *ibuf, integer *nbytes, integer *boffst); +extern integer qpfzwt_(integer *chan, integer *status); +extern integer qpinht_(integer *nqp, integer *oqp, integer *out); +extern integer qpioce_(integer *io); +extern integer qpiolk_(integer *io, shortint *mask, integer *merge); +extern integer qpiomx_(integer *io, shortint *key); +extern integer qpiops_(integer *io, integer *iev, integer *nevens); +extern integer qpiosc_(integer *io); +extern integer qpiose_(integer *io, integer *vs, integer *ve, integer *ndim); +extern integer qpiosi_(integer *io, integer *param, integer *value); +extern integer qpiosr_(integer *io, shortint *expr); +extern integer qpiour_(integer *io, integer *param, real *value); +extern integer qpiowt_(integer *io, integer *evi); +extern integer qpmkfe_(shortint *poefie, shortint *extn, shortint *fname, integer *maxch); +extern integer qppare_(shortint *qpspec, shortint *root, integer *szroot, shortint *filter, integer *szfilr); +extern integer qppcle_(integer *fd); +extern integer qppstr_(integer *qp, shortint *param, shortint *strval); +extern integer qpputb_(integer *qp, shortint *param, logical *value); +extern integer qpputc_(integer *qp, shortint *param, shortint *value); +extern integer qpputd_(integer *qp, shortint *param, doublereal *value); +extern integer qpputi_(integer *qp, shortint *param, integer *value); +extern integer qpputl_(integer *qp, shortint *param, integer *value); +extern integer qpputr_(integer *qp, shortint *param, real *value); +extern integer qpputs_(integer *qp, shortint *param, shortint *value); +extern integer qpputx_(integer *qp, shortint *param, complex *value); +extern integer qprebd_(shortint *poefie); +extern integer qprene_(shortint *opoefe, shortint *npoefe); +extern integer qprenf_(integer *qp, shortint *param, shortint *newnae); +extern integer qpsavs_(integer *qp, integer *mw); +extern integer qpseel_(integer *fl, integer *pos); +extern integer qpseti_(integer *qp, integer *param, integer *value); +extern integer qpsetr_(integer *qp, integer *param, real *value); +extern integer qpsync_(integer *qp); +extern integer qpungk_(integer *gt, shortint *tokbuf); +extern integer qpwrie_(integer *qp, shortint *param, shortint *buf, integer *nelem, integer *first, shortint *datate); +extern integer r2tr_(integer *int__, real *b0, real *b1); +extern integer r2tx_(integer *nthpo, real *cr0, real *cr1, real *ci0, real *ci1); +extern integer r4syn_(integer *int__, real *b0, real *b1, real *b2, real *b3); +extern integer r4tr_(integer *int__, real *b0, real *b1, real *b2, real *b3); +extern integer r4tx_(integer *nthpo, real *cr0, real *cr1, real *cr2, real *cr3, real *ci0, real *ci1, real *ci2, real *ci3); +extern integer r8syn_(integer *int__, integer *nn, real *br0, real *br1, real *br2, real *br3, real *br4, real *br5, real *br6, real *br7, real *bi0, real *bi1, real *bi2, real *bi3, real *bi4, real *bi5, real *bi6, real *bi7); +extern integer r8tr_(integer *int__, integer *nn, real *br0, real *br1, real *br2, real *br3, real *br4, real *br5, real *br6, real *br7, real *bi0, real *bi1, real *bi2, real *bi3, real *bi4, real *bi5, real *bi6, real *bi7); +extern integer r8tx_(integer *nxtlt, integer *nthpo, integer *lengt, real *cr0, real *cr1, real *cr2, real *cr3, real *cr4, real *cr5, real *cr6, real *cr7, real *ci0, real *ci1, real *ci2, real *ci3, real *ci4, real *ci5, real *ci6, real *ci7); +extern integer realft_(real *data, integer *n, integer *isign); +extern integer reord_(real *cl, integer *ncl, real *c1, integer *mark, integer *nmg); +extern integer reset_(void); +extern integer resetn_(void); +extern integer retsr_(integer *irold); +extern integer rgadd_(integer *rg, shortint *rstr, integer *rmin, integer *rmax); +extern integer rgbind_(integer *rg, integer *nbin, doublereal *in, integer *nin, doublereal *out, integer *nout); +extern integer rgbinr_(integer *rg, integer *nbin, real *in, integer *nin, real *out, integer *nout); +extern integer rgdump_(integer *rg); +extern integer rgexcd_(integer *rg, doublereal *a, integer *nin, doublereal *b, integer *nout); +extern integer rgexcr_(integer *rg, real *a, integer *nin, real *b, integer *nout); +extern integer rgfree_(integer *rg); +extern integer rggxmd_(integer *gp, shortint *rstr, doublereal *x, integer *npts, integer *pltype); +extern integer rggxmr_(integer *gp, shortint *rstr, real *x, integer *npts, integer *pltype); +extern integer rginds_(integer *rg, integer *indics, integer *npts, integer *type__); +extern integer rginve_(integer *rg, integer *rmin, integer *rmax); +extern integer rgmere_(integer *rg); +extern integer rgordr_(integer *rg); +extern integer rgpacd_(integer *rg, doublereal *a, doublereal *b); +extern integer rgpacr_(integer *rg, real *a, real *b); +extern integer rgunpd_(integer *rg, doublereal *packed, doublereal *unpacd); +extern integer rgunpr_(integer *rg, real *packed, real *unpacd); +extern integer rgwtbd_(integer *rg, integer *nbin, doublereal *in, doublereal *wtin, integer *nin, doublereal *out, doublereal *wtout, integer *nout); +extern integer rgwtbr_(integer *rg, integer *nbin, real *in, real *wtin, integer *nin, real *out, real *wtout, integer *nout); +extern integer rgxadd_(integer *rg, shortint *rstr, doublereal *rvals, integer *npts); +extern integer rgxadr_(integer *rg, shortint *rstr, real *rvals, integer *npts); +extern integer rmcloe_(integer *rm); +extern integer rmdodi_(shortint *leaf, shortint *box, real *window, shortint *outlit, shortint *nrlist); +extern integer rmdoui_(shortint *leaf, shortint *box, shortint *nrnew, shortint *outnet, real *in, real *window, shortint *outlit, shortint *nrlist); +extern integer rmdowf_(shortint *leaf, shortint *box, real *window, shortint *outlit, shortint *nrlist); +extern integer rmdump_(integer *rm, logical *unsord, logical *sorted, logical *in, logical *out); +extern integer rmpack_(integer *rm, integer *datast); +extern integer rmscle_(integer *rm); +extern integer rmsdup_(integer *rm, logical *unsord, logical *sorted, logical *in, logical *out); +extern integer rmsifp_(shortint *l, shortint *r__, real *window, shortint *outlit, shortint *nrlist); +extern integer rmswap_(shortint *l, shortint *r__, real *window, shortint *outlit, shortint *nrlist); +extern integer rmtcle_(integer *rm); +extern integer rmtdup_(integer *rm, logical *unsord, logical *sorted, logical *in, logical *out); +extern integer rmtort_(shortint *leaf, shortint *box, shortint *nrnew, shortint *outnet, real *in, real *window, shortint *outlit, shortint *nrlist); +extern integer rmunpk_(integer *rm, integer *datast); +extern integer rmuodi_(shortint *leaf, shortint *box, shortint *nrnew, shortint *outnet, real *in, real *window, shortint *outlit, shortint *nrlist); +extern integer rmuoui_(shortint *leaf, shortint *box, real *window, shortint *outlit, shortint *nrlist); +extern integer rmuptf_(shortint *leaf, shortint *box, real *window, shortint *outlit, shortint *nrlist); +extern integer rngadd_(integer *rg, shortint *rstr, real *r1, real *r2, real *dr); +extern integer rngcle_(integer *rg); +extern integer rngerr_(integer *errnum, shortint *rstr, real *r1, real *r2, real *dr, integer *rg); +extern integer salloc_(integer *outpur, integer *nelem, integer *datate); +extern integer sbytes_(integer *bufout, integer *bufin, integer *index, integer *size, integer *skip, integer *count); +extern integer scanc_(shortint *cval); +extern integer set3_(real *xa, real *xb, real *ya, real *yb, real *ulo, real *uhi, real *vlo, real *vhi, real *wlo, real *whi, real *eye); +extern integer set3d_(real *eye, real *ulo, real *uhi, real *vlo, real *vhi, real *wlo, real *whi); +extern integer set_(real *vl, real *vr, real *vb, real *vt, real *wl, real *wr, real *wb, real *wt, integer *lf); +extern integer seter_(char *messg, integer *nerr, integer *iopt, ftnlen messg_len); +extern integer setfp_(integer *im, integer *fp); +extern integer seti_(integer *ix, integer *iy); +extern integer setr_(real *xmin, real *xmax, real *ymin, real *ymax, real *zmin, real *zmax, real *r0); +extern integer setusv_(char *vn, integer *iv, ftnlen vn_len); +extern integer sfree_(integer *oldsp); +extern integer sgchdw_(integer *mx, integer *my); +extern integer sgchfh_(void); +extern integer sgchme_(integer *mx, integer *my); +extern integer sgeprf_(integer *number, shortint *memory, integer *iop, integer *top, shortint *progrm, integer *pc); +extern integer sgespc_(integer *tr, integer *gki, integer *fn, shortint *instrn, integer *bp, integer *buftop, integer *deletn); +extern integer sgewsn_(integer *fn, shortint *instrn, real *x1, real *y1, real *x2, real *y2); +extern integer sgfpor_(integer *fd); +extern integer sgfttr_(integer *fd, shortint *buf, integer *maxch, integer *status); +extern integer sgibcl_(shortint *m, integer *nx, integer *ny, integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer sgical_(integer *dummy); +extern integer sgicle_(void); +extern integer sgiclr_(integer *dummy); +extern integer sgicls_(shortint *devnae, integer *n); +extern integer sgicor_(integer *index); +extern integer sgidae_(integer *gout, shortint *p, integer *npts, integer *ltype); +extern integer sgiese_(integer *fn, shortint *instrn, integer *nwords); +extern integer sgifat_(shortint *gki); +extern integer sgifia_(shortint *p, integer *npts); +extern integer sgiflh_(integer *dummy); +extern integer sgifot_(integer *font); +extern integer sgigey_(integer *nx, integer *ny, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer sgiint_(integer *tty, shortint *devnae); +extern integer sgilie_(integer *index); +extern integer sgimcl_(shortint *m, integer *nx, integer *ny, integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer sgiopn_(shortint *devnae, integer *dd); +extern integer sgiops_(shortint *devnae, integer *n, integer *mode); +extern integer sgiplt_(shortint *gki); +extern integer sgipmt_(shortint *gki); +extern integer sgipoe_(shortint *p, integer *npts); +extern integer sgipor_(shortint *p, integer *npts); +extern integer sgipuy_(shortint *m, integer *nx, integer *ny, integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer sgiret_(void); +extern integer sgitet_(integer *xc, integer *yc, shortint *text, integer *n); +extern integer sgitxt_(shortint *gki); +extern integer sgkcle_(integer *fd); +extern integer sgkdrw_(integer *fd, integer *ax, integer *ay); +extern integer sgkflh_(integer *fd); +extern integer sgkfre_(integer *fd); +extern integer sgklih_(integer *fd, integer *width); +extern integer sgkmke_(shortint *root, integer *num, shortint *outstr, integer *maxch); +extern integer sgkmoe_(integer *fd, integer *x, integer *y); +extern integer sgkver_(integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer sgmgeg_(shortint *gim); +extern integer sgmiod_(shortint *gim); +extern integer sgmioe_(shortint *gim); +extern integer sgmout_(shortint *cap, shortint *gim, integer *nargs); +extern integer sgmqur_(shortint *gim); +extern integer sgmquy_(shortint *queryp, shortint *gim, integer *nargs, shortint *retvap, shortint *retval, integer *nout); +extern integer sgmrep_(shortint *gim); +extern integer sgmres_(shortint *gim); +extern integer sgmwie_(integer *width, integer *height); +extern integer sgmwrp_(shortint *gim); +extern integer sgmwrs_(shortint *gim); +extern integer simaxi_(integer *a, integer *na, real *x, integer *b, integer *nb); +extern integer simaxr_(real *a, integer *na, real *x, real *b, integer *nb); +extern integer simaxs_(shortint *a, integer *na, real *x, shortint *b, integer *nb); +extern integer sisami_(integer *a, integer *b, real *x, integer *npix); +extern integer sisamr_(real *a, real *b, real *x, integer *npix); +extern integer sisams_(shortint *a, shortint *b, real *x, integer *npix); +extern integer skcloe_(integer *coo); +extern integer skctym_(integer *coo, integer *im); +extern integer skenws_(integer *coo, shortint *wcsstr, integer *maxch); +extern integer skequl_(integer *cooin, integer *cooout, doublereal *ilng, doublereal *ilat, doublereal *ipmlng, doublereal *ipmlat, doublereal *px, doublereal *rv, doublereal *olng, doublereal *olat); +extern integer skiipt_(shortint *label, shortint *images, integer *mw, integer *coo); +extern integer skiiwe_(integer *fd, shortint *label, shortint *images, integer *mw, integer *coo); +extern integer skimpt_(shortint *label, shortint *images, integer *ctype, integer *lngax, integer *latax, integer *wtype, integer *ptype, integer *radecs, doublereal *equinx, doublereal *epoch); +extern integer skimwe_(integer *fd, shortint *label, shortint *images, integer *ctype, integer *lngax, integer *latax, integer *wtype, integer *ptype, integer *radecs, doublereal *equinx, doublereal *epoch); +extern integer skinpt_(shortint *label, shortint *system, integer *ctype, integer *radecs, doublereal *equinx, doublereal *epoch); +extern integer skinwe_(integer *fd, shortint *label, shortint *system, integer *ctype, integer *radecs, doublereal *equinx, doublereal *epoch); +extern integer sklltn_(integer *cooin, integer *cooout, doublereal *ilng, doublereal *ilat, doublereal *ipmlng, doublereal *ipmlat, doublereal *px, doublereal *rv, doublereal *olng, doublereal *olat); +extern integer sksavm_(integer *coo, integer *mw, integer *im); +extern integer sksetd_(integer *coo, integer *param, doublereal *value); +extern integer skseti_(integer *coo, integer *param, integer *value); +extern integer sksets_(integer *coo, integer *param, shortint *value); +extern integer skstas_(integer *coo, integer *param, shortint *value, integer *maxch); +extern integer skultn_(integer *cooin, integer *cooout, doublereal *ilng, doublereal *ilat, doublereal *olng, doublereal *olat, integer *npts); +extern integer smark_(integer *oldsp); +extern integer sprinf_(shortint *outstr, integer *maxch, shortint *formag); +extern integer srfabd_(void); +extern integer srface_(real *x, real *y, real *z__, integer *m, integer *mx, integer *nx, integer *ny, real *s, real *stereo); +extern integer srfgk_(real *x, real *y, real *z__, integer *m, integer *mx, integer *nx, integer *ny, real *s, real *stereo); +extern integer srftet_(void); +extern integer sscan_(shortint *str); +extern integer stcloe_(integer *stp); +extern integer stcntr_(real *z__, integer *l, integer *m, integer *n, real *conv); +extern integer stfacs_(integer *kernel, shortint *root, shortint *extn, integer *acmode, integer *status); +extern integer stfadr_(integer *im, shortint *pname, integer *dtype, integer *plen, shortint *pval, integer *pno); +extern integer stfcle_(integer *im, integer *status); +extern integer stfcos_(integer *stf, integer *spool, integer *gpb, integer *user); +extern integer stfcoy_(integer *kernel, shortint *oroot, shortint *oextn, shortint *nroot, shortint *nextn, integer *status); +extern integer stfdee_(integer *kernel, shortint *root, shortint *extn, integer *status); +extern integer stfgeb_(shortint *card, integer *bval); +extern integer stfgei_(shortint *card, integer *ival); +extern integer stfgen_(integer *im, integer *oim, integer *acmode, shortint *outstr, integer *maxch); +extern integer stfges_(shortint *card, shortint *outstr, integer *maxch); +extern integer stfget_(shortint *card, shortint *commet, integer *maxch); +extern integer stfins_(integer *im); +extern integer stfmeb_(integer *nim, integer *oim); +extern integer stfmke_(shortint *hdrrot, shortint *hdrexn, shortint *pixfne, integer *maxch); +extern integer stfnee_(integer *im); +extern integer stfopn_(integer *kernel, integer *im, integer *oim, shortint *root, shortint *extn, shortint *ksectn, integer *grarg, integer *gcarg, integer *acmode, integer *status); +extern integer stfopx_(integer *im, integer *status); +extern integer stforb_(integer *ostf, integer *nstf); +extern integer stfrdr_(integer *im, integer *group, integer *acmode); +extern integer stfree_(integer *stp, integer *marker); +extern integer stfrek_(integer *im); +extern integer stfrfr_(integer *im, integer *fits, integer *fitsln); +extern integer stfrgb_(integer *im, integer *group, integer *acmode, real *datamn, real *datamx); +extern integer stfrne_(integer *kernel, shortint *oroot, shortint *oextn, shortint *nroot, shortint *nextn, integer *status); +extern integer stfupr_(integer *im, integer *status); +extern integer stfwfr_(integer *im); +extern integer stfwgb_(integer *im, integer *group, real *datamn, real *datamx); +extern integer stgcal_(integer *dummy); +extern integer stgcle_(void); +extern integer stgclr_(integer *dummy); +extern integer stgcls_(shortint *devnae, integer *n); +extern integer stgct1_(shortint *cap, integer *arg1); +extern integer stgct2_(shortint *cap, integer *arg1, integer *arg2); +extern integer stgct3_(shortint *cap, integer *arg1, integer *arg2, integer *arg3); +extern integer stgctl_(shortint *cap); +extern integer stgdes_(integer *flags); +extern integer stgdrr_(shortint *ch, integer *x, integer *y, integer *xsize, integer *ysize, integer *orien, integer *font); +extern integer stgdrw_(integer *x, integer *y); +extern integer stgese_(integer *fn, shortint *instrn, integer *nwords); +extern integer stgfat_(shortint *gki); +extern integer stgfia_(shortint *p, integer *npts); +extern integer stgflh_(integer *dummy); +extern integer stggdb_(void); +extern integer stggeb_(void); +extern integer stgger_(integer *cursor); +extern integer stggey_(integer *nx, integer *ny, integer *x1, integer *y1, integer *x2, integer *y2); +extern integer stggrm_(integer *stream); +extern integer stgint_(integer *tty, shortint *devnae); +extern integer stglor_(integer *newcur); +extern integer stgmoe_(integer *x, integer *y); +extern integer stgonr_(integer *errcoe); +extern integer stgont_(integer *vex, integer *nexthr); +extern integer stgopn_(shortint *devnae, integer *dd, integer *in, integer *out, integer *xres, integer *yres, integer *hardcr); +extern integer stgops_(shortint *devnae, integer *n, integer *mode); +extern integer stgou2_(integer *fd, shortint *progrm, integer *arg1, integer *arg2); +extern integer stgour_(shortint *cap, shortint *strval); +extern integer stgplt_(shortint *gki); +extern integer stgpmt_(shortint *gki); +extern integer stgpoe_(shortint *p, integer *npts); +extern integer stgpor_(shortint *p, integer *npts); +extern integer stgpue_(integer *fd, shortint *text); +extern integer stgpuy_(shortint *m, integer *nx, integer *ny, integer *ax1, integer *ay1, integer *ax2, integer *ay2); +extern integer stgrdr_(integer *tty, integer *cursor, integer *outpuc, integer *cn, integer *key, integer *sx, integer *sy, integer *raster, integer *rx, integer *ry); +extern integer stgren_(integer *xres, integer *yres); +extern integer stgrer_(integer *cursor, integer *cn, integer *key, integer *sx, integer *sy, integer *raster, integer *rx, integer *ry); +extern integer stgres_(integer *flags); +extern integer stgret_(void); +extern integer stgser_(integer *x, integer *y, integer *cursor); +extern integer stgtet_(integer *xc, integer *yc, shortint *text, integer *n); +extern integer stgtxt_(shortint *gki); +extern integer stgtxy_(integer *qualiy); +extern integer stgunn_(shortint *gki); +extern integer stgwry_(integer *fd, shortint *text, integer *nchars); +extern integer stinfo_(integer *stp, integer *fd, integer *verboe); +extern integer stkmkg_(integer *curseg, integer *sp, integer *segmee); +extern integer stline_(real *z__, integer *ll, integer *mm, integer *nn, real *conv); +extern integer stmark_(integer *stp, integer *marker); +extern integer strcle_(integer *fd); +extern integer strdeb_(shortint *line, shortint *outlie, integer *maxch, integer *tabsie); +extern integer strenb_(shortint *line, shortint *outlie, integer *maxch, integer *tabsie); +extern integer strlwr_(shortint *a); +extern integer strmln_(real *u, real *v, real *work, integer *imax, integer *iptsx, integer *jptsy, integer *nset, integer *ier); +extern integer strsee_(integer *fd, integer *mode); +extern integer strsrt_(integer *x, shortint *sb, integer *nstr); +extern integer strtbl_(integer *fd, shortint *buf, integer *strp, integer *nstr, integer *firstl, integer *lastcl, integer *maxch, integer *ncol); +extern integer strupr_(shortint *str); +extern integer stsave_(integer *stp, integer *fd); +extern integer stsque_(integer *stp); +extern integer sttyco_(shortint *args, integer *ttin, integer *ttout, integer *outfd); +extern integer sttyet_(shortint *envvar, shortint *value); +extern integer sttynm_(integer *ttin, integer *ttout, shortint *termil); +extern integer sttyse_(integer *ttin, integer *ttout, integer *tty); +extern integer sttysm_(integer *ttin, integer *ttout, integer *fd, integer *all); +extern integer sttytt_(integer *ttin, integer *ttout, shortint *termil); +extern integer stxchs_(integer *tx, integer *ch, integer *cw, integer *hwsz, logical *hard, integer *orien); +extern integer syserr_(integer *errcoe); +extern integer sysers_(integer *errcoe, shortint *usersg); +extern integer sysges_(shortint *fname); +extern integer sysgsg_(shortint *args, integer *ip, shortint *outstr, integer *maxch); +extern integer sysid_(shortint *outstr, integer *maxch); +extern integer sysmte_(integer *savete); +extern integer syspac_(integer *errcoe, shortint *errmsg); +extern integer syspat_(shortint *args, integer *ip, logical *skip); +extern integer syspte_(integer *fd, shortint *opstr, integer *savete); +extern integer sysret_(shortint *args, integer *ip); +extern integer syssct_(integer *cmdin, shortint *iargs); +extern integer tautog_(integer *ierror); +extern integer tautoh_(void); +extern integer tcnqck_(integer *ierror); +extern integer tcnsmt_(integer *ierror); +extern integer tcnsup_(integer *ierror); +extern integer tconan_(integer *ierror); +extern integer tconaq_(integer *ierror); +extern integer tconas_(integer *ierror); +extern integer tconrc_(void); +extern integer tconre_(integer *nplot, integer *ierror); +extern integer tconrn_(void); +extern integer tconrq_(void); +extern integer tconrs_(void); +extern integer tdashc_(integer *ierror); +extern integer tdashh_(void); +extern integer tdashl_(integer *ierror); +extern integer tdashp_(integer *ierror); +extern integer tdashr_(void); +extern integer tdashs_(integer *ierror); +extern integer thaftn_(void); +extern integer thafto_(integer *ierror); +extern integer threbd_(void); +extern integer tick3_(integer *mag, integer *min__); +extern integer tick43_(integer *magu, integer *minu, integer *magv, integer *minv, integer *magw, integer *minw); +extern integer tick4_(integer *lmajx, integer *lminx, integer *lmajy, integer *lminy); +extern integer ticks_(integer *lmaj, integer *lmin); +extern integer tirafs_(void); +extern integer tisohr_(integer *ierror); +extern integer tisosf_(void); +extern integer tisosr_(integer *nplot, integer *ierror); +extern integer toldao_(void); +extern integer tprzs_(void); +extern integer tpwriy_(void); +extern integer tpwry_(integer *ierror); +extern integer tpwrzi_(integer *ierror); +extern integer tpwrzs_(integer *ierror); +extern integer tpwrzt_(integer *ierror); +extern integer tr32_(real *x, real *y, integer *mx, integer *my); +extern integer trn32i_(real *u, real *v, real *w, real *xt, real *yt, real *zt, integer *ient); +extern integer trn32s_(real *x, real *y, real *z__, real *xt, real *yt, real *zt, integer *iflag); +extern integer trn32t_(real *u, real *v, real *w, real *xt, real *yt, real *zt, integer *ient); +extern integer tsleep_(integer *secons); +extern integer tsrfac_(integer *nplot, integer *ierror); +extern integer tsrftt_(void); +extern integer tst3d2_(void); +extern integer tstrml_(integer *ierror); +extern integer tstrmn_(void); +extern integer tsurfe_(void); +extern integer tthre2_(void); +extern integer tthred_(void); +extern integer tthree_(integer *ierror); +extern integer ttseti_(integer *fd, integer *param, integer *value); +extern integer ttsets_(integer *fd, integer *param, shortint *svalue); +extern integer ttybre_(integer *fd, integer *tty, integer *ostrie, integer *op, integer *sotype, logical *soseen); +extern integer ttycds_(integer *tty); +extern integer ttycle_(integer *tty); +extern integer ttycln_(integer *fd, integer *tty); +extern integer ttyclr_(integer *fd, integer *tty); +extern integer ttydee_(shortint *device, shortint *ldevie, integer *maxch); +extern integer ttydey_(integer *fd, integer *tty, integer *delay); +extern integer ttyfey_(integer *fd, shortint *device, integer *tty); +extern integer ttygoo_(integer *fd, integer *tty, integer *col, integer *line); +extern integer ttygpe_(integer *fd, integer *tty, shortint *text, integer *mapcc); +extern integer ttygse_(integer *in, integer *out, integer *tty, integer *width, integer *height); +extern integer ttyins_(integer *tty, integer *tcapce, integer *tcapix, integer *ncaps); +extern integer ttyint_(integer *fd, integer *tty); +extern integer ttypue_(integer *fd, integer *tty, shortint *text, integer *mapcc); +extern integer ttypus_(integer *fd, integer *tty, shortint *ctrlsr, integer *afflnt); +extern integer ttysce_(integer *tty, shortint *termce, shortint *devnae); +extern integer ttysei_(integer *tty, integer *paramr, integer *value); +extern integer ttyso_(integer *fd, integer *tty, integer *onflag); +extern integer ttywre_(integer *fd, integer *tty, shortint *ctrlsr, integer *nchars, integer *afflnt); +extern integer tvelvc_(integer *nplot, integer *ierror); +extern integer tvelvt_(void); +extern integer twofft_(real *data1, real *data2, real *fft1, real *fft2, integer *n); +extern integer uerrbd_(void); +extern integer uliber_(integer *errcode, char *pkerrmsg, integer *msglen, ftnlen pkerrmsg_len); +extern integer ungete_(integer *fd, shortint *str); +extern integer ungeti_(integer *fd, integer *ch); +extern integer unread_(integer *fd, shortint *buf, integer *nchars); +extern integer utilbd_(void); +extern integer vect3_(real *u, real *v, real *w); +extern integer vectd_(real *x, real *y); +extern integer vector_(real *px, real *py); +extern integer veldat_(void); +extern integer velvct_(real *u, integer *lu, real *v, integer *lv, integer *m, integer *n, real *flo, real *hi, integer *nset, integer *length, integer *ispv, real *spv); +extern integer velvec_(real *u, integer *lu, real *v, integer *lv, integer *m, integer *n, real *flo, real *hi, integer *nset, integer *ispv, real *spv); +extern integer vfncle_(integer *vfd, integer *update); +extern integer vfnene_(shortint *vfn, integer *ip, shortint *root, integer *lenrot, shortint *extn, integer *lenexn); +extern integer vfnexr_(shortint *vfn, shortint *outstr, integer *maxch); +extern integer vfnman_(shortint *irafen, shortint *osextn, integer *maxch); +extern integer vfnsqe_(shortint *root, shortint *outstr, integer *maxch); +extern integer vfntre_(shortint *rawvfn, shortint *osdir, integer *lenosr, shortint *root, integer *lenrot, shortint *extn, integer *lenexn); +extern integer vfnunn_(shortint *osextn, shortint *irafen, integer *maxch); +extern integer vmallc_(integer *ubufp, integer *nelems, integer *dtype); +extern integer vvfnee_(integer *ch, shortint *outbuf, integer *op, integer *maxch); +extern integer vvfnip_(shortint *map, shortint *iraf, shortint *os, integer *nextn, integer *maxexn); +extern integer vvfnis_(shortint *ex, shortint *extn, integer *maxexn, integer *nextn); +extern integer vvfnre_(integer *vfd); +extern integer wcslab_(integer *mw, real *logx1, real *logx2, real *logy1, real *logy2, integer *gp, shortint *title); +extern integer wfaitd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfaitt_(integer *fc, integer *dir); +extern integer wfaitv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfarcd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfarct_(integer *fc, integer *dir); +extern integer wfarcv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfcard_(integer *fc, doublereal *p, doublereal *w); +extern integer wfcart_(integer *fc, integer *dir); +extern integer wfcarv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfcscd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfcsct_(integer *fc, integer *dir); +extern integer wfcscv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfdecs_(integer *fc, integer *ira, integer *idec); +extern integer wffnld_(shortint *name__, integer *flags, integer *init, integer *destry, integer *fwd, integer *inv); +extern integer wfglsd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfglst_(integer *fc, integer *dir); +extern integer wfglsv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfgsbb_(doublereal *x, integer *order, doublereal *k1, doublereal *k2, doublereal *basis); +extern integer wfgsbg_(doublereal *x, integer *order, doublereal *k1, doublereal *k2, doublereal *basis); +extern integer wfgsbl_(doublereal *x, integer *order, doublereal *k1, doublereal *k2, doublereal *basis); +extern integer wfgsce_(integer *sf); +extern integer wfgscf_(integer *sf, doublereal *coeff, integer *ncoeff); +extern integer wfgsre_(integer *sf, doublereal *fit); +extern integer wfinit_(void); +extern integer wfmerd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfmert_(integer *fc, integer *dir); +extern integer wfmerv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfmold_(integer *fc, doublereal *p, doublereal *w); +extern integer wfmolt_(integer *fc, integer *dir); +extern integer wfmolv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfmspd_(integer *fc, doublereal *in, doublereal *out); +extern integer wfmspf_(shortint *atval, integer *coeff, doublereal *xmin, doublereal *xmax); +extern integer wfmspt_(integer *fc, integer *dir); +extern integer wfmspv_(integer *fc, doublereal *in, doublereal *out); +extern integer wfmspy_(integer *fc); +extern integer wfpard_(integer *fc, doublereal *p, doublereal *w); +extern integer wfpart_(integer *fc, integer *dir); +extern integer wfparv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfpcod_(integer *fc, doublereal *p, doublereal *w); +extern integer wfpcot_(integer *fc, integer *dir); +extern integer wfpcov_(integer *fc, doublereal *w, doublereal *p); +extern integer wfqscd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfqsct_(integer *fc, integer *dir); +extern integer wfqscv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfsind_(integer *fc, doublereal *p, doublereal *w); +extern integer wfsint_(integer *fc, integer *dir); +extern integer wfsinv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfsmpn_(integer *fc, doublereal *ax, doublereal *ay); +extern integer wfsmpt_(integer *fc, integer *dir); +extern integer wfstgd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfstgt_(integer *fc, integer *dir); +extern integer wfstgv_(integer *fc, doublereal *w, doublereal *p); +extern integer wftand_(integer *fc, doublereal *p, doublereal *w); +extern integer wftant_(integer *fc, integer *dir); +extern integer wftanv_(integer *fc, doublereal *w, doublereal *p); +extern integer wftnxd_(integer *fc, doublereal *p, doublereal *w); +extern integer wftnxt_(integer *fc, integer *dir); +extern integer wftnxv_(integer *fc, doublereal *w, doublereal *p); +extern integer wftnxy_(integer *fc); +extern integer wftscd_(integer *fc, doublereal *p, doublereal *w); +extern integer wftsct_(integer *fc, integer *dir); +extern integer wftscv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfzead_(integer *fc, doublereal *p, doublereal *w); +extern integer wfzeat_(integer *fc, integer *dir); +extern integer wfzeav_(integer *fc, doublereal *w, doublereal *p); +extern integer wfzpnd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfzpnt_(integer *fc, integer *dir); +extern integer wfzpnv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfzpny_(integer *fc); +extern integer wfzpxd_(integer *fc, doublereal *p, doublereal *w); +extern integer wfzpxt_(integer *fc, integer *dir); +extern integer wfzpxv_(integer *fc, doublereal *w, doublereal *p); +extern integer wfzpxy_(integer *fc); +extern integer wlaxie_(doublereal *x0, doublereal *y0, doublereal *x1, doublereal *y1, doublereal *screey, doublereal *nx, doublereal *ny); +extern integer wlcons_(doublereal *screey, doublereal *x, doublereal *y, integer *vectoe); +extern integer wldece_(integer *mw, shortint *input, integer *axno); +extern integer wldesy_(integer *wd); +extern integer wldete_(integer *systee, doublereal *polepn, doublereal *screey, integer *graphe); +extern integer wldms_(doublereal *arcrad, shortint *dms, shortint *units, integer *maxch, integer *precin, logical *all); +extern integer wlgend_(doublereal *minimm, doublereal *maximm, doublereal *range, doublereal *lbegin, doublereal *lend, doublereal *interl); +extern integer wlgete_(integer *mw, integer *systee, doublereal *logicr, doublereal *worldr, integer *flip); +extern integer wlgetf_(doublereal *val1, doublereal *val2, doublereal *min__, doublereal *max__, doublereal *diff, logical *wrap); +extern integer wlgetn_(integer *lwct, integer *flip, doublereal *polepn, doublereal *screey, doublereal *poleln, integer *badlae); +extern integer wlgra1_(integer *wd, doublereal *x, doublereal *ymin, doublereal *ymax, integer *gridon, integer *label, real *tickse); +extern integer wlgra2_(integer *wd, doublereal *y, doublereal *xmin, doublereal *xmax, integer *gridon, integer *label, real *tickse); +extern integer wlgras_(integer *wd); +extern integer wlgrid_(integer *wd); +extern integer wlgris_(integer *wd); +extern integer wlgrrs_(integer *wd); +extern integer wlhms_(doublereal *rarad, shortint *hms, shortint *units, integer *maxch, integer *precin, logical *all); +extern integer wlimdt_(integer *frame, integer *im, real *c1, real *c2, real *l1, real *l2, real *vl, real *vr, real *vb, real *vt); +extern integer wlintg_(doublereal *value, integer *systee, integer *whichs, shortint *output); +extern integer wll2wd_(integer *lwct, integer *flip, doublereal *lx, doublereal *ly, doublereal *wx, doublereal *wy, integer *npts); +extern integer wllabe_(shortint *input, logical *flag__); +extern integer wllabl_(integer *wd); +extern integer wllabs_(integer *wd, integer *axis, integer *side, real *offset); +extern integer wlmapt_(integer *gp, real *c1, real *c2, real *l1, real *l2, real *ux1, real *ux2, real *uy1, real *uy2, logical *fill); +extern integer wlmark_(integer *gp, integer *wcs, real *tickse, integer *in, doublereal *x0, doublereal *y0, doublereal *x1, doublereal *y1, doublereal *sx, doublereal *sy, doublereal *tickx, doublereal *ticky); +extern integer wlpoil_(integer *wd, doublereal *x1, doublereal *y1, doublereal *x2, doublereal *y2, integer *axis, doublereal *axisve, integer *gridon, integer *label, real *tickse); +extern integer wlpoll_(integer *wd); +extern integer wlpoln_(integer *wlct, integer *flip, doublereal *longie, logical *north, integer *systee, doublereal *polepn); +extern integer wlputs_(logical *sidefs, shortint *output, integer *maxlen); +extern integer wlrare_(doublereal *ra, integer *nvalus, doublereal *min__, doublereal *max__, doublereal *diff); +extern integer wlrote_(real *x, real *y, integer *npts, real *angle, real *nx, real *ny); +extern integer wlroua_(doublereal *longmn, doublereal *longmx, doublereal *longrn, integer *numtry, doublereal *minimm, doublereal *maximm, doublereal *majorl); +extern integer wlrouc_(doublereal *latmin, doublereal *latmax, doublereal *latran, integer *numtry, doublereal *minimm, doublereal *maximm, doublereal *majorl); +extern integer wlrous_(integer *wd, integer *axis, doublereal *minimm, doublereal *maximm, doublereal *range); +extern integer wlsetp_(integer *wd); +extern integer wlsidg_(integer *side, shortint *output, integer *maxlen); +extern integer wlskya_(integer *wd, doublereal *ax1ary, integer *npoins, doublereal *polepn, logical *north, doublereal *ax1min, doublereal *ax1max, doublereal *ax1ran, doublereal *ax2min, doublereal *ax2max, doublereal *ax2ran); +extern integer wltite_(integer *gp, shortint *title, integer *side, real *size, real *viewpt); +extern integer wlw2ld_(integer *wlct, integer *flip, doublereal *wx, doublereal *wy, doublereal *lx, doublereal *ly, integer *npts); +extern integer wlwcsb_(integer *wd); +extern integer wlwcss_(integer *mw, real *logx1, real *logx2, real *logy1, real *logy2); +extern integer wlwril_(integer *wd, doublereal *value, integer *side, real *x, real *y, doublereal *angle, integer *axis, integer *precin, logical *dofull, real *offset); +extern integer wtstr_(real *px, real *py, char *ch, integer *is, integer *io, integer *ic, ftnlen ch_len); +extern integer xcallc_(integer *ubufp, integer *buflen, integer *dtype); +extern integer xdevss_(shortint *device, integer *out); +extern integer xeract_(integer *errore, shortint *messae, integer *severy); +extern integer xerfmg_(shortint *errmsg, shortint *outstr, integer *maxch); +extern integer xerpsh_(void); +extern integer xerpsr_(shortint *str); +extern integer xerpuc_(shortint *ch); +extern integer xerpue_(integer *fd, shortint *text); +extern integer xerret_(void); +extern integer xerror_(integer *errore, shortint *messae); +extern integer xersel_(integer *errcoe); +extern integer xervey_(void); +extern integer xfatal_(integer *errore, shortint *messae); +extern integer xfchdr_(shortint *newdir); +extern integer xfcloe_(integer *fdarg); +extern integer xfdele_(shortint *fname); +extern integer xffluh_(integer *fd); +extern integer xfputc_(integer *fd, shortint *ch); +extern integer xfputr_(shortint *ch); +extern integer xfrnam_(shortint *oldnae, shortint *newnae); +extern integer xfseek_(integer *fd, integer *offset); +extern integer xfungc_(integer *fd, shortint *ch); +extern integer xfwrie_(integer *fd, shortint *buffer, integer *maxchs); +extern integer xgtuid_(shortint *userne, integer *maxch); +extern integer xmallc_(integer *ubufp, integer *nelems, integer *dtype); +extern integer xmfree_(integer *ptr, integer *dtype); +extern integer xmjbuf_(integer *bp); +extern integer xmktep_(shortint *seed, shortint *tempfe, integer *maxchs); +extern integer xmpl10_(void); +extern integer xmpl11_(void); +extern integer xonerr_(integer *status); +extern integer xonext_(integer *exitce); +extern integer xpages_(shortint *files, shortint *device, shortint *prompt, integer *firste, integer *clearn, integer *mapcc); +extern integer xprinf_(shortint *formag); +extern integer xqsort_(integer *x, integer *nelem, I_fp compae); +extern integer xrealc_(integer *ubufp, integer *nelems, integer *dtype); +extern integer xstdeh_(integer *excepn, integer *nexthr); +extern integer xstrct_(shortint *str, shortint *outstr, integer *maxch); +extern integer xstrcy_(shortint *s1, shortint *s2, integer *maxch); +extern integer xt21id_(integer *im, integer *axis, integer *col1, integer *col2, integer *line1, integer *line2, integer *x, integer *y, integer *npts); +extern integer xt21ig_(integer *im, integer *axis, integer *col1, integer *col2, integer *line1, integer *line2, integer *x, integer *y, integer *npts); +extern integer xt21im_(integer *im, integer *axis, integer *col1, integer *col2, integer *line1, integer *line2, integer *x, integer *y, integer *npts); +extern integer xtansr_(shortint *prompt, integer *answer); +extern integer xtargs_(integer *stp, shortint *key, shortint *val, integer *maxchr); +extern integer xtbace_(integer *ba); +extern integer xtbagi_(integer *ba, integer *c__, integer *l, integer *data, integer *n); +extern integer xtbags_(integer *ba, integer *c__, integer *l, shortint *data, integer *n); +extern integer xtbapi_(integer *ba, integer *c__, integer *l, integer *data, integer *n); +extern integer xtbaps_(integer *ba, integer *c__, integer *l, shortint *data, integer *n); +extern integer xtclar_(shortint *paramr, integer *answer); +extern integer xtcsub_(integer *co, integer *col1, integer *col2, integer *line1, integer *line2, integer *data); +extern integer xtcsum_(integer *co, integer *col1, integer *col2, integer *line1, integer *line2, integer *data); +extern integer xtdelp_(shortint *output, shortint *origil); +extern integer xtextn_(integer *fd, shortint *fname, shortint *exttye, integer *indics, shortint *extnae, integer *extver, integer *lindex, integer *lname, integer *lver, shortint *ikpars, integer *err); +extern integer xtfpfe_(integer *fp); +extern integer xtfpsp_(integer *pm, integer *nc, integer *nl, integer *v, shortint *data, integer *lvalin, integer *cvalin, integer *lvalot, integer *cvalot); +extern integer xtgets_(shortint *fname); +extern integer xtgids_(shortint *str, shortint *dicstr, integer *ids, integer *maxids); +extern integer xtimet_(shortint *image, shortint *ext, integer *maxchr); +extern integer xtimrt_(shortint *image, shortint *root, integer *maxchr); +extern integer xtloge_(integer *logfd, integer *nlogfd, shortint *prefix); +extern integer xtlsub_(integer *im, integer *col1, integer *col2, integer *line1, integer *line2, integer *data); +extern integer xtlsum_(integer *im, integer *col1, integer *col2, integer *line1, integer *line2, integer *data); +extern integer xtmase_(shortint *fname, shortint *extnae, integer *mode, shortint *mname, integer *maxchr); +extern integer xtmk1d_(shortint *image, shortint *secstr, integer *szfnae); +extern integer xtmkic_(shortint *image, shortint *secstr, shortint *imagec, integer *szfnae); +extern integer xtmkip_(shortint *input, shortint *output, shortint *origil, integer *szfnae); +extern integer xtmksn_(shortint *image, shortint *secstr, shortint *sectin, integer *szsecn); +extern integer xtpart_(shortint *args, integer *ip, logical *skip); +extern integer xtphiy_(integer *im, shortint *str); +extern integer xtsor2_(real *a1, real *a2, integer *npts); +extern integer xtsor3_(real *a1, real *a2, real *a3, integer *npts); +extern integer xtsor4_(real *a1, real *a2, real *a3, real *a4, integer *npts); +extern integer xtsord_(doublereal *a1, doublereal *a2, doublereal *a3, integer *npts); +extern integer xtstad_(doublereal *sample, integer *nsampe, real *frac, doublereal *mean, doublereal *sigma, doublereal *median, doublereal *mode); +extern integer xtstai_(integer *sample, integer *nsampe, real *frac, real *mean, real *sigma, real *median, real *mode); +extern integer xtstar_(real *sample, integer *nsampe, real *frac, real *mean, real *sigma, real *median, real *mode); +extern integer xtstas_(shortint *sample, integer *nsampe, real *frac, real *mean, real *sigma, real *median, real *mode); +extern integer xtstre_(shortint *str); +extern integer xttxte_(integer *fd); +extern integer xttyse_(integer *width, integer *height); +extern integer xvvbip_(integer *opcode, integer *in1, integer *in2, integer *out); +extern integer xvvbop_(integer *opcode, integer *in1, integer *in2, integer *out); +extern integer xvvqut_(integer *cond, integer *in1, integer *in2, integer *out); +extern integer xvvunp_(integer *opcode, integer *in, integer *out); +extern integer xwhen_(integer *signal, integer *handlr, integer *oldhar); +extern integer ytfpfe_(integer *fp); +extern integer ytfpsp_(integer *pmin, integer *pm, integer *nc, integer *nl, integer *v, shortint *data, integer *lvalin, integer *cvalin, integer *lvalot, integer *cvalot); +extern integer zardim_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer zardmt_(integer *mtchan, shortint *buf, integer *maxbys, integer *offset); +extern integer zardnu_(integer *chan, shortint *buf, integer *maxbys, integer *loffst); +extern integer zardps_(integer *ps, shortint *buf, integer *maxbys, integer *offset); +extern integer zawrim_(integer *chan, shortint *buf, integer *nbytes, integer *offset); +extern integer zawrmt_(integer *mtchan, shortint *buf, integer *nbytes, integer *offset); +extern integer zawrnu_(integer *chan, shortint *buf, integer *nbytes, integer *loffst); +extern integer zawrps_(integer *ps, shortint *buf, integer *nbytes, integer *offset); +extern integer zawtim_(integer *chan, integer *nbytes); +extern integer zawtmt_(integer *mtchan, integer *status); +extern integer zawtnu_(integer *chan, integer *status); +extern integer zawtps_(integer *ps, integer *status); +extern integer zblkim_(integer *chan1, integer *chan2, integer *chan3, integer *chan4, integer *nframs, real *rate); +extern integer zclrim_(integer *chan); +extern integer zclsim_(integer *chan, integer *status); +extern integer zclsmt_(integer *mtchan, integer *status); +extern integer zclsnu_(integer *chan, integer *status); +extern integer zclsps_(integer *chan, integer *status); +extern integer zclstt_(integer *fd, integer *status); +extern integer zerosc_(void); +extern integer zersim_(integer *chan); +extern integer zflsnu_(integer *chan, integer *status); +extern integer zflstt_(integer *fd, integer *status); +extern integer zfrmim_(integer *chan); +extern integer zgetnu_(integer *chan, shortint *buf, integer *maxch, integer *status); +extern integer zgettt_(integer *fd, shortint *buf, integer *maxch, integer *status); +extern integer zlset_(real *z__, integer *mx, integer *nx, integer *ny, real *zl, integer *nlevl); +extern integer zmapim_(integer *chan, shortint *maptye); +extern integer zmtcim_(integer *chan1, integer *chan2); +extern integer znotnu_(integer *chan, integer *loffst); +extern integer znottt_(integer *fd, integer *offset); +extern integer zopnim_(shortint *devino, integer *mode, integer *chan); +extern integer zopnmt_(shortint *iodev, integer *acmode, integer *mtchan); +extern integer zopnnu_(shortint *osfn, integer *mode, integer *chan); +extern integer zopntt_(shortint *osfn, integer *mode, integer *chan); +extern integer zputnu_(integer *chan, shortint *buf, integer *nchars, integer *status); +extern integer zputtt_(integer *fd, shortint *buf, integer *nchars, integer *status); +extern integer zrcrim_(integer *chan, integer *xcur, integer *ycur); +extern integer zrgbim_(integer *redchn, integer *greenn, integer *bluecn); +extern integer zrmim_(integer *chan, integer *zfactr); +extern integer zscale_(integer *im, real *z1, real *z2, real *contrt, integer *optime, integer *lenste); +extern integer zscfla_(real *data, real *flat, real *x, integer *npix, real *z0, real *dz); +extern integer zsczls_(real *sample, integer *npix, real *contrt, real *z1, real *z2); +extern integer zseknu_(integer *chan, integer *loffst, integer *status); +extern integer zsektt_(integer *fd, integer *offset, integer *status); +extern integer zsestt_(integer *fd, integer *param, shortint *svalue); +extern integer zsettt_(integer *chan, integer *param, integer *value); +extern integer zststt_(integer *fd, integer *param, shortint *outstr, integer *maxch, integer *nchars); +extern integer zsttim_(integer *chan, integer *what, integer *lvalue); +extern integer zsttmt_(integer *mtchan, integer *what, integer *lvalue); +extern integer zsttnu_(integer *chan, integer *param, integer *lvalue); +extern integer zsttps_(integer *ps, integer *what, integer *lvalue); +extern integer zstttt_(integer *fd, integer *param, integer *lvalue); +extern integer zttgeg_(integer *chan, shortint *obuf, integer *maxch, integer *nchars); +extern integer zttloo_(integer *inflag, integer *outflg); +extern integer zttlov_(integer *chan); +extern integer zttpbf_(integer *errcoe); +extern integer zttplk_(integer *flag__); +extern integer zttpug_(integer *chan, shortint *dstr, integer *nchars); +extern integer zttttt_(shortint *messae); +extern integer zttupe_(shortint *in, shortint *out, integer *nchars); +extern integer zwndi3_(integer *chan1, integer *chan2, integer *chan3); +extern integer zwndim_(integer *chan); +extern integer agfpbn_(real *fpdp); +extern integer ahivi_(integer *a, integer *npix); +extern integer ahivl_(integer *a, integer *npix); +extern integer alovi_(integer *a, integer *npix); +extern integer alovl_(integer *a, integer *npix); +extern integer amedi_(integer *a, integer *npix); +extern integer amedl_(integer *a, integer *npix); +extern integer aravd_(doublereal *a, integer *npix, doublereal *mean, doublereal *sigma, doublereal *ksig); +extern integer aravi_(integer *a, integer *npix, real *mean, real *sigma, real *ksig); +extern integer aravl_(integer *a, integer *npix, doublereal *mean, doublereal *sigma, doublereal *ksig); +extern integer aravr_(real *a, integer *npix, real *mean, real *sigma, real *ksig); +extern integer aravs_(shortint *a, integer *npix, real *mean, real *sigma, real *ksig); +extern integer aravx_(complex *a, integer *npix, real *mean, real *sigma, real *ksig); +extern integer asoki_(integer *a, integer *npix, integer *ksel); +extern integer asokl_(integer *a, integer *npix, integer *ksel); +extern integer await_(integer *fd); +extern integer awaitb_(integer *fd); +extern integer awvgd_(doublereal *a, integer *npix, doublereal *mean, doublereal *sigma, doublereal *lcut, doublereal *hcut); +extern integer awvgi_(integer *a, integer *npix, real *mean, real *sigma, real *lcut, real *hcut); +extern integer awvgl_(integer *a, integer *npix, doublereal *mean, doublereal *sigma, doublereal *lcut, doublereal *hcut); +extern integer awvgr_(real *a, integer *npix, real *mean, real *sigma, real *lcut, real *hcut); +extern integer awvgs_(shortint *a, integer *npix, real *mean, real *sigma, real *lcut, real *hcut); +extern integer awvgx_(complex *a, integer *npix, real *mean, real *sigma, real *lcut, real *hcut); +extern integer begmem_(integer *bestse, integer *oldsie, integer *maxsie); +extern integer btoi_(logical *boolee); +extern integer cctoc_(shortint *str, integer *ip, shortint *cval); +extern integer ccxset_(shortint *text, integer *n, shortint *out, integer *startt); +extern integer clcfeh_(shortint *param, shortint *outstr, integer *maxch); +extern integer clcfid_(shortint *param, shortint *outstr, integer *maxch); +extern integer clgcur_(shortint *param, real *wx, real *wy, integer *wcs, integer *key, shortint *strval, integer *maxch); +extern integer clgeti_(shortint *param); +extern integer clgetl_(shortint *param); +extern integer clgfil_(integer *list, shortint *fname, integer *maxch); +extern integer clginp_(shortint *param); +extern integer clgkey_(shortint *param, integer *key, shortint *strval, integer *maxch); +extern integer clglpb_(shortint *param, logical *bval); +extern integer clglpc_(shortint *param, shortint *cval); +extern integer clglpd_(shortint *param, doublereal *dval); +extern integer clglpi_(shortint *param, integer *ival); +extern integer clglpl_(shortint *param, integer *lval); +extern integer clglpr_(shortint *param, real *rval); +extern integer clglps_(shortint *param, shortint *sval); +extern integer clglpx_(shortint *param, complex *xval); +extern integer clglsr_(shortint *param, shortint *outstr, integer *maxch); +extern integer clgpsi_(integer *pp, shortint *parnae); +extern integer clgpsl_(integer *pp, shortint *parnae); +extern integer clgwrd_(shortint *param, shortint *keywod, integer *maxchr, shortint *dictiy); +extern integer clktie_(integer *oldtie); +extern integer clopst_(shortint *pset); +extern integer clplen_(integer *list); +extern integer clpopi_(shortint *param); +extern integer clpops_(shortint *param); +extern integer clpopu_(shortint *param); +extern integer clpsee_(integer *pp, shortint *parnae); +extern integer clpsit_(shortint *cmd, integer *arg1, integer *arg2); +extern integer clscan_(shortint *param); +extern integer clstai_(integer *paramr); +extern integer coerce_(integer *ptr, integer *type1, integer *type2); +extern integer cogetr_(integer *co, integer *col, integer *line1, integer *line2); +extern integer comap_(integer *im, integer *maxbuf); +extern integer conxch_(real *x, real *y, integer *i1, integer *i2, integer *i3, integer *i4); +extern integer cputie_(integer *oldcpe); +extern integer cqccry_(integer *cq); +extern integer cqdgei_(integer *cq, integer *record, shortint *field); +extern integer cqdscn_(integer *cq); +extern integer cqdtye_(shortint *c__); +extern integer cqfgad_(integer *cq, shortint *field, doublereal *array, integer *maxlen); +extern integer cqfgai_(integer *cq, shortint *field, integer *array, integer *maxlen); +extern integer cqfgar_(integer *cq, shortint *field, real *array, integer *maxlen); +extern integer cqfgei_(integer *cq, shortint *field); +extern integer cqfgtt_(integer *cq, shortint *field, shortint *str, integer *maxch); +extern integer cqfimy_(integer *cq, shortint *imname); +extern integer cqfinn_(integer *res, integer *fieldo, shortint *fname, integer *szfnae, integer *foffst, integer *fsize, integer *ftype, shortint *units, integer *szunis, shortint *fmts, integer *szfmts); +extern integer cqfino_(integer *res, shortint *field, integer *foffst, integer *fsize, integer *ftype, shortint *units, integer *szunis, shortint *fmts, integer *szfmts); +extern integer cqfirt_(integer *cq); +extern integer cqfnae_(integer *res, integer *fieldo, shortint *fname, integer *szfnae); +extern integer cqfnur_(integer *res, shortint *field); +extern integer cqfoft_(integer *res, shortint *field); +extern integer cqfquy_(integer *cq, shortint *catfie, shortint *catfmt); +extern integer cqfrit_(integer *cq, shortint *catfmt); +extern integer cqfsie_(integer *res, shortint *field); +extern integer cqftye_(integer *res, shortint *field); +extern integer cqgnrd_(integer *res, shortint *buf, integer *maxch, integer *recptr); +extern integer cqgqpn_(integer *cq, integer *parno, shortint *pname, integer *maxnae, shortint *value, integer *maxval, shortint *units, integer *maxuns, shortint *format, integer *maxfot); +extern integer cqgqpr_(integer *cq, shortint *name__, shortint *pname, integer *maxnae, shortint *value, integer *maxval, shortint *units, integer *maxuns, shortint *format, integer *maxfot); +extern integer cqgred_(integer *res, shortint *buf, integer *maxch, integer *recptr); +extern integer cqgvac_(integer *res, integer *recptr, shortint *field, shortint *str, integer *maxch); +extern integer cqgvad_(integer *res, integer *recptr, shortint *field, doublereal *dval); +extern integer cqgvai_(integer *res, integer *recptr, shortint *field, integer *ival); +extern integer cqgval_(integer *res, integer *recptr, shortint *field, integer *lval); +extern integer cqgvar_(integer *res, integer *recptr, shortint *field, real *rval); +extern integer cqgvas_(integer *res, integer *recptr, shortint *field, shortint *sval); +extern integer cqhinn_(integer *res, integer *kwno, shortint *hkname, integer *szhkne, shortint *hkvale, integer *szhkve); +extern integer cqhino_(integer *res, shortint *hkname, shortint *hkvale, integer *szhkve); +extern integer cqimqy_(integer *cq, shortint *imname); +extern integer cqirit_(integer *cq); +extern integer cqisti_(integer *res, integer *param); +extern integer cqistt_(integer *res, integer *param, shortint *str, integer *maxch); +extern integer cqkinn_(integer *res, integer *fieldo, shortint *kfield, integer *szkfid, shortint *ikname, integer *szikne, shortint *ikvale, integer *szikve, integer *iktype, shortint *ikunis, integer *szikus); +extern integer cqkino_(integer *res, shortint *kfield, shortint *ikname, integer *szikne, shortint *ikvale, integer *szikve, integer *iktype, shortint *ikunis, integer *szikus); +extern integer cqloce_(integer *cq, shortint *name__); +extern integer cqlocn_(integer *cq, integer *catno, shortint *name__, integer *maxch); +extern integer cqmap_(shortint *databe, integer *mode); +extern integer cqnqps_(integer *cq); +extern integer cqquey_(integer *cq); +extern integer cqrint_(integer *cq); +extern integer cqrsti_(integer *res, integer *param); +extern integer cqrstt_(integer *res, integer *param, shortint *str, integer *maxch); +extern integer cqscan_(integer *cq); +extern integer cqsetd_(integer *res, integer *recptr); +extern integer cqsetn_(integer *cq, integer *catno); +extern integer cqsett_(integer *cq, shortint *name__); +extern integer cqsqpn_(integer *cq, integer *parno, shortint *valuer); +extern integer cqsqpr_(integer *cq, shortint *name__, shortint *valuer); +extern integer cqstai_(integer *cq, integer *param); +extern integer cqstat_(integer *cq, integer *param, shortint *str, integer *maxch); +extern integer cqwinn_(integer *res, integer *fieldo, shortint *wfield, integer *szwfid, shortint *wkname, integer *szwkne, shortint *wkvale, integer *szwkve, integer *wktype, shortint *wkunis, integer *szwkus); +extern integer cqwino_(integer *res, shortint *wfield, shortint *wkname, integer *szwkne, shortint *wkvale, integer *szwkve, integer *wktype, shortint *wkunis, integer *szwkus); +extern integer cqwrdr_(integer *index, shortint *outstr, integer *maxch, shortint *dict); +extern integer ctocc_(shortint *ch, shortint *outstr, integer *maxch); +extern integer ctod_(shortint *str, integer *ip, doublereal *dval); +extern integer ctoi_(shortint *str, integer *ip, integer *ival); +extern integer ctol_(shortint *str, integer *ip, integer *lval); +extern integer ctor_(shortint *str, integer *ip, real *rval); +extern integer ctotok_(shortint *str, integer *ip, shortint *outstr, integer *maxch); +extern integer ctowrd_(shortint *str, integer *ip, shortint *outstr, integer *maxch); +extern integer ctox_(shortint *str, integer *ip, complex *xval); +extern integer decods_(shortint *rangeg, integer *ranges, integer *maxras, integer *nvalus); +extern integer diropn_(shortint *fname, integer *mode); +extern integer dsmap_(integer *frame, integer *mode, integer *color, integer *chan); +extern integer dspmmp_(shortint *pmname, integer *refim); +extern integer dsuluc_(shortint *fname, real *z1, real *z2); +extern integer dtgeti_(integer *dt, integer *record, shortint *field); +extern integer dtloce_(integer *dt, shortint *name__); +extern integer dtmap1_(shortint *databe, shortint *key, integer *mode); +extern integer dtmap_(shortint *databe, integer *mode); +extern integer dtmdee_(shortint *datesr, integer *year, integer *month, integer *day, doublereal *time, integer *flags); +extern integer dtmdes_(shortint *datesr, integer *year, integer *month, integer *day, integer *hours, integer *minuts, doublereal *secons, integer *flags); +extern integer dtmene_(shortint *datesr, integer *maxch, integer *year, integer *month, integer *day, doublereal *time, integer *precin, integer *flags); +extern integer dtmens_(shortint *datesr, integer *maxch, integer *year, integer *month, integer *day, integer *hours, integer *minuts, doublereal *secons, integer *precin, integer *flags); +extern integer dtmlte_(shortint *datesr, integer *ltime); +extern integer dtoc3_(doublereal *val, shortint *out, integer *maxch, integer *decpl, integer *afmt, integer *width); +extern integer dtoc_(doublereal *dval, shortint *outstr, integer *maxch, integer *decpl, integer *afmt, integer *width); +extern integer dtscan_(integer *dt); +extern integer envfid_(shortint *key, shortint *value, integer *maxch); +extern integer envfit_(integer *valp); +extern integer envfre_(integer *oldtop, integer *userfn); +extern integer envgei_(shortint *varnae); +extern integer envges_(shortint *key, shortint *value, integer *maxch); +extern integer envnet_(integer *lastel, integer *valp, integer *showrs); +extern integer envpus_(shortint *key, shortint *value); +extern integer envscn_(shortint *cmd); +extern integer errcoe_(void); +extern integer errget_(shortint *outstr, integer *maxch); +extern integer evexpr_(shortint *expr, integer *getopa, integer *ufcnea); +extern integer evvexr_(shortint *expr, integer *getop, integer *getopa, integer *ufcn, integer *ufcnda, integer *flags); +extern integer extrea_(real *x, real *y, real *curvae, integer *npts, real *dx); +extern integer fdevbk_(shortint *path); +extern integer ffault_(integer *fd, integer *fileot, integer *nresee, integer *rwflag); +extern integer ffilsz_(integer *fd); +extern integer fgdev0_(integer *ffp, integer *what); +extern integer fgetfd_(shortint *filene, integer *mode, integer *type__); +/*extern integer filbuf_(integer *fd);*/ +extern integer finfo_(shortint *fname, integer *ostrut); +extern integer fmaccs_(shortint *dfname, integer *mode); +extern integer fmfinf_(integer *fc, integer *lfile); +extern integer fmfopn_(integer *fm, integer *lfile, integer *mode, integer *type__); +extern integer fmgetd_(integer *fm, integer *lfile, integer *mode, integer *type__); +extern integer fmioed_(integer *fm, integer *lfile, integer *npages); +extern integer fmlfpe_(shortint *lfname, integer *fm, integer *lfile, integer *type__); +extern integer fmlfst_(integer *fm, integer *lfile, integer *statbf); +extern integer fmnexe_(integer *fm); +extern integer fmopen_(shortint *fname, integer *mode); +extern integer fmstai_(integer *fm, integer *param); +extern integer fnextn_(shortint *vfn, shortint *outstr, integer *maxch); +extern integer fnldir_(shortint *vfn, shortint *outstr, integer *maxch); +extern integer fnroot_(shortint *vfn, shortint *outstr, integer *maxch); +extern integer fntedt_(shortint *in, shortint *out, integer *editp, integer *nedit, shortint *patbuf); +extern integer fntget_(shortint *temple, integer *ix, integer *patp, integer *npat, integer *sbuf, integer *maxch); +extern integer fntgfb_(integer *list, shortint *fname, integer *maxch); +extern integer fntgfn_(integer *pp, shortint *outstr, integer *maxch); +extern integer fntleb_(integer *list); +extern integer fntopb_(shortint *temple, integer *sort); +extern integer fntopn_(shortint *temple); +extern integer fntopt_(shortint *str, shortint *patstr, integer *maxch, shortint *fname, shortint *ldir, integer *ftype); +extern integer fntree_(integer *pp, shortint *outstr, integer *maxch, integer *token); +extern integer fntrfb_(integer *list, integer *index, shortint *fname, integer *maxch); +extern integer fprfmt_(integer *ival); +extern integer freadp_(integer *fd, integer *offset, integer *nchars); +extern integer fsetfd_(integer *fd, shortint *filene, integer *mode, integer *type__); +extern integer fsfopn_(shortint *fname, integer *mode); +extern integer fstati_(integer *fd, integer *what); +extern integer fstatl_(integer *fd, integer *what); +extern integer fstdfe_(shortint *fname, integer *ofd); +extern integer futime_(shortint *fname, integer *atime, integer *mtime); +extern integer fwritp_(integer *fd, integer *offset, integer *nchars); +extern integer fxfchv_(integer *im, integer *group); +extern integer fxfcte_(shortint *card, integer *kwindx); +extern integer fxfexr_(integer *fit, integer *ig, integer *extn, integer *extv); +extern integer fxfhdt_(integer *group, integer *fit, integer *pfd, integer *acmode); +extern integer fxfhee_(integer *im); +extern integer fxfksx_(shortint *outstr); +extern integer fxfred_(integer *fd, shortint *ibuf, shortint *obuf, integer *ncards); +extern integer fxfstr_(shortint *s1, shortint *s2); +extern integer fxftox_(integer *im); +extern integer fxfuad_(integer *fit, integer *im, integer *up, shortint *card); +extern integer fxfxal_(integer *hd, integer *ncua, integer *nlines); +extern integer gctod_(shortint *str, integer *ip, doublereal *odval); +extern integer gctol_(shortint *str, integer *ip, integer *lval, integer *radix); +extern integer gctox_(shortint *str, integer *ip, complex *oxval); +extern integer getci_(integer *fd, integer *ch); +extern integer getdae_(shortint *ch); +extern integer getlie_(integer *fd, shortint *linebf); +extern integer getlle_(integer *fd, shortint *obuf, integer *maxch); +extern integer getloe_(integer *fd, shortint *obuf, integer *maxch, integer *linenm); +extern integer getner_(integer *ranges, integer *number); +extern integer getprr_(integer *ranges, integer *number); +extern integer ggcur_(integer *gp, integer *cn, integer *key, real *sx, real *sy, integer *raster, real *rx, real *ry); +extern integer ggeti_(integer *gp, shortint *cap); +extern integer ggets_(integer *gp, shortint *cap, shortint *outstr, integer *maxch); +extern integer gimgeg_(integer *gp, integer *mappig, integer *rop, integer *src, integer *st, integer *sx, integer *sy, integer *sw, integer *sh, integer *dst, integer *dt, integer *dx, integer *dy, integer *dw, integer *dh); +extern integer gimqur_(integer *gp, integer *raster, integer *type__, integer *width, integer *height, integer *depth); +extern integer gimrep_(integer *gp, integer *colorp, integer *first, integer *maxelm, integer *r__, integer *g, integer *b); +extern integer gkifen_(integer *fd, integer *instrn); +extern integer glbgek_(integer *gp, integer *ax, real *x, real *y, integer *majork); +extern integer gltoc_(integer *lval, shortint *outstr, integer *maxch, integer *base); +extern integer gmttot_(integer *gmt); +extern integer gopen_(shortint *device, integer *mode, integer *fd); +extern integer gopeni_(shortint *device, integer *mode, shortint *uifnae, integer *fd); +extern integer gpatme_(shortint *patstr, integer *from, integer *delim, shortint *patbuf, integer *szpat); +extern integer gpatmh_(shortint *str, shortint *pat, integer *firstr, integer *lastcr); +extern integer gptfit_(shortint *gki, integer *ip, integer *lastip); +extern integer gqvery_(void); +extern integer grcbol_(shortint *opstr, integer *ip); +extern integer grccod_(integer *rc, integer *stream, real *sx, real *sy, integer *raster, real *rx, real *ry, shortint *opstr); +extern integer grccur_(integer *rc, integer *stream, integer *key, real *x, real *y, integer *raster, real *rx, real *ry, integer *ppos); +extern integer grcmay_(integer *rc, integer *key, integer *nukey); +extern integer grcopn_(shortint *device, integer *mode, integer *stream, integer *rc); +extern integer grcrey_(integer *stream, shortint *prompt, shortint *obuf, integer *maxch); +extern integer grcses_(integer *tr, integer *raster, real *mx, real *my); +extern integer grdwcs_(shortint *devnae, integer *wcs, integer *lenwcs); +extern integer gstati_(integer *gp, integer *param); +extern integer gstats_(integer *gp, integer *param, shortint *outstr, integer *maxch); +extern integer gstrct_(shortint *str, shortint *outstr, integer *maxch); +extern integer gstrcy_(shortint *s1, shortint *s2, integer *maxch); +extern integer gstrdb_(shortint *line, shortint *outlie, integer *maxch, integer *tabs); +extern integer gstreb_(shortint *line, shortint *outlie, integer *maxch, integer *tabs); +extern integer gstrmh_(shortint *str, shortint *pat, integer *firstr, integer *lastcr); +extern integer gtgcu1_(integer *gt, shortint *cur, real *wx, real *wy, integer *wcs, integer *key, shortint *cmd, integer *szcmd); +extern integer gtgcur_(shortint *cur, real *wx, real *wy, integer *wcs, integer *key, shortint *cmd, integer *szcmd); +extern integer gtgeti_(integer *gt, integer *param); +extern integer gtini1_(integer *gp); +extern integer gtinit_(void); +extern integer gtndis_(real *x1, real *x2, real *step); +extern integer gtrcle_(integer *p1, integer *p2, integer *npts, integer *index, real *s, real *ref); +extern integer gtrcot_(shortint *kernfe, shortint *taskne, shortint *devnae, integer *stream, integer *in, integer *out); +extern integer gtrfen_(integer *tr, integer *gki); +extern integer gtrgty_(integer *stream); +extern integer gtrint_(integer *stream); +extern integer gtrpop_(shortint *pv, integer *npts, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer gtrrer_(integer *fd, integer *key, real *sx, real *sy, integer *raster, real *rx, real *ry); +extern integer gtrwrp_(integer *fd, integer *nchars); +extern integer gttyld_(shortint *fname, shortint *device, shortint *outstr, integer *maxch); +extern integer gtybih_(integer *capcoe, integer *tcapce, integer *ncaps); +extern integer gtycas_(integer *gty); +extern integer gtyeny_(shortint *cap); +extern integer gtyexs_(shortint *str, integer *ip, shortint *outstr, integer *maxch); +extern integer gtyfiy_(integer *tty, shortint *cap, integer *ip); +extern integer gtygei_(integer *tty, shortint *cap); +extern integer gtyges_(integer *tty, shortint *cap, shortint *outstr, integer *maxch); +extern integer gtyopn_(shortint *termce, shortint *device, shortint *ufiels); +extern integer i8sav_(integer *isw, integer *ivalue, logical *set); +extern integer iand_(integer *a, integer *b); +extern integer idbfid_(integer *im, shortint *key, integer *rp); +extern integer idbfir_(shortint *s1, shortint *s2, integer *maxch); +extern integer idbgeg_(integer *im, shortint *key, shortint *outstr, integer *maxch); +extern integer idbkwp_(shortint *key); +extern integer idbned_(integer *idb, integer *recptr); +extern integer idbopn_(integer *im, integer *ualen); +extern integer idbpug_(integer *im, shortint *key, shortint *strval); +extern integer idkopn_(integer *aframe, integer *acolor, integer *tty); +extern integer iisflu_(integer *chan); +extern integer ikiacs_(shortint *image, shortint *root, shortint *extn, integer *acmode); +extern integer ikiext_(shortint *envime, shortint *defime, shortint *envimn, shortint *defimn); +extern integer ikiged_(integer *ip, shortint *outstr, integer *maxch, integer *delim); +extern integer ikigen_(integer *kernel, integer *index, shortint *extn, integer *maxch); +extern integer ikiger_(shortint *param); +extern integer ikivan_(integer *kernel, shortint *extn); +extern integer imaccf_(integer *im, shortint *key); +extern integer imaccs_(shortint *image, integer *acmode); +extern integer imcssz_(integer *im, integer *vs, integer *ve, integer *ndim, integer *dtype, integer *npix, integer *rwflag); +extern integer imdgcr_(shortint *param, real *wx, real *wy, integer *wcs, integer *key, shortint *strval, integer *maxch); +extern integer imdges_(integer *frame, integer *server, shortint *image, integer *szimae, shortint *title, integer *sztite, real *a, real *b, real *c__, real *d__, real *tx, real *ty); +extern integer imdgsg_(shortint *cap); +extern integer imdma1_(integer *frame, integer *mode, integer *selece, integer *erase); +extern integer imdmae_(integer *frame, integer *mode, integer *selece); +extern integer imdmap_(shortint *device, integer *accese, I_fp imdopn); +extern integer imdopn_(shortint *fname, integer *accese); +extern integer imdqup_(integer *wcs, shortint *reg, real *sx, real *sy, integer *snx, integer *sny, integer *dx, integer *dy, integer *dnx, integer *dny, shortint *objref); +extern integer imdrcr_(shortint *device, real *x, real *y, integer *wcs, integer *key, shortint *strval, integer *maxch, integer *inwcs, integer *pause); +extern integer imdwcr_(void); +extern integer imgeti_(integer *im, shortint *key); +extern integer imgetl_(integer *im, shortint *key); +extern integer imgfte_(integer *im, shortint *key); +extern integer imggsc_(integer *im, integer *vs, integer *ve, integer *ndim, integer *dtype, integer *totpix); +extern integer imggsd_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer imggsi_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer imggsl_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer imggsr_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer imggss_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer imggsx_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer imgibf_(integer *im, integer *vs, integer *ve, integer *ndim, integer *dtype); +extern integer imgl1d_(integer *im); +extern integer imgl1i_(integer *im); +extern integer imgl1l_(integer *im); +extern integer imgl1r_(integer *im); +extern integer imgl1s_(integer *im); +extern integer imgl1x_(integer *im); +extern integer imgl2d_(integer *im, integer *linenm); +extern integer imgl2i_(integer *im, integer *linenm); +extern integer imgl2l_(integer *im, integer *linenm); +extern integer imgl2r_(integer *im, integer *linenm); +extern integer imgl2s_(integer *im, integer *linenm); +extern integer imgl2x_(integer *im, integer *linenm); +extern integer imgl3d_(integer *im, integer *line, integer *band); +extern integer imgl3i_(integer *im, integer *line, integer *band); +extern integer imgl3l_(integer *im, integer *line, integer *band); +extern integer imgl3r_(integer *im, integer *line, integer *band); +extern integer imgl3s_(integer *im, integer *line, integer *band); +extern integer imgl3x_(integer *im, integer *line, integer *band); +extern integer imgnfn_(integer *fn, shortint *outstr, integer *maxch); +extern integer imgnld_(integer *imdes, integer *linepr, integer *v); +extern integer imgnli_(integer *imdes, integer *linepr, integer *v); +extern integer imgnll_(integer *imdes, integer *linepr, integer *v); +extern integer imgnln_(integer *im, integer *linepr, integer *v, integer *dtype); +extern integer imgnlr_(integer *imdes, integer *linepr, integer *v); +extern integer imgnls_(integer *imdes, integer *linepr, integer *v); +extern integer imgnlx_(integer *imdes, integer *linepr, integer *v); +extern integer imgobf_(integer *im, integer *vs, integer *ve, integer *ndim, integer *dtype); +extern integer imgs1d_(integer *im, integer *x1, integer *x2); +extern integer imgs1i_(integer *im, integer *x1, integer *x2); +extern integer imgs1l_(integer *im, integer *x1, integer *x2); +extern integer imgs1r_(integer *im, integer *x1, integer *x2); +extern integer imgs1s_(integer *im, integer *x1, integer *x2); +extern integer imgs1x_(integer *im, integer *x1, integer *x2); +extern integer imgs2d_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imgs2i_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imgs2l_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imgs2r_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imgs2s_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imgs2x_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imgs3d_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imgs3i_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imgs3l_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imgs3r_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imgs3s_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imgs3x_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imloop_(integer *v, integer *vs, integer *ve, integer *vinc, integer *ndim); +extern integer immap_(shortint *imspec, integer *acmode, integer *hdrarg); +extern integer immapz_(shortint *imspec, integer *acmode, integer *hdrarg); +extern integer imnote_(integer *im, integer *v); +extern integer imofnl_(integer *im, shortint *temple, integer *sort); +extern integer imofns_(integer *im, shortint *temple); +extern integer imofnu_(integer *im, shortint *temple); +extern integer impgsd_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer impgsi_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer impgsl_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer impgsr_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer impgss_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer impgsx_(integer *imdes, integer *vs, integer *ve, integer *ndim); +extern integer impl1d_(integer *im); +extern integer impl1i_(integer *im); +extern integer impl1l_(integer *im); +extern integer impl1r_(integer *im); +extern integer impl1s_(integer *im); +extern integer impl1x_(integer *im); +extern integer impl2d_(integer *im, integer *linenm); +extern integer impl2i_(integer *im, integer *linenm); +extern integer impl2l_(integer *im, integer *linenm); +extern integer impl2r_(integer *im, integer *linenm); +extern integer impl2s_(integer *im, integer *linenm); +extern integer impl2x_(integer *im, integer *linenm); +extern integer impl3d_(integer *im, integer *line, integer *band); +extern integer impl3i_(integer *im, integer *line, integer *band); +extern integer impl3l_(integer *im, integer *line, integer *band); +extern integer impl3r_(integer *im, integer *line, integer *band); +extern integer impl3s_(integer *im, integer *line, integer *band); +extern integer impl3x_(integer *im, integer *line, integer *band); +extern integer impmmo_(integer *pl, integer *refim); +extern integer impmmp_(shortint *mask, integer *mode, integer *refim); +extern integer impmon_(shortint *mask, integer *mode, shortint *title, integer *maxch, integer *refim); +extern integer impmsr_(integer *im, integer *bp, integer *szbuf); +extern integer impnld_(integer *imdes, integer *linepr, integer *v); +extern integer impnli_(integer *imdes, integer *linepr, integer *v); +extern integer impnll_(integer *imdes, integer *linepr, integer *v); +extern integer impnln_(integer *im, integer *linepr, integer *v, integer *dtype); +extern integer impnlr_(integer *imdes, integer *linepr, integer *v); +extern integer impnls_(integer *imdes, integer *linepr, integer *v); +extern integer impnlx_(integer *imdes, integer *linepr, integer *v); +extern integer imps1d_(integer *im, integer *x1, integer *x2); +extern integer imps1i_(integer *im, integer *x1, integer *x2); +extern integer imps1l_(integer *im, integer *x1, integer *x2); +extern integer imps1r_(integer *im, integer *x1, integer *x2); +extern integer imps1s_(integer *im, integer *x1, integer *x2); +extern integer imps1x_(integer *im, integer *x1, integer *x2); +extern integer imps2d_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imps2i_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imps2l_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imps2r_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imps2s_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imps2x_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern integer imps3d_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imps3i_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imps3l_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imps3r_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imps3s_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imps3x_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern integer imsinb_(integer *im, integer *vs, integer *ve, integer *ndim); +extern integer imstai_(integer *im, integer *option); +extern integer imtgem_(integer *imt, shortint *outstr, integer *maxch); +extern integer imtlen_(integer *imt); +extern integer imtmae_(shortint *fnt, shortint *outstr, integer *maxch); +extern integer imtopn_(shortint *temple); +extern integer imtopp_(shortint *param); +extern integer imtrgm_(integer *imt, integer *index, shortint *outstr, integer *maxch); +extern integer ingetc_(integer *in, integer *param); +extern integer ingeti_(integer *in, integer *param); +extern integer ingetp_(integer *in, integer *param); +extern integer ingnd_(integer *gp, doublereal *x, doublereal *y, integer *npts, real *wx, real *wy); +extern integer ingned_(integer *in, integer *gp, integer *gt, integer *nl, doublereal *x, doublereal *y, integer *npts, integer *nvars__, real *wx, real *wy); +extern integer ingner_(integer *in, integer *gp, integer *gt, integer *nl, real *x, real *y, integer *npts, integer *nvars__, real *wx, real *wy); +extern integer ingnr_(integer *gp, real *x, real *y, integer *npts, real *wx, real *wy); +extern integer inlstd_(integer *index, shortint *outstr, integer *maxch, shortint *dict); +extern integer inlstt_(shortint *str, integer *ip, shortint *dict, integer *skip, shortint *outstr, integer *maxch); +extern integer ior_(integer *a, integer *b); +extern integer irafmn_(shortint *acmd, integer *ainchn, integer *aoutcn, integer *aerrcn, integer *adrivr, integer *adevte, integer *prtype, shortint *bkgfie, integer *jobcoe, I_fp sysruk, I_fp onenty); +extern integer isdiry_(shortint *vfn, shortint *pathne, integer *maxch); +extern integer ishift_(integer *inword, integer *n); +extern integer itoc_(integer *ival, shortint *str, integer *maxch); +extern integer iwcare_(shortint *card, integer *type__, integer *axis, integer *index); +extern integer iwfind_(integer *iw, integer *type__, integer *axis, integer *index); +extern integer iwgbis_(integer *iw, integer *ctype, integer *axis); +extern integer iwopen_(integer *ds, integer *frame, shortint *imname, integer *szimne, integer *wcssts); +extern integer iwrfis_(integer *mw, integer *im, integer *mode); +extern integer ixdecs_(shortint *rangeg, integer *ranges, integer *maxras, integer *nvalus); +extern integer ixgetr_(integer *ranges, integer *number); +extern integer kfmx_(real *rx); +extern integer kfmy_(real *ry); +extern integer kfpx_(real *rx); +extern integer kfpy_(real *ry); +extern integer kicont_(shortint *rname); +extern integer kidece_(shortint *str, integer *nchars); +extern integer kiexte_(shortint *resoue, shortint *nodene, integer *maxch, integer *nchars); +extern integer kifine_(shortint *alias); +extern integer kigetn_(integer *server, integer *oschan); +/*extern integer kigets_(void);*/ +extern integer kignoe_(shortint *rname, shortint *outstr, integer *delim); +extern integer kiloce_(shortint *node); +extern integer kimape_(shortint *name__, shortint *newnae, integer *maxch); +extern integer kimapn_(integer *chan, shortint *nodene, integer *maxch); +extern integer kiopes_(integer *node); +/*extern integer kirece_(integer *server, integer *opcode, integer *subcoe);*/ +/*extern integer kisend_(integer *server, integer *opcode, integer *subcoe);*/ +extern integer kisenv_(integer *server, integer *opcode, integer *subcoe); +extern integer kmallc_(integer *ubufp, integer *nelems, integer *dtype); +extern integer kmpx_(integer *ix); +extern integer kmpy_(integer *iy); +extern integer kpmx_(integer *ix); +extern integer kpmy_(integer *iy); +extern integer krealc_(integer *ptr, integer *aneles, integer *adtype); +extern integer ksrece_(integer *server); +extern integer kssend_(integer *server, integer *opcode, integer *subcoe); +extern integer kumx_(real *rx); +extern integer kumy_(real *ry); +extern integer kupx_(real *rx); +extern integer kupy_(real *ry); +extern integer ldecos_(shortint *rangeg, integer *ranges, integer *maxras, integer *nvalus); +extern integer lexnum_(shortint *str, integer *ipstat, integer *nchars); +extern integer lgetnr_(integer *ranges, integer *number); +extern integer lgetpr_(integer *ranges, integer *number); +extern integer lnofeh_(integer *lp, integer *line, integer *loffst, integer *ltag); +extern integer lnoopn_(integer *maxlis); +extern integer lpopen_(shortint *device, integer *mode, integer *type__); +extern integer lsttot_(integer *lst); +extern integer ltoc_(integer *lval, shortint *outstr, integer *maxch); +extern integer mallo1_(integer *outpur, integer *nelems, integer *dtype, integer *szalin, integer *fwaaln); +extern integer maskcp_(shortint *colorg); +extern integer maskcr_(integer *colors, integer *maskvl); +extern integer mefgei_(integer *mef, shortint *key); +extern integer mefgel_(integer *mef, shortint *key); +extern integer mefgnc_(integer *mef); +extern integer mefkce_(shortint *card, integer *index); +extern integer mefklx_(shortint *outstr); +extern integer meflor_(integer *mef, integer *spool, integer *group); +extern integer mefopn_(shortint *fitsfe, integer *acmode, integer *oldp); +extern integer mefpie_(integer *mef); +extern integer mefrdn_(integer *mef, integer *gn); +extern integer mefrdr_(integer *mef, integer *group, shortint *extnae, integer *extver); +extern integer mefrdv_(integer *mef, shortint *extnae, integer *extver); +extern integer mefred_(integer *fd, shortint *ibuf, shortint *obuf, integer *ncards); +extern integer mefstr_(shortint *s1, shortint *s2); +extern integer meftox_(integer *mef); +extern integer mgdptr_(integer *fwa, integer *dtype, integer *szalin, integer *fwaaln); +extern integer mgtfwa_(integer *ptr, integer *dtype); +extern integer miirec_(integer *fd, integer *spp, integer *maxchs); +extern integer miired_(integer *fd, doublereal *spp, integer *maxelm); +extern integer miirei_(integer *fd, integer *spp, integer *maxelm); +extern integer miirel_(integer *fd, integer *spp, integer *maxelm); +extern integer miirer_(integer *fd, real *spp, integer *maxelm); +extern integer miires_(integer *fd, shortint *spp, integer *maxelm); +extern integer miogld_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer miogli_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer miogll_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer mioglr_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer miogls_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer mioglx_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer mioopn_(shortint *mask, integer *flags, integer *im); +extern integer mioopo_(integer *pm, integer *im); +extern integer miopld_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer miopli_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer miopll_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer mioplr_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer miopls_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer mioplx_(integer *mp, integer *ptr, integer *mval, integer *v, integer *npix); +extern integer miosti_(integer *mp, integer *param); +extern integer msvfwa_(integer *fwa, integer *dtype, integer *szalin, integer *fwaaln); +extern integer mtcap_(shortint *mtname); +extern integer mtdevd_(shortint *iodev); +extern integer mtfile_(shortint *fname); +extern integer mtgtyn_(shortint *device, shortint *ufiels); +extern integer mtneeo_(shortint *mtname); +extern integer mtopen_(shortint *mtname, integer *acmode, integer *bufsie); +extern integer mtskid_(integer *fd, integer *nrecos); +extern integer mwalld_(integer *mw, integer *nelem); +extern integer mwalls_(integer *mw, integer *nchars); +extern integer mwcopd_(integer *mw, integer *omw, integer *ooff, integer *nelem); +extern integer mwcops_(integer *mw, integer *omw, integer *ooff); +extern integer mwfins_(integer *mw, shortint *system); +extern integer mwflop_(integer *mw, shortint *fnname); +extern integer mwgctd_(integer *act, doublereal *oltm, doublereal *oltv, integer *axtyp1, integer *axtyp2, integer *maxdim); +extern integer mwgctr_(integer *act, real *oltm, real *oltv, integer *axtyp1, integer *axtyp2, integer *maxdim); +extern integer mwnewy_(integer *omw); +extern integer mwopem_(integer *im); +extern integer mwopen_(integer *bufptr, integer *ndim); +extern integer mwrefr_(integer *mw, shortint *str); +extern integer mwsave_(integer *omw, integer *bp, integer *buflen); +extern integer mwsctn_(integer *mw, shortint *syste1, shortint *syste2, integer *axbits); +extern integer mwstai_(integer *mw, integer *param); +extern integer ndopen_(shortint *fname, integer *mode); +extern integer nerro_(integer *nerr); +extern integer nowhie_(shortint *in, shortint *out, integer *maxch); +extern integer nscan_(void); +extern integer obsgei_(integer *obs, shortint *param); +extern integer obsopn_(shortint *obsery); +extern integer obspas_(integer *obs, shortint *param); +extern integer obsvon_(shortint *obsery, integer *verboe); +extern integer oifrdr_(integer *fd, integer *im, integer *uchars, integer *htype); +extern integer onenty_(integer *prtype, shortint *bkgfie, shortint *cmd); +extern integer onenty_(integer *prtype, shortint *bkgfie, shortint *cmd); +extern integer oscmd_(shortint *cmd, shortint *infile__, shortint *outfie, shortint *errfie); +extern integer osfnlk_(shortint *osfn); +extern integer osfntt_(shortint *osfn, integer *time); +extern integer osfnuk_(shortint *osfn, integer *time); +extern integer patamh_(shortint *str, integer *from, shortint *pat); +extern integer patgel_(shortint *patstr, shortint *patbuf, integer *szpat, integer *ip, integer *op); +extern integer patgse_(shortint *pat, integer *n); +extern integer patinx_(shortint *pat, integer *n); +extern integer patloe_(shortint *ch, shortint *pat, integer *offset); +extern integer patmae_(shortint *str, shortint *pat, integer *szpat); +extern integer patmah_(shortint *str, shortint *pat); +extern integer patomh_(shortint *str, integer *ip, shortint *pat, integer *pp); +extern integer patsts_(shortint *patbuf, integer *szpat, integer *op, integer *lastop, integer *lastce); +extern integer peaks_(real *x, real *y, real *backgd, integer *npts, real *dx); +extern integer pggetd_(integer *tty, shortint *fname, integer *nchars, integer *totchs, integer *lineno, integer *fileno, integer *nfiles); +extern integer pggete_(integer *fd, shortint *lbuf); +extern integer pgpage_(integer *tty, shortint *fname, shortint *newfne, shortint *upromt, integer *clearn, integer *firste, integer *mapcc, integer *fileno, integer *nfiles, logical *redirn, integer *spoold); +extern integer pgpeed_(void); +extern integer placcs_(integer *pl, integer *v); +extern integer plallc_(integer *pl, integer *nwords); +extern integer plcome_(integer *pl1, integer *pl2, integer *outfd); +extern integer plcree_(integer *naxes, integer *axlen, integer *depth); +extern integer plempe_(integer *pl); +extern integer pll2pi_(shortint *llsrc, integer *xs, integer *pxdst, integer *npix); +extern integer pll2pl_(shortint *llsrc, integer *xs, integer *pxdst, integer *npix); +extern integer pll2ps_(shortint *llsrc, integer *xs, shortint *pxdst, integer *npix); +extern integer pll2ri_(shortint *llsrc, integer *xs, integer *rl, integer *npix); +extern integer pll2rl_(shortint *llsrc, integer *xs, integer *rl, integer *npix); +extern integer pll2rs_(shortint *llsrc, integer *xs, shortint *rl, integer *npix); +extern integer plllen_(shortint *ll); +extern integer plloop_(integer *v, integer *vs, integer *ve, integer *ndim); +extern integer plnewy_(integer *oldpl); +extern integer plopen_(integer *smp); +extern integer plp2li_(integer *pxsrc, integer *xs, shortint *lldst, integer *npix); +extern integer plp2ll_(integer *pxsrc, integer *xs, shortint *lldst, integer *npix); +extern integer plp2ls_(shortint *pxsrc, integer *xs, shortint *lldst, integer *npix); +extern integer plp2ri_(integer *pxsrc, integer *xs, integer *rl, integer *npix); +extern integer plp2rl_(integer *pxsrc, integer *xs, integer *rl, integer *npix); +extern integer plp2rs_(shortint *pxsrc, integer *xs, shortint *rl, integer *npix); +extern integer plr2li_(integer *rlsrc, integer *xs, shortint *lldst, integer *npix); +extern integer plr2ll_(integer *rlsrc, integer *xs, shortint *lldst, integer *npix); +extern integer plr2ls_(shortint *rlsrc, integer *xs, shortint *lldst, integer *npix); +extern integer plr2pi_(integer *rlsrc, integer *xs, integer *pxdst, integer *npix); +extern integer plr2pl_(integer *rlsrc, integer *xs, integer *pxdst, integer *npix); +extern integer plr2ps_(shortint *rlsrc, integer *xs, shortint *pxdst, integer *npix); +extern integer plrefe_(integer *pl, integer *v); +extern integer plrgex_(integer *plr, integer *i__, integer *j); +extern integer plropn_(integer *pl, integer *plane, integer *buflit); +extern integer plsave_(integer *pl, integer *bp, integer *buflen, integer *flags); +extern integer plstai_(integer *pl, integer *param); +extern integer pmaccs_(integer *pl, integer *v); +extern integer pmnewk_(integer *refim, integer *depth); +extern integer pmrgex_(integer *pmr, integer *i__, integer *j); +extern integer pmropn_(integer *pl, integer *plane, integer *buflit); +extern integer pmstai_(integer *pl, integer *param); +extern integer pollgs_(integer *fds); +extern integer pollon_(void); +extern integer polltt_(integer *fds, integer *fd, integer *type__); +extern integer prclcr_(integer *pid); +extern integer prcldr_(integer *job); +extern integer prcloe_(integer *pid); +extern integer prdone_(integer *job); +extern integer prenve_(integer *pid, integer *marker); +/*extern integer prfilf_(integer *fd);*/ +extern integer prfinc_(integer *pid); +extern integer prgete_(integer *fd, shortint *lbuf); +extern integer prgetr_(integer *pid, integer *stream); +extern integer propcr_(shortint *proces, integer *in, integer *out); +extern integer propdr_(shortint *proces, shortint *bkgfie, shortint *bkgmsg); +extern integer propen_(shortint *proces, integer *in, integer *out); +extern integer protet_(shortint *fname, integer *action); +extern integer prpsio_(integer *pid, integer *fd, integer *rwflag); +extern integer prstai_(integer *pid, integer *param); +extern integer pscens_(integer *ps, shortint *str); +extern integer pschwh_(shortint *ch, integer *font); +extern integer psgett_(integer *ps, shortint *fontcr); +extern integer psioit_(shortint *lbuf, integer *pseude, integer *nchars); +extern integer psopen_(integer *fd, integer *defaur); +extern integer psrjps_(integer *ps, shortint *str); +extern integer pstexh_(integer *ps, shortint *str); +extern integer qmaccs_(void); +extern integer qmgetc_(integer *fd, integer *ch); +extern integer qmsetr_(integer *uservl, integer *defval); +extern integer qmspai_(integer *uservl, integer *defval); +extern integer qmsymb_(integer *qm); +extern integer qpaccf_(integer *qp, shortint *param); +extern integer qpaccs_(shortint *poefie, integer *mode); +extern integer qpargt_(integer *gt, shortint *argbuf, integer *maxch); +extern integer qpctod_(shortint *str, integer *ip, doublereal *dval); +extern integer qpctoi_(shortint *str, integer *ip, integer *ival); +extern integer qpdtye_(integer *qp, shortint *datate, integer *dsym); +extern integer qpelee_(integer *qp, shortint *datate, integer *reftye); +extern integer qpexad_(integer *ex, shortint *attrie, integer *xs, integer *xe, integer *xlen); +extern integer qpexai_(integer *ex, shortint *attrie, integer *xs, integer *xe, integer *xlen); +extern integer qpexar_(integer *ex, shortint *attrie, integer *xs, integer *xe, integer *xlen); +extern integer qpexcd_(integer *ex, shortint *atname, shortint *assigp, shortint *expr, integer *offset, integer *dtype); +extern integer qpexci_(integer *ex, shortint *atname, shortint *assigp, shortint *expr, integer *offset, integer *dtype); +extern integer qpexcr_(integer *ex, shortint *atname, shortint *assigp, shortint *expr, integer *offset, integer *dtype); +extern integer qpexdc_(integer *ex, integer *nelem, integer *dtype); +extern integer qpexdr_(integer *ex, shortint *strval); +extern integer qpexee_(integer *ex, integer *iev, integer *oev, integer *nev); +extern integer qpexge_(integer *ex, shortint *attrie, shortint *outstr, integer *maxch); +extern integer qpexgr_(integer *ex, shortint *outstr, integer *maxch); +extern integer qpexmr_(integer *ex, shortint *exprlt); +extern integer qpexon_(integer *qp, shortint *expr); +extern integer qpexpd_(shortint *expr, integer *xs, integer *xe, integer *xlen); +extern integer qpexpi_(shortint *expr, integer *xs, integer *xe, integer *xlen); +extern integer qpexpr_(shortint *expr, integer *xs, integer *xe, integer *xlen); +extern integer qpexps_(integer *ex); +extern integer qpexpt_(integer *qp, shortint *s1, shortint *s2, integer *maxch); +extern integer qpexrd_(integer *ex, doublereal *value); +extern integer qpexsd_(doublereal *x1, doublereal *x2, doublereal *xs, doublereal *xe, integer *nrangs, integer *ip, doublereal *oxs, doublereal *oxe); +extern integer qpexsi_(integer *x1, integer *x2, integer *xs, integer *xe, integer *nrangs, integer *ip, integer *oxs, integer *oxe); +extern integer qpexsr_(real *x1, real *x2, real *xs, real *xe, integer *nrangs, integer *ip, real *oxs, real *oxe); +extern integer qpgeti_(integer *qp, shortint *param); +extern integer qpgetk_(integer *gt, shortint *tokbuf, integer *maxch); +extern integer qpgetl_(integer *qp, shortint *param); +extern integer qpgetm_(integer *qp, shortint *param, integer *opp); +extern integer qpgmsm_(integer *qp, shortint *macro, integer *textp); +extern integer qpgnfn_(integer *fl, shortint *outstr, integer *maxch); +extern integer qpgpsm_(integer *qp, shortint *param); +extern integer qpgstr_(integer *qp, shortint *param, shortint *outstr, integer *maxch); +extern integer qpioge_(integer *io, integer *vs, integer *ve, integer *maxdim); +extern integer qpiogr_(integer *io, shortint *outstr, integer *maxch); +extern integer qpiols_(integer *io); +extern integer qpioon_(integer *qp, shortint *paramx, integer *mode); +extern integer qpiope_(integer *io, shortint *expr, integer *filter, integer *szfilr, shortint *mask, integer *szmask); +extern integer qpiori_(integer *io, integer *obuf, integer *vs, integer *ve, integer *ndim, real *xblock, real *yblock); +extern integer qpiors_(integer *io, shortint *obuf, integer *vs, integer *ve, integer *ndim, real *xblock, real *yblock); +extern integer qpiort_(integer *io, integer *evi); +extern integer qpiost_(integer *io, integer *param); +extern integer qplenf_(integer *qp, shortint *param); +extern integer qplenl_(integer *fl); +extern integer qploas_(integer *qp); +extern integer qpmaxi_(integer *x, integer *y); +extern integer qpmini_(integer *x, integer *y); +extern integer qpnexk_(integer *gt); +extern integer qpofnl_(integer *qp, shortint *temple, logical *sort); +extern integer qpofns_(integer *qp, shortint *temple); +extern integer qpofnu_(integer *qp, shortint *temple); +extern integer qpopen_(shortint *poefie, integer *mode, integer *oqp); +extern integer qpopet_(integer *qp, shortint *text); +extern integer qpparl_(integer *qp, shortint *fieldt, integer *dd); +extern integer qppopn_(integer *qp, shortint *param, integer *mode, integer *type__); +extern integer qpputm_(integer *qp, shortint *param, integer *opp); +extern integer qpquef_(integer *qp, shortint *param, shortint *datate, integer *maxelm, shortint *commet, integer *flags); +extern integer qprawk_(integer *gt, shortint *outstr, integer *maxch); +extern integer qpread_(integer *qp, shortint *param, shortint *buf, integer *maxelm, integer *first, shortint *datate); +extern integer qprlmd_(integer *os, integer *oe, integer *olen, doublereal *xs, doublereal *xe, integer *nx, doublereal *ys, doublereal *ye, integer *ny); +extern integer qprlmi_(integer *os, integer *oe, integer *olen, integer *xs, integer *xe, integer *nx, integer *ys, integer *ye, integer *ny); +extern integer qprlmr_(integer *os, integer *oe, integer *olen, real *xs, real *xe, integer *nx, real *ys, real *ye, integer *ny); +extern integer qpsizf_(integer *qp, integer *dtype, integer *dsym, integer *reftye); +extern integer qpstai_(integer *qp, integer *param); +extern integer rcursr_(integer *stream, shortint *outstr, integer *maxch); +extern integer rdukey_(shortint *keystr, integer *maxch); +extern integer reopen_(integer *fd, integer *mode); +extern integer rgence_(integer *rg, shortint *outstr, integer *maxch); +extern integer rginre_(integer *rg, integer *rval); +extern integer rgintt_(integer *rg1, integer *rg2); +extern integer rgnext_(integer *rg, integer *number); +extern integer rgrans_(shortint *rstr, integer *rmin, integer *rmax); +extern integer rgunin_(integer *rg1, integer *rg2); +extern integer rgwinw_(integer *rg, integer *rmin, integer *rmax); +extern integer rgxrad_(shortint *rstr, doublereal *rvals, integer *npts); +extern integer rgxrar_(shortint *rstr, real *rvals, integer *npts); +extern integer rmopen_(integer *box, shortint *type__, integer *ndatas, integer *pixtye); +extern integer rmsopn_(integer *box, integer *type__, real *data); +extern integer rmtopn_(integer *box, real *data); +extern integer rnginx_(integer *rg, integer *ival, real *rval); +extern integer rngopn_(shortint *rstr, real *r1, real *r2, real *dr); +extern integer sgeexe_(shortint *progrm, shortint *memory, integer *regiss); +extern integer sgfger_(integer *fd, shortint *svbuf, integer *sp, shortint *buf, integer *ip, integer *maxch, integer *nchars); +extern integer sgidrr_(shortint *ch, integer *x, integer *y, integer *xsize, integer *ysize, integer *orien, integer *font); +extern integer sgigeg_(integer *maxlen, logical *penup, integer *ltype); +extern integer sgigsg_(shortint *cap); +extern integer sgkopn_(shortint *device, integer *tty); +extern integer siblki_(integer *im, integer *x1, integer *x2, integer *y, integer *xbavg, integer *ybavg); +extern integer siblkr_(integer *im, integer *x1, integer *x2, integer *y, integer *xbavg, integer *ybavg); +extern integer siblks_(integer *im, integer *x1, integer *x2, integer *y, integer *xbavg, integer *ybavg); +extern integer siblmi_(integer *im, integer *fp, integer *x1, integer *x2, integer *y, integer *xbavg, integer *ybavg, integer *order); +extern integer siblmr_(integer *im, integer *fp, integer *x1, integer *x2, integer *y, integer *xbavg, integer *ybavg, integer *order); +extern integer siblms_(integer *im, integer *fp, integer *x1, integer *x2, integer *y, integer *xbavg, integer *ybavg, integer *order); +extern integer skcopy_(integer *cooin); +extern integer skdecm_(integer *im, shortint *wcs, integer *mw, integer *coo); +extern integer skdecr_(shortint *instr, integer *coo, integer *imcoo); +extern integer skdecs_(shortint *instr, integer *mw, integer *coo, integer *imcoo); +extern integer skimws_(integer *im, integer *mw, integer *ctype, integer *lngax, integer *latax, integer *wtype, integer *radecs, doublereal *equinx, doublereal *epoch); +extern integer skstai_(integer *coo, integer *param); +extern integer skstrs_(shortint *instr, integer *ctype, integer *radecs, doublereal *equinx, doublereal *epoch); +extern integer skwrdr_(integer *index, shortint *outstr, integer *maxch, shortint *dict); +extern integer stallc_(integer *stp, integer *blklen); +extern integer stentr_(integer *stp, shortint *key, integer *usymln); +extern integer stfcte_(shortint *card, integer *index); +extern integer stfind_(integer *stp, shortint *key); +extern integer stfinl_(integer *stp, shortint *key, integer *symbos, integer *maxsys); +extern integer stgene_(shortint *progrm, shortint *memory, integer *regiss); +extern integer stggee_(integer *fd, shortint *obuf); +extern integer stggsg_(shortint *cap); +extern integer stgmsn_(integer *fd); +extern integer stgrey_(integer *fd, shortint *obuf, integer *maxch); +extern integer stgtxe_(integer *pksize); +extern integer sthash_(shortint *key, integer *moduls); +extern integer sthead_(integer *stp); +extern integer stname_(integer *stp, integer *sym); +extern integer stnext_(integer *stp, integer *sym); +extern integer stnsys_(integer *stp, integer *marker); +extern integer stopen_(shortint *name__, integer *leninx, integer *lenstb, integer *szsbuf); +extern integer stpstr_(integer *stp, shortint *str, integer *minchs); +extern integer strdic_(shortint *instr, shortint *outstr, integer *maxchs, shortint *dict); +extern integer strefb_(integer *stp, integer *offset); +extern integer streff_(integer *stp, integer *offset); +extern integer strese_(integer *fd); +extern integer strgee_(integer *fd); +extern integer strids_(shortint *set, shortint *str); +extern integer stridx_(shortint *ch, shortint *str); +extern integer strlds_(shortint *set, shortint *str); +extern integer strldx_(shortint *ch, shortint *str); +extern integer strmac_(shortint *macro, shortint *argstr, shortint *outstr, integer *maxch); +extern integer strmah_(shortint *str, shortint *pat); +extern integer strncp_(shortint *s1, shortint *s2, integer *n); +extern integer stropn_(shortint *str, integer *maxch, integer *mode); +extern integer strseh_(shortint *str, shortint *patstr); +extern integer stsize_(integer *stp); +extern integer sttygg_(shortint *args, integer *ip, shortint *keyw, integer *maxkc, shortint *value, integer *maxvc, integer *defact, integer *yesno); +extern integer sysged_(integer *fd, shortint *cmd, shortint *taskne, integer *arglit, integer *timeit, integer *prtype); +extern integer syshot_(shortint *keyfi1, shortint *keyfi2, shortint *parfie, shortint *showpt, logical *showvl); +extern integer sysruk_(shortint *task, shortint *cmd, integer *rukarf, integer *rukint); +extern integer sysruk_(shortint *task, shortint *cmd, integer *rukarf, integer *rukint); +extern integer ttopen_(shortint *termil, integer *mode); +extern integer ttstai_(integer *fd, integer *param); +extern integer ttstas_(integer *fd, integer *param, shortint *outstr, integer *maxch); +extern integer ttybih_(integer *capcoe, integer *tcapce, integer *ncaps); +extern integer ttycas_(integer *tty); +extern integer ttyctl_(integer *fd, integer *tty, shortint *cap, integer *afflnt); +extern integer ttyeny_(shortint *cap); +extern integer ttyexs_(shortint *str, integer *ip, shortint *outstr, integer *maxch); +extern integer ttyfiy_(integer *tty, shortint *cap, integer *ip); +extern integer ttygds_(shortint *ttynae); +extern integer ttygei_(integer *tty, shortint *cap); +extern integer ttyges_(integer *tty, shortint *cap, shortint *outstr, integer *maxch); +extern integer ttylod_(shortint *fname, shortint *device, shortint *outstr, integer *maxch); +extern integer ttyods_(shortint *ttynae); +extern integer ttyopn_(shortint *termce, shortint *device, I_fp ttylod); +extern integer ttyred_(integer *fd, integer *tty, shortint *outbuf, integer *maxch, shortint *patbuf, integer *timeot); +extern integer ttysti_(integer *tty, integer *paramr); +extern integer ttysui_(shortint *ctrlsr, shortint *outstr, integer *maxch, integer *coords, integer *ncoors); +extern integer vfnadd_(integer *vfd, shortint *osfn, integer *maxch); +extern integer vfndee_(shortint *osfn, integer *ip, shortint *outstr, integer *maxch); +extern integer vfndel_(integer *vfd, shortint *osfn, integer *maxch); +extern integer vfnenr_(integer *vfd, shortint *osfn, integer *maxch); +extern integer vfngen_(integer *vfd, shortint *vfn, shortint *osfn, integer *maxch); +extern integer vfnise_(shortint *fname); +extern integer vfnmap_(integer *vfd, shortint *osfn, integer *maxch); +extern integer vfnmau_(integer *vfd, shortint *osfn, integer *maxch); +extern integer vfnopn_(shortint *vfn, integer *mode); +extern integer vfnunp_(integer *vfd, shortint *osfn, shortint *vfn, integer *maxch); +extern integer vvfncm_(shortint *a, integer *nchars); +extern integer wfgson_(shortint *atstr); +extern integer wfsmph_(doublereal *x, doublereal *v, integer *npts); +extern integer wlcree_(void); +extern integer wldir1_(integer *wlct, integer *flip, doublereal *polepn, logical *north, doublereal *polarn, doublereal *lbegin, doublereal *lend, doublereal *screey); +extern integer wlfine_(doublereal *x, doublereal *y, doublereal *screey); +extern integer wlfuln_(integer *wd, integer *labels, integer *nlabes, integer *axis, integer *side, integer *precin); +extern integer wlline_(shortint *linetg); +extern integer wlmaxy_(doublereal *array, integer *npts); +extern integer wloppe_(integer *side); +extern integer wlpren_(integer *wd, integer *axis); +extern integer xalloe_(shortint *device); +extern integer xdeale_(shortint *device, integer *rewind); +extern integer xdevor_(shortint *device, shortint *owner, integer *maxch); +extern integer xerpoi_(void); +extern integer xfaccs_(shortint *fname, integer *mode, integer *type__); +extern integer xfnote_(integer *fd); +extern integer xfopen_(shortint *fname, integer *mode, integer *type__); +extern integer xfpoll_(integer *fds, integer *nfds, integer *timeot); +extern integer xfread_(integer *fd, shortint *buffer, integer *maxchs); +extern integer xfscan_(integer *fd); +extern integer xgdevt_(shortint *device, shortint *outstr, integer *maxch, integer *onedev); +extern integer xgtpid_(void); +extern integer xisaty_(integer *fd); +extern integer xnint_(doublereal *x); +extern integer xsizef_(integer *dtype); +extern integer xstrcp_(shortint *s1, shortint *s2); +extern integer xstrln_(shortint *str); +extern integer xtargn_(shortint *argstr); +extern integer xtbaon_(integer *nc, integer *nl, integer *maxval); +extern integer xtext1_(shortint *files, shortint *exttye, shortint *index, shortint *extnae, shortint *extver, integer *lindex, integer *lname, integer *lver, shortint *ikpars, integer *err); +extern integer xtexts_(shortint *files, shortint *exttye, shortint *index, shortint *extnae, shortint *extver, integer *lindex, integer *lname, integer *lver, integer *datals, shortint *ikpars, integer *err, integer *imext); +extern integer xtfpd_(integer *fp, integer *im, integer *line, integer *fd); +extern integer xtfpi_(integer *fp, integer *im, integer *line, integer *fd); +extern integer xtfpit_(integer *pm, integer *lvalin, integer *cvalin); +extern integer xtfpl_(integer *fp, integer *im, integer *line, integer *fd); +extern integer xtfpr_(integer *fp, integer *im, integer *line, integer *fd); +extern integer xtfps_(integer *fp, integer *im, integer *line, integer *fd); +extern integer xtfpsd_(integer *fp, integer *im, integer *line, integer *col1, integer *col2, integer *line1, integer *line2, integer *fd); +extern integer xtfpsi_(integer *fp, integer *im, integer *line, integer *col1, integer *col2, integer *line1, integer *line2, integer *fd); +extern integer xtfpsl_(integer *fp, integer *im, integer *line, integer *col1, integer *col2, integer *line1, integer *line2, integer *fd); +extern integer xtfpsr_(integer *fp, integer *im, integer *line, integer *col1, integer *col2, integer *line1, integer *line2, integer *fd); +extern integer xtfpss_(integer *fp, integer *im, integer *line, integer *col1, integer *col2, integer *line1, integer *line2, integer *fd); +extern integer xtfpvd_(integer *fp, integer *im, integer *line); +extern integer xtfpvi_(integer *fp, integer *im, integer *line); +extern integer xtfpvl_(integer *fp, integer *im, integer *line); +extern integer xtfpvr_(integer *fp, integer *im, integer *line); +extern integer xtfpvs_(integer *fp, integer *im, integer *line); +extern integer xtimes_(shortint *files, shortint *index, shortint *extnae, shortint *extver, integer *lindex, integer *lname, integer *lver, shortint *ikpars, integer *err); +extern integer xtimtm_(integer *list1, integer *list2, integer *list3, shortint *image1, shortint *image2, shortint *image3, integer *szimae); +extern integer xtlogn_(shortint *logpam, shortint *prefix, integer *logfd, integer *stdflg); +extern integer xtoc_(complex *xval, shortint *outstr, integer *maxch, integer *decpl, integer *fmt, integer *width); +extern integer xtsamd_(integer *im, integer *bpm, doublereal *sample, integer *nsampe, integer *nlines); +extern integer xtsami_(integer *im, integer *bpm, integer *sample, integer *nsampe, integer *nlines); +extern integer xtsamr_(integer *im, integer *bpm, real *sample, integer *nsampe, integer *nlines); +extern integer xtsams_(integer *im, integer *bpm, shortint *sample, integer *nsampe, integer *nlines); +extern integer xtscod_(integer *i__, integer *j); +extern integer xtscoe_(integer *i__, integer *j); +extern integer xttxtn_(shortint *fname); +extern integer xvvnee_(integer *type1, integer *type2); +extern integer xvvpah_(shortint *str, shortint *pat); +extern integer xxscan_(void); +extern integer ytfpit_(integer *pmin, integer *lvalin, integer *cvalin); +extern integer zsccoa_(real *a, shortint *badpix, integer *npix, real *mean, real *sigma); +extern integer zscfie_(real *data, integer *npix, real *zstart, real *zslope, real *krej, integer *ngrow, integer *maxitr); +extern integer zscpmn_(shortint *sectin, integer *refim); +extern integer zscres_(real *data, real *flat, real *normx, shortint *badpix, integer *npix, doublereal *sumxsr, doublereal *sumxz, doublereal *sumx, doublereal *sumz, real *thresd, integer *ngrow); +extern integer zttger_(integer *chan, integer *ch); +extern integer zttloe_(shortint *in, shortint *out, integer *nchars); +extern integer zttquy_(shortint *logtet, integer *nchars, shortint *dtext, integer *maxch, integer *szdtet); +extern logical aveqc_(shortint *a, shortint *b, integer *npix); +extern logical aveqd_(doublereal *a, doublereal *b, integer *npix); +extern logical aveqi_(integer *a, integer *b, integer *npix); +extern logical aveql_(integer *a, integer *b, integer *npix); +extern logical aveqr_(real *a, real *b, integer *npix); +extern logical aveqs_(shortint *a, shortint *b, integer *npix); +extern logical aveqx_(complex *a, complex *b, integer *npix); +extern logical clgetb_(shortint *param); +extern logical clgpsb_(integer *pp, shortint *parnae); +extern logical envgeb_(shortint *varnae); +extern logical fmlocd_(integer *fm, integer *lfile); +extern logical fnulle_(shortint *fname); +extern logical fpequd_(doublereal *x, doublereal *y); +extern logical fpequr_(real *x, real *y); +extern logical fpnonr_(real *x1, real *x2); +extern logical fxffpd_(doublereal *x, doublereal *y, integer *it); +extern logical fxfisk_(shortint *line); +extern logical fxfxn1_(shortint *buf, integer *dataln); +extern logical ggetb_(integer *gp, shortint *cap); +extern logical glbeq_(real *a, real *b); +extern logical gtygeb_(integer *tty, shortint *cap); +extern logical imgetb_(integer *im, shortint *key); +extern logical impml1_(integer *im); +extern logical impml2_(integer *im, integer *lineno); +extern logical impml3_(integer *im, integer *lineno, integer *bandno); +extern logical impmlv_(integer *im, integer *v); +extern logical impms1_(integer *im, integer *x1, integer *x2); +extern logical impms2_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2); +extern logical impms3_(integer *im, integer *x1, integer *x2, integer *y1, integer *y2, integer *z1, integer *z2); +extern logical impmsv_(integer *im, integer *vs, integer *ve, integer *ndim); +extern logical isinre_(integer *ranges, integer *number); +extern logical itob_(integer *intege); +extern logical lisine_(integer *ranges, integer *number); +extern logical mefcmv_(integer *mef, shortint *extnae, integer *extver); +extern logical mefgeb_(integer *mef, shortint *key); +extern logical plempy_(integer *pl); +extern logical pllcot_(shortint *llsrc, integer *xs, integer *npix, integer *mval); +extern logical pllemy_(shortint *llsrc, integer *xs, integer *npix); +extern logical plleql_(shortint *l1, shortint *l2); +extern logical plliny_(integer *pl, integer *v); +extern logical plreqi_(integer *r1, integer *r2); +extern logical plreql_(integer *r1, integer *r2); +extern logical plreqs_(shortint *r1, shortint *r2); +extern logical plsect_(integer *plsrc, integer *v1, integer *v2, integer *ndim, integer *mval); +extern logical plsecy_(integer *plsrc, integer *v1, integer *v2, integer *ndim); +extern logical plubox_(integer *ufd, integer *y, integer *rlreg, integer *xs, integer *npix); +extern logical plucie_(integer *ufd, integer *y, integer *rlreg, integer *xs, integer *npix); +extern logical plupon_(integer *ufd, integer *line, integer *rlreg, integer *xs, integer *npix); +extern logical pmempy_(integer *pl); +extern logical pmliny_(integer *pl, integer *v); +extern logical pmsect_(integer *pl, integer *vs, integer *ve, integer *ndim, integer *mval); +extern logical pmsecy_(integer *pl, integer *vs, integer *ve, integer *ndim); +extern logical qpgetb_(integer *qp, shortint *param); +extern logical qplesd_(doublereal *x, doublereal *y); +extern logical qplesi_(integer *x, integer *y); +extern logical qplesr_(real *x, real *y); +extern logical rngeli_(integer *rg, integer *x); +extern logical rngelr_(integer *rg, real *x, real *delta); +extern logical rngini_(integer *rg, integer *x); +extern logical rnginr_(integer *rg, real *x); +extern logical sgewse_(void); +extern logical sgmexe_(integer *fn, shortint *gim, integer *nwords); +extern logical sgmspc_(integer *tr, integer *gki, integer *fn, shortint *gim, integer *bp, integer *buftop, integer *deletn); +extern logical sgmwse_(logical *enable); +extern logical sgmwsn_(integer *fn, shortint *gim, real *rx1, real *ry1, real *rx2, real *ry2); +extern logical streq_(shortint *s1, shortint *s2); +extern logical strge_(shortint *s1, shortint *s2); +extern logical strgt_(shortint *s1, shortint *s2); +extern logical strle_(shortint *s1, shortint *s2); +extern logical strlt_(shortint *s1, shortint *s2); +extern logical strne_(shortint *s1, shortint *s2); +extern logical strse1_(shortint *str, shortint *patstr, integer *patlen); +extern logical ttygeb_(integer *tty, shortint *cap); +extern logical xerpop_(void); +extern logical xtexth_(shortint *extnae, shortint *pattes); +extern logical xtimlq_(integer *im1, integer *im2); +extern logical xtimnq_(shortint *imnam1, shortint *imnam2); +extern real adoti_(integer *a, integer *b, integer *npix); +extern real adotr_(real *a, real *b, integer *npix); +extern real adots_(shortint *a, shortint *b, integer *npix); +extern real adotx_(complex *a, complex *b, integer *npix); +extern real aelogr_(real *x); +extern real agmaxi_(real *sval, real *zhgh, real *zdra, integer *nviz, integer *iivz, integer *nevz, integer *iiez); +extern real agmini_(real *sval, real *zlow, real *zdra, integer *nviz, integer *iivz, integer *nevz, integer *iiez); +extern real ahivr_(real *a, integer *npix); +extern real alovr_(real *a, integer *npix); +extern real amedr_(real *a, integer *npix); +extern real apolr_(real *x, real *coeff, integer *ncoeff); +extern real asokr_(real *a, integer *npix, integer *ksel); +extern real assqi_(integer *a, integer *npix); +extern real assqr_(real *a, integer *npix); +extern real assqs_(shortint *a, integer *npix); +extern real asumi_(integer *a, integer *npix); +extern real asumr_(real *a, integer *npix); +extern real asums_(shortint *a, integer *npix); +extern real c1dcer_(real *x, real *data, integer *npts, real *width); +extern real cented_(real *x, real *data, integer *npts, real *width, integer *type__, real *radius, real *thresd); +extern real cfux_(real *rx); +extern real cfuy_(real *ry); +extern real clgetr_(shortint *param); +extern real clgpsr_(integer *pp, shortint *parnae); +extern real cmfx_(integer *ix); +extern real cmfy_(integer *iy); +extern real cmux_(integer *ix); +extern real cmuy_(integer *iy); +extern real concom_(real *xq, real *yq, real *xd, real *yd, real *zd, integer *ndp, real *wk, integer *iwk, integer *loc); +extern real conlcm_(real *x, real *y, real *xd, real *yd, real *zd, integer *ndp, real *wk, integer *iwk, integer *loc); +extern real cpfx_(integer *ix); +extern real cpfy_(integer *iy); +extern real cpux_(integer *ix); +extern real cpuy_(integer *iy); +extern real cqdger_(integer *cq, integer *record, shortint *field); +extern real cqfger_(integer *cq, shortint *field); +extern real cqistr_(integer *res, integer *param); +extern real cqrstr_(integer *res, integer *param); +extern real cufx_(real *rx); +extern real cufy_(real *ry); +extern real dtgetr_(integer *dt, integer *record, shortint *field); +extern real elogr_(real *x); +extern real envger_(shortint *varnae); +extern real fpfixr_(real *x); +extern real fran_(void); +extern real gammln_(real *xx); +extern real gasdev_(integer *seed); +extern real ggetr_(integer *gp, shortint *cap); +extern real glbmip_(real *x1, real *x2, integer *nminor); +extern real glbtin_(integer *gp, integer *ax, real *ndcleh); +extern real grcrel_(shortint *opstr, integer *ip); +extern real gstatr_(integer *gp, integer *param); +extern real gtdise_(real *x, real *step, real *nearek); +extern real gtgetr_(integer *gt, integer *param); +extern real gtliny_(real *x1, real *x2); +extern real gtxctn_(integer *gp, real *x1, integer *wcs1, integer *wcs2); +extern real gtyctn_(integer *gp, real *y1, integer *wcs1, integer *wcs2); +extern real gtyger_(integer *tty, shortint *cap); +extern real icrmsr_(real *x, real *y, real *fit, real *wts, integer *npts); +extern real imgetr_(integer *im, shortint *key); +extern real imstar_(integer *im, integer *param); +extern real ingdvr_(real *x); +extern real ingetr_(integer *in, integer *param); +extern real inrmsr_(real *y, real *fit, real *wts, integer *npts); +extern real mefger_(integer *mef, shortint *key); +extern real mwc1tr_(integer *act, real *x); +extern real obsger_(integer *obs, shortint *param); +extern real poidev_(real *xm, integer *seed); +extern real qmspar_(real *uservl, real *defval); +extern real qpgetr_(integer *qp, shortint *param); +extern real qpiovr_(integer *io, integer *param); +extern real qpmaxr_(real *x, real *y); +extern real qpminr_(real *x, real *y); +extern real qpstar_(integer *qp, integer *param); +extern real rmgdaa_(integer *rm, integer *index); +extern real rmgmed_(integer *rm, real *nclip, integer *navg, real *blank, integer *exclue, shortint *nused); +extern real rmmed_(integer *rm, real *nclip, integer *navg, real *blank, integer *exclue, integer *index, real *in, shortint *mask, shortint *nused); +extern real rmsord_(integer *rm, real *nclip, integer *index, real *data); +extern real rmturh_(integer *rm, integer *index, real *data); +extern real rngnet_(integer *rg, real *x, integer *ival, real *rval); +extern real rpthe4_(real *p1x, real *p1y, real *p2x, real *p2y); +extern real ttyger_(integer *tty, shortint *cap); +extern real wldisr_(real *x1, real *y1, real *x2, real *y2); +extern shortint ahivc_(shortint *a, integer *npix); +extern shortint ahivs_(shortint *a, integer *npix); +extern shortint alovc_(shortint *a, integer *npix); +extern shortint alovs_(shortint *a, integer *npix); +extern shortint amedc_(shortint *a, integer *npix); +extern shortint ameds_(shortint *a, integer *npix); +extern shortint asokc_(shortint *a, integer *npix, integer *ksel); +extern shortint asoks_(shortint *a, integer *npix, integer *ksel); +extern shortint chfeth_(shortint *str, integer *ip, shortint *ch); +extern shortint chrlwr_(shortint *ch); +extern shortint chrupr_(shortint *ch); +extern shortint clgetc_(shortint *param); +extern shortint clgets_(shortint *param); +extern shortint clgpsc_(integer *pp, shortint *parnae); +extern shortint clgpss_(integer *pp, shortint *parnae); +extern shortint cqitye_(integer *itype); +extern shortint imgetc_(integer *im, shortint *key); +extern shortint imgets_(integer *im, shortint *key); +extern shortint mefgec_(integer *mef, shortint *key); +extern shortint mefges_(integer *mef, shortint *key); +extern shortint psfonr_(integer *ps, integer *font); +extern shortint qpgetc_(integer *qp, shortint *param); +extern shortint qpgets_(integer *qp, shortint *param); +extern shortint xfgetc_(integer *fd, shortint *ch); +extern shortint xfgetr_(shortint *ch); +extern int bitmov_(integer *a, integer *aoff, integer *b, integer *boff, integer *nbits); +extern int bswap2_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int bswap4_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int bytmov_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int chrpak_(shortint *a, integer *aoff, char *b, integer *boff, integer *nchars, ftnlen b_len); +extern int chrupk_(char *a, integer *aoff, shortint *b, integer *boff, integer *nchars, ftnlen a_len); +extern int f77pak_(shortint *sppstr, char *f77str, integer *maxch, ftnlen f77str_len); +extern int f77upk_(char *f77str, shortint *sppstr, integer *maxch, ftnlen f77str_len); +extern int ieevpd_(doublereal *native, doublereal *ieee, integer *nelem); +extern int ieevud_(doublereal *ieee, doublereal *native, integer *nelem); +extern int ieepad_(doublereal *x); +extern int ieeupd_(doublereal *x); +extern int ieesnd_(doublereal *x); +extern int ieegnd_(doublereal *x); +extern int ieestd_(integer *onin, integer *onout); +extern int ieezsd_(void); +extern int ieemad_(integer *inval, integer *outval); +extern int ieegmd_(integer *inval, integer *outval); +extern int ieesmd_(integer *inval, integer *outval); +extern int ieevpr_(real *native, real *ieee, integer *nelem); +extern int ieevur_(real *ieee, real *native, integer *nelem); +extern int ieepar_(real *x); +extern int ieeupr_(real *x); +extern int ieesnr_(real *x); +extern int ieegnr_(real *x); +extern int ieestr_(integer *onin, integer *onout); +extern int ieezsr_(void); +extern int ieemar_(integer *inval, integer *outval); +extern int ieegmr_(integer *inval, integer *outval); +extern int ieesmr_(integer *inval, integer *outval); +extern integer miilen_(integer *nelems, integer *miidae); +extern integer miinem_(integer *nchars, integer *miitye); +extern int miipak_(integer *spp, integer *mii, integer *nelems, integer *sppdae, integer *miidae); +extern int miipa6_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipa2_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipa8_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipad_(integer *spp, doublereal *mii, integer *nelems, integer *sppdae); +extern int miipar_(integer *spp, real *mii, integer *nelems, integer *sppdae); +extern integer miipke_(integer *nelems, integer *miitye); +extern int miiupk_(integer *mii, integer *spp, integer *nelems, integer *miidae, integer *sppdae); +extern int miiup6_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiup2_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiup8_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiupd_(doublereal *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiupr_(real *mii, integer *spp, integer *nelems, integer *sppdae); +extern integer nmilen_(integer *nelems, integer *nmidae); +extern integer nminem_(integer *nchars, integer *nmitye); +extern int nmipak_(integer *spp, integer *nmi, integer *nelems, integer *sppdae, integer *nmidae); +extern int nmipa6_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipa2_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipa8_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipad_(integer *spp, doublereal *nmi, integer *nelems, integer *sppdae); +extern int nmipar_(integer *spp, real *nmi, integer *nelems, integer *sppdae); +extern integer nmipke_(integer *nelems, integer *nmitye); +extern int nmiupk_(integer *nmi, integer *spp, integer *nelems, integer *nmidae, integer *sppdae); +extern int nmiup6_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiup2_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiup8_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiupd_(doublereal *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiupr_(real *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int strpak_(shortint *instr, char *outstr, integer *maxch, ftnlen outstr_len); +extern int strupk_(char *instr, shortint *outstr, integer *maxch, ftnlen instr_len); +extern real urand_(integer *lseed); +extern integer xori_(integer *a, integer *b); +extern shortint xors_(shortint *a, shortint *b); +extern integer xorl_(integer *a, integer *b); +extern integer sysruk_(shortint *task, shortint *cmd, integer *rukarf, integer *rukint); +extern int sbit_(void); +extern int tbit_(void); diff --git a/unix/hlib/libc/xnames.h b/unix/hlib/libc/xnames.h new file mode 100644 index 00000000..a99e12b6 --- /dev/null +++ b/unix/hlib/libc/xnames.h @@ -0,0 +1,244 @@ +/* + * XNAMES.H -- C callable external names of the SPP library procedures. + * The C version of the name is identical to the SPP name except that it is + * given as a macro in upper case. The definition is the host system external + * name of the Fortran procedure. The trailing underscore in these names is + * UNIX dependent; other systems use a leading underscore, or no special + * characters at all (the purpose of the underscore on UNIX systems is to + * avoid name collisions between C and Fortran procedures, since the F77 + * runtime library on UNIX is built on the UNIX/C library). Change the names + * in the column at the right if your system employs a different convention. + * + * If your system does not employ something like the underscore to avoid + * name collisions, name collisions can be expected. To fix these change + * the name given here and add a define to lib$iraf.h to change the external + * name generated by the preprocessor. It is NOT necessary to resolve name + * collisions by changing the actual program sources. + * + * The external names defined herein MUST agree with those in "hlib$iraf.h". + */ + +#define ACCESS xfaccs_ /* to avoid name collisions */ +#define CALLOC xcallc_ +#define CLOSE xfcloe_ +#define DELETE xfdele_ +#define ERROR xerror_ +#define FLUSH xffluh_ +#define GETC xfgetc_ +#define GETCHAR xfgetr_ +#define MALLOC xmallc_ +#define MFREE xmfree_ +#define MKTEMP xmktep_ +#define NOTE xfnote_ +#define OPEN xfopen_ +#define PRINTF xprinf_ +#define PUTC xfputc_ +#define PUTCHAR xfputr_ +#define QSORT xqsort_ +#define READ xfread_ +#define REALLOC xrealc_ +#define SEEK xfseek_ +#define SIZEOF xsizef_ +#define UNGETC xfungc_ +#define WRITE xfwrie_ + +#define AREAD aread_ /* other VOS names */ +#define AREADB areadb_ +#define AWAIT await_ +#define AWAITB awaitb_ +#define AWRITE awrite_ +#define AWRITEB awritb_ +#define BEGMEM begmem_ +#define BRKTIME brktie_ +#define BTOI btoi_ +#define CLKTIME clktie_ +#define CNVDATE cnvdae_ +#define CNVTIME cnvtie_ +#define COERCE coerce_ +#define CPUTIME cputie_ +#define CTOD ctod_ +#define CTOX ctox_ +#define DIROPEN diropn_ +#define DTOC dtoc_ +#define ENVFIND envfid_ +#define ENVFREE envfre_ +#define ENVGETB envgeb_ +#define ENVGETI envgei_ +#define ENVGETS envges_ +#define ENVINIT envint_ +#define ENVLIST envlit_ +#define ENVMARK envmak_ +#define ENVPUTS envpus_ +#define ENVRESET envret_ +#define ENVSCAN envscn_ +#define ERRACT erract_ +#define ERRCODE errcoe_ +#define ERRGET errget_ +#define FALLOC falloc_ +#define FATAL xfatal_ +#define FCHDIR xfchdr_ +#define FCOPY fcopy_ +#define FCOPYO fcopyo_ +#define FDEBUG fdebug_ +#define FDELPF fdelpf_ +#define FDEVBLK fdevbk_ +#define FDIRNAME fdirne_ +#define FILBUF filbuf_ +#define FINFO finfo_ +#define FIXMEM fixmem_ +#define FLSBUF flsbuf_ +#define FMAPFN fmapfn_ +#define FMKDIR fmkdir_ +#define FNEXTN fnextn_ +#define FNLDIR fnldir_ +#define FNROOT fnroot_ +#define FNTCLS fntcls_ +#define FNTGFN fntgfn_ +#define FNTOPN fntopn_ +#define FOWNER fowner_ +#define FPATHNAME fpathe_ +#define FPRINTF fprinf_ +#define FREDIR fredir_ +#define FREDIRO fredio_ +#define FSETI fseti_ +#define FSTATI fstati_ +#define FSTATL fstatl_ +#define FSTATS fstats_ +#define GETPID xgtpid_ +#define GCTOD gctod_ +#define GCTOL gctol_ +#define GCTOX gctox_ +#define GETLINE getlie_ +#define GETUID xgtuid_ +#define GLTOC gltoc_ +#define GPATMAKE gpatme_ +#define GPATMATCH gpatmh_ +#define GSTRMATCH gstrmh_ +#define GTR_GFLUSH gtrgfh_ +#define IMACCESS imaccs_ +#define IMDRCUR imdrcr_ +#define IRAF_MAIN irafmn_ +#define XISATTY xisaty_ +#define XTTYSIZE xttyse_ +#define ITOB itob_ +#define KI_EXTNODE kiexte_ +#define KI_MAPCHAN kimapn_ +#define LEXNUM lexnum_ +#define LPOPEN lpopen_ +#define NDOPEN ndopen_ +#define ONENTRY onenty_ +#define ONERROR onerrr_ +#define ONEXIT onexit_ +#define OSCMD oscmd_ +#define PARGB pargb_ +#define PARGC pargc_ +#define PARGD pargd_ +#define PARGI pargi_ +#define PARGL pargl_ +#define PARGR pargr_ +#define PARGS pargs_ +#define PARGSTR pargsr_ +#define PARGX pargx_ +#define POLL xfpoll_ +#define POLL_OPEN pollon_ +#define POLL_CLOSE pollce_ +#define POLL_ZERO pollzo_ +#define POLL_SET pollst_ +#define POLL_CLEAR pollcr_ +#define POLL_TEST polltt_ +#define POLL_GET_NFDS pollgs_ +#define POLL_PRINT pollpt_ +#define PRCHDIR prchdr_ +#define PRCLCPR prclcr_ +#define PRCLDPR prcldr_ +#define PRCLOSE prcloe_ +#define PRDONE prdone_ +#define PRENVFREE prenve_ +#define PRENVSET prenvt_ +#define PRFILBUF prfilf_ +#define PRKILL prkill_ +#define PROPCPR propcr_ +#define PROPDPR propdr_ +#define PROPEN propen_ +#define PROTECT protet_ +#define PRREDIR prredr_ +#define PRSIGNAL prsigl_ +#define PRSTATI prstai_ +#define PRUPDATE prupde_ +#define PRPSINIT prpsit_ +#define PUTCC putcc_ +#define PUTLINE putlie_ +#define RCURSOR rcursr_ +#define RDUKEY rdukey_ +#define RENAME xfrnam_ +#define REOPEN reopen_ +#define SALLOC salloc_ +#define SFREE sfree_ +#define SMARK smark_ +#define SPRINTF sprinf_ +#define STG_GETLINE stggee_ +#define STG_PUTLINE stgpue_ +#define STKCMP stkcmp_ +#define STRMATCH strmah_ +#define STROPEN stropn_ +#define STRTBL strtbl_ +#define STTYCO sttyco_ +#define SYSRUK sysruk_ +#define TSLEEP tsleep_ +#define TTSETI ttseti_ +#define TTSETS ttsets_ +#define TTSTATI ttstai_ +#define TTSTATS ttstas_ +#define TTYCDES ttycds_ +#define TTYCLEAR ttyclr_ +#define TTYCLEARLN ttycln_ +#define TTYCLOSE ttycls_ +#define TTYCTRL ttyctl_ +#define TTYGDES ttygds_ +#define TTYGETB ttygeb_ +#define TTYGETI ttygei_ +#define TTYGETR ttyger_ +#define TTYGETS ttyges_ +#define TTYGOTO ttygoo_ +#define TTYINIT ttyint_ +#define TTYODES ttyods_ +#define TTYOPEN ttyopn_ +#define TTYPUTLINE ttypue_ +#define TTYPUTS ttypus_ +#define TTYSETI ttysei_ +#define TTYSO ttyso_ +#define TTYSTATI ttysti_ +#define UNGETLINE ungete_ +#define UNREAD unread_ +#define URAND urand_ +#define VFNOPEN vfnopn_ +#define VFNCLOSE vfncle_ +#define VFNMAP vfnmap_ +#define VFNADD vfnadd_ +#define VFNDEL vfndel_ +#define VFNUNMAP vfnunp_ +#define VMALLOC vmallc_ +#define XACOS xacos_ +#define XALLOCATE xalloe_ +#define XASIN xasin_ +#define XATAN xatan_ +#define XATAN2 xatan2_ +#define XCOS xcos_ +#define XDEALLOCATE xdeale_ +#define XDEVOWNER xdevor_ +#define XDEVSTATUS xdevss_ +#define XER_RESET xerret_ +#define XEXP xexp_ +#define XLOG xlog_ +#define XLOG10 xlog10_ +#define XNINT xnint_ +#define XMJBUF xmjbuf_ +#define XONERR xonerr_ +#define XPOW xpow_ +#define XSIN xsin_ +#define XSQRT xsqrt_ +#define XTAN xtan_ +#define XTOC xtoc_ +#define XWHEN xwhen_ + +#define D_xnames diff --git a/unix/hlib/libc/xwhen.h b/unix/hlib/libc/xwhen.h new file mode 100644 index 00000000..90281911 --- /dev/null +++ b/unix/hlib/libc/xwhen.h @@ -0,0 +1,10 @@ +/* Exception handling. + */ +#define X_ACV 501 /* access violation */ +#define X_ARITH 502 /* arithmetic error */ +#define X_INT 503 /* keyboard interrupt */ +#define X_IPC 504 /* write to IPC with no reader */ +#define X_IGNORE NULL /* ignore exception */ +#define X_FIRST_EXCEPTION 501 + +#define D_xwhen diff --git a/unix/hlib/libc/zfstat.h b/unix/hlib/libc/zfstat.h new file mode 100644 index 00000000..48862cd3 --- /dev/null +++ b/unix/hlib/libc/zfstat.h @@ -0,0 +1,8 @@ +/* File status parameters (zsttbf, etc.) + */ +#define FSTT_BLKSIZE 1 +#define FSTT_FILSIZE 2 +#define FSTT_OPTBUFSIZE 3 +#define FSTT_MAXBUFSIZE 4 + +#define D_zfstat diff --git a/unix/hlib/libos.a b/unix/hlib/libos.a new file mode 120000 index 00000000..fcecfe3d --- /dev/null +++ b/unix/hlib/libos.a @@ -0,0 +1 @@ +../bin/libos.a \ No newline at end of file diff --git a/unix/hlib/login.cl b/unix/hlib/login.cl new file mode 100644 index 00000000..bd10cd22 --- /dev/null +++ b/unix/hlib/login.cl @@ -0,0 +1,182 @@ +# LOGIN.CL -- User login file for the IRAF command language. + +# Identify login.cl version (checked in images.cl). +if (defpar ("logver")) + logver = "IRAF V2.16.1 Oct 2013" + +set home = "U_HOME" +set imdir = "U_IMDIR" +set cache = "U_CACHEDIR" +set uparm = "home$uparm/" +set userid = "U_USER" + +# Set the terminal type. We assume the user has defined this correctly +# when issuing the MKIRAF and no longer key off the unix TERM to set a +# default. +if (access (".hushiraf") == no) + print "setting terminal type to 'U_TERM' ..." +stty U_TERM + + +#============================================================================ +# Uncomment and edit to change the defaults. +#set editor = vi +#set printer = lp +#set pspage = "letter" +#set stdimage = imt800 +#set stdimcur = stdimage +#set stdplot = lw +#set clobber = no +#set imclobber = no +#set filewait = yes +#set cmbuflen = 512000 +#set min_lenuserarea = 64000 +#set imtype = "imh" +set imextn = "oif:imh fxf:fits,fit fxb:fxb plf:pl qpf:qp stf:hhh,??h" + + +# XIMTOOL/DISPLAY stuff. Set node to the name of your workstation to +# enable remote image display. The trailing "!" is required. +#set node = "my_workstation!" + +# CL parameters you mighth want to change. +#ehinit = "nostandout eol noverify" +#epinit = "standout showall" +showtype = yes + + +#============================================================================ +# 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 $awk $sed $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" +task $clw = "$clear;w" +task $pg = ("$(less -Cqm $*)") + + +#============================================================================ +# Load private home$loginuser.cl definitions. The global login means that +# a user can create a loginuser.cl in the HOME$.iraf/ directory that will +# apply to all logins. In a case where MKIRAF created a local login.cl then +# this will load any loginuser.cl in the current directory. + +if (access ("home$loginuser.cl")) + cl < "home$loginuser.cl" +; +keep + + +# Allow a local loginuser.cl to override global definitions. In a global +# login this allows a 'loginuser.cl' file in a current project directory to +# override definitions set in the global login.cl/loginuser.cl file. In a +# case where MKIRAF create a local login this simple re-loads the loginuser.cl + +if (access ("./loginuser.cl")) + cl < "./loginuser.cl" +; +keep + + +# Allow for a local uparm directory. In a global login this allows us to +# create a 'uparm' directory in a specific project dir that will override +# the params in the global login. In a case where MKIRAF created a local +# uparm this simply redefines the 'uparm' as the absolute path. + +path (osfn(".")) | scan (s1) +if (access (s1 // "uparm/")) { + s1 = substr (s1, strldx("!",s1)+1, strlen(s1)) # strip 'node!' prefix + printf ("reset uparm = \"" // s1 // "uparm/\"; keep\n") | cl() + s1 = "" +} +; +keep + +#============================================================================ +# Load the default CL package. Doing so here allows us to override package +# paths and load personalized packages from our loginuser.cl. +clpackage + + +# 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 +vo # Virtual Observatory tools + +prcache directory +cache directory page type help + +# Print the message of the day. +if (access (".hushiraf")) + menus = no +else { + clear; type hlib$motd +} + + +#============================================================================ +# Check for updates to the system +chkupdate + +# Notify the user if we're using the global login. +path (".") | scan (s1) +if ( osfn("home$") != substr (s1, strldx("!",s1)+1, strlen(s1)) ) { + printf (" *** Using global login file: %slogin.cl\n", osfn("home$")) +} +; + + +#============================================================================ +# Uncomment to initialize the SAMP interface on startup. +if (deftask ("samp") == yes) { + printf (" *** Initializing SAMP .... ") + if (sampHubAccess() == yes) { + # Enable SAMP messaaging. Set default handlers that don't require + # VO capabilities. + samp quiet + samp ("on", >& "dev$null") +# samp ("handler", "table.load.votable", "tinfo $url", >& "dev$null") +# samp ("handler", "image.load.fits", "imstat $url", >& "dev$null") + samp noquiet + print ("on") + } else + print ("No Hub Available\n") +} + + +#============================================================================ +# Delete any old MTIO lock (magtape position) files. +if (deftask ("mtclean")) + mtclean +else + delete uparm$mt?.lok,uparm$*.wcs verify- + + +#============================================================================ +print (" The following commands or packages are currently defined:\n") + +keep + diff --git a/unix/hlib/mach.h b/unix/hlib/mach.h new file mode 120000 index 00000000..19fd90e9 --- /dev/null +++ b/unix/hlib/mach.h @@ -0,0 +1 @@ +mach32.h \ No newline at end of file diff --git a/unix/hlib/mach32.h b/unix/hlib/mach32.h new file mode 100644 index 00000000..0765113b --- /dev/null +++ b/unix/hlib/mach32.h @@ -0,0 +1,34 @@ +# Machine Parameters + +define SZB_CHAR 2 # machine bytes per char +define SZB_ADDR 1 # machine bytes per address increment +define SZ_VMPAGE 256 # page size (1 if no virtual mem.) +define MAX_DIGITS 25 # max digits in a number +define NDIGITS_RP 7 # number of digits of real precision +define NDIGITS_DP 16 # number of digits of precision (double) +define MAX_EXPONENT 38 # max exponent, base 10 +define MAX_EXPONENTR 38 # IEEE single +define MAX_EXPONENTD 308 # IEEE double + +define MAX_SHORT 32767 # largest numbers +define MAX_INT 2147483647 +define MAX_LONG 2147483647 +define MAX_REAL 0.99e37 # anything larger is INDEF +define MAX_DOUBLE 0.99d307 +define NBITS_BYTE 8 # nbits in a machine byte +define NBITS_SHORT 16 # nbits in a short +define NBITS_INT 32 # nbits in an integer +define NBITS_LONG 32 # nbits in a long +define EPSILONR (1.192e-7) # smallest E such that 1.0 + E > 1.0 +define EPSILOND (2.220d-16) # double precision epsilon +define EPSILON EPSILONR + +# Is byte swapping needed for a 2 or 4 byte MII integer or a 4 or 8 byte +# IEEE floating to convert to or from MII format on this machine? + +define BYTE_SWAP2 YES +define BYTE_SWAP4 YES +define BYTE_SWAP8 YES +define IEEE_SWAP4 YES +define IEEE_SWAP8 YES +define IEEE_USED YES diff --git a/unix/hlib/mach64.h b/unix/hlib/mach64.h new file mode 100644 index 00000000..c87a96ff --- /dev/null +++ b/unix/hlib/mach64.h @@ -0,0 +1,34 @@ +# Machine Parameters + +define SZB_CHAR 2 # machine bytes per char +define SZB_ADDR 1 # machine bytes per address increment +define SZ_VMPAGE 256 # page size (1 if no virtual mem.) +define MAX_DIGITS 25 # max digits in a number +define NDIGITS_RP 7 # number of digits of real precision +define NDIGITS_DP 16 # number of digits of precision (double) +define MAX_EXPONENT 38 # max exponent, base 10 +define MAX_EXPONENTR 38 # IEEE single +define MAX_EXPONENTD 308 # IEEE double + +define MAX_SHORT 32767 # largest numbers +define MAX_INT 2147483647 +define MAX_LONG 2147483647 +define MAX_REAL 0.99e37 # anything larger is INDEF +define MAX_DOUBLE 0.99d307 +define NBITS_BYTE 8 # nbits in a machine byte +define NBITS_SHORT 16 # nbits in a short +define NBITS_INT 64 # nbits in an integer +define NBITS_LONG 64 # nbits in a long +define EPSILONR (1.192e-7) # smallest E such that 1.0 + E > 1.0 +define EPSILOND (2.220d-16) # double precision epsilon +define EPSILON EPSILONR + +# Is byte swapping needed for a 2 or 4 byte MII integer or a 4 or 8 byte +# IEEE floating to convert to or from MII format on this machine? + +define BYTE_SWAP2 YES +define BYTE_SWAP4 YES +define BYTE_SWAP8 YES +define IEEE_SWAP4 YES +define IEEE_SWAP8 YES +define IEEE_USED YES diff --git a/unix/hlib/math.h b/unix/hlib/math.h new file mode 100644 index 00000000..42aa6ba0 --- /dev/null +++ b/unix/hlib/math.h @@ -0,0 +1,59 @@ +# MATH.H -- Definitions of various mathematical constants. +# Values are given to 20 decimal places. +# From Abramowitz & Stegun, Handbook of Mathematical Functions, Ch. 1. +# LN denotes natural logarithm +# LOG denote base 10 logarithm + + +# Real precision definitions. + +define SQRTOF2 1.4142135623730950488 + +define BASE_E 2.7182818284590452353 +define EXP_PI 23.140692632779269006 + +define LN_2 .69314718055994530942 +define LN_10 2.3025850929940456840 +define LN_PI 1.1447298858494001741 +define LOG_E .43429448190325182765 + +define PI 3.1415926535897932385 +define TWOPI 6.2831853071795864769 +define FOURPI 12.566370614359172953 +define HALFPI 1.5707963267948966192 +define SQRTOFPI 1.7724538509055160273 + +define RADIAN 57.295779513082320877 +define RADTODEG (($1)*RADIAN) +define DEGTORAD (($1)/RADIAN) + +define GAMMA .57721566490153286061 # Euler's constant +define LN_GAMMA (-.54953931298164482234) +define EXP_GAMMA 1.7810724179901979852 + + +# Double precision definitions. + +define DSQRTOF2 1.4142135623730950488d0 + +define DBASE_E 2.7182818284590452353d0 +define DEXP_PI 23.140692632779269006d0 + +define DLN_2 .69314718055994530942d0 +define DLN_10 2.3025850929940456840d0 +define DLN_PI 1.1447298858494001741d0 +define DLOG_E .43429448190325182765d0 + +define DPI 3.1415926535897932385d0 +define DTWOPI 6.2831853071795864769d0 +define DFOURPI 12.566370614359172953d0 +define DHALFPI 1.5707963267948966192d0 +define DSQRTOFPI 1.7724538509055160273d0 + +define DRADIAN 57.295779513082320877d0 +define DRADTODEG (($1)*DRADIAN) +define DDEGTORAD (($1)/DRADIAN) + +define DGAMMA .57721566490153286061d0 # Euler's constant +define DLN_GAMMA (-.54953931298164482234d0) +define DEXP_GAMMA 1.7810724179901979852d0 diff --git a/unix/hlib/mkfloat.csh b/unix/hlib/mkfloat.csh new file mode 100755 index 00000000..e65460c6 --- /dev/null +++ b/unix/hlib/mkfloat.csh @@ -0,0 +1,143 @@ +#!/bin/csh +# +# MKFLOAT.CSH -- Install the indicated version of the IRAF binaries, i.e., +# archive the current objects and libraries, set BIN to point to bin.FFF, +# and set mkpkg to produce FFF binaries (FFF = f68881, ffpa, sparc, etc.). +# +# NOTE -- This script should be run only by the IRAF system manager. It is +# assumed that the environment variables defined in the IRAF .login and in +# hlib/irafuser.csh are defined. + + +set ARCH = "$1" +set DIRS = "lib pkg sys" +set FILE = unix/hlib/mkpkg.inc +set DFL = _DFL.mkfloat +set TFL = _TFL.mkfloat + +set mach = `uname -s | tr '[A-Z]' '[a-z]'` +set os_mach = `uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + +unalias ls rm cat grep tar cmp diff echo ln mv zcat gunzip compress which +unset noclobber + +# Set the following to -xpf for BSD Tar and to -xof for SYSV Tar. +set TARXFLGS = -xpf +#set TARXFLGS = -xof + +# set echo + +# See if we're able to compress the files. +set do_compress = 1 +if (! -x `which compress` || $os_mach == "cygwin") then + if (! -x `which gzip`) then + echo "no compress command found, OBJS.arc files will not be compressed" + set do_compress = 0 + else + set COMPRESS = "gzip -S .Z" + endif +else + set COMPRESS = `which compress` +endif + +# Check for an error in the package structure, i.e. the 'bin' is a directory +# and not a symlink we can change. It's valid for an external package to +# have only a 'bin' directory, but then it's toplevel mkpkg shouldn't be +# calling us. +if ("`ls -l bin | grep 'l.........'`" == "") then + echo "'bin' is a directory, should be symbolic link pointing to valid" + echo "architecture. Possible error in copying package structure??" + echo "Use tar to copy and move directories to preserve links." + exit 1 +else + set float = `ls -l bin | sed -e 's+^.*bin\.++'` +endif +if ("$ARCH" == "") then + echo "system is configured for $float" + exit 0 +else if ($float == "$ARCH") then + echo "system is already configured for $ARCH" + exit 0 +else if (! -e bin.$ARCH) then + echo "must set up a bin.$ARCH subdirectory first" + exit 1 +endif + +# Get the list of directories to be changed. +shift +if ("$1" == "-d") then + set DIRS = "" + shift + while ("$1" != "") + set DIRS = "$DIRS $1" + shift + end +endif + +echo -n \ +"deleting any dreg .e files left lying about in the source directories... " +rmbin -n -o .a .o .e .E $DIRS > $TFL; grep '\.[eE]$' $TFL | tee _.e_files +rm -f `cat _.e_files` _.e_files; grep -v '\.[eE]$' $TFL > $DFL; rm $TFL +echo "done" + +echo -n "archiving and deleting $float objects... " +if (-e bin.$float) then + if (! -z $DFL) then + tar -cf bin.$float/OBJS.arc `cat $DFL` + tar -tf bin.$float/OBJS.arc | grep -v '/$' | cut -d " " -f 1 > $TFL + cmp -s $DFL $TFL + if ($status) then + echo "Error: cannot archive $float objects" + diff $DFL $TFL + rm $DFL $TFL bin.$float/OBJS.arc + exit 1 + else if ($do_compress == 1) then + echo "done" + echo -n "compressing bin.$float/OBJS.arc " + nice $COMPRESS -f bin.$float/OBJS.arc & + rm -f $TFL + endif + endif +else + echo "old objects will not be archived as no bin.$float directory found" +endif +echo "" +rm -f `cat $DFL` $DFL + +if ($ARCH != generic) then + echo -n "restoring archived $ARCH objects... " + if (-e bin.$ARCH/OBJS.arc.Z) then + if ({ (zcat bin.$ARCH/OBJS.arc.Z | tar $TARXFLGS -) }) then + rm -f bin.$ARCH/OBJS.arc.Z + endif + echo "done" + else if (-e bin.$ARCH/OBJS.arc.gz) then + if ({ (cat bin.$ARCH/OBJS.arc.gz | gunzip | tar $TARXFLGS -) }) then + rm -f bin.$ARCH/OBJS.arc.gz + endif + echo "done" + else if (-e bin.$ARCH/OBJS.arc) then + if ({ (cat bin.$ARCH/OBJS.arc | tar $TARXFLGS -) }) then + rm -f bin.$ARCH/OBJS.arc + endif + echo "done" + else + echo "" + echo "no object archive found; full sysgen will be needed" + endif +endif + +# Set BIN to point to new directory. +rm -f bin; ln -s bin.$ARCH bin + +# If script is run at IRAF root, edit mkpkg.inc for new float option. +#if (-e $FILE) then +# sed -e "s+= $float+= $ARCH+" $FILE > temp; mv -f temp $FILE +#endif + +# Warn the user if the new ARCH does not match their current IRAFARCH. +if ($?IRAFARCH == 1) then + if ($ARCH != $IRAFARCH && $ARCH != generic) then + echo "Warning: IRAFARCH is still set in your environment to $IRAFARCH" + endif +endif diff --git a/unix/hlib/mkfloat.sh b/unix/hlib/mkfloat.sh new file mode 100755 index 00000000..66da9170 --- /dev/null +++ b/unix/hlib/mkfloat.sh @@ -0,0 +1,142 @@ +#!/bin/bash +# +# MKFLOAT.SH -- Install the indicated version of the IRAF binaries, i.e., +# archive the current objects and libraries, BIN to point to bin.FFF, +# and mkpkg to produce FFF binaries (FFF=f68881, ffpa, sparc, etc.). +# +# NOTE -- This script should be run only by the IRAF system manager. It is +# assumed that the environment variables defined in the IRAF .login and in +# hlib/irafuser.csh are defined. + + +ARCH="$1" +DIRS="lib pkg sys" +FILE=unix/hlib/mkpkg.inc +DFL=_DFL.mkfloat +TFL=_TFL.mkfloat + +mach=`uname -s | tr '[A-Z]' '[a-z]'` +os_mach=`uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + + +# Set the following to -xpf for BSD Tar and to -xof for SYSV Tar. +TARXFLGS=-xpf +#TARXFLGS=-xof + +# See if we're able to compress the files. +do_compress=1 +if [ ! -x `which compress` -o "$os_mach" = "cygwin" ]; then + if [ ! -x `which gzip` ]; then + /bin/echo "no compress command found, files will not be compressed" + do_compress=0 + else + COMPRESS="gzip -S .Z" + fi +else + COMPRESS=`which compress` +fi + +# Check for an error in the package structure, i.e. the 'bin' is a directory +# and not a symlink we can change. It's valid for an external package to +# have only a 'bin' directory, but then it's toplevel mkpkg shouldn't be +# calling us. +if [ "`ls -l bin | grep 'l.........'`" = "" ]; then + /bin/echo "'bin' is a directory, should be symbolic link pointing to valid" + /bin/echo "architecture. Possible error in copying package structure??" + /bin/echo "Use tar to copy and move directories to preserve links." + exit 1 +else + float=`ls -l bin | sed -e 's+^.*bin\.++'` +fi +if [ "$ARCH" = "" ]; then + /bin/echo "system is configured for $float" + exit 0 +elif [ "$float" = "$ARCH" ]; then + /bin/echo "system is already configured for $ARCH" + exit 0 +elif [ ! -e bin.$ARCH ]; then + /bin/echo "must up a bin.$ARCH subdirectory first" + exit 1 +fi + +# Get the list of directories to be changed. +shift +DIRS="" +if [ "$1" = "-d" ]; then + DIRS="" + shift + while : ; do + DIRS="$DIRS $1" + shift + done +fi + +/bin/echo -n \ +"deleting any dreg .e files left lying about in the source directories... " +rmbin -n -o .a .o .e .E $DIRS > $TFL; grep '\.[eE]$' $TFL | tee _.e_files +rm -f `cat _.e_files` _.e_files; grep -v '\.[eE]$' $TFL > $DFL; rm $TFL +/bin/echo "done" + +/bin/echo -n "archiving and deleting $float objects... " +if [ -e bin.$float ]; then + if [ -s $DFL ]; then + tar -cf bin.$float/OBJS.arc `cat $DFL` + tar -tf bin.$float/OBJS.arc | grep -v '/$' | cut -d " " -f 1 > $TFL + cmp -s $DFL $TFL + if [ $status ]; then + /bin/echo "Error: cannot archive $float objects" + diff $DFL $TFL + rm $DFL $TFL bin.$float/OBJS.arc + exit 1 + elif (( $do_compress>0 )); then + /bin/echo "done" + /bin/echo -n "compressing bin.$float/OBJS.arc " + nice $COMPRESS -f bin.$float/OBJS.arc & + rm -f $TFL + fi + fi +else + /bin/echo "old objects will not be archived as no bin.$float dir found" +fi +/bin/echo "done." +rm -f `cat $DFL` $DFL + +if [ $ARCH != "generic" ]; then + /bin/echo -n "restoring archived $ARCH objects... " + if [ -e bin.$ARCH/OBJS.arc.Z ]; then + zcat bin.$ARCH/OBJS.arc.Z | tar $TARXFLGS - + if (( $status<1 )); then + rm -f bin.$ARCH/OBJS.arc.Z + fi + /bin/echo "done" + elif [ -e bin.$ARCH/OBJS.arc.gz ]; then + cat bin.$ARCH/OBJS.arc.gz | gunzip | tar $TARXFLGS - + if (( $status<1 )); then + rm -f bin.$ARCH/OBJS.arc.gz + fi + /bin/echo "done" + elif [ -e bin.$ARCH/OBJS.arc ]; then + cat bin.$ARCH/OBJS.arc | tar $TARXFLGS - + if (( $status<1 )); then + rm -f bin.$ARCH/OBJS.arc + fi + /bin/echo "done" + else + /bin/echo "" + /bin/echo "no object archive found; full sysgen will be needed" + fi +fi + +# Set BIN to point to new directory. +rm -f bin; ln -s bin.$ARCH bin + + +# Warn the user if the new ARCH does not match their current IRAFARCH. +if [ -n $IRAFARCH ]; then + if [ "$ARCH" != "$IRAFARCH" ]; then + /bin/echo "Warning: IRAFARCH is still in your environment to $IRAFARCH" + fi + if [ "$ARCH" == "generic" ]; then + /bin/echo "Warning: IRAFARCH is still in your environment to 'generic'" + fi +fi diff --git a/unix/hlib/mkiraf.csh b/unix/hlib/mkiraf.csh new file mode 100755 index 00000000..d89aecb5 --- /dev/null +++ b/unix/hlib/mkiraf.csh @@ -0,0 +1,119 @@ +#! /bin/csh +# MKIRAF -- Setup the IRAF environment for a user. Should be called from the +# directory from which the user will thereafter type "cl" to start a session. + +# The following definitions are site dependent. [SITEDEP] + +set iraf = "/iraf/iraf" +set imdir = "/iraf/imdirs" +set cachedir = "/iraf/cache" +set ttymsg =\ +"Terminal types: xgterm,xterm,gterm,vt640,vt100,etc." + +# ------------- (end of site dependent definitions) ------------------------ + +unalias rm mkdir pwd echo mkdir sed whoami pushd popd + +# The following kludge is for Solaris, which doesn't have whoami. +if (! $?USER) then + setenv USER `whoami` +endif +alias whoami "(echo $USER)" + +# Protect against running mkiraf in an iraf system directory. +pushd $iraf >& /dev/null; set irafdir = `pwd`; popd >& /dev/null +if ("`pwd | grep $irafdir`" != "") then + if ("`pwd | grep iraf/local`" == "") then + echo "Error: current directory is not an iraf user login directory" + exit 1 + endif +endif + + +# Process command-line arguments. +set user_term = "none" +set init = 0 +set quiet = 0 + +while ($#argv >= 1) + if ("$argv[1]" == "-t" || "$argv[1]" == "-term") then + set user_term = $argv[2] + shift + else if ("$argv[1]" == "-i" || "$argv[1]" == "-init") then + set init = 1 + else if ("$argv[1]" == "-q" || "$argv[1]" == "-quiet") then + set quiet = 1 + else + echo "Unknown flag '"$argv[1]"'" + endif + shift +end + + + +# Make an empty "uparm" (user parameter) directory. +if (! -e uparm) then + if ($quiet == 0) then + echo '-- creating a new uparm directory' + endif + mkdir uparm +else + if ($init == 0) then + echo -n 'Initialize uparm? (y|n): ' + set yesno = $< + if ($yesno == 'y' || $yesno == 'yes') then + echo '-- initializing uparm' + rm -rf uparm; mkdir uparm + endif + else + if ($quiet == 0) then + echo '-- initializing uparm' + endif + /bin/rm -rf uparm; mkdir uparm + endif +endif + +if (-e login.cl) then + mv -f login.cl login.cl.OLD +endif + + +# Edit the login.cl file, setting the user's home directory, default image +# directory, and terminal. + +if ($user_term == "none") then + echo $ttymsg + echo -n 'Enter terminal type: ' + echo $< | sed -e "s;.*;s+U_TERM+&+;" > _sed +else + echo $user_term | sed -e "s;.*;s+U_TERM+&+;" > _sed +endif + +pwd | sed -e "s;.*;s+U_HOME+&/+;" >> _sed +pwd | sed -e "s;.*;s+U_UPARM+&/uparm/+;" >> _sed + +if (! (-e "$imdir" && -w "$imdir") ) then + set imdir = HDR$ + whoami | sed -e "s;.*;s+U_IMDIR+${imdir}/+;" >> _sed +else + whoami | sed -e "s;.*;s+U_IMDIR+${imdir}/&/+;" >> _sed + whoami | sed -e "s;.*;mkdir $imdir/& 2> /dev/null;" | sh +endif + +if (! (-e "$cachedir" && -w "$cachedir") ) then + set cachedir = /tmp/ + whoami | sed -e "s;.*;s+U_CACHEDIR+${cachedir}/+;" >> _sed +else + whoami | sed -e "s;.*;s+U_CACHEDIR+${cachedir}/&/+;" >> _sed + whoami | sed -e "s;.*;mkdir $cachedir/& 2> /dev/null;" | sh +endif + +whoami | sed -e "s;.*;s+U_USER+&+;" >> _sed + +sed -f _sed < $iraf/unix/hlib/login.cl > login.cl; rm _sed + + +if ($quiet == 0) then + echo 'A new LOGIN.CL file has been created in the current directory.' + echo 'You may wish to review and edit this file to change the defaults.' +endif diff --git a/unix/hlib/mkiraf.sh b/unix/hlib/mkiraf.sh new file mode 100755 index 00000000..ff2a1630 --- /dev/null +++ b/unix/hlib/mkiraf.sh @@ -0,0 +1,194 @@ +#!/bin/bash +# +# MKIRAF -- Setup the IRAF environment for a user. Should be called from the +# directory from which the user will thereafter type "cl" to start a session. +# +# Usage: +# +# % mkiraf [--term=] [--init] [--noinit] [--quiet] +# +# Where +# -t,--term= Set the default terminal type +# -i,--init Initialize the uparm directory +# -n,--noinit Do not nitialize the uparm directory +# -q,--quiet Suppress output +# +# Use of the -t, -i, or -n options will suppress the corresponding prompts +# for input. + + + # Initialize the script variables. +myterm="none" +uparm_init=-1 +quiet=0 +def=0 +force=0 +defterm="xgterm" + + # Paths edited by the install script. +iraf="/srv/conda/sources/iraf/" +imdir="/srv/conda/sources/iraf/fakehome/imdir//" +cachedir="/srv/conda/sources/iraf/fakehome/cache//" +# Bad hack - jhunk +FAKEHOME=$(dirname $imdir) + +# ------------- (end of site dependent definitions) ------------------------ + +# The following kludge is for Solaris, which doesn't have whoami. +if [ "$USER" = "" ]; then + USER=`whoami` +fi + + +# Parse the command-line options. +for i in "$@" +do + case $i in + -t=*|--term=*) # Set the default terminal type + myterm=`echo $i | sed 's/[-a-zA-Z0-9]*=//'` + ;; + -d|--default) # Create default login dir + def=1 + quiet=1 + echo "" + ;; + -i|--init) # Initialize uparm directory + uparm_init=1 + ;; + -n|--noinit) # Don't initialize uparm directory + uparm_init=0 + ;; + -q|--quiet) # Suppress output + quiet=1 + ;; + -f|--force) # Install in $iraf regardless + force=1 + ;; + *) + /bin/echo "Error: unknown option '$i'" + exit 1 + ;; + esac +done + + + +# Protect against running mkiraf in an iraf system directory. +irafdir=`cd $iraf ; pwd` +if (( $force==0 )); then + if [ ! "`pwd | grep $irafdir`" = "" ]; then + if [ "`pwd | grep iraf/local`" = "" ]; then + /bin/echo "Error: current directory is not an iraf user login directory" + exit 1 + fi + fi +fi + +if (( $def == 1 )); then + #myterm="xgterm" + cd $FAKEHOME + if [ ! -e .iraf ]; then + mkdir $FAKEHOME/.iraf + fi + cd $FAKEHOME/.iraf + if [ ! -e bin ]; then + mkdir bin + fi + if [ ! -e imdir ]; then + mkdir imdir + fi + if [ ! -e cache ]; then + mkdir cache + fi + cp $iraf/unix/hlib/setup.*sh . +fi + + +# Make an empty "uparm" (user parameter) directory. +if [ ! -e uparm ]; then + if (( quiet<1 )); then + if (( $def == 0 )); then + /bin/echo '-- creating a new uparm directory' + fi + fi + mkdir uparm +elif [ ! -d uparm ]; then + /bin/echo "Error: a file uparm exists" + exit 1 +else + if (( uparm_init<0 )) ; then + if (( quiet<1 )) ; then + /bin/echo -n 'Initialize uparm? (y|n): ' + read yesno + else + yesno="yes" + fi + if [ "$yesno" = "y" -o "$yesno" = "yes" ]; then + if (( quiet<1 )); then + /bin/echo '-- initializing uparm' + fi + /bin/rm -rf uparm + mkdir uparm + fi + elif (( uparm_init==1 )); then + if (( quiet<1 )); then + /bin/echo '-- initializing uparm' + fi + /bin/rm -rf uparm + mkdir uparm + fi +fi + +# Edit the login.cl file, setting the user's home directory, default image +# directory, and terminal. + +if [ "$myterm" == "none" ]; then + /bin/echo "Terminal types: xgterm,xtermjh,xterm,etc." + /bin/echo -n 'Enter terminal type ('$defterm'): ' + read myterm + if [ "$myterm" == "" ]; then + myterm=$defterm + fi +fi + +# Initialize the 'imdir' and 'cachedir' paths. +IDIR="${imdir}$USER" +if [ -d $imdir ]; then + mkdir -p $IDIR &> /dev/null +fi +if [ ! -d $IDIR -o ! -w $IDIR ]; then + IDIR="HDR$" +fi + +CDIR="${cachedir}$USER" +if [ -d $cachedir ]; then + mkdir -p $CDIR &> /dev/null +fi +if [ ! -d $CDIR -o ! -w $CDIR ]; then + CDIR="/tmp" +fi + + +# Back up the old login.cl file. +if [ -e login.cl ]; then + mv -f login.cl login.cl.OLD +fi + +# Create the path editing script. +_sed() { + /bin/echo $1 | sed -e "s;.*;s+U_TERM+&+;" + pwd | sed -e "s;.*;s+U_HOME+&/+;" + pwd | sed -e "s;.*;s+U_UPARM+&/uparm/+;" + /bin/echo $IDIR | sed -e "s;.*;s+U_IMDIR+&/+;" + /bin/echo $CDIR | sed -e "s;.*;s+U_CACHEDIR+&/+;" + /bin/echo $USER | sed -e "s;.*;s+U_USER+&+;" +} + +sed "`_sed $myterm`" < ${iraf}/unix/hlib/login.cl > login.cl + +if (( $def == 0 )); then + if (( quiet<1 )) ; then + /bin/echo 'A new LOGIN.CL file has been created in the current directory.' + /bin/echo 'You may wish to review and edit this file to change the defaults.' + fi +fi diff --git a/unix/hlib/mkmlist.csh b/unix/hlib/mkmlist.csh new file mode 100755 index 00000000..e4435916 --- /dev/null +++ b/unix/hlib/mkmlist.csh @@ -0,0 +1,21 @@ +#! /bin/csh +# MKMLIST -- Make a library member list on the standard output, e.g., for +# inclusion in a MKPKG file. + +# try to protect people from themselves... +unalias ls ex rm grep sed sort uniq cat + +ls *.[xfcs] > _ml1 +grep '^include' *.x >> _ml1 + +grep -v '#' _ml1 | grep -v '' | sort | uniq |\ + sed -e 's/^.*include./ /' | sed -e 's/\"//g' |\ + sed -e 's/\.x/.x /' > _ml2 + +ex - << 'EOC' _ml2 +g/^ / .-1,.j +1,$s/^/ / +wq +'EOC' + +cat _ml2; rm _ml[12] diff --git a/unix/hlib/mkmlist.sh b/unix/hlib/mkmlist.sh new file mode 100755 index 00000000..7d61264b --- /dev/null +++ b/unix/hlib/mkmlist.sh @@ -0,0 +1,19 @@ +#!/bin/bash +# MKMLIST -- Make a library member list on the standard output, e.g., for +# inclusion in a MKPKG file. + +_ml1() { + ls *.[xfcs] + grep '^include' *.x +} + +_ml2() { + _ml1 | grep -v '#' | grep -v '' | sort | uniq |\ + sed -e 's/^.*include./ /' | sed -e 's/\"//g' |\ + sed -e 's/\.x/.x /' | tr -s '\n ' '\t' +} + +echo -n " " +_ml2 | sed -e 's/\( \)\([^<]\)/# \2/g' | tr '#' '\n' |\ + sed -e 's/> being +# explicitly included (see $hlib/libc/varargs.h). + +$set XNOWARN = '& "$xc -c -/erroff=E_INC_USR_INC_MAY_NOT_PORTABLE &"' +$special "libc$": + printf.c $(XNOWARN) + eprintf.c $(XNOWARN) + sprintf.c $(XNOWARN) + scanf.c $(XNOWARN) + ; +$special "pkg$cl/": + clprintf.c $(XNOWARN) + errs.c $(XNOWARN) + ; + +# The iraf main has to be compiled without optimization on the Sun-4 +# as setjmp does not save the register set. + +$set XNO = '& "$xc -cq &"' +$special "sys$etc/": + main.x $(XNO) + ; + +# $set XBIG = '& "$xc -c -/Ns2048 &"' +# $special "sys$fmtio/": evvexpr.x $(XBIG) ; + + +# The following need to be linked nonshared to avoid the 268 MB memory limit +# in the shared Sun/IRAF library implementation. + +$set NONSHARE = '& "LFLAGS = -z -/Bstatic"' +$special "dataio$": xx_dataio.e $(NONSHARE) ; +$special "images$": xx_images.e $(NONSHARE) ; +$special "images$tv/": xx_tv.e $(NONSHARE) ; +$special "plot$": xx_plot.e $(NONSHARE) ; + diff --git a/unix/hlib/mkpkg.sf.SUN3 b/unix/hlib/mkpkg.sf.SUN3 new file mode 100644 index 00000000..556afcaa --- /dev/null +++ b/unix/hlib/mkpkg.sf.SUN3 @@ -0,0 +1,54 @@ +# Mkpkg special file list for SUN/IRAF, SUN/UNIX V3.2. +# Modified for SunOS 4.0. + +# All files needing special processing for the local host operating system, +# e.g., to permit host dependent optimization or to work around compiler bugs, +# should be listed here. + +# Files optimized for the local host system. +# ----------------------------------------- + +$special "sys$gio/nspp/sysint/": ishift.x as$ishift.s ; +$special "sys$gio/ncarutil/sysint/": ishift.x as$ishift.s ; + +$special "sys$osb/": aclrb.c as$aclrb.c + bytmov.c as$bytmov.c + ieeer.x as$ieeer.x + ieeed.x as$ieeed.x + ; + +$special "sys$vops/ak/": aclrc.x as$aclrc.c + aclrs.x as$aclrs.c + aclri.x as$aclri.c + aclrl.x as$aclrl.c + aclrr.x as$aclrr.c + aclrd.x as$aclrd.c + ; + +$special "sys$vops/lz/": amovc.x as$amovc.c + amovs.x as$amovs.c + amovi.x as$amovi.c + amovl.x as$amovl.c + amovr.x as$amovr.c + amovd.x as$amovd.c + ; + +# Files requiring special compilation due to host compiler bugs. +# ------------------------------------------------------------- + +# All this has been commented out for the new V1.3 Fortran compiler. +$set XNO = '& "$xc -cq &"' +$set XO1 = '& "$xc -cq -/O1 &"' +$set XO2 = '& "$xc -cq -/O2 &"' + +$special "sys$vops/ak/": + abnekx.x $(XNO) + abnex.x $(XNO) + ; +$special "sys$vops/lz/": + aveqx.x $(XNO) + ; + +$set XBIG = '& "$xc -c -/Ns2048 -/Nx2048 &"' +$special "sys$fmtio/": evvexpr.x $(XBIG) ; + diff --git a/unix/hlib/mkpkg.sf.SUN4 b/unix/hlib/mkpkg.sf.SUN4 new file mode 100644 index 00000000..de55ae44 --- /dev/null +++ b/unix/hlib/mkpkg.sf.SUN4 @@ -0,0 +1,55 @@ +# Mkpkg special file list for SUN/IRAF. +# SunOS Release Sys4GAMMA (HERCULES) #1: Fri Sep 18 10:15:21 PDT 1987 +# SunOS Release Sys4BETA1 (ORION) #1: Fri Oct 23 13:09:29 PDT 1987 + +$special "sys$osb/": aclrb.c as$aclrb.c + bytmov.c as$bytmov.c + ieeer.x as$ieeer.x + ieeed.x as$ieeed.x + ; + +$special "sys$vops/ak/": aclrc.x as$aclrc.c + aclrs.x as$aclrs.c + aclri.x as$aclri.c + aclrl.x as$aclrl.c + aclrr.x as$aclrr.c + aclrd.x as$aclrd.c + ; + +$special "sys$vops/lz/": amovc.x as$amovc.c + amovs.x as$amovs.c + amovi.x as$amovi.c + amovl.x as$amovl.c + amovr.x as$amovr.c + amovd.x as$amovd.c + ; + +$special "sys$memdbg/": zrtadr.c as$zrtadr.s ; + +# The iraf main has to be compiled without optimization on the Sun-4 +# as setjmp does not save the register set. + +$set XNO = '& "$xc -cq &"' +$special "sys$etc/": + main.x $(XNO) + ; + +# All files needing special processing for the local host operating system, +# e.g., to permit host dependent optimization or to work around compiler bugs, +# should be listed here. + +$special "sys$vops/ak/": + abnekx.x $(XNO) + abnex.x $(XNO) + ; +$special "sys$vops/lz/": + aveqx.x $(XNO) + ; + +# TMPFS bug should be fixed by now. +#$special "sys$etc/": +# oscmd.x as$oscmd.s +# ; + +$set XBIG = '& "$xc -c -/Ns2048 &"' +$special "sys$fmtio/": evvexpr.x $(XBIG) ; diff --git a/unix/hlib/mkpkg.sf.SX86 b/unix/hlib/mkpkg.sf.SX86 new file mode 100644 index 00000000..a0b56fcf --- /dev/null +++ b/unix/hlib/mkpkg.sf.SX86 @@ -0,0 +1,41 @@ +# Mkpkg special file list for Solaris-X86/IRAF GNU compilers. + +$special "sys$osb/": aclrb.c as$aclrb.c + bytmov.c as$bytmov.c + ieeer.x as$ieeer.x + ieeed.x as$ieeed.x + ; + +$special "sys$vops/ak/": aclrc.x as$aclrc.c + aclrs.x as$aclrs.c + aclri.x as$aclri.c + aclrl.x as$aclrl.c + aclrr.x as$aclrr.c + aclrd.x as$aclrd.c + ; + +$special "sys$vops/lz/": amovc.x as$amovc.c + amovs.x as$amovs.c + amovi.x as$amovi.c + amovl.x as$amovl.c + amovr.x as$amovr.c + amovd.x as$amovd.c + ; + +#$special "sys$memdbg/": zrtadr.c as$zrtadr.s ; + + +# The iraf main has to be compiled without optimization on the Sun-4 +# as setjmp does not save the register set. + +#$set XNO = '& "$xc -cq &"' +#$special "sys$etc/": +# main.x $(XNO) +# ; + +$set XBIG = '& "$xc -c -w -/Nx512 -/Ns2048 &"' +$special "sys$fmtio/": evvexpr.x $(XBIG) ; + +$set XNL = '& "$xc -c -/NL400 &"' +$special "math$slalib/": obs.f $(XNL) ; + diff --git a/unix/hlib/motd b/unix/hlib/motd new file mode 100644 index 00000000..77d4f035 --- /dev/null +++ b/unix/hlib/motd @@ -0,0 +1,14 @@ + + NOAO/IRAF PC-IRAF Revision 2.16.1 EXPORT Mon Oct 14 21:40:13 MST 2013 + This is the EXPORT version of IRAF V2.16 supporting PC systems. + + + Welcome to IRAF. To list the available commands, type ? or ??. To get + detailed information about a command, type `help '. To run a + command or load a package, type its name. Type `bye' to exit a + package, or `logout' to get out of the CL. Type `news' to find out + what is new in the version of the system you are using. + + Visit http://iraf.net if you have questions or to report problems. + + diff --git a/unix/hlib/r1mach.f b/unix/hlib/r1mach.f new file mode 100644 index 00000000..167e19f1 --- /dev/null +++ b/unix/hlib/r1mach.f @@ -0,0 +1,376 @@ + REAL FUNCTION R1MACH(I) +C +C SINGLE-PRECISION MACHINE CONSTANTS +C +C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. +C +C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C +C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING. +C +C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING. +C +C R1MACH(5) = LOG10(B) +C +C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, +C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY +C REMOVING THE C FROM COLUMN 1. +C +C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), THE FIRST +C SET OF CONSTANTS BELOW SHOULD BE APPROPRIATE. +C +C WHERE POSSIBLE, DECIMAL, OCTAL OR HEXADECIMAL CONSTANTS ARE USED +C TO SPECIFY THE CONSTANTS EXACTLY. SOMETIMES THIS REQUIRES USING +C EQUIVALENT INTEGER ARRAYS. IF YOUR COMPILER USES HALF-WORD +C INTEGERS BY DEFAULT (SOMETIMES CALLED INTEGER*2), YOU MAY NEED TO +C CHANGE INTEGER TO INTEGER*4 OR OTHERWISE INSTRUCT YOUR COMPILER +C TO USE FULL-WORD INTEGERS IN THE NEXT 5 DECLARATIONS. +C +C COMMENTS JUST BEFORE THE END STATEMENT (LINES STARTING WITH *) +C GIVE C SOURCE FOR R1MACH. +C + INTEGER SMALL(2) + INTEGER LARGE(2) + INTEGER RIGHT(2) + INTEGER DIVER(2) + INTEGER LOG10(2) + INTEGER I +C/6S +C/7S + SAVE SMALL, LARGE, RIGHT, DIVER, LOG10 +C/ + REAL RMACH(5) +C + EQUIVALENCE (RMACH(1),SMALL(1)) + EQUIVALENCE (RMACH(2),LARGE(1)) + EQUIVALENCE (RMACH(3),RIGHT(1)) + EQUIVALENCE (RMACH(4),DIVER(1)) + EQUIVALENCE (RMACH(5),LOG10(1)) +C +C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T +C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T +C PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). +C + DATA SMALL(1) / 8388608 / + DATA LARGE(1) / 2139095039 / + DATA RIGHT(1) / 864026624 / + DATA DIVER(1) / 872415232 / + DATA LOG10(1) / 1050288283 / +C +C MACHINE CONSTANTS FOR AMDAHL MACHINES. +C +C DATA SMALL(1) / 1048576 / +C DATA LARGE(1) / 2147483647 / +C DATA RIGHT(1) / 990904320 / +C DATA DIVER(1) / 1007681536 / +C DATA LOG10(1) / 1091781651 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA RMACH(1) / Z400800000 / +C DATA RMACH(2) / Z5FFFFFFFF / +C DATA RMACH(3) / Z4E9800000 / +C DATA RMACH(4) / Z4EA800000 / +C DATA RMACH(5) / Z500E730E8 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. +C +C DATA RMACH(1) / O1771000000000000 / +C DATA RMACH(2) / O0777777777777777 / +C DATA RMACH(3) / O1311000000000000 / +C DATA RMACH(4) / O1301000000000000 / +C DATA RMACH(5) / O1157163034761675 /, SC/987/ +C +C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. +C +C DATA RMACH(1) / 00564000000000000000B / +C DATA RMACH(2) / 37767777777777777776B / +C DATA RMACH(3) / 16414000000000000000B / +C DATA RMACH(4) / 16424000000000000000B / +C DATA RMACH(5) / 17164642023241175720B /, SC/987/ +C +C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. +C +C DATA RMACH(1) / O"00564000000000000000" / +C DATA RMACH(2) / O"37767777777777777776" / +C DATA RMACH(3) / O"16414000000000000000" / +C DATA RMACH(4) / O"16424000000000000000" / +C DATA RMACH(5) / O"17164642023241175720" /, SC/987/ +C +C MACHINE CONSTANTS FOR CONVEX C-1. +C +C DATA RMACH(1) / '00800000'X / +C DATA RMACH(2) / '7FFFFFFF'X / +C DATA RMACH(3) / '34800000'X / +C DATA RMACH(4) / '35000000'X / +C DATA RMACH(5) / '3F9A209B'X /, SC/987/ +C +C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. +C +C DATA RMACH(1) / 200034000000000000000B / +C DATA RMACH(2) / 577767777777777777776B / +C DATA RMACH(3) / 377224000000000000000B / +C DATA RMACH(4) / 377234000000000000000B / +C DATA RMACH(5) / 377774642023241175720B /, SC/987/ +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. +C +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - +C STATIC RMACH(5) +C +C DATA SMALL/20K,0/,LARGE/77777K,177777K/ +C DATA RIGHT/35420K,0/,DIVER/36020K,0/ +C DATA LOG10/40423K,42023K/, SC/987/ +C +C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7. +C +C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1),LARGE(2) / '37777777, '00000177 / +C DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 / +C DATA DIVER(1),DIVER(2) / '20000000, '00000353 / +C DATA LOG10(1),LOG10(2) / '23210115, '00000377 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C +C DATA RMACH(1) / O402400000000 / +C DATA RMACH(2) / O376777777777 / +C DATA RMACH(3) / O714400000000 / +C DATA RMACH(4) / O716400000000 / +C DATA RMACH(5) / O776464202324 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. +C +C DATA RMACH(1) / Z00100000 / +C DATA RMACH(2) / Z7FFFFFFF / +C DATA RMACH(3) / Z3B100000 / +C DATA RMACH(4) / Z3C100000 / +C DATA RMACH(5) / Z41134413 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE INTERDATA 8/32 +C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. +C +C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE +C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. +C +C DATA RMACH(1) / Z'00100000' / +C DATA RMACH(2) / Z'7EFFFFFF' / +C DATA RMACH(3) / Z'3B100000' / +C DATA RMACH(4) / Z'3C100000' / +C DATA RMACH(5) / Z'41134413' /, SC/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). +C +C DATA RMACH(1) / "000400000000 / +C DATA RMACH(2) / "377777777777 / +C DATA RMACH(3) / "146400000000 / +C DATA RMACH(4) / "147400000000 / +C DATA RMACH(5) / "177464202324 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1) / 8388608 / +C DATA LARGE(1) / 2147483647 / +C DATA RIGHT(1) / 880803840 / +C DATA DIVER(1) / 889192448 / +C DATA LOG10(1) / 1067065499 /, SC/987/ +C +C DATA RMACH(1) / O00040000000 / +C DATA RMACH(2) / O17777777777 / +C DATA RMACH(3) / O06440000000 / +C DATA RMACH(4) / O06500000000 / +C DATA RMACH(5) / O07746420233 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1),SMALL(2) / 128, 0 / +C DATA LARGE(1),LARGE(2) / 32767, -1 / +C DATA RIGHT(1),RIGHT(2) / 13440, 0 / +C DATA DIVER(1),DIVER(2) / 13568, 0 / +C DATA LOG10(1),LOG10(2) / 16282, 8347 /, SC/987/ +C +C DATA SMALL(1),SMALL(2) / O000200, O000000 / +C DATA LARGE(1),LARGE(2) / O077777, O177777 / +C DATA RIGHT(1),RIGHT(2) / O032200, O000000 / +C DATA DIVER(1),DIVER(2) / O032400, O000000 / +C DATA LOG10(1),LOG10(2) / O037632, O020233 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. +C +C DATA SMALL(1) / $00800000 / +C DATA LARGE(1) / $7F7FFFFF / +C DATA RIGHT(1) / $33800000 / +C DATA DIVER(1) / $34000000 / +C DATA LOG10(1) / $3E9A209B /, SC/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C DATA RMACH(1) / O000400000000 / +C DATA RMACH(2) / O377777777777 / +C DATA RMACH(3) / O146400000000 / +C DATA RMACH(4) / O147400000000 / +C DATA RMACH(5) / O177464202324 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE VAX UNIX F77 COMPILER. +C +C DATA SMALL(1) / 128 / +C DATA LARGE(1) / -32769 / +C DATA RIGHT(1) / 13440 / +C DATA DIVER(1) / 13568 / +C DATA LOG10(1) / 547045274 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE VAX-11 WITH +C FORTRAN IV-PLUS COMPILER. +C +C DATA RMACH(1) / Z00000080 / +C DATA RMACH(2) / ZFFFF7FFF / +C DATA RMACH(3) / Z00003480 / +C DATA RMACH(4) / Z00003500 / +C DATA RMACH(5) / Z209B3F9A /, SC/987/ +C +C MACHINE CONSTANTS FOR VAX/VMS VERSION 2.2. +C +C DATA RMACH(1) / '80'X / +C DATA RMACH(2) / 'FFFF7FFF'X / +C DATA RMACH(3) / '3480'X / +C DATA RMACH(4) / '3500'X / +C DATA RMACH(5) / '209B3F9A'X /, SC/987/ +C +C *** ISSUE STOP 777 IF ALL DATA STATEMENTS ARE COMMENTED... +C IF (SC .NE. 987) THEN +C* *** CHECK FOR AUTODOUBLE *** +C SMALL(2) = 0 +C RMACH(1) = 1E13 +C IF (SMALL(2) .NE. 0) THEN +C* *** AUTODOUBLED *** +C IF ( SMALL(1) .EQ. 1117925532 +C * .AND. SMALL(2) .EQ. -448790528) THEN +C* *** IEEE BIG ENDIAN *** +C SMALL(1) = 1048576 +C SMALL(2) = 0 +C LARGE(1) = 2146435071 +C LARGE(2) = -1 +C RIGHT(1) = 1017118720 +C RIGHT(2) = 0 +C DIVER(1) = 1018167296 +C DIVER(2) = 0 +C LOG10(1) = 1070810131 +C LOG10(2) = 1352628735 +C ELSE IF ( SMALL(2) .EQ. 1117925532 +C * .AND. SMALL(1) .EQ. -448790528) THEN +C* *** IEEE LITTLE ENDIAN *** +C SMALL(2) = 1048576 +C SMALL(1) = 0 +C LARGE(2) = 2146435071 +C LARGE(1) = -1 +C RIGHT(2) = 1017118720 +C RIGHT(1) = 0 +C DIVER(2) = 1018167296 +C DIVER(1) = 0 +C LOG10(2) = 1070810131 +C LOG10(1) = 1352628735 +C ELSE IF ( SMALL(1) .EQ. -2065213935 +C * .AND. SMALL(2) .EQ. 10752) THEN +C* *** VAX WITH D_FLOATING *** +C SMALL(1) = 128 +C SMALL(2) = 0 +C LARGE(1) = -32769 +C LARGE(2) = -1 +C RIGHT(1) = 9344 +C RIGHT(2) = 0 +C DIVER(1) = 9472 +C DIVER(2) = 0 +C LOG10(1) = 546979738 +C LOG10(2) = -805796613 +C ELSE IF ( SMALL(1) .EQ. 1267827943 +C * .AND. SMALL(2) .EQ. 704643072) THEN +C* *** IBM MAINFRAME *** +C SMALL(1) = 1048576 +C SMALL(2) = 0 +C LARGE(1) = 2147483647 +C LARGE(2) = -1 +C RIGHT(1) = 856686592 +C RIGHT(2) = 0 +C DIVER(1) = 873463808 +C DIVER(2) = 0 +C LOG10(1) = 1091781651 +C LOG10(2) = 1352628735 +C ELSE +C WRITE(*,*)'Adjust autodoubled R1MACH by uncommenting' +C WRITE(*,*)'data statements appropriate for your machine.' +C STOP 777 +C END IF +C ELSE +C RMACH(1) = 1234567. +C IF (SMALL(1) .EQ. 1234613304) THEN +C* *** IEEE *** +C SMALL(1) = 8388608 +C LARGE(1) = 2139095039 +C RIGHT(1) = 864026624 +C DIVER(1) = 872415232 +C LOG10(1) = 1050288283 +C ELSE IF (SMALL(1) .EQ. -1271379306) THEN +C* *** VAX *** +C SMALL(1) = 128 +C LARGE(1) = -32769 +C RIGHT(1) = 13440 +C DIVER(1) = 13568 +C LOG10(1) = 547045274 +C ELSE IF (SMALL(1) .EQ. 1175639687) THEN +C* *** IBM *** +C SMALL(1) = 1048576 +C LARGE(1) = 2147483647 +C RIGHT(1) = 990904320 +C DIVER(1) = 1007681536 +C LOG10(1) = 1091781651 +C ELSE +C WRITE(*,*)'Adjust R1MACH by uncommenting' +C WRITE(*,*)'data statements appropriate for your machine.' +C STOP 777 +C END IF +C END IF +C SC = 987 +C END IF +C +C *** ISSUE STOP 776 IF ALL DATA STATEMENTS ARE OBVIOUSLY WRONG... +C IF (RMACH(4) .GE. 1.0) STOP 776 +C*C/6S +C*C IF (I .LT. 1 .OR. I .GT. 5) +C*C 1 CALL SETERR(24HR1MACH - I OUT OF BOUNDS,24,1,2) +C*C/7S +C* IF (I .LT. 1 .OR. I .GT. 5) +C* 1 CALL SETERR('R1MACH - I OUT OF BOUNDS',24,1,2) +C*C/ +C +C IF (I .LT. 1 .OR. I .GT. 5) THEN +C WRITE(*,*) 'R1MACH(I): I =',I,' is out of bounds.' +C STOP +C END IF + IF (I .LT. 1 .OR. I .GT. 5) THEN + R1MACH = 0.0 + END IF + R1MACH = RMACH(I) + RETURN +C +C* /* C source for R1MACH -- remove the * in column 1 */ +C*#include +C*#include +C*#include +C* +C*float r1mach_(long *i) +C*{ +C* switch(*i){ +C* case 1: return FLT_MIN; +C* case 2: return FLT_MAX; +C* case 3: return FLT_EPSILON/FLT_RADIX; +C* case 4: return FLT_EPSILON; +C* case 5: return log10(FLT_RADIX); +C* } +C* +C* fprintf(stderr, "invalid argument: r1mach(%ld)\n", *i); +C* exit(1); +C* return 0; /* for compilers that complain of missing return values */ +C* } + END diff --git a/unix/hlib/setup.csh b/unix/hlib/setup.csh new file mode 100755 index 00000000..6a826c75 --- /dev/null +++ b/unix/hlib/setup.csh @@ -0,0 +1,21 @@ +#!/bin/csh -f + +# Allow a previously defined $iraf to be used. +if ( ! ( $?iraf )) then + setenv iraf /iraf/iraf/ +endif + +# Allow a previously defined $IRAFARCH to be used. +if ( ! ( $?IRAFARCH )) then + setenv IRAFARCH `$iraf/unix/hlib/irafarch.csh -actual` +endif +source $iraf/unix/hlib/irafuser.csh + +set path = ($FAKEHOME/bin $path) +set cdpath = ($iraf $iraf/pkg $iraf/noao $iraf/sys $iraf/unix $iraf/unix/boot) + +# The world'd most obvious alias .... +alias iraf "xgterm -e cl &" + +rehash + diff --git a/unix/hlib/setup.sh b/unix/hlib/setup.sh new file mode 100755 index 00000000..882bf828 --- /dev/null +++ b/unix/hlib/setup.sh @@ -0,0 +1,18 @@ +#!/bin/bash + +# Allow a previously defined $iraf to be used. +if [ -z "$iraf" ]; then + export iraf=/iraf/iraf/ +fi + +# Allow a previously defined $IRAFARCH to be used. +if [ -z "$IRAFARCH" ]; then + export IRAFARCH=`$iraf/unix/hlib/irafarch.sh -actual` +fi +source $iraf/unix/hlib/irafuser.sh + +export PATH=$iraf/fakehome/bin:$iraf/bin:${PATH} + +# The world'd most obvious alias .... +alias iraf="xgterm -e cl &" + diff --git a/unix/hlib/spy.cl b/unix/hlib/spy.cl new file mode 100644 index 00000000..31522f4d --- /dev/null +++ b/unix/hlib/spy.cl @@ -0,0 +1,31 @@ +# SPY -- [MACHDEP] Give info on who is logged in, what they are up to, +# how much resources they have consumed, and so on. This routine is +# machine dependent. + +procedure spy() + +begin + string mach + + if ($nargs > 0) { + # "Verbose" mode: show UNIX processor status, filtering + # out all the uninteresting system processes. + + print ("!!uname" | cl() | scan (mach) + if (strlwr (mach) == "ssol") { + !! ps -ef | grep -v root + } else if (strlwr (mach) == "SunOS") { + !! ps -axu | grep -v root + } else if (strlwr (mach) == "linux" || strlwr (mach) == "Darwin") { + !! ps axuf | grep -v root + } else { + !! ps -ef | grep -v root + } + + } else { + # Merely give info on who is logged in and what they are doing. + # The following is for Berkeley UNIX only. + + !! w + } +end diff --git a/unix/hlib/strip b/unix/hlib/strip new file mode 100644 index 00000000..e69de29b diff --git a/unix/hlib/strip.iraf b/unix/hlib/strip.iraf new file mode 100644 index 00000000..74e61ada --- /dev/null +++ b/unix/hlib/strip.iraf @@ -0,0 +1,66 @@ +# STRIP.IRAF -- Rmfiles command script, used to strip the IRAF system down to +# its bare essentials (for a production version of the system). The RMFILES +# program which reads this must be run from the IRAF root directory. + + unix/as.linux -all + unix/as.linux64 -all + unix/as.i386 -all + unix/as.mc68020 -all + unix/as.rs6000 -all + unix/as.sparc -all + unix/as.ssol -all + unix/as.vax -all + unix/boot -allbut .hlp .hd + unix/gdev -all + unix/os -all + unix/mc68000 -all + unix/portkit -all + unix/shlib -all + unix/sun -all + + dev -only .dat + doc -allbut .hlp + math -all + pkg -allbut .hlp .hd .men .cl .par .key .dat .mip + pkg/bench -all + sys -all + +-file unix/hlib/libcalcomp.a +-file pkg/dataio/fits/structure.hlp +-file pkg/images/imcalc/Imcalc.hlp +-file pkg/images/tv/iis/ids/doc/Imdis.hlp +-file pkg/images/tv/doc/Tv.hlp +-file pkg/lists/doc/Lcalc.hlp +-file pkg/lists/doc/Lists.hlp +-file pkg/system/doc/Sys.hlp +-file pkg/system/doc/Sys_intro.hlp +-file pkg/system/help/design.hlp +-file tags + +-file bin.alpha/OBJS.arc.Z +-file bin.ddec/OBJS.arc.Z +-file bin.f2c/OBJS.arc.Z +-file bin.f68881/OBJS.arc.Z +-file bin.ffpa/OBJS.arc.Z +-file bin.hp300/OBJS.arc.Z +-file bin.hp700/OBJS.arc.Z +-file bin.hp800/OBJS.arc.Z +-file bin.i386/OBJS.arc.Z +-file bin.irix/OBJS.arc.Z +-file bin.mips/OBJS.arc.Z +-file bin.rs6000/OBJS.arc.Z +-file bin.sf2c/OBJS.arc.Z + +-file bin.sparc/OBJS.arc.Z +-file bin.ssun/OBJS.arc.Z + +-file bin.redhat/OBJS.arc.Z +-file bin.linux/OBJS.arc.Z +-file bin.linux64/OBJS.arc.Z +-file bin.macosx/OBJS.arc.Z +-file bin.macintel/OBJS.arc.Z +-file bin.cygwin/OBJS.arc.Z +-file bin.freebsd/OBJS.arc.Z +-file bin.sunos/OBJS.arc.Z +-file bin.linuxppc/OBJS.arc.Z + diff --git a/unix/hlib/sysinfo b/unix/hlib/sysinfo new file mode 100755 index 00000000..b3c6f8dc --- /dev/null +++ b/unix/hlib/sysinfo @@ -0,0 +1,2503 @@ +#!/bin/csh -f +# +# SYSINFO -- Display IRAF system diagnostic and configuration information. +# +# The intent of this program is to provide a means for IRAF site managers +# to troubleshoot their IRAF installations by running numerous verification +# tests on the iraf directory structure, networking setup, external package +# installations, tape configurations, etc. Failed tests are not always +# fatal but may indicate a problem in the way something was installed or +# configured. +# +# Usage: sysinfo [ -G | -V | -N | -P | -D | -T | -h ] +# +# where: -G Print General Info only" +# -V Do Verification tests only" +# -N Do Networking tests only" +# -P Do Extern Package tests only" +# -D Do Display tests only" +# -T Do Tape Device tests only" +# -h Print this message" +# +# ---------------------------------------------------------------------------- + +unset noclobber +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort +unalias uniq head sed tr which +set path = ($path /sbin /usr/sbin /bin /usr/bin /usr/ucb /etc /usr/etc /usr/openwin/bin /usr/X11R6/bin /usr/X11/bin) +onintr sysinfo_cleanup + + +############################################################################## +# START OF MACHDEP DEFINITIONS. +############################################################################## + +# MACHDEP definitions which may be reset below. + +set hmach = "INDEF" +set pciraf = 0 +set suniraf = 0 +set do_tapecaps = 0 +set hilite = 0 + +# Utility aliases. +alias BOLD_ON "(if ($hilite) tput bold)" +alias BOLD_OFF "(if ($hilite) tput sgr0)" +alias SO_ON "(if ($hilite) tput smso)" +alias SO_OFF "(if ($hilite) tput rms0)" + +alias DO_OK "(echo -n '[ '; BOLD_ON; echo -n ' OK '; BOLD_OFF; echo ' ]')" +alias DO_WARN "(echo -n '[ '; BOLD_ON; echo -n 'WARN'; BOLD_OFF; echo ' ]')" +alias DO_FAIL "(echo -n '[ '; SO_ON; echo -n 'FAIL'; SO_OFF; echo ' ]')" + +alias MSG "(echo -n ' ';BOLD_ON;echo -n '*** ';BOLD_OFF; echo \!*)" +alias MSGN "(echo -n ' ';BOLD_ON;echo -n '*** ';BOLD_OFF; echo -n \!*)" +alias MSGB "(echo -n ' ';BOLD_ON;echo -n '*** ';echo \!*; BOLD_OFF)" +alias MSGBN "(echo -n ' ';BOLD_ON;echo -n '*** ';echo -n \!*;BOLD_OFF)" +alias ERRMSG "(echo -n ' ';BOLD_ON;echo -n 'ERROR: ';BOLD_OFF; echo \!*)" +alias WARNING "(echo -n ' ';BOLD_ON;echo -n 'WARNING: ';BOLD_OFF; echo \!*)" +alias NEWLINE "(echo '')" + +alias RM "rm -rf" + + + + +# Determine platform architecture. +set UNAME="" +if (-e /usr/bin/uname) then + set uname_cmd = /usr/bin/uname + set UNAME=`/usr/bin/uname | tr '[A-Z]' '[a-z]'` +else if (-e /bin/uname) then + set uname_cmd = /bin/uname + set UNAME=`/bin/uname | tr '[A-Z]' '[a-z]'` +else + WARNING "No 'uname' command found to determine architecture." + exit 1 +endif + +set pciraf = 0 +set hmach = "INDEF" +switch ($UNAME) + case sunos: + if (`$uname_cmd -m | cut -c2-` != "86pc") then + setenv OSVERSION `uname -r | cut -c1` + if ($OSVERSION == 5) then # Sparc Solaris + set mach = "ssun" + set hmach = "ssol" + set TAPES = "/dev/rmt/[0-9]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/usr/ucb/ls -s" + set LSDF = "-lLtg" + else # Sparc SunOS 4.x + set mach = "sparc" + set hmach = "sparc" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + endif + else + set mach = "sunos" # Intel Solaris + set hmach = "sunos" + set TAPES = "/dev/*st[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLt" + set pciraf = 1 + endif + breaksw + case linux: + if (`$uname_cmd -m` == "x86_64") then # Linux64 + set mach = "linux64" + set hmach = "linux64" + set TAPES = "/dev/*st[0-7]" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLt" + + else if (`$uname_cmd -m` == "ppc") then # LinuxPPC + set mach = "linuxppc" + set hmach = "linuxppc" + set TAPES = "/dev/*st[0-7]" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLt" + else + if (-f /etc/redhat-release) then # RedHat Linux + set mach = "redhat" + set hmach = "redhat" + set TAPES = "/dev/*st[0-7]" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + else # Other Linux + set mach = "linux" + set hmach = "linux" + set TAPES = "/dev/*st[0-7]" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + endif + endif + set pciraf = 1 + breaksw + case darwin: # Mac OS X + case macosx: + case macintel: + if (`$uname_cmd -m` == "x86_64") then # 64-bit + set mach = "macintel" + set hmach = "macintel" + else + set mach = "macosx" # 32-bit + set hmach = "macosx" + endif + set TAPES = "/dev/*sa[0-7]" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + set pciraf = 1 + breaksw + case freebsd: # FreeBSD + set mach = "freebsd" + set hmach = "freebsd" + set TAPES = "/dev/*sa[0-7]" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + set pciraf = 1 + breaksw + case hp-ux: # HP/UX 10.20 + set mach = "hp700" + set hmach = "hp700" + set TAPES = "/dev/rmt/[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLt" + breaksw + case irix: # SGI IRIX 6.5 + case irix64: + set mach = "irix" + set hmach = "irix" + set TAPES = "/dev/tps[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLt" + breaksw + case aix: # IBM AIX V4 + set mach = "rs6000" + set hmach = "rs6000" + set TAPES = "/dev/rmt[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + breaksw + case osf1: # Alpha Tru64 + set mach = "alpha" + set hmach = "alpha" + set TAPES = "/dev/nrmt[0-7]* /dev/rmt[0-7]*" + set shlib = "yes" + set LIBFILES = "libiraf.so" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + breaksw + case ultrix: # DEC Ultrix + set mach = "ultrix" + set hmach = "ultrix" + set TAPES = "/dev/[n]rmt[0-7]*" + set shlib = "no" + set LIBFILES = "" + set LS = "/bin/ls -s" + set LSDF = "-lLtg" + breaksw + + default: + # We don't want to be limited by the CYGWIN version numbering so + # look for a truncated match here before punting. + set os_mach = `echo $UNAME | cut -c1-6` + if ("$os_mach" == "cygwin") then + set mach = "cygwin" + set hmach = "cygwin" + set shlib = "no" + set LIBFILES = "" + set TAPES = "" # no tape support + set do_tapecaps = 0 + set do_tapes = 0 + set do_pipes = 0 + breaksw + + else + ERRMSG "Unable to determine platform architecture. Please" + ERRMSG "contact the forums at http://forums.iraf.net" + NEWLINE + exit 1 + else +endsw + +###################### END OF MACHDEP DEFINITIONS. ######################## + + +#============================================================================= +# Initializations. +#============================================================================= +set errstat = 0 # initialize status counters +set ok_count = 0 +set err_count = 0 +set warn_count = 0 +set defstat = " OK " + + +#============================================================================= +# Process any command line arguments. +#============================================================================= + +set early_exit = 0 +set general = 0 +set severe = 0 + +while ("$1" != "") + switch ("$1") + case -G: # Output General Info only + set general = 1 + set early_exit = 1 + goto General + breaksw + case -V: # Verification Test Only + set early_exit = 1 + breaksw + case -N: # Test Networking Only + set early_exit = 1 + goto Networking + breaksw + case -P: # Test Packages Only + set early_exit = 1 + goto External_Packages + breaksw + case -D: # Test Display Only + set early_exit = 1 + goto Image_Display + breaksw + case -T: # Test Tapes Only + set early_exit = 1 + goto Tape_Device + breaksw + + case -hl: # disable highlighting + NEWLINE + echo "WARNING: Highlighting is not permitted by this script, ignoring." + NEWLINE + breaksw + case +hl: # enable highlighting + NEWLINE + echo "WARNING: Highlighting is not permitted by this script, ignoring." + NEWLINE + breaksw + + case -help: + case -h: + goto Usage + default: + ERRMSG "SYSINFO: unknown argument $1" + goto Usage + endsw + + if ("$2" == "") then + break + else + shift + endif +end + + + +#============================================================================= +# General Information +#============================================================================= + +General: + +NEWLINE +BOLD_ON +echo " General Information" +echo " ===================" +BOLD_OFF +NEWLINE + +# Document the system information. +echo "Host name: "`hostname` +echo "Operating System: "`uname -a` +echo "Architecture: "$mach +echo "HSI architecture: "$hmach + +if ($pciraf && -e /etc/issue) then + set issue = `cat /etc/issue` + NEWLINE + echo "PC Issue: " $issue +endif + +NEWLINE + +# Check the iraf root directory stuff +echo -n "IRAF environment path: " +if ($?iraf == 1) then + set env_iraf = $iraf + echo "$iraf" +else + set env_iraf = "" + echo "" +endif + +echo -n "Checking for " +if (-e /usr/include/iraf.h) then + NEWLINE + echo -n " IRAF path: " + set ip = `grep "^#define IRAF" /usr/include/iraf.h | sed -e 's/\"//g'` + if ("$ip" != "") then + echo $ip[3] + set irafh_iraf = $ip[3] + else + echo "not found" + endif + + echo -n " HOST path: " + set ip = `grep "^#define HOST" /usr/include/iraf.h | sed -e 's/\"//g'` + if ("$ip" != "") then + echo $ip[3] + else + echo "not found" + endif + + echo -n " TMP path: " + set ip = `grep "^#define TMP" /usr/include/iraf.h | sed -e 's/\"//g'` + if ("$ip" != "") then + echo $ip[3] + else + echo "not found" + endif +else + echo " not found" + NEWLINE + echo " *** The file /usr/include/iraf.h was not found on this system" + echo " *** which means the install script was not run on this machine." + if ("$env_iraf" != "") then + echo " *** Using environment definition: $env_iraf" + endif + NEWLINE + set irafh_iraf = "" +endif + +if ("$env_iraf" != "" && "$irafh_iraf" != "") then + if ("$env_iraf" != "$irafh_iraf") then + NEWLINE + echo "WARNING: iraf environment and root directories differ." + + # First make sure we have a valid path. + if ( !(-e $env_iraf/unix/hlib/zzsetenv.def)) then + MSG "Environment definition looks incorrect." + MSG "Using definition '$irafh_iraf'" + + # Strip off any trailing '/'. + set iraf = `echo $irafh_iraf | sed -e 's+/\(["]*\)$+\1+'` + + else if ( !(-e $irafh_iraf/unix/hlib/zzsetenv.def)) then + MSG " definition looks incorrect." + MSG "Using environment definition '$env_iraf'" + + # Strip off any trailing '/'. + set iraf = `echo $env_iraf | sed -e 's+/\(["]*\)$+\1+'` + endif + + NEWLINE + + else + if ("$env_iraf" != "") then + set iraf = `echo $env_iraf | sed -e 's+/\(["]*\)$+\1+'` + else + set iraf = `echo $irafh_iraf | sed -e 's+/\(["]*\)$+\1+'` + endif + endif + +else if ("$env_iraf" == "" && "$irafh_iraf" == "") then + NEWLINE + MSG "No 'iraf' defined in the environment and there is no " + MSG "file on this machine. Please specify an iraf path in the" + MSG "environment or run the install script to proceed." + NEWLINE + exit 1 + +else if ("$env_iraf" == "") then + # Strip off any trailing '/'. + set iraf = `echo $irafh_iraf | sed -e 's+/\(["]*\)$+\1+'` + +else if ("$irafh_iraf" == "") then + # Strip off any trailing '/'. + set iraf = `echo $env_iraf | sed -e 's+/\(["]*\)$+\1+'` +endif + + +NEWLINE +echo "Using iraf root path: $iraf" +NEWLINE + +# Initialize for files we'll be checking later. +set tapecap_file = "$iraf/dev/tapecap" +set termcap_file = "$iraf/dev/termcap" +set graphcap_file = "$iraf/dev/graphcap" + + + +# Get the motd header string. +echo -n 'IRAF version: ' +if (-e $iraf/unix/hlib/motd) then + set motd = "$iraf/unix/hlib/motd" + set ver = `head -1 $motd | sed -e 's/NOAO//g' -e 's/EXPORT//g'` + echo $ver +else + echo "" +endif +NEWLINE + + +# Get the last time the hlib$utime (install) was updated. +echo -n "Install script last run: " +if (-e $iraf/unix/hlib/utime) then + set dat = `$LS $LSDF $iraf/unix/hlib/utime | head -2 | tail -1` + set utime = `echo -n $dat | awk '{printf ("%3s %2s %-5s\t", $7, $8, $9)}'` + echo $utime +else + echo "" +endif + +# Look around for the local iraf commands directory. +echo -n "IRAF command directories: " +set clpath = `which cl` +set lbins = "" +if ("`echo $clpath | grep 'Command not found'`" == "") then + set d_lbin = $clpath:h + + foreach p ($path) + if (-d $p && -e $p/cl) then + set lbin = $p + set lbins = `echo $lbins $p` + if ("$lbins" == "$lbin") then + echo $p + else + echo " $p" + endif + endif + end + + if ("$lbin" == "") then + echo "not found" + endif +else + echo "not found" +endif + + +# If we use a shared library see if it's in the path someplace. +if ("$shlib" == "yes") then + echo -n "IRAF shared lib directory: " + set llib = "" + set llibs = "" + + # Look around and come up with a likely candidate directory. + set sysp = "/usr/local/lib /local/lib /usr/lib /var/shlib /lib" + if ($?LD_LIBRARY_PATH) then + set userp = `echo $LD_LIBRARY_PATH | sed -e 's/:/ /g'` + else + set userp = "" + endif + foreach p ($sysp $userp) + if (-d $p) then + foreach l ($LIBFILES) + if (-e $p/$l) then + set llib = $p + set llibs = `echo $llibs $p` + + if ("$llibs" == "$llib") then + echo $p + else + echo " $p" + endif + endif + end + endif + end + + if ("$llib" == "") then + echo "not found" + endif +endif + + +# Get the default imdir from the mkiraf.csh +echo -n "Default image storage dir: " +set hlib = $iraf/unix/hlib/ +if (-e $hlib/mkiraf.csh) then + set p = `grep "^set imdir" $hlib/mkiraf.csh | sed -e 's/\"//g'` + if ("$p" != "") then + echo $p[4] + set imdir = $p[4] + else + echo "not found" + endif +else + echo "" +endif + + +# Print some interesting default system settings from hlib$zzsetenv.def. +set WS = '[ ]' +set ZZDEFS = "printer stdplot editor imtype stdimage cmbuflen min_lenuserarea graphcap termcap tapecap" + +NEWLINE +echo 'Default settings in the hlib$zzsetenv.def file:' + +if (-e $hlib/zzsetenv.def) then + foreach i ($ZZDEFS) + set p = `grep "^set$WS$i" $hlib/zzsetenv.def | sed -e 's/\"//g'` + if ("$p" != "") then + set $i = '$p[4]' + echo ${i}: $p[4] | awk '{ printf (" %-12s\t %s\n", $1, $2)}' + + # Save the *cap file for later use. + if ("$i" == "termcap" && "$p[4]" != 'dev$termcap') then + set termcap_file = $p[4] + else if ("$i" == "graphcap" && "$p[4]" != 'dev$graphcap') then + set graphcap_file = $p[4] + else if ("$i" == "tapecap" && "$p[4]" != 'dev$tapecap') then + set tapecap_file = $p[4] + endif + else + echo ${i}: | awk '{ printf (" %-12s\tnot found\n", $1, $2)}' + endif + end +else + MSG 'hlib$zzsetenv.def file not found' + set severe = 1 +endif +NEWLINE + + +if ($pciraf) then + NEWLINE + echo "X Server Version information:" + echo " "`X -version |& egrep "^XFree86"` + echo " "`X -version |& egrep "^Release"` + echo " "`X -version |& egrep "Operating"` +endif + + +NEWLINE +echo "Compilers and Development Tools Available:" +echo " (NOTE: duplicates are possible due to the search path" +echo " used and symbolic links for commands.)" +NEWLINE +set found = 0 +foreach d ($path) + foreach i (cc gcc acc c89 f77 g77 f90 fort f2c yacc bison lex flex) + if (-e $d/$i) then + echo " "$d/$i + set found = 1 + endif + end +end +if ($found == 0) then + echo " None Found" + NEWLINE +endif + + +if ($severe == 1) then + NEWLINE + NEWLINE + BOLD_ON + echo "======================================================================" + echo "SYSINFO: Aborting due to severe errors." + echo "======================================================================" + BOLD_OFF + NEWLINE + exit 1 + +else if ($general == 1) then + goto exit_early +endif + + + + + +#============================================================================= +# Installation Verification +#============================================================================= + +Verification: + +echo; NEWLINE +echo "======================= Verifying Installation =======================" +NEWLINE + +############################################################################## +# +# Step 1: VERIFICATION +# +# Run some simple checks to be sure the system was unpacked correctly +# and the settings used are correct. Verification tests include: +# +# o Verify the machine type and document settings. +# o Check iraf root directory looks correct. +# o Check iraf root and imdir aren't the same +# o Check iraf user exists in passwd file. +# o Check iraf user login path in passwd file is iraf$local. +# o Check iraf tree for proper structure. +# o Check iraf tree is owned by 'iraf' +# o Check binary dirs are both populated correctly. +# o Check that the local bin directory exists. +# o Check that the local lib directory exists. +# +# An error at this stage will cause the script to exit so we can reset and +# try again. +# +############################################################################## + + +# ============================================ +# The following is partially system dependent. +# ============================================ + +# Set the BINDIRS pathnames - directories where the HSI executables go. +set host = "$iraf/unix" +set hbin = "$iraf/unix/bin.$hmach" +set hlib = "$iraf/unix/hlib" +set fbin = "$iraf/bin" + +# Replace any // by /. +set host = `echo $host | sed -e "s+//+/+g"` +set hbin = `echo $hbin | sed -e "s+//+/+g"` +set fbin = `echo $fbin | sed -e "s+//+/+g"` +set hlib = `echo $hlib | sed -e "s+//+/+g"` + +# Strip any trailing /. +set host = `echo $host | sed -e 's+/\(["]*\)$+\1+'` +set hbin = `echo $hbin | sed -e 's+/\(["]*\)$+\1+'` +set fbin = `echo $fbin | sed -e 's+/\(["]*\)$+\1+'` +set hlib = `echo $hlib | sed -e 's+/\(["]*\)$+\1+'` +set BINDIRS = "$hbin $hlib $fbin $host" + +# The following file lists are partially system dependent. +set PATHFILES = "mkiraf.csh libc/iraf.h cl.csh ../../local/.login" +set MODEFILES = "cl.csh fc.csh mkiraf.csh mkfloat.csh mkmlist.csh $host/reboot generic.e mkpkg.e rmbin.e rmfiles.e rpp.e rtar.e wtar.e xc.e xpp.e xyacc.e sgidispatch.e $hbin/sgi2*.e" +set LINKFILES = "cl.e mkiraf.csh mkmlist.csh generic.e mkpkg.e rmbin.e rmfiles.e rtar.e sgidispatch.e wtar.e rpp.e xpp.e xyacc.e xc.e" +set CMDLINKS = "cl mkiraf mkmlist generic mkpkg rmbin rmfiles rtar sgidispatch wtar rpp xpp xyacc xc" +# ------------------------------------------ + + +# Check for file. +echo -n "Checking for file ... " +if (! (-e /usr/include/iraf.h)) then + DO_FAIL ; set errstat = 1 ; set iraf_root_ok = 0 + NEWLINE + MSG "The file /usr/include/iraf.h was not found which means" + MSG "the install script was not run on this machine." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK ; set iraf_root_ok = 1 + set ok_count = `expr $ok_count + 1` +endif + + +# Check $iraf path in PATHFILES +echo -n "Checking iraf path in system files ... " + +set err_seen = 0 +foreach i ($PATHFILES) + if (-e $iraf/unix/hlib/$i) then + grep $iraf $iraf/unix/hlib/$i >& /dev/null + endif + if ($status == 1 || (! (-e $iraf/unix/hlib/$i))) then + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 ; set err_count = `expr $err_count + 1` + endif + if (! -e $i) then + MSG "File $i not found." + else + MSG "File $i contains the wrong iraf path" + endif + endif +end +if ("$err_seen" == 0) then + BOLD_ON + echo "[ $defstat ]" + BOLD_OFF +endif + + + +# Check that the specified local bin directory exists. +echo -n "Checking that local command bin directory exists ... " +if ("$lbin" == "") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "No local bin directory found on this machine which" + MSG "implies that either your path does not include the" + MSG "local bin dir or else the install script was not run" + MSG "on this machine." + NEWLINE + set err_count = `expr $err_count + 1` +else + if (-d "$lbin") then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The specified local bin directory does not exist. This" + MSG "directory should be a common local bin directory which " + MSG "is found in all user's paths, e.g. /usr/local/bin." + MSG "Please create the directory or else reset and try again." + NEWLINE + set err_count = `expr $err_count + 1` + endif +endif + + +# Check that the specified local lib directory exists. +if ("$shlib" == "yes") then + echo -n "Checking that local lib directory exists ... " + if (-d "$llib") then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The specified local lib directory does not exist. This" + MSG "directory should be a common local lib directory which " + MSG "is found in all user's paths, e.g. /usr/local/lib." + MSG "This directory is required for the iraf shared library." + MSG "Please create the directory or else reset and try again." + NEWLINE + set err_count = `expr $err_count + 1` + endif +endif + + +# Check mode on MODEFILES +echo -n "Checking iraf file permissions ... " +set err_seen = 0 +foreach i ($MODEFILES) + set file = $i + if (! -e $file) then + foreach j ($BINDIRS) + if (-e $j/$i) then + set file = $j/$i + break + endif + end + endif + + if (-e $file) then + if ("`$LS -l $file | grep '.rwxr.xr.x'`" == "") then + if ("$err_seen" == 0) then + DO_WARN + set err_seen = 1 ; set err_count = `expr $err_count + 1` + endif + MSG "File $file:t not mode 0755." + endif + else + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 ; set err_count = `expr $err_count + 1` + endif + MSG "File $file:t not found." + endif +end +if ("$err_seen" == 0) then + BOLD_ON + echo "[ $defstat ]" + BOLD_OFF +endif + + +# Check valid links on CMDLINKS +echo "Checking iraf command links ..." +set err_seen = 0 +foreach p ($lbins) + echo -n " Checking command dir $p ... " + + foreach cmd ($CMDLINKS) + + # Locate the file to be linked to. + set file1 = $cmd:r + foreach j ($BINDIRS) + set file2 = $j/$file1.csh + if (-e $file2) then + break + endif + set file2 = $j/$cmd.e + if (-e $file2) then + break + endif + end + + # See first if it exists directly, or as a link to some other + # valid file. + if (! (-e $p/$cmd) && ! (-e $file2) ) then + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 ; set err_count = `expr $err_count + 1` + endif + echo -n " " ; MSG "File $p/$cmd not found." + + # Then check that the link is correct + else if ("`$LS -l $p/$file1 | grep $file2`" == "") then + if ("$err_seen" == 0) then + DO_FAIL + set err_seen = 1 ; set err_count = `expr $err_count + 1` + endif + echo -n " " ; MSG "Link $p/$cmd is invalid." + endif + end + if ("$err_seen" == 0) then + BOLD_ON + echo "[ $defstat ]" + BOLD_OFF + endif +end +if ($err_seen == 1) then + NEWLINE + MSG "1) A 'not found' error means that one or more of the commands" + MSG " normally installed by the install script was not found." + MSG " This may indicate a non-standard installation." + MSG "2) A 'link is invalid' message means that the command link" + MSG " was found but either points to a nonexistent file or to" + MSG " the wrong file for this platform (e.g. the HSI bin.sparc" + MSG " directory instead of bin.ssol)." + MSG "3) Multiple local bin directories are not strictly an error" + MSG " but may confuse users. Unneeded links should be removed." + MSG "" + MSG "The command links should be checked in either cases and the" + MSG "install script rerun to clear the error." + NEWLINE +endif + + +# Check iraf root directory looks correct. +NEWLINE +echo -n "Checking contents of iraf root directory ... " +if (! ((-d $iraf/dev) && (-d $iraf/pkg) && (-d $iraf/noao))) then + DO_FAIL ; set errstat = 1 ; set iraf_root_ok = 0 + NEWLINE + MSG "The definition of '$iraf' looks incorrect. The iraf root" + MSG "directory is the place where the AS distribution was unpacked," + MSG "it contains subdirectories such as 'dev', 'local', 'noao', and" + MSG "'pkg' and the binary directory links." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK ; set iraf_root_ok = 1 + set ok_count = `expr $ok_count + 1` +endif + + +# Cannot have iraf and imdir the same. +echo -n "Checking iraf root and imdir directory ... " +if ($iraf == $imdir) then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "'imdir' should not be the same as the iraf root directory." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK + set ok_count = `expr $ok_count + 1` +endif + +# Check iraf user. +echo -n "Checking for iraf user account ... " + +set pass = "" +if ($pciraf && ($mach == "macosx" || $mach == "macintel")) then + # Special-case user info check for OS X and systems where the /etc/passwd + # file may not contain the user info. + + if (`id iraf |& grep -i 'no such user'` != "") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "No 'iraf' user was found on the system. The iraf user should" + MSG "be created before installing the system to ensure all files" + MSG "are owned by the iraf user, and the have the proper environment" + MSG "defined for installation and maintanence." + NEWLINE + + else + DO_OK + set ok_count = `expr $ok_count + 1` + + # Check iraf user login path and shell + echo -n "Checking iraf user login directory ... " + + set v = `finger iraf |& egrep "^Directory"` + set ihome = `echo $v[2] | sed -e 's+/\(["]*\)$+\1+'` + set shel = `echo $v[4] | sed -e 's+/\(["]*\)$+\1+' | grep csh` + if ("$ihome" != "$iraf/local" || $shel == "") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The iraf user login info appears to be incorrect. For the" + MSG "given iraf root this path should be '$iraf/local'," + MSG "please run the 'chpass' command to change this. The iraf" + MSG "user account should also be defined to use a C-shell." + if ("$iraf_root_ok" == 0) then + MSG "(This error may be related to the incorrect definition of" + MSG "the iraf root directory seen above.)" + endif + NEWLINE + else + DO_OK + set ok_count = `expr $ok_count + 1` + endif + + endif + +else if (!(-r /etc/passwd)) then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The /etc/passwd file is not readable so I can't check for" + MSG "and iraf user. This may also cause problems with IRAF + MSG "networking when connecting to this machine." + NEWLINE +else + set pass = `grep ^iraf: /etc/passwd` + if ("$pass" == "") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "No 'iraf' user was found in the /etc/passwd file. The iraf" + MSG "user should be created before installing the system to ensure" + MSG "all files are owned by the iraf user, and the have the proper" + MSG "environment defined for installation and maintanence." + NEWLINE + else + DO_OK + set ok_count = `expr $ok_count + 1` + + # Check iraf user login path in passwd file is iraf$local. + echo -n "Checking iraf user login directory ... " + set pass = `grep ^iraf: /etc/passwd | sed -e 's/[ \*]/_/g'|sed -e 's/:/ /g'` + + set c = `echo $pass | wc -w` + set indx = `expr $c - 1` + + set ihome = `echo $pass[$indx] | sed -e 's+/\(["]*\)$+\1+'` + set shel = `echo $pass[$c] | sed -e 's+/\(["]*\)$+\1+' | grep csh` + if ("$ihome" != "$iraf/local" || $shel == "") then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The iraf user login directory appears to be incorrect." + MSG "For the given iraf root this path should be '$iraf/local'," + MSG "please edit the /etc/passwd file to change this. The iraf" + MSG "user account should also be defined to use a C-shell." + if ("$iraf_root_ok" == 0) then + MSG "(This error may be related to the incorrect definition of" + MSG "the iraf root directory seen above.)" + endif + NEWLINE + else + DO_OK + set ok_count = `expr $ok_count + 1` + endif + endif +endif + + +# Check iraf tree for proper structure. +set iraf_r = $iraf # iraf root directory +set iraf_p = $iraf_r:h # iraf parent directory +set iraf_b = $iraf_p/irafbin # irafbin directory +set iraf_ib = $iraf_b/bin.$mach # irafbin IB directory +set iraf_nb = $iraf_b/noao.bin.$mach # irafbin NB directory +set iraf_tree_ok = 1 + +echo "Checking for proper iraf tree structure in $iraf_p ..." + +echo -n " Checking for 'iraf' subdir ... " +if (-d "$iraf_p/iraf") then + DO_OK + set ok_count = `expr $ok_count + 1` +else + DO_FAIL ; set errstat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` +endif + +echo -n " Checking for 'irafbin' subdir ... " +if (-d "$iraf_p/irafbin") then + DO_OK ; set ok_count = `expr $ok_count + 1` +else + set zztemp = $iraf_tree_ok + echo " " ; set errstat = 1 ; set iraf_tree_ok = 0 + + # Look for a fallback to recover ... + echo -n " Checking for fallback tree structure ... " + set iraf_p = $iraf/../ + set iraf_b = $iraf_p/irafbin # irafbin directory + set iraf_ib = $iraf_b/bin.$mach # irafbin IB directory + set iraf_nb = $iraf_b/noao.bin.$mach # irafbin NB directory + if (-d "$iraf_p/irafbin") then + DO_OK ; set errstat = 0 ; set iraf_tree_ok = $zztemp + set ok_count = `expr $ok_count + 1` + else + DO_FAIL ; set errstat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` + endif +endif + +echo -n " Checking for 'irafbin/bin.$mach' subdir ... " +if (-d "$iraf_p/irafbin/bin.$mach") then + DO_OK + set ok_count = `expr $ok_count + 1` +else + DO_FAIL ; set errstat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` +endif + +echo -n " Checking for 'irafbin/noao.bin.$mach' subdir ... " +if (-d "$iraf_p/irafbin/noao.bin.$mach") then + DO_OK + set ok_count = `expr $ok_count + 1` +else + DO_FAIL ; set errstat = 1 ; set iraf_tree_ok = 0 + set err_count = `expr $err_count + 1` +endif + + +if ("$iraf_tree_ok" == 0) then + set back = $cwd ; chdir $iraf_p ; set iraf_p = $cwd; chdir $back + NEWLINE + MSG " An error was detected in the structure of the iraf tree." + MSG " Your directory tree should look something like:" + MSG "" + MSG " $iraf_p" + MSG " / \" + MSG " (AS) /iraf /irafbin" + MSG " / \" + MSG " (IB) bin.$mach noao.bin.$mach (NB)" + MSG "" + MSG " The AS, IB, and NB distribution files are shown where they" + MSG " should be unpacked." + NEWLINE +endif + + +echo -n " Checking file ownerships ... " + +if ($mach == "hp700" || $mach == "rs6000" || $mach == "irix") then + set downr = `$LS -lLd $iraf_p/iraf | awk '{print ($5)}'` + set fownr = `$LS -lLd $iraf_p/iraf/mkpkg | awk '{print ($5)}'` +else + set downr = `$LS -lLd $iraf_p/iraf | awk '{print ($4)}'` + set fownr = `$LS -lLd $iraf_p/iraf/mkpkg | awk '{print ($4)}'` +endif + +if ("$downr" == "iraf" && "$fownr" == "iraf") then + DO_OK + set ok_count = `expr $ok_count + 1` +else if ("$downr" == "tody" && "$fownr" == "tody") then + # Special exemption for NOAO installations. + DO_OK + set ok_count = `expr $ok_count + 1` +else + DO_FAIL + NEWLINE + MSG "(root dir owned by $downr, iraf files owned by $fownr)" + MSG "The iraf tree should be owned by the iraf user so it can" + MSG "be updated and maintained properly." + MSG "" + MSG 'To fix this, login as root, set the iraf environment, and' + MSG 'issue the commands:' + MSG "" + MSG " cd " `echo $iraf_p` + MSG ' chown -R iraf . # change dir owner' + MSG ' cd $hbin # go to HSI bin dir' + MSG ' chown 0 alloc.e # fix alloc.e ownership' + MSG ' chmod 4755 alloc.e # fix permissions' + NEWLINE + set errstat = 1 ; set err_count = `expr $err_count + 1` +endif + + +# Check that binary dirs are populated correctly. +set archs = "" +set back = $cwd ; chdir $iraf_p ; set iraf_p = $cwd; chdir $back + +NEWLINE ; NEWLINE +echo "======================================================================" +NEWLINE +echo "Checking Core system binaries in $iraf_p/irafbin ..." + +# Do a special check that we have a bin directory for the current arch. +echo -n " Checking for current platform arch... " +if (! -e $iraf_ib) then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The core system binary directory, $iraf_ib, does" + MSG "not exist for this platform." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK + set ok_count = `expr $ok_count + 1` +endif + +NEWLINE +echo " Size Date" +echo " ---- ----" + +# Check all of the bin directories in case we have a multi-arch system +foreach i ($iraf_p/irafbin/bin.*) + set dir = $i:t + if ($dir:r == "bin") then + set sz = `(chdir $i ; du -s | awk '{printf ("%d", $1)}')` + echo -n $dir $sz | awk '{printf ("%18s\t%5d\t", $1, $2)}' + + if (`$LS -lL $i | wc -l` > 1) then + set dat = `$LS $LSDF $i/* | head -2 | tail -1` + echo -n $dat | awk '{printf ("%3s %2s %-5s\t\t\t", $7, $8, $9)}' + + if (! (-e "$i/cl.e" && -e "$i/x_system.e")) then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The core system binary directory, $i:t, does" + MSG "not appear to contain the proper binaries. The IB dist-" + MSG "ribution files should be unpacked in this directory." + NEWLINE + set err_count = `expr $err_count + 1` + else + DO_OK ; set ok_count = `expr $ok_count + 1` + + # Save the list of installed binaries, allow for changes between + # the binary arch and HSI arch here (e.g. ssun->ssol). + if ("$dir:e" == "ssun") then + set archs = `echo $archs ssol` + else + set archs = `echo $archs $dir:e` + endif + endif + + else + echo "< empty > [ FAIL ]" ; set errstat = 1 + NEWLINE + MSG "bin directory is empty or does not contain IRAF binaries." + NEWLINE + endif + endif +end + + +NEWLINE +NEWLINE +echo "Checking NOAO Package binaries in $iraf_p/irafbin ..." + +# Do a special check that we have a bin directory for the current arch. +echo -n " Checking for current platform arch... " +if (! -e $iraf_nb) then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The NOAO package binary directory, $iraf_nb, does" + MSG "not exist for this platform." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK + set ok_count = `expr $ok_count + 1` +endif + +NEWLINE +NEWLINE +echo " Size Date" +echo " ---- ----" +foreach i ($iraf_p/irafbin/noao.bin.*) + set dir = $i:t + if ($dir:r == "noao.bin") then + set sz = `(chdir $i ; du -s | awk '{printf ("%d", $1)}')` + echo -n $dir $sz | awk '{printf ("%18s\t%5d\t", $1, $2)}' + + if (`$LS -lL $i | wc -l` > 1) then + set dat = `$LS $LSDF $i/* | head -2 | tail -1` + echo -n $dat | awk '{printf ("%3s %2s %-5s\t\t\t", $7, $8, $9)}' + + if (! (-e "$i/x_apphot.e" && -e "$i/x_rv.e")) then + DO_FAIL ; set errstat = 1 + NEWLINE + if (-e "$iraf_ib/x_apphot.e" && -e "$iraf_ib/x_rv.e") then + NEWLINE + MSG "The NOAO package binary directory, $iraf_nb, is" + MSG "empty but the binaries appear to have been unpacked in" + MSG "the core system directory, $iraf_ib. These will need to" + MSG "be moved, please delete the binaries and start again, be" + MSG "sure to unpack the NB distribution files in the $iraf_nb" + MSG "directory and the core system file in the $iraf_ib" + MSG "directory." + else + NEWLINE + MSG "The NOAO package binary directory, $iraf_nb, does" + MSG "not appear to contain the proper files. The NB dist-" + MSG "ribution files should be unpacked in this directory." + endif + NEWLINE + set err_count = `expr $err_count + 1` + else + DO_OK ; set ok_count = `expr $ok_count + 1` + endif + + else + echo "< empty > [ FAIL ]" ; set errstat = 1 + NEWLINE + MSG "bin directory is empty or does not contain NOAO binaries." + NEWLINE + endif + + else + continue + endif +end + + +# Check the HSI binaries. +NEWLINE +NEWLINE +echo "Checking HSI system binaries in $iraf/unix ..." + +# Do a special check that we have a bin directory for the current arch. +echo -n " Checking for current platform arch... " +if (! -e $iraf/unix/bin.$hmach) then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The HSI binary directory, $iraf/unix/bin.$hmach, does" + MSG "not exist for this platform." + NEWLINE + set err_count = `expr $err_count + 1` + +else if (! (-e "$iraf/unix/bin.$hmach/alloc.e")) then + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The HSI binary directory, $iraf/unix/bin.$hmach, appears" + MSG "to be empty." + NEWLINE + set err_count = `expr $err_count + 1` +else + DO_OK + set ok_count = `expr $ok_count + 1` +endif + +NEWLINE +NEWLINE +echo " Size Date" +echo " ---- ----" + +set delete_bin = "" +set empty_bin = "" +foreach i ($iraf_p/iraf/unix/bin.*) + set dir = $i:t + if ($dir:r == "bin") then + set sz = `(chdir $i ; du -s | awk '{printf ("%d", $1)}')` + echo -n $dir $sz | awk '{printf ("%18s\t%5d\t", $1, $2)}' + + if (`$LS -lL $i | wc -l` > 1) then + set d = `$LS $LSDF $i/* | head -2 | tail -1` + echo -n $dat | awk '{printf ("%3s %2s %-5s\t\t\t", $7, $8, $9)}' + + if (! (-e "$i/alloc.e" && -e "$i/xc.e")) then + DO_FAIL ; set errstat = 1 + else + DO_OK ; set ok_count = `expr $ok_count + 1` + endif + if ("`echo $archs | grep $dir:e`" == "") then + set delete_bin = `echo $delete_bin $dir` + endif + + else + if ($sz < 8 && "`echo $archs | grep $dir:e`" == "") then + BOLD_ON + echo "< unused > [ OK ]" + BOLD_OFF + else + BOLD_ON + echo "< empty > [ WARNING ]" ; set errstat = 1 + BOLD_OFF + set warn_count = `expr $warn_count + 1` + set empty_bin = `echo $empty_bin $dir` + endif + if ($sz > 8 && "`echo $archs | grep $dir:e`" == "") then + set delete_bin = `echo $delete_bin $dir` + endif + endif + + else + continue + endif +end +NEWLINE + +if ("$delete_bin" != "") then + NEWLINE + MSG "The following bin directories were found to be" + MSG "unneeded for this installation. If disk usage is a" + MSG "concern the contents may be deleted to reclaim space:" + MSG "" + foreach i ($delete_bin) + MSG " $iraf/unix/$i" + end +endif +NEWLINE + +if ($early_exit == 1) then + goto exit_early +endif + +#============================================================================= +# Networking Information +#============================================================================= + +Networking: + +set net_errstat = 0 # initialize error status + +NEWLINE +echo "======================= Networking Information =======================" +NEWLINE + +set hname = `hostname` +set lhost_abbr = `hostname | awk '{printf ("%16.16s\n", $1 ) }'` +set ihosts = $iraf/dev/hosts +set nhost_files = `$LS -1 $iraf/dev/hosts* | wc -l` + +echo 'Local host name: '$hname +echo 'Truncated host name: '$lhost_abbr +if (`echo $hname | grep "\."` != "") then + # When using FQDN lnode may not be set.... + set is_fqdn = yes + set domain = `hostname | sed -e 's/^[a-zA-Z0-9_\-]*\.//g'` + set lhost = `hostname | sed -e 's/\.[a-zA-Z0-9]*//g'` +else + set is_fqdn = no + set domain = "" + set lhost = $hname +endif +echo 'Domain name: '$domain +echo 'No. of dev$host* files: '$nhost_files +echo 'Using IRAF hosts file: '$ihosts + + +NEWLINE +echo -n 'Checking for iraf hosts file ... ' +if (-e $ihosts) then + DO_OK + set ok_count = `expr $ok_count + 1` + + set nhosts = `grep irafks.e $ihosts | wc -l` + set lnode = `grep irafks.e $ihosts | sort | grep $lhost | head -1` + + # The following madness is required to workaround shortcomings in the + # GNU versions of the sed command (i.e. Linux/FreeBSD). Working sed + # commands for Sun here. + # + # set n = `cat $ihosts | sort | grep $lhost | head -1` + # set irafks = `echo $n | sed -e 's/^[a-zA-Z0-9 _\!\/\-\.:]*//g'` + # set nalias = `echo $n | sed -e 's/:[a-zA-Z0-9 _\!\/\-\.]*//g'` + # set rhs = `echo $n | sed -e 's/^[a-zA-Z0-9 _\!\-\.]*://g'` + # set nnode = `echo $rhs | sed -e 's/\![a-zA-Z0-9 _\!\/\-\.]*//g'` + + set TEMP = "/tmp/_$$" + echo $lnode | sed -e 's/\!/ /g' > $TEMP + set line = `cat $TEMP` + RM $TEMP + + set nalias = "" + set irafks = "" + set nnode = "" + if ("$line" != "") then + while ("$line[1]" != "") + if ("$line[1]" == ":") then + break + else + set nalias = `echo $nalias $line[1]` + endif + shift line + end + shift line + set nnode = $line[1] ; shift line + set irafks = $line[1] ; shift line + endif + + # Print out the entry information found. + echo ' No. nodes in hosts file: '$nhosts + echo ' irafks.e pathname: '$irafks + echo ' Node aliases: '$nalias + echo ' Network node name: '$nnode + NEWLINE + + # Make sure the node is in the file. + echo -n ' Checking for local node in hosts file ... ' + if ("`grep $lhost $ihosts | head -1`" != "") then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_FAIL ; set net_errstat = 1 + NEWLINE + MSG "The local host, $lhost, was not found in the iraf hosts" + MSG "file $iraf/dev/hosts. This means that IRAF networking" + MSG "will not be available from this machine to others in the" + MSG "iraf network." + NEWLINE + set err_count = `expr $err_count + 1` + endif + + # See if the irafks.e path is correct on this machine. + if ("$irafks" != "") then + echo -n ' Checking for irafks.e binary ... ' + if (-e $irafks) then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_FAIL ; set net_errstat = 1 + NEWLINE + MSG "The named irafks.e binary was not found on this system." + NEWLINE + set err_count = `expr $err_count + 1` + endif + endif + + # Look for duplicate host names which may trigger a CL bug. + echo -n ' Checking for duplicate hosts in dev$hosts file ... ' + set dup_hosts = `grep irafks.e $ihosts | sort | awk '{print $1}' | uniq -d` + if ("$#dup_hosts" == 0) then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_WARN ; set net_errstat = 1 + NEWLINE + MSG 'Duplicate hosts found in dev$hosts file:' + grep irafks.e $ihosts | \ + sort | \ + awk '{print $1}' | \ + uniq -d | \ + awk '{printf(" ***\t\t%s\n", $1)}' + MSG "" + MSG "Duplicate node names should be removed to ensure" + MSG "networking and the CL operate properly." + NEWLINE + set warn_count = `expr $warn_count + 1` + endif + +else + DO_FAIL ; set net_errstat = 1 + NEWLINE + MSG "The IRAF hosts file, $ihosts, was not found." + NEWLINE + set err_count = `expr $err_count + 1` +endif + + +# See what NETSTATUS says about this setup. +NEWLINE +echo -n 'Verify NETSTATUS says iraf networking is enabled ... ' +set system = $iraf/bin.$mach/x_system.e +if (-e $system) then + set net = `$system netstatus | grep -i "interface disabled"` + if ("$net" == "") then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_FAIL ; set net_errstat = 1 + NEWLINE + MSG "The NETSTATUS task claims that networking is disabled." + NEWLINE + set err_count = `expr $err_count + 1` + endif +else + DO_FAIL ; set net_errstat = 1 + NEWLINE + MSG "The NETSTATUS task binary could not be executed." + NEWLINE + set err_count = `expr $err_count + 1` +endif + + +# See if we're in the trusted hosts file for rsh access. +NEWLINE +echo -n 'Checking for host in /etc/hosts.equiv ... ' +set equiv = /etc/hosts.equiv +if (-e $equiv) then + if ("`grep $lhost $equiv | head -1`" != "") then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_WARN ; set net_errstat = 1 + NEWLINE + MSG "The local host, '$lhost', is not present in the $equiv" + MSG "file." + MSG "" + MSG "By default IRAF networking will try to use the 'rsh'" + MSG "protocol for connecting to a remote machine. Without a" + MSG "$equiv entry a networking attempt will fail and" + MSG "a password prompt will be required since an rexec protocol" + MSG "is the fallback. Some systems are not configured for rsh" + MSG "access even with a $equiv file, or rsh is not a valid" + MSG "command, and so some other protocol will be required." + MSG "" + MSG "A KSRSH unix environment variable may be defined to specify" + MSG "a different command or protocol (e.g. remsh or ssh). This" + MSG "is not a fatal error and will not prevent IRAF networking" + MSG "from working, but can be used to avoid to password prompt." + NEWLINE + set warn_count = `expr $warn_count + 1` + endif +else + DO_WARN ; set net_errstat = 1 + NEWLINE + MSG "The trusted hosts file, '$equiv', is not present on this" + MSG "system. This may mean that the 'rsh' connection protocol" + MSG "is not available and IRAF networking will require password" + MSG "prompts." + MSG "" + MSG "By default IRAF networking will try to use the 'rsh'" + MSG "protocol for connecting to a remote machine. Without a" + MSG "$equiv entry a networking attempt will fail and" + MSG "a password prompt will be required since an 'rexec' protocol" + MSG "is the fallback. Some systems are not configured for rsh" + MSG "access even with a $equiv file, or 'rsh' is not a valid" + MSG "command, and so some other protocol will be required." + MSG "" + MSG "A 'KSRSH' unix environment variable may be defined to specify" + MSG "a different command or protocol (e.g. 'remsh' or 'ssh'). This" + MSG "is not a fatal error and will not prevent IRAF networking from" + MSG "operating, but can be used to avoid to password prompt." + NEWLINE + set warn_count = `expr $warn_count + 1` +endif + + +# Print out the recommended dev$hosts entry for this machine. +NEWLINE +echo "----------------------------------------------------------------------" +NEWLINE +echo "Recommended $ihosts file entry for this machine: " +NEWLINE +echo -n " " +if ("$is_fqdn" == "no") then + echo $lhost " : "$hname"\!"$iraf/bin.$mach/irafks.e +else + echo $lhost $lhost_abbr " : " $nnode"\!"$iraf/bin.$mach/irafks.e +endif +NEWLINE + + +if ($early_exit == 1) then + goto exit_early +endif + +#============================================================================= +# Image Display Device Information +#============================================================================= + +Image_Display: + +NEWLINE +echo "===================== Image Display Device Info ======================" +NEWLINE + +set DISPLAY_SERVERS = "ximtool ximtool-alt saoimage ds9 saotng" +set GRAPHICS_TERMS = "xgterm xterm" +set IMTOOLRC = /usr/local/lib/imtoolrc + + +if (! ($?termcap_file)) then + set termcap_file = "$iraf/dev/termcap" +endif +if (! ($?graphcap_file)) then + set graphcap_file = "$iraf/dev/graphcap" +endif + + +echo -n "Display Servers Available: " +set found = 0 +set have_sockets = 0 +set have_saoimage = 0 +set have_ximtool = 0 +foreach i ($DISPLAY_SERVERS) + set p = `which $i |& grep -i "^\/"` + if ($status == 0) then + if ("$found" == 0) then + DO_OK + set ok_count = `expr $ok_count + 1` + endif + set d = `$LS $LSDF $p | head -2 | tail -1` + echo $d | awk '{printf (" ( Date: %3s %2s %-5s )\t", $7, $8, $9) }' + echo " "$p + set found = 1 + if ("$i" == "saoimage") set have_saoimage = 1 + if ("$i" == "ximtool") set have_ximtool = 1 + if ("$i" != "saoimage") set have_sockets = 1 + endif +end + +if ($found == 0) then + DO_FAIL ; set errstat = 1 + echo " None Found" + NEWLINE + MSG "No display servers were found on this machine or in the user" + MSG "path. A display server such as XImtool/SAOimage/SAOtng/DS9" + MSG "is required to be running on the local machine before an iraf" + MSG "display command (e.g. DISPLAY/TVMARK/IMEXAMINE) will work." + MSG "" + MSG "Remote displays (i.e. the server on one machine and IRAF on" + MSG "another) require either iraf networking be enabled or the X" + MSG "'DISPLAY' variable be set so the server appears on the remote" + MSG "machine." + MSG "" + MSG "XImtool can be downloaded from" + MSG "" + MSG " http://iraf.net/ftp/iraf/x11iraf" + MSG "" + MSG "or it's mirror sites. Contact http://iraf.net with questions." + NEWLINE + set err_count = `expr $err_count + 1` +endif +NEWLINE + + +echo -n "Graphics Terminals Available: " +set found = 0 +foreach i ($GRAPHICS_TERMS) + set p = `which $i |& grep "^\/"` + if ($status == 0) then + if ("$found" == 0) then + DO_OK + set ok_count = `expr $ok_count + 1` + endif + set d = `$LS $LSDF $p | head -2 | tail -1` + echo $d | awk '{printf (" ( Date: %3s %2s %-5s )\t", $7, $8, $9) }' + echo " "`which $i` + set found = 1 + endif +end +if ($found == 0) then + DO_FAIL ; set errstat = 1 + echo " None Found" + NEWLINE + MSG "No 'xterm' or 'xgterm' binary was found on this systen or" + MSG "in the user path. IRAF graphics require some form of " + MSG "graphics-enabled terminal window to be running or else" + MSG "garbarge characters will appear on the screen. Windows" + MSG "such as 'cmdtool', 'rxvt', 'aixterm', 'hpterm', 'decterm'" + MSG "do not support graphics and should not be used for IRAF." + MSG "" + MSG "The default terminal type is set in the login.cl when" + MSG "a user runs MKIRAF, this is the type of window they should" + MSG "be running when starting IRAF. Users can use the 'show" + MSG "terminal' command to see the current setting, or 'stty" + MSG "xterm' or 'stty xgterm' command (or rerun MKIRAF and reset" + MSG "the default terminal type) to change the default iraf terminal." + MSG "" + MSG "XGterm can be downloaded from" + MSG "" + MSG " http://iraf.net/ftp/iraf/x11iraf" + MSG "" + MSG "or it's mirror sites. Contact site support with questions." + set err_count = `expr $err_count + 1` +endif +NEWLINE + + +# Check for imtoolrc file and /usr/local/lib dir. +set errstat = 0 +NEWLINE +echo -n "Checking for /usr/local/lib directory ... " +if (-d /usr/local/lib) then + DO_OK + set ok_count = `expr $ok_count + 1` + + # Check for imtoolrc file... + echo -n "Checking for imtoolrc file ... " + if (-e $IMTOOLRC) then + DO_OK + set ok_count = `expr $ok_count + 1` + + set islink = `$LS -l $IMTOOLRC | grep "^l"` + set file = $iraf/dev/imtoolrc + if ("$islink" != "" && -e $file) then + + # Check for valid link + echo -n "Checking for valid imtoolrc link ... " + set tmp = `diff $IMTOOLRC $file | wc -l` + if ("$tmp" == 0) then + DO_OK + set ok_count = `expr $ok_count + 1` + else + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The /usr/local/lib/imtoolrc link is invalid" + NEWLINE + set err_count = `expr $err_count + 1` + endif + endif + + else + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The /usr/local/lib/imtoolrc file is missing." + MSG "This normally gets created by the iraf install script" + MSG "but only if /usr/local/lib already exists. Without" + MSG "this file you won't be able to use ximtool with a buffer" + MSG "larger than 512x512, to fix this just create the" + MSG "/usr/local/lib dir and rerun the install script or" + MSG "make the link by hand as the root user." + NEWLINE + set err_count = `expr $err_count + 1` + endif + + + # Check for imtoolcmap directory... + if ($have_ximtool == 1) then + echo -n "Checking for imtoolcmap directory ... " + if (-d /usr/local/lib/imtoolcmap) then + DO_OK + set ok_count = `expr $ok_count + 1` + + else + DO_WARN + NEWLINE + MSG "The /usr/local/lib/imtoolcmap directory is missing." + MSG "This directory is not required but provides extra" + MSG "colormap options for XImtool. The colormaps may be" + MSG "be obtained from " + MSG "" + MSG " http://iraf.net/ftp/iraf/x11iraf/imtoolcmap.tar" + MSG "" + MSG "This should be unpacked as the /usr/local/lib/imtoolcmap" + MSG "directory. This is not a fatal error." + NEWLINE + set warn_count = `expr $warn_count + 1` + endif + endif + + +else + DO_FAIL ; set errstat = 1 + NEWLINE + MSG "The /usr/local/lib directory does not exist." + NEWLINE + set err_count = `expr $err_count + 1` +endif +if ($errstat == 1) then + MSG "The imtoolrc file is used by the display servers (XImtool," + MSG "SAOimage, etc) to set various frame buffer sizes. Without" + MSG "this file the server can only use a 512x512 frame buffer," + MSG "and displays to larger buffers will result in the message" + MSG "'attempt to write out of bounds on framebuf'. Sites can" + MSG "rerun the install script or make the link by hand, users" + MSG 'can copy the dev$imtoolrc file to their $HOME directory as' + MSG "'.imtoolrc' as a workaround." +endif + +if ($have_saoimage == 1) then + echo -n "Checking file descriptor limits: " + set ds = `limit descriptors | awk '{print ($2)}'` + if ("$ds" != "64") then + DO_WARN + NEWLINE + MSG "SAOimage has a hardwired restriction of 64 file descriptors," + MSG "however this user shell allows more. When there are many" + MSG "windws open SAOimage may fail, this warning applies only" + MSG "to users of SAOimage. A 'limit descriptors 64' command" + MSG "can be used to reset the limit." + NEWLINE + set warn_count = `expr $warn_count + 1` + else + DO_OK + endif +endif + + +# See whether we have fifo pipes installed. +set errstat = 0 +if ( !($pciraf && ($mach == "macosx" || $mach == "macintel")) ) then + foreach p (/dev/imt1i /dev/imt1o) + echo -n "Checking for $p fifo pipe ... " + if (-e $p) then + if ("`$LS -l $p | grep '.rw.rw.rw.'`" == "") then + if ($have_sockets == 1) then + DO_WARN ; set errstat = 1 + set warn_count = `expr $warn_count + 1` + else + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` + endif + MSG "File $p not mode 666." + else + DO_OK + set ok_count = `expr $ok_count + 1` + endif + else + if ($have_sockets == 1) then + DO_WARN ; set errstat = 1 + set warn_count = `expr $warn_count + 1` + else + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` + endif + MSG "The $p fifo pipe is missing." + endif + end + + echo -n "Checking for /dev/imt1 fifo pipe link ... " + if (-e /dev/imt1) then + if ("`$LS -l /dev/imt1 | grep imt1o`" != "") then + DO_OK + set ok_count = `expr $ok_count + 1` + else + if ($have_sockets == 1) then + DO_WARN ; set errstat = 1 + set warn_count = `expr $warn_count + 1` + else + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` + endif + MSG "The /dev/imt1 fifo pipe link is invalid." + endif + else + if ($have_sockets == 1) then + DO_WARN ; set errstat = 1 + set warn_count = `expr $warn_count + 1` + else + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` + endif + MSG "The /dev/imt1 fifo pipe link is missing (but is not" + MSG "strictly required for proper display). If it exists it" + MSG "should be a symlink pointing to /dev/imt1o." + endif + if ($errstat == 1 && $have_sockets == 0) then + NEWLINE + MSG "The /dev fifo pipes are used only by SAOimage as a default" + MSG "communication with IRAF or as a fallback for other display" + MSG "servers such as XImtool. Except for SAOimage or in the case" + MSG "of some other mechanism such as a private graphcap file or" + MSG "IMTDEV environment variable, missing /dev pipes should not be" + MSG "fatal for image display. A 'Cannot open device' message may" + MSG "simply mean there is no display server running, or the 'node'" + MSG "CL environment variable has been set to an invalid node or" + MSG "iraf networking is not enabled on the host. The pipes are" + MSG "created by the install script (which can be run on this host)" + MSG "or they can be created by hand as root with the 'mknod' or" + MSG "'mkfifo' command." + NEWLINE + endif +endif + + +# Make sure there are entries in the the termcap and graphcap files for xgterm +# and imtool. + +echo -n "Checking termcap file for an XGterm entry ... " +set temp = `grep -l xgterm $termcap_file | grep -v "^#"` +if ("$temp" == "") then + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` +else + DO_OK + set ok_count = `expr $ok_count + 1` +endif + +echo -n "Checking graphcap file for XGterm/imtool entries ... " +set gcok = yes +foreach i (xgterm imtool) + set temp = `grep -l $i $graphcap_file | grep -v "^#"` + if ("$temp" == "" && "$gcok" == "yes") then + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` + set gcok = no + endif +end +if ($gcok == yes) then + DO_OK + set ok_count = `expr $ok_count + 1` +endif + +if ($early_exit == 1) then + goto exit_early +endif + +#============================================================================= +# Tape Device Information +#============================================================================= + +Tape_Device: + +NEWLINE +echo "====================== Tape Device Information =======================" +NEWLINE + +set errstat = 0 + +if (! ($?tapecap_file)) then + set tapecap_file = "$iraf/dev/tapecap" +endif + +# Check the alloc.e binary. +NEWLINE +set file = "$iraf/unix/bin.$hmach/alloc.e" +echo -n 'Checking for hbin$alloc.e binary ... ' +if (-e $file) then + DO_OK + set ok_count = `expr $ok_count + 1` + + echo -n 'Checking hbin$alloc.e ownership ... ' + if (-e $file) then + if ("`$LS -l $file | grep 'root'`" == "") then + DO_FAIL + set errstat = 1 ; set err_count = `expr $err_count + 1` + echo " *** File $file:t not owned by root." + else + DO_OK + set ok_count = `expr $ok_count + 1` + endif + endif + + echo -n 'Checking hbin$alloc.e binary permissions ... ' + if (-e $file) then + if ("`$LS -l $file | grep '.rwsr.xr.x'`" == "") then + DO_FAIL + set errstat = 1 ; set err_count = `expr $err_count + 1` + echo " *** File $file:t not mode 4755." + else + DO_OK + set ok_count = `expr $ok_count + 1` + endif + endif + + if ($errstat == 1) then + NEWLINE + MSG "The alloc.e binary is used to allocate tape devices" + MSG "for exclusive access by the user. It does this by" + MSG "changing the ownership and permissions on the /dev" + MSG "files associated with each device. For this reason" + MSG "it must be owned by root with setuid permissions so" + MSG "it can execute properly. Tape devices are not required" + MSG "to be allocated before they are used but executing the" + MSG "ALLOC command w/in iraf will result in an error." + MSG "This error can be cleared by running the IRAF install" + MSG "script as root, or issuing the commands:" + MSG "" + MSG " # cd $hbin" + MSG " # chown 0 alloc.e ; chmod 4755 alloc.e" + NEWLINE + endif + +else + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` + MSG "File $file not found." +endif + + +# Check for a tapecap file. +set errstat = 0 +NEWLINE +echo -n 'Checking for tapecap file ... ' +if (-e $iraf/dev/tapecap.`hostname`) then + DO_OK + set ok_count = `expr $ok_count + 1` + echo " Using file: $iraf/dev/tapecap.`hostname`" +else + if (-e $tapecap_file) then + DO_OK + set ok_count = `expr $ok_count + 1` + echo " Using tapecap file: $tapecap_file" + else + DO_FAIL ; set errstat = 1 + set err_count = `expr $err_count + 1` + endif +endif +if ($errstat == 1) then + NEWLINE + MSG 'No tapecap file found on this system.' + NEWLINE + MSG 'IRAF will first attempt to find a file in the iraf$dev' + MSG 'directory called "tapecap.\", if that fails it will' + MSG 'fallback to use the dev$tapecap file (or whichever file is' + MSG 'named by the 'tapecap' variable in the hlib$zzsetenv.def file).' + MSG '' + MSG 'Not all IRAF distributions come with a default tapecap file' + MSG 'appropriate for the given machine. For example, the default' + MSG 'dev$tapecap for Sun/IRAF is for SunOS and will not generally' + MSG 'work for Solaris. The PC-IRAF distribution comes with generic' + MSG 'tapecap.linux, tapecap.freebsd, etc files which must be renamed' + MSG '"tapecap" to be used. Generic device entries are provided with' + MSG 'each tapecap file (e.g. mtp for a DAT on unit 0) but in most' + MSG 'cases the tapecap file must be installed and/or configured' + MSG 'before devices will be accessible.' + MSG '' + MSG 'Further information on configuring tapecaps can be found in' + MSG 'the last IRAF Newsletter at:' + MSG '' + MSG ' http://iraf.noao.edu/irafnews/apr98/irafnews.1f.html' + MSG '' + MSG 'or by contacting http://iraf.net' + NEWLINE +endif + + + +NEWLINE +echo "Tape Device Template: $TAPES" + +set nloks = `$LS -lL /tmp/*.lok |& grep -v -i "no match" | wc -l` +if ($nloks == 0) then + set nloks = "" +endif +echo "Lok Files on this machine: $nloks" +if ("$nloks" != '') then + $LS -lL /tmp/*.lok +endif + +NEWLINE + +set ntapes = `$LS -lL $TAPES |& grep -v -i "no match" | wc -l` +if ($ntapes == 0) then + set ntapes = "" +endif +echo "Tape Devices Available: $ntapes" +NEWLINE + +if ("$ntapes" != '') then + +NEWLINE +echo " ******************************************************************" +echo " ** More tape devices files may be defined than there are actual **" +echo " ** devices on the machine. For those file which correspond to **" +echo " ** a physical device the file should have mode 666 and be owned **" +echo " ** by root. **" +echo " ******************************************************************" +NEWLINE + + ls -lL $TAPES +endif + +if ($early_exit == 1) then + goto exit_early +endif + + +#============================================================================= +# External Package Information +#============================================================================= + +External_Packages: + +NEWLINE +echo "=================== External Package Information =====================" +NEWLINE + +# Check the iraf root directory stuff +if ($?iraf == 1) then + set hlib = $iraf/unix/hlib +else + if (-e /usr/include/iraf.h) then + set ip = `grep "^#define IRAF" /usr/include/iraf.h |sed -e 's/\"//g'` + if ("$ip" != "") then + set iraf = $ip[3] + endif + set hlib = $iraf/unix/hlib + + else + MSG "No 'iraf' defined in your environment and no " + MSG "file found on this system." + MSG "" + MSG "Aborting..." + endif +endif + +# Strip off any trailing '/'. +set iraf = `echo $iraf | sed -e 's+/\(["]*\)$+\1+'` + +set epkg = $hlib/extern.pkg + + +# Get the helpdb string. +set helpdb = `cat $epkg | grep -v "^#" | grep helpdb` + + +# Get the list of tasks defined in the extern.pkg file. +set t = `cat $epkg | grep -v "^#" | grep task | sed -e 's/task//g' -e 's/=//g' -e 's/\.pkg//g' -e 's/\$//g'` + +set tasks = "" +while ("$t[1]" != "") + set tasks = `echo $tasks $t[1]` + shift t ; shift t + if ("$#t" == "0") then + break + endif +end + +# Get the variables and paths declared, includes data directories. + +cat $epkg | grep -v "^#" | grep -v helpdb | grep ^set > /tmp/_ext$$ +cat $epkg | grep -v "^#" | grep -v helpdb | grep ^reset >> /tmp/_ext$$ + +set l = `cat /tmp/_ext$$ | sed -e 's/reset//g' -e 's/set//g' -e 's/=//g'` + +set pkg = "" +set ppath = "" +while ("$l[1]" != "") + set pkg = `echo $pkg $l[1]` + set ppath = `echo $ppath $l[2]` + shift l; shift l + + if ("$#l" == "0") then + break + endif +end +RM /tmp/_ext$$ + + +NEWLINE +echo " 1) The 'Path' check verifies that the extern.pkg path exists and is" +echo " not located in the iraf root directory (NOAO excepted)." +echo " 2) The 'Helpdb' check verifies that the package is declared in the" +echo " helpdb string. A warning here indicates the helpdb.mip file is" +echo " out of date w.r.t the package .hd files. Help database files may" +echo " be updated using the SOFTOOLS.MKHELPDB task." +echo " 3) The 'Binaries' check prints the most recent file date for the" +echo " installed binaries. A failed test indicates no binaries for" +echo " the current architecture." +echo " 4) The date given is the date of the most recent file in the named" +echo " bin directory. Dates before 12/99 indicate binaries which should" +echo " be recompiled for Y2K compliance (assuming IRAF V2.11.3 or later" +echo " is available on the machine)." +NEWLINE +NEWLINE +echo "Number of declared packages: " $#tasks +echo "Number of logical directories: " $#ppath +NEWLINE +echo "Checking packages ..." +NEWLINE +echo " Package Path Helpdb Binaries Date" +echo " ------- ---- ------ -------- ----" +#NEWLINE + + +set CL = $iraf/bin.$mach/cl.e +if (! -e $CL) then + echo "ERROR: CL executable not found, skipping package checks..." + set err_count = `expr $err_count + 1` + goto exit_early +endif + + +set lp = "" +set lpath = "" +set delpak = () +set delpak_p = () +foreach p ($pkg) + set decl = `cat $epkg | grep task | grep $p` + set pat = $ppath[1] + if ("$decl" != "") then + + # See if this is an iraf logical path and resolve it. + echo $pat | egrep '\$' >& /dev/null + if ($status == 0) then + set cmd = `echo $pat | awk '{printf("=osfn(\"%s\");logout\n", $1)}'` + echo "#\!$CL -f" > /tmp/_cmd$$ + echo $cmd >> /tmp/_cmd$$ + chmod 755 /tmp/_cmd$$ + + set pat = `/tmp/_cmd$$` + rm -rf /tmp/_cmd$$ + endif + + # Check that the path exists. + if (-d $pat) then + echo $p | awk '{printf ("%12.12s", $1 ) }' + if ("$p" == "noao") then + BOLD_ON + echo -n " [ OK ]" + BOLD_OFF + set ok_count = `expr $ok_count + 1` + else + if (`echo $pat | grep $iraf` == "") then + BOLD_ON + echo -n " [ OK ]" + BOLD_OFF + set ok_count = `expr $ok_count + 1` + else if (`echo $pat | grep $iraf | grep "/\.\."` != "") then + BOLD_ON + echo -n " [ OK ]" + BOLD_OFF + set ok_count = `expr $ok_count + 1` + else + BOLD_ON + echo " [FAIL] " ; set errstat = 1 + BOLD_OFF + echo " *** invalid path: $p = $pat" + echo " *** package should not be in iraf root dir" + set err_count = `expr $err_count + 1` + set delpak = ($delpak $p) + set delpak_p = ($delpak_p $pat) + goto pkg_err + endif + endif + else + set delpak = ($delpak $p) + set delpak_p = ($delpak_p $pat) + set err_count = `expr $err_count + 1` + goto pkg_err + endif + + + # See if the package was declared with help. + echo $helpdb | grep $p >& /dev/null + if ($status == 0) then + + # The package has help but we'll assume the standard help + # database name and look to see if the helpdb itself is current. + # The helpdb.mip file should be newer than any .hd files in + # the package tree. + if (-e $pat/lib/helpdb.mip) then + set pkgp = `echo $pat | sed -e 's+/\(["]*\)$+\1+'` + set hdbfile = "$pkgp/lib/helpdb.mip" + set hdfiles = `find $pkgp -name \*.hd -a -newer $hdbfile -print` + if ("$hdfiles" != "") then + echo -n " [WARN] " + set warn_count = `expr $warn_count + 1` + else + echo -n " [ OK ] " + set ok_count = `expr $ok_count + 1` + endif + else + echo -n " [ OK ] " + set ok_count = `expr $ok_count + 1` + endif + + else + echo -n " [FAIL] " ; set errstat = 1 + set err_count = `expr $err_count + 1` + endif + + # See if binaries exist for this platform. + set dir = $pat/bin.$mach + if (-d $dir) then + if (`$LS -lL $dir | wc -l` > 1) then + set d = `$LS $LSDF $pat/bin.$mach/* | head -2 | tail -1` + set dat = `echo $d |awk '{printf("%s %s %s",$7,$8,$9)}'` + + #echo -n "[ OK ]" + if ("`echo $dat | grep 199 | grep Dec`" == "") then + if ("`echo $dat | grep 200`" == "" && "`echo $dat | grep ':'`" == "") then + echo -n "[WARN]" + set warn_count = `expr $warn_count + 1` + else + echo -n "[ OK ]" + set ok_count = `expr $ok_count + 1` + endif + else + echo -n "[ OK ]" + set ok_count = `expr $ok_count + 1` + endif + + echo $d | awk '{printf ("\t%3s %2s %-5s", $7, $8, $9) }' + echo " "bin.$mach + else + echo -n "[FAIL] " ; set errstat = 1 + set err_count = `expr $err_count + 1` + echo " "bin.$mach + #goto pkg_err + endif + else + echo -n "[FAIL] " ; set errstat = 1 + echo " "bin.$mach + set err_count = `expr $err_count + 1` + endif + + # Check for other architectures installed + if (-e $pat/bin) then + if (-e $pat/bin.$mach) then + foreach dir ($pat/bin.*) + set b = $dir:t + if ("$b" != "bin.generic" && "$b" != "bin.$mach") then + if (`$LS -l $dir | wc -l` > 1) then + set d = `$LS $LSDF $pat/$b/* | head -2 | tail -1` + set dat = `echo $d |awk '{printf("%s %s %s",$7,$8,$9)}'` + echo -n " " + if ("`echo $dat | grep 199 | grep Dec`" == "") then + if ("`echo $dat | grep 200`" == "" && "`echo $dat | grep ':'`" == "") then + echo -n " [WARN] " + set warn_count = `expr $warn_count + 1` + else + echo -n " [ OK ] " + set ok_count = `expr $ok_count + 1` + endif + else + echo -n " [ OK ] " + set ok_count = `expr $ok_count + 1` + endif + echo $d |awk '{printf ("%3s %2s %-5s", $7, $8, $9)}' + echo " "$b + endif + endif + end + endif + endif + #NEWLINE + + else + set lp = `echo $lp $p` + set lpath = `echo $lpath $pat` + endif + +pkg_err: + shift ppath +end + +# Report unnecessary packages or logical dirs. +set npack = $#delpak +if ($npack != 0) then + NEWLINE + NEWLINE + MSG "The folowing packages were declared but do not exist on the" + MSG 'current platform and can be removed from the hlib$extern.pkg' + MSG "file:" + MSG "" + + set i = 1 + while ($i <= $npack) + echo $delpak[$i] $delpak_p[$i] | \ + awk '{printf (" ***\t%16s = %s\n", $1, $2)}' + set i = `expr $i + 1` + end + MSG "" +endif + + +# Now check logical directories defined in the file. +set dellog = () +set dellog_p = () +if ("$lp" != "") then + NEWLINE + NEWLINE + echo "Checking logical directories ..." + NEWLINE + echo " Logical Directory Path" + echo " ----------------- ----" + + foreach p ($lp) + set pat = $lpath[1] + echo $p | awk '{printf ("%20.20s", $1 ) }' + + # See if this is an iraf logical path and resolve it. + echo $pat | egrep '\$' >& /dev/null + if ($status == 0) then + set cmd = `echo $pat | awk '{printf("=osfn(\"%s\");logout\n", $1)}'` + echo "#\!$CL -f" > /tmp/_cmd$$ + echo $cmd >> /tmp/_cmd$$ + chmod 755 /tmp/_cmd$$ + + set pat = `/tmp/_cmd$$` + rm -rf /tmp/_cmd$$ + endif + + if (-d $pat) then + echo " [ OK ]" + set ok_count = `expr $ok_count + 1` + else + echo -n " [ FAIL ]" ; set errstat = 1 + echo " *** invalid path" + set dellog = ($dellog $p) + set dellog_p = ($dellog_p $pat) + set err_count = `expr $err_count + 1` + endif + + shift lpath + end +endif + + +set nlog = $#dellog +if ($nlog != 0) then + NEWLINE + NEWLINE + MSG "The folowing logical directories were found to be invalid for" + MSG 'current platform and can be removed from the hlib$extern.pkg' + MSG "file:" + MSG "" + + set i = 1 + while ($i <= $nlog) + echo $dellog[$i] $dellog_p[$i] | \ + awk '{printf (" ***\t%16s = %s\n", $1, $2)}' + set i = `expr $i + 1` + end + MSG "" +endif + + +exit_early: + + NEWLINE + NEWLINE + echo "======================================================================" + NEWLINE + echo "SYSINFO completed with: Tests Passed: $ok_count" + echo " Warnings: $warn_count" + echo " Errors: $err_count" + if ($err_count > 0) then + NEWLINE + echo " Not all errors listed here will be fatal but may indicate a" + echo " problem with some aspect of the system, or will reveal the" + echo " likely cause of a problem currently being seen." + NEWLINE + echo " Users should contact http://iraf.net if help is needed with" + echo " correcting any problems, or with suggestions/comments for" + echo " future versions of this diagnostic script." + endif + NEWLINE + echo "======================================================================" + NEWLINE + +sysinfo_cleanup: + RM /tmp/_cmd$$ + RM /tmp/_ext$$ + +exit 0 + + +# Print usage information. We will not get here unless the "-help" flag +# was issued. + +Usage: + + NEWLINE + echo "Usage: sysinfo [ -G | -V | -N | -P | -D | -T | -help ]" + NEWLINE + echo " where: -G Print General Info only" + echo " -V Do Verification tests only" + echo " -N Do Networking tests only" + echo " -P Do Extern Package tests only" + echo " -D Do Display tests only" + echo " -T Do Tape Device tests only" + echo " -h Print this message" + NEWLINE + diff --git a/unix/hlib/uninstall b/unix/hlib/uninstall new file mode 100755 index 00000000..0eaaa694 --- /dev/null +++ b/unix/hlib/uninstall @@ -0,0 +1,365 @@ +#!/bin/csh +# +# ---------------------------------------------------------------------------- +# +# UNINSTALL -- Remove IRAF on a UNIX/IRAF host. +# +# Usage: uninstall [-n] [-h] [-hl] [-c] [-v] [-b ] +# +# where -n # no execute +# -h # print this help summary +# -hl # disable text highlighting +# -c # remove command links only +# -v # print verbage output +# -b # specify local bin directory to search +# +# Use "uninstall -n" to do a dry run to see what the would be done, without +# actually modifying the host system. To do the actual un-install one must +# be superuser, but anyone can run "uninstall -n" to see what it would do. +# +# ---------------------------------------------------------------------------- + +unset noclobber +unalias rm set grep ls pwd +onintr uninstall_cleanup_ + +set exec = yes +set lbin = "" +set cmd_only = no +set verbage = no +set hilite = 1 + +set FILES = "/usr/include/iraf.h /usr/local/lib/imtoolrc" +set DEVS = "/dev/imt1i /dev/imt1o /dev/imt1" +set CMDS = "cl mkiraf mkmlist generic mkpkg rmbin rmfiles rtar sgidispatch wtar rpp xpp xyacc xc" + +alias RM "/bin/rm -f" + +# Utility aliases. +alias BOLD_ON "(if ($hilite) tput bold)" +alias BOLD_OFF "(if ($hilite) tput sgr0)" + +alias ERRMSG "(echo -n ' ';BOLD_ON;echo -n 'ERROR: ';BOLD_OFF; echo \!*)" +alias WARNING "(echo -n ' ';BOLD_ON;echo -n 'WARNING: ';BOLD_OFF; echo \!*)" +alias NEWLINE "(echo '')" + + +#============================================================================= +# Process any command line arguments. +#============================================================================= +while ("$1" != "") + switch ("$1") + case -n: # no execute + set exec = no + alias RM "echo -n \!* >& /dev/null" + breaksw + case -hl: # disable highlighting + set hilite = 0 + case +hl: # enable highlighting + set hilite = 1 + breaksw + case -h: # print usage + goto Usage + case -c: # command file links only + set cmd_only = yes + breaksw + case -q: # quiet output + set verbage = no + breaksw + case -v: # verbage output + set verbage = yes + breaksw + case -b: # set local bin directory (unix) + if ("$2" != "") then + shift + else + echo "missing argument to '-b ' switch" + exit 1 + endif + set lbin = "$1" + + if (! -e $lbin) then + echo "ERROR: Local bin dir '$lbin' not found." + exit 1 + endif + breaksw + default: + echo "ERROR: unrecognized command-line argument '$1'" + goto Usage + endsw + + if ("$2" == "") then + break + else + shift + endif +end + +# Initialize. +clear +NEWLINE +BOLD_ON +echo " IRAF System Un-installation" +echo " ---------------------------" +BOLD_OFF +NEWLINE + + +# See whether we're gonna work.... +if ($exec == yes && `whoami` != "root") then + + BOLD_ON + echo "**********************************************************************" + echo -n "WARNING" + BOLD_OFF + echo ": This script must be run as root for changes to take effect." + echo " If you decide to proceed, the 'no-op' flag will be enabled" + echo " by default. No changes will be made to the system files," + echo " however you will be able to see what the script does." + BOLD_ON + echo "**********************************************************************" + BOLD_OFF + echo "" + echo -n "Proceed with a no-op uninstallation anyway (y)? " ; setenv ans "$<" + if ("$ans" == "n" || "$ans" == "no") then + echo "Quitting." + exit 0 + endif + NEWLINE; NEWLINE + + set exec = no + alias RM "echo -n \!* >& /dev/null" +endif + + +set iraf_paths = "" +set n_iraf_paths = 0 + +# Search the path for iraf command directories, assume we may have more than +# one so build up a list of all of them. +if ("$lbin" == "") then + foreach i ($path) + if (-d $i && -e $i/cl && -e $i/mkiraf) then + set iraf_paths = ($iraf_paths $i) + set n_iraf_paths = `expr $n_iraf_paths + 1` + endif + end + + # Look around and come up with a likely candidate directory. + if ($n_iraf_paths == 0) then + set d_lbin = "" + foreach dir (/usr/local/bin /opt/local/bin /local/bin /usr/bin /bin) + if (-d $i && -e $i/cl && -e $i/mkiraf) then + set iraf_paths = ($iraf_paths $i) + set n_iraf_paths = `expr $n_iraf_paths + 1` + endif + end + + if (! $n_iraf_paths) then + echo "WARNING: no IRAF command directories found." + endif + endif +endif + + +echo "Files to be deleted to remove IRAF from this machine:" +NEWLINE +BOLD_ON +if ("$cmd_only" == "no") then + foreach i ($FILES $DEVS) + if (-e $i) echo " $i" + end +endif + +foreach i ($iraf_paths) + echo " All IRAF commands found in $i, including" +end +echo "" +echo " cl mkiraf mkmlist generic mkpkg" +echo " rmbin rmfiles rtar wtar xc" +echo " xpp rpp xyacc sgidispatch" +echo "" +BOLD_OFF + + +NEWLINE +echo 'You will be prompted before any files are removed. The system may' +echo 'be restored by rerunning the IRAF install script on this machine.' +NEWLINE + +echo -n "Hit to proceed, 'q' to quit: " + +set ans = "$<" +if ("$ans" == "q" || "$ans" == "quit") exit 0 +NEWLINE ; NEWLINE + + +# Initialize the local bin dir to delete. +set npath = 1 +set d_lbin = $iraf_paths[$npath] + + + +# ============================================================================ +# Delete the miscellaneous files associated with the system. +# ============================================================================ + +if ("$cmd_only" == "no") then + + # See whether we want to delete the symlink. + foreach file ($FILES) + if ($verbage == yes) NEWLINE + if (-e $file) then + echo -n "Remove the $file link (y/n/q)? (y) " + set ans = "$<" + if ("$ans" == "y" || "$ans" == "Y" || "$ans" == "") then + if ($verbage == yes) echo -n " Deleting $file...." + RM $file + if (-e $i && $exec == yes && $verbage == yes) then + echo "file '$i' could not be deleted." + else if ($verbage == yes) then + echo "ok" + endif + else if ("$ans" == "q" || "$ans" == "q") then + echo "Quitting." + exit 0 + endif + endif + end + + # See whether we want to delete the fifo pipes. + if (-e /dev/imt1i || -e /dev/imt1o) then + if ($verbage == yes) NEWLINE + echo -n "Remove the /dev fifo pipes (y/n/q)? (y) " + set ans = "$<" + if ("$ans" == "y" || "$ans" == "Y" || "$ans" == "") then + foreach i ($DEVS) # remove fifo devs + if ($verbage == yes) echo -n " Deleting $i...." + if (-e $i) then + RM $file + if (-e $i && $exec == yes && $verbage == yes) then + echo "file '$i' could not be deleted." + else if ($verbage == yes) then + echo "ok" + endif + endif + end + else if ("$ans" == "q" || "$ans" == "q") then + echo "Quitting." + exit 0 + endif + endif + +endif + + +#============================================================================= +# Get UNIX directory where commands (links) are installed, if not found then +# set it on command line. +#============================================================================= + +if ($n_iraf_paths > 0) then + # Initialize the local bin dir to delete. + set npath = 1 + set d_lbin = $iraf_paths[$npath] +endif + + +if ("$d_lbin" == "") then +again_: + echo -n "Local iraf commands directory? " + set lbin = "$<" + if ("$lbin" == "") goto again_ + + if (!( -e $lbin/cl && -e $lbin/mkiraf)) then + echo "IRAF commands not found in $lbin, please try again..." + set lbin = "" + goto again_ + endif + +else +next_: + if ($verbage == yes) NEWLINE + echo -n "Remove IRAF Commands in $d_lbin (y/n/q)? (y) " + set ans = "$<" + if ("$ans" == "y" || "$ans" == "Y" || "$ans" == "") then + set lbin = $d_lbin + else if ("$ans" == "n" || "$ans" == "no") then + goto no_delete_ + else if ("$ans" == "q" || "$ans" == "quit") then + echo "Quitting." + exit 0 + else + set npath = `expr $npath + 1` + set d_lbin = $iraf_paths[$npath] + goto next_ + endif +endif + +foreach i ($CMDS) # remove the iraf commands + set file = $lbin/$i + if (-e $file) then + if ($verbage == yes) echo -n " Deleting $file...." + if (-e $file) then + RM $file + if (-e $file && $exec == yes && $verbage == yes) then + echo "[ ERROR: file '$file' could not be deleted. ]" + else if ($verbage == yes) then + echo "ok" + endif + endif + else + echo -n " Warning: $file was not found on this machine...." + endif +end + + +#============================================================================= +# Delete the iraf commands and files. +#============================================================================= + +set npath = `expr $npath + 1` + +# See whether this was the only instance and quit. +if ($npath <= $n_iraf_paths) then + set d_lbin = $iraf_paths[$npath] + goto next_ +endif + +no_delete_: + +set back = `pwd` ; chdir $iraf/.. ; set iraf_p = `pwd` ; chdir $back +NEWLINE +NEWLINE +echo "IRAF has been successfully uninstalled from this system. To fully" +echo "remove the system you must delete the iraf directory tree using the" +echo "command: " +NEWLINE +BOLD_ON +echo " % /bin/rm -rf $iraf_p" +BOLD_OFF +NEWLINE +echo "External packages, X11IRAF and/or other display servers and packages" +echo "will also need to be deleted separately." +NEWLINE +exit 0 + +uninstall_cleanup_: + +exit 0 + + + +# Print usage information. We will not get here unless the "-help" flag +# was issued. + +Usage: + echo "Usage: uninstall [-n] [-h] [-hl] [-c] [-v] [-b ]" + echo " " + echo " where -n # no execute" + echo " -h # print this help summary" + echo " -hl # disable text highlighting" + echo " -c # remove command links only" + echo " -v # print verbage output" + echo " -b # specify local bin directory to search" + exit 0 diff --git a/unix/hlib/util.csh/.repo_desc b/unix/hlib/util.csh/.repo_desc new file mode 100644 index 00000000..0658e86d --- /dev/null +++ b/unix/hlib/util.csh/.repo_desc @@ -0,0 +1,27 @@ +# +# Pkg Deps Description + +adccdrom none ADC CD-ROM tools +cfh12k mscred,fitsutil CFHT 12K reductions +ctio none CTIO tools +deitab none DEIMOS tables package +esowfi mscred,fitsutil ESO WFI reductions +fitsutil none FITS utilities +guiapps none Prototype GUI application +iue none IUE reduction package +mem0 none Maximum Entropy deconvolution +mscred fitsutil Mosaic CCD reduction package +mtools none Jeff Munn's utility package +nfextern none General IR reductions/NEWFIRM package +nfdat_ctio nfextern Calibration data for NEWFIRM at CTIO +optic mscred,fitsutil OPTIC reductions +rvsao none SAO's RV package +song none SONG reductions +sqiid none SQIID reductions +stecf none ST-ECF v1.5 +steward none Steward Observatory tools +stsdas tables STSDAS v3.12 - HST reduction tools +tables none TABLES v3.12 - Tables utilities +ucsclris none UCSC LRIS mask making +upsqiid none UPiated SQIID reductions +xdimsum none IR reductions diff --git a/unix/hlib/util.csh/.repo_local b/unix/hlib/util.csh/.repo_local new file mode 100644 index 00000000..d5b230b3 --- /dev/null +++ b/unix/hlib/util.csh/.repo_local @@ -0,0 +1,200 @@ +# Arch Pkg Epoch File +# + linux64 adccdrom 1339696737 adccdrom-linux64.tar.gz + linux adccdrom 1339696737 adccdrom-linux.tar.gz + redhat adccdrom 1339696738 adccdrom-src.tar.gz + macintel adccdrom 1339696735 adccdrom-macintel.tar.gz + macosx adccdrom 1339696736 adccdrom-macosx.tar.gz + ssun adccdrom 1339696738 adccdrom-src.tar.gz + sparc adccdrom 1339696738 adccdrom-src.tar.gz + freebsd adccdrom 1339696738 adccdrom-src.tar.gz + sunos adccdrom 1339696738 adccdrom-src.tar.gz + linux64 cfh12k 1332309566 cfh12k-universal.tar.gz + linux cfh12k 1332309566 cfh12k-universal.tar.gz + redhat cfh12k 1332309566 cfh12k-universal.tar.gz + macintel cfh12k 1332309566 cfh12k-universal.tar.gz + macosx cfh12k 1332309566 cfh12k-universal.tar.gz + ssun cfh12k 1332309566 cfh12k-universal.tar.gz + sparc cfh12k 1332309566 cfh12k-universal.tar.gz + freebsd cfh12k 1332309566 cfh12k-universal.tar.gz + sunos cfh12k 1332309566 cfh12k-universal.tar.gz + linux64 ctio 1339696753 ctio-linux64.tar.gz + linux ctio 1339696757 ctio-linux.tar.gz + redhat ctio 1339696759 ctio-src.tar.gz + macintel ctio 1339696741 ctio-macintel.tar.gz + macosx ctio 1339696747 ctio-macosx.tar.gz + ssun ctio 1339696759 ctio-src.tar.gz + sparc ctio 1339696759 ctio-src.tar.gz + freebsd ctio 1339696759 ctio-src.tar.gz + sunos ctio 1339696759 ctio-src.tar.gz + linux64 deitab 1339696765 deitab-linux64.tar.gz + linux deitab 1339696767 deitab-linux.tar.gz + redhat deitab 1339696768 deitab-src.tar.gz + macintel deitab 1339696760 deitab-macintel.tar.gz + macosx deitab 1339696762 deitab-macosx.tar.gz + ssun deitab 1339696768 deitab-src.tar.gz + sparc deitab 1339696768 deitab-src.tar.gz + freebsd deitab 1339696768 deitab-src.tar.gz + sunos deitab 1339696768 deitab-src.tar.gz + linux64 esowfi 1332309566 esowfi-universal.tar.gz + linux esowfi 1332309566 esowfi-universal.tar.gz + redhat esowfi 1332309566 esowfi-universal.tar.gz + macintel esowfi 1332309566 esowfi-universal.tar.gz + macosx esowfi 1332309566 esowfi-universal.tar.gz + ssun esowfi 1332309566 esowfi-universal.tar.gz + sparc esowfi 1332309566 esowfi-universal.tar.gz + freebsd esowfi 1332309566 esowfi-universal.tar.gz + sunos esowfi 1332309566 esowfi-universal.tar.gz + linux64 fitsutil 1339696790 fitsutil-linux64.tar.gz + linux fitsutil 1339696797 fitsutil-linux.tar.gz + redhat fitsutil 1339696802 fitsutil-src.tar.gz + macintel fitsutil 1339696774 fitsutil-macintel.tar.gz + macosx fitsutil 1339696782 fitsutil-macosx.tar.gz + ssun fitsutil 1339696802 fitsutil-src.tar.gz + sparc fitsutil 1339696802 fitsutil-src.tar.gz + freebsd fitsutil 1339696802 fitsutil-src.tar.gz + sunos fitsutil 1339696802 fitsutil-src.tar.gz + linux64 guiapps 1339696827 guiapps-linux64.tar.gz + linux guiapps 1339696837 guiapps-linux.tar.gz + redhat guiapps 1339696843 guiapps-src.tar.gz + macintel guiapps 1339696808 guiapps-macintel.tar.gz + macosx guiapps 1339696817 guiapps-macosx.tar.gz + ssun guiapps 1339696843 guiapps-src.tar.gz + sparc guiapps 1339696843 guiapps-src.tar.gz + freebsd guiapps 1339696843 guiapps-src.tar.gz + sunos guiapps 1339696843 guiapps-src.tar.gz + linux64 mem0 1339696846 mem0-linux64.tar.gz + linux mem0 1339696847 mem0-linux.tar.gz + redhat mem0 1339696847 mem0-src.tar.gz + macintel mem0 1339696844 mem0-macintel.tar.gz + macosx mem0 1339696845 mem0-macosx.tar.gz + ssun mem0 1339696847 mem0-src.tar.gz + sparc mem0 1339696847 mem0-src.tar.gz + freebsd mem0 1339696847 mem0-src.tar.gz + sunos mem0 1339696847 mem0-src.tar.gz + linux64 mscdb 1339696652 mscdb-universal.tar.gz + linux mscdb 1339696652 mscdb-universal.tar.gz + redhat mscdb 1339696652 mscdb-universal.tar.gz + macintel mscdb 1339696652 mscdb-universal.tar.gz + macosx mscdb 1339696652 mscdb-universal.tar.gz + ssun mscdb 1339696652 mscdb-universal.tar.gz + sparc mscdb 1339696652 mscdb-universal.tar.gz + freebsd mscdb 1339696652 mscdb-universal.tar.gz + sunos mscdb 1339696652 mscdb-universal.tar.gz + linux64 mscred 1343187073 mscred-linux64.tar.gz + linux mscred 1343187056 mscred-linux.tar.gz + redhat mscred 1343187082 mscred-src.tar.gz + macintel mscred 1343187018 mscred-macintel.tar.gz + macosx mscred 1343187037 mscred-macosx.tar.gz + ssun mscred 1343187082 mscred-src.tar.gz + sparc mscred 1343187082 mscred-src.tar.gz + freebsd mscred 1343187082 mscred-src.tar.gz + sunos mscred 1343187082 mscred-src.tar.gz + linux64 mtools 1339696859 mtools-linux64.tar.gz + linux mtools 1339696862 mtools-linux.tar.gz + redhat mtools 1339696863 mtools-src.tar.gz + macintel mtools 1339696850 mtools-macintel.tar.gz + macosx mtools 1339696855 mtools-macosx.tar.gz + ssun mtools 1339696863 mtools-src.tar.gz + sparc mtools 1339696863 mtools-src.tar.gz + freebsd mtools 1339696863 mtools-src.tar.gz + sunos mtools 1339696863 mtools-src.tar.gz + linux64 nfextern 1343186860 nfextern-linux64.tar.gz + linux nfextern 1343186815 nfextern-linux.tar.gz + redhat nfextern 1343187011 nfextern-src.tar.gz + macintel nfextern 1343186914 nfextern-macintel.tar.gz + macosx nfextern 1343186971 nfextern-macosx.tar.gz + ssun nfextern 1332311037 nfextern-ssun.tar.gz + sparc nfextern 1343187011 nfextern-src.tar.gz + freebsd nfextern 1343187011 nfextern-src.tar.gz + sunos nfextern 1343187011 nfextern-src.tar.gz + linux64 optic 1332309566 optic-universal.tar.gz + linux optic 1332309566 optic-universal.tar.gz + redhat optic 1332309566 optic-universal.tar.gz + macintel optic 1332309566 optic-universal.tar.gz + macosx optic 1332309566 optic-universal.tar.gz + ssun optic 1332309566 optic-universal.tar.gz + sparc optic 1332309566 optic-universal.tar.gz + freebsd optic 1332309566 optic-universal.tar.gz + sunos optic 1332309566 optic-universal.tar.gz + linux64 patch 1337903759 patch-src.tar.gz + linux patch 1337903759 patch-src.tar.gz + redhat patch 1337903759 patch-src.tar.gz + macintel patch 1337903759 patch-src.tar.gz + macosx patch 1337903759 patch-src.tar.gz + ssun patch 1337903759 patch-src.tar.gz + sparc patch 1337903759 patch-src.tar.gz + freebsd patch 1337903759 patch-src.tar.gz + sunos patch 1337903759 patch-src.tar.gz + linux64 rvsao 1322067222 rvsao-redhat.tar.gz + linux rvsao 1322067222 rvsao-redhat.tar.gz + redhat rvsao 1322067222 rvsao-redhat.tar.gz + macintel rvsao 1322067226 rvsao-macosx.tar.gz + macosx rvsao 1322067226 rvsao-macosx.tar.gz + ssun rvsao 1322067223 rvsao-ssun.tar.gz + sparc rvsao 1322067228 rvsao-src.tar.gz + freebsd rvsao 1322067228 rvsao-src.tar.gz + sunos rvsao 1322067228 rvsao-src.tar.gz + linux64 song 1332309566 song-universal.tar.gz + linux song 1332309566 song-universal.tar.gz + redhat song 1332309566 song-universal.tar.gz + macintel song 1332309566 song-universal.tar.gz + macosx song 1332309566 song-universal.tar.gz + ssun song 1332309566 song-universal.tar.gz + sparc song 1332309566 song-universal.tar.gz + freebsd song 1332309566 song-universal.tar.gz + sunos song 1332309566 song-universal.tar.gz + linux64 sqiid 1332309566 sqiid-universal.tar.gz + linux sqiid 1332309566 sqiid-universal.tar.gz + redhat sqiid 1332309566 sqiid-universal.tar.gz + macintel sqiid 1332309566 sqiid-universal.tar.gz + macosx sqiid 1332309566 sqiid-universal.tar.gz + ssun sqiid 1332309566 sqiid-universal.tar.gz + sparc sqiid 1332309566 sqiid-universal.tar.gz + freebsd sqiid 1332309566 sqiid-universal.tar.gz + sunos sqiid 1332309566 sqiid-universal.tar.gz + linux64 stsdas 1316518910 stsdas-linux.tar.gz + linux stsdas 1316518910 stsdas-linux.tar.gz + redhat stsdas 1316518961 stsdas-src.tar.gz + macintel stsdas 1316518808 stsdas-macosx.tar.gz + macosx stsdas 1316518808 stsdas-macosx.tar.gz + ssun stsdas 1316518961 stsdas-src.tar.gz + sparc stsdas 1316518961 stsdas-src.tar.gz + freebsd stsdas 1316518961 stsdas-src.tar.gz + sunos stsdas 1316518961 stsdas-src.tar.gz + linux64 tables 1316518978 tables-linux.tar.gz + linux tables 1316518978 tables-linux.tar.gz + redhat tables 1316518984 tables-src.tar.gz + macintel tables 1316518971 tables-macosx.tar.gz + macosx tables 1316518971 tables-macosx.tar.gz + ssun tables 1316518984 tables-src.tar.gz + sparc tables 1316518984 tables-src.tar.gz + freebsd tables 1316518984 tables-src.tar.gz + sunos tables 1316518984 tables-src.tar.gz + linux64 ucsclris 1339696867 ucsclris-linux64.tar.gz + linux ucsclris 1339696867 ucsclris-linux.tar.gz + redhat ucsclris 1339696868 ucsclris-src.tar.gz + macintel ucsclris 1339696864 ucsclris-macintel.tar.gz + macosx ucsclris 1339696865 ucsclris-macosx.tar.gz + ssun ucsclris 1339696868 ucsclris-src.tar.gz + sparc ucsclris 1339696868 ucsclris-src.tar.gz + freebsd ucsclris 1339696868 ucsclris-src.tar.gz + sunos ucsclris 1339696868 ucsclris-src.tar.gz + linux64 upsqiid 1332309566 upsqiid-universal.tar.gz + linux upsqiid 1332309566 upsqiid-universal.tar.gz + redhat upsqiid 1332309566 upsqiid-universal.tar.gz + macintel upsqiid 1332309566 upsqiid-universal.tar.gz + macosx upsqiid 1332309566 upsqiid-universal.tar.gz + ssun upsqiid 1332309566 upsqiid-universal.tar.gz + sparc upsqiid 1332309566 upsqiid-universal.tar.gz + freebsd upsqiid 1332309566 upsqiid-universal.tar.gz + sunos upsqiid 1332309566 upsqiid-universal.tar.gz + linux64 xdimsum 1339696873 xdimsum-linux64.tar.gz + linux xdimsum 1339696874 xdimsum-linux.tar.gz + redhat xdimsum 1339696874 xdimsum-src.tar.gz + macintel xdimsum 1339696869 xdimsum-macintel.tar.gz + macosx xdimsum 1339696871 xdimsum-macosx.tar.gz + ssun xdimsum 1339696874 xdimsum-src.tar.gz + sparc xdimsum 1339696874 xdimsum-src.tar.gz + freebsd xdimsum 1339696874 xdimsum-src.tar.gz + sunos xdimsum 1339696874 xdimsum-src.tar.gz diff --git a/unix/hlib/util.csh/.repo_manifest b/unix/hlib/util.csh/.repo_manifest new file mode 100644 index 00000000..d5b230b3 --- /dev/null +++ b/unix/hlib/util.csh/.repo_manifest @@ -0,0 +1,200 @@ +# Arch Pkg Epoch File +# + linux64 adccdrom 1339696737 adccdrom-linux64.tar.gz + linux adccdrom 1339696737 adccdrom-linux.tar.gz + redhat adccdrom 1339696738 adccdrom-src.tar.gz + macintel adccdrom 1339696735 adccdrom-macintel.tar.gz + macosx adccdrom 1339696736 adccdrom-macosx.tar.gz + ssun adccdrom 1339696738 adccdrom-src.tar.gz + sparc adccdrom 1339696738 adccdrom-src.tar.gz + freebsd adccdrom 1339696738 adccdrom-src.tar.gz + sunos adccdrom 1339696738 adccdrom-src.tar.gz + linux64 cfh12k 1332309566 cfh12k-universal.tar.gz + linux cfh12k 1332309566 cfh12k-universal.tar.gz + redhat cfh12k 1332309566 cfh12k-universal.tar.gz + macintel cfh12k 1332309566 cfh12k-universal.tar.gz + macosx cfh12k 1332309566 cfh12k-universal.tar.gz + ssun cfh12k 1332309566 cfh12k-universal.tar.gz + sparc cfh12k 1332309566 cfh12k-universal.tar.gz + freebsd cfh12k 1332309566 cfh12k-universal.tar.gz + sunos cfh12k 1332309566 cfh12k-universal.tar.gz + linux64 ctio 1339696753 ctio-linux64.tar.gz + linux ctio 1339696757 ctio-linux.tar.gz + redhat ctio 1339696759 ctio-src.tar.gz + macintel ctio 1339696741 ctio-macintel.tar.gz + macosx ctio 1339696747 ctio-macosx.tar.gz + ssun ctio 1339696759 ctio-src.tar.gz + sparc ctio 1339696759 ctio-src.tar.gz + freebsd ctio 1339696759 ctio-src.tar.gz + sunos ctio 1339696759 ctio-src.tar.gz + linux64 deitab 1339696765 deitab-linux64.tar.gz + linux deitab 1339696767 deitab-linux.tar.gz + redhat deitab 1339696768 deitab-src.tar.gz + macintel deitab 1339696760 deitab-macintel.tar.gz + macosx deitab 1339696762 deitab-macosx.tar.gz + ssun deitab 1339696768 deitab-src.tar.gz + sparc deitab 1339696768 deitab-src.tar.gz + freebsd deitab 1339696768 deitab-src.tar.gz + sunos deitab 1339696768 deitab-src.tar.gz + linux64 esowfi 1332309566 esowfi-universal.tar.gz + linux esowfi 1332309566 esowfi-universal.tar.gz + redhat esowfi 1332309566 esowfi-universal.tar.gz + macintel esowfi 1332309566 esowfi-universal.tar.gz + macosx esowfi 1332309566 esowfi-universal.tar.gz + ssun esowfi 1332309566 esowfi-universal.tar.gz + sparc esowfi 1332309566 esowfi-universal.tar.gz + freebsd esowfi 1332309566 esowfi-universal.tar.gz + sunos esowfi 1332309566 esowfi-universal.tar.gz + linux64 fitsutil 1339696790 fitsutil-linux64.tar.gz + linux fitsutil 1339696797 fitsutil-linux.tar.gz + redhat fitsutil 1339696802 fitsutil-src.tar.gz + macintel fitsutil 1339696774 fitsutil-macintel.tar.gz + macosx fitsutil 1339696782 fitsutil-macosx.tar.gz + ssun fitsutil 1339696802 fitsutil-src.tar.gz + sparc fitsutil 1339696802 fitsutil-src.tar.gz + freebsd fitsutil 1339696802 fitsutil-src.tar.gz + sunos fitsutil 1339696802 fitsutil-src.tar.gz + linux64 guiapps 1339696827 guiapps-linux64.tar.gz + linux guiapps 1339696837 guiapps-linux.tar.gz + redhat guiapps 1339696843 guiapps-src.tar.gz + macintel guiapps 1339696808 guiapps-macintel.tar.gz + macosx guiapps 1339696817 guiapps-macosx.tar.gz + ssun guiapps 1339696843 guiapps-src.tar.gz + sparc guiapps 1339696843 guiapps-src.tar.gz + freebsd guiapps 1339696843 guiapps-src.tar.gz + sunos guiapps 1339696843 guiapps-src.tar.gz + linux64 mem0 1339696846 mem0-linux64.tar.gz + linux mem0 1339696847 mem0-linux.tar.gz + redhat mem0 1339696847 mem0-src.tar.gz + macintel mem0 1339696844 mem0-macintel.tar.gz + macosx mem0 1339696845 mem0-macosx.tar.gz + ssun mem0 1339696847 mem0-src.tar.gz + sparc mem0 1339696847 mem0-src.tar.gz + freebsd mem0 1339696847 mem0-src.tar.gz + sunos mem0 1339696847 mem0-src.tar.gz + linux64 mscdb 1339696652 mscdb-universal.tar.gz + linux mscdb 1339696652 mscdb-universal.tar.gz + redhat mscdb 1339696652 mscdb-universal.tar.gz + macintel mscdb 1339696652 mscdb-universal.tar.gz + macosx mscdb 1339696652 mscdb-universal.tar.gz + ssun mscdb 1339696652 mscdb-universal.tar.gz + sparc mscdb 1339696652 mscdb-universal.tar.gz + freebsd mscdb 1339696652 mscdb-universal.tar.gz + sunos mscdb 1339696652 mscdb-universal.tar.gz + linux64 mscred 1343187073 mscred-linux64.tar.gz + linux mscred 1343187056 mscred-linux.tar.gz + redhat mscred 1343187082 mscred-src.tar.gz + macintel mscred 1343187018 mscred-macintel.tar.gz + macosx mscred 1343187037 mscred-macosx.tar.gz + ssun mscred 1343187082 mscred-src.tar.gz + sparc mscred 1343187082 mscred-src.tar.gz + freebsd mscred 1343187082 mscred-src.tar.gz + sunos mscred 1343187082 mscred-src.tar.gz + linux64 mtools 1339696859 mtools-linux64.tar.gz + linux mtools 1339696862 mtools-linux.tar.gz + redhat mtools 1339696863 mtools-src.tar.gz + macintel mtools 1339696850 mtools-macintel.tar.gz + macosx mtools 1339696855 mtools-macosx.tar.gz + ssun mtools 1339696863 mtools-src.tar.gz + sparc mtools 1339696863 mtools-src.tar.gz + freebsd mtools 1339696863 mtools-src.tar.gz + sunos mtools 1339696863 mtools-src.tar.gz + linux64 nfextern 1343186860 nfextern-linux64.tar.gz + linux nfextern 1343186815 nfextern-linux.tar.gz + redhat nfextern 1343187011 nfextern-src.tar.gz + macintel nfextern 1343186914 nfextern-macintel.tar.gz + macosx nfextern 1343186971 nfextern-macosx.tar.gz + ssun nfextern 1332311037 nfextern-ssun.tar.gz + sparc nfextern 1343187011 nfextern-src.tar.gz + freebsd nfextern 1343187011 nfextern-src.tar.gz + sunos nfextern 1343187011 nfextern-src.tar.gz + linux64 optic 1332309566 optic-universal.tar.gz + linux optic 1332309566 optic-universal.tar.gz + redhat optic 1332309566 optic-universal.tar.gz + macintel optic 1332309566 optic-universal.tar.gz + macosx optic 1332309566 optic-universal.tar.gz + ssun optic 1332309566 optic-universal.tar.gz + sparc optic 1332309566 optic-universal.tar.gz + freebsd optic 1332309566 optic-universal.tar.gz + sunos optic 1332309566 optic-universal.tar.gz + linux64 patch 1337903759 patch-src.tar.gz + linux patch 1337903759 patch-src.tar.gz + redhat patch 1337903759 patch-src.tar.gz + macintel patch 1337903759 patch-src.tar.gz + macosx patch 1337903759 patch-src.tar.gz + ssun patch 1337903759 patch-src.tar.gz + sparc patch 1337903759 patch-src.tar.gz + freebsd patch 1337903759 patch-src.tar.gz + sunos patch 1337903759 patch-src.tar.gz + linux64 rvsao 1322067222 rvsao-redhat.tar.gz + linux rvsao 1322067222 rvsao-redhat.tar.gz + redhat rvsao 1322067222 rvsao-redhat.tar.gz + macintel rvsao 1322067226 rvsao-macosx.tar.gz + macosx rvsao 1322067226 rvsao-macosx.tar.gz + ssun rvsao 1322067223 rvsao-ssun.tar.gz + sparc rvsao 1322067228 rvsao-src.tar.gz + freebsd rvsao 1322067228 rvsao-src.tar.gz + sunos rvsao 1322067228 rvsao-src.tar.gz + linux64 song 1332309566 song-universal.tar.gz + linux song 1332309566 song-universal.tar.gz + redhat song 1332309566 song-universal.tar.gz + macintel song 1332309566 song-universal.tar.gz + macosx song 1332309566 song-universal.tar.gz + ssun song 1332309566 song-universal.tar.gz + sparc song 1332309566 song-universal.tar.gz + freebsd song 1332309566 song-universal.tar.gz + sunos song 1332309566 song-universal.tar.gz + linux64 sqiid 1332309566 sqiid-universal.tar.gz + linux sqiid 1332309566 sqiid-universal.tar.gz + redhat sqiid 1332309566 sqiid-universal.tar.gz + macintel sqiid 1332309566 sqiid-universal.tar.gz + macosx sqiid 1332309566 sqiid-universal.tar.gz + ssun sqiid 1332309566 sqiid-universal.tar.gz + sparc sqiid 1332309566 sqiid-universal.tar.gz + freebsd sqiid 1332309566 sqiid-universal.tar.gz + sunos sqiid 1332309566 sqiid-universal.tar.gz + linux64 stsdas 1316518910 stsdas-linux.tar.gz + linux stsdas 1316518910 stsdas-linux.tar.gz + redhat stsdas 1316518961 stsdas-src.tar.gz + macintel stsdas 1316518808 stsdas-macosx.tar.gz + macosx stsdas 1316518808 stsdas-macosx.tar.gz + ssun stsdas 1316518961 stsdas-src.tar.gz + sparc stsdas 1316518961 stsdas-src.tar.gz + freebsd stsdas 1316518961 stsdas-src.tar.gz + sunos stsdas 1316518961 stsdas-src.tar.gz + linux64 tables 1316518978 tables-linux.tar.gz + linux tables 1316518978 tables-linux.tar.gz + redhat tables 1316518984 tables-src.tar.gz + macintel tables 1316518971 tables-macosx.tar.gz + macosx tables 1316518971 tables-macosx.tar.gz + ssun tables 1316518984 tables-src.tar.gz + sparc tables 1316518984 tables-src.tar.gz + freebsd tables 1316518984 tables-src.tar.gz + sunos tables 1316518984 tables-src.tar.gz + linux64 ucsclris 1339696867 ucsclris-linux64.tar.gz + linux ucsclris 1339696867 ucsclris-linux.tar.gz + redhat ucsclris 1339696868 ucsclris-src.tar.gz + macintel ucsclris 1339696864 ucsclris-macintel.tar.gz + macosx ucsclris 1339696865 ucsclris-macosx.tar.gz + ssun ucsclris 1339696868 ucsclris-src.tar.gz + sparc ucsclris 1339696868 ucsclris-src.tar.gz + freebsd ucsclris 1339696868 ucsclris-src.tar.gz + sunos ucsclris 1339696868 ucsclris-src.tar.gz + linux64 upsqiid 1332309566 upsqiid-universal.tar.gz + linux upsqiid 1332309566 upsqiid-universal.tar.gz + redhat upsqiid 1332309566 upsqiid-universal.tar.gz + macintel upsqiid 1332309566 upsqiid-universal.tar.gz + macosx upsqiid 1332309566 upsqiid-universal.tar.gz + ssun upsqiid 1332309566 upsqiid-universal.tar.gz + sparc upsqiid 1332309566 upsqiid-universal.tar.gz + freebsd upsqiid 1332309566 upsqiid-universal.tar.gz + sunos upsqiid 1332309566 upsqiid-universal.tar.gz + linux64 xdimsum 1339696873 xdimsum-linux64.tar.gz + linux xdimsum 1339696874 xdimsum-linux.tar.gz + redhat xdimsum 1339696874 xdimsum-src.tar.gz + macintel xdimsum 1339696869 xdimsum-macintel.tar.gz + macosx xdimsum 1339696871 xdimsum-macosx.tar.gz + ssun xdimsum 1339696874 xdimsum-src.tar.gz + sparc xdimsum 1339696874 xdimsum-src.tar.gz + freebsd xdimsum 1339696874 xdimsum-src.tar.gz + sunos xdimsum 1339696874 xdimsum-src.tar.gz diff --git a/unix/hlib/util.csh/.repo_pkgs b/unix/hlib/util.csh/.repo_pkgs new file mode 100644 index 00000000..eb7b2181 --- /dev/null +++ b/unix/hlib/util.csh/.repo_pkgs @@ -0,0 +1,22 @@ +adccdrom +cfh12k +ctio +deitab +esowfi +fitsutil +guiapps +mem0 +mscdb +mscred +mtools +nfextern +optic +patch +rvsao +song +sqiid +stsdas +tables +ucsclris +upsqiid +xdimsum diff --git a/unix/hlib/util.csh/.zzsetenv.def b/unix/hlib/util.csh/.zzsetenv.def new file mode 100644 index 00000000..2fa992c0 --- /dev/null +++ b/unix/hlib/util.csh/.zzsetenv.def @@ -0,0 +1 @@ +keep diff --git a/unix/hlib/util.csh/README b/unix/hlib/util.csh/README new file mode 100644 index 00000000..2a17ea68 --- /dev/null +++ b/unix/hlib/util.csh/README @@ -0,0 +1,19 @@ + + This directory contains utility scripts used to build and +maintain the system from the top-level IRAF root directory. These +scripts should NOT be used to build individual packages or source +directories. + +Contents include: + + README This file + chk64 Check subdirectories for 64-bit issues + mkarch Reconfigure the system for given architecture + mkclean Clean the current architecture of binaries + mkdist Create a distribution file (NYI) + mkproto Create system prototype files + mksrc Clean the system of all binaries + mksysgen Build from a clean system source + mkup Update current-arch binaries + mkupx Update current-arch binaries (debug) + diff --git a/unix/hlib/util.csh/check_update b/unix/hlib/util.csh/check_update new file mode 100755 index 00000000..a26298e9 --- /dev/null +++ b/unix/hlib/util.csh/check_update @@ -0,0 +1,68 @@ +#!/bin/csh -f +# +# CHECK_UPDATE -- Check to see if an update is available. Return $status=1 +# if a patch is available. +# + +# Called from Makefile, set iraf root. +source $iraf/unix/hlib/irafuser.csh + + +set REPO = `${iraf}/util/pkgrepo` +if ($?IRAFARCH) then + set arch = $IRAFARCH +else + set arch = `${iraf}/unix/hlib/irafarch.csh -actual` +endif + + +# Check to see if a patch file is available. + +/bin/rm -f /tmp/_rdate /tmp/_pdate + +set FGET = "${iraf}/util/fget" +${FGET} -q -o /tmp/_rdate http://iraf.noao.edu/ftp/v216/PCIX/.release_date +${FGET} -q -o /tmp/_pdate http://iraf.noao.edu/ftp/v216/PCIX/.patch_release + +if (-e /tmp/_rdate) then + set rdate = `cat /tmp/_rdate` +else + echo "cannot get rdate" + exit 0 +endif +if (-e /tmp/_pdate) then + set pdate = `cat /tmp/_pdate` +else + echo "cannot get pdate" + exit 0 +endif + + +if (-e ${iraf}/.patch_release) then + set ipdate = `/bin/ls -l --time-style=+%s ${iraf}/.patch_release | \ + awk '{ print ($6) }'` +else + set ipdate = 0 +endif + +if ($#argv > 0 && "$1" == "-d") then # Debug + echo " rdate = " $rdate + echo " pdate = " $pdate + echo "ipdate = " $ipdate +endif + +if ($rdate > $pdate) then # New Release + exit 1 +endif + + +if ($pdate == 0) then + exit 0 + +else if ($pdate > $ipdate && $ipdate != 0) then # Patch newer than installed + exit 1 + +endif + + +exit 0 # No update available diff --git a/unix/hlib/util.csh/chk64 b/unix/hlib/util.csh/chk64 new file mode 100755 index 00000000..3ebe24bc --- /dev/null +++ b/unix/hlib/util.csh/chk64 @@ -0,0 +1,17 @@ +#!/bin/csh -f + +find . -type f -name \*.x -exec egrep -H SZ_REAL {} \; >& _real +find . -type f -name \*.h -exec egrep -H SZ_REAL {} \; >& _realh + +find . -type f -name \*.h -exec egrep -H SZ_INT {} \; >& _inth +find . -type f -name \*.x -exec egrep -H SZ_INT {} \; >& _int + +find . -type f -name \*.x -exec egrep -H SZ_STRUCT {} \; >& _sz +find . -type f -name \*.h -exec egrep -H SZ_STRUCT {} \; >& _szh + +find . -type f -name \*.x -exec egrep -H mii_ {} \; >& _mii +find . -type f -name \*.gx -exec egrep -H SZ_PIXEL {} \; >& _szpix + +find . -type f -name \*.x -exec egrep -H sizeof {} \; | \ + egrep -v -e ":int" >& _sizeof +find . -type f -name \*.x -exec egrep -H szdtype {} \; >& _szdtype diff --git a/unix/hlib/util.csh/fget b/unix/hlib/util.csh/fget new file mode 100755 index 00000000..23af7c6a --- /dev/null +++ b/unix/hlib/util.csh/fget @@ -0,0 +1,185 @@ +#!/bin/csh -f +# +# FGET -- Download a URL. +# +# Usage: fget [-h] [-n] [-q | -v] url +# +# Where -n no-op flag +# -q suppress output +# -v verbose output +# -d set download directory +# -o set output filename +# -h this message +# +# Example: +# % fget -q ftp://iraf.noao.edu/iraf/extern/foo-linux.tar.gz +# +# ---------------------------------------------------------------------------- + + +unset noclobber +onintr cleanup_ +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort which +unalias ftp wget + +setenv path "(../util /sbin /usr/sbin /bin /usr/bin /usr/5bin /usr/ucb /etc /usr/etc $path /usr/local/bin /opt/local/bin /local/bin /home/local/bin)" + +# set echo + + +############################################################################## +# START OF MACHDEP DEFINITIONS. +############################################################################## + +# MACHDEP definitions which may be reset below. + + +# Find the iraf root directory. +if (! $?iraf) then + set iraf = "" + foreach f ( ~/.iraf.h ~/.iraf/iraf.h /usr/include/iraf.h) + # $iraf is defined, use a well-known path for the system + if (-e ${f}) then + set i = `egrep IRAF ${f} | egrep \#define | sed -e 's/"//g'` + set iraf = $i[3] +echo $i + break + endif + end +endif +if ("$iraf" == "") then + if (-e /iraf/iraf) then + set iraf = /iraf/iraf/ + else + set iraf = `dirname $0`/../ + endif +endif + +# Determine platform architecture. +set arch = `$iraf/unix/hlib/irafarch.csh` + + +############################################################################## +# END OF MACHDEP DEFINITIONS. +############################################################################## + +#============================================================================= +# Declarations and initializations. +#============================================================================= + +set exec = yes +set verb = no +set url = "" +set fname = "" +set ddir = "" + + +# Process cmdline flags. +while ("$1" != "") + switch ("$1") + case -n: # no execute + set exec = no + breaksw + case -q: # be quiet + set verb = no + set quiet = yes + breaksw + case -v: # be chatty + set verb = yes + set quiet = no + breaksw + case -h: # print help summary + goto Usage + case -d: # set download directory + set ddir = $2 + shift + breaksw + case -o: # set output file name + set fname = $2 + shift + breaksw + default: + set url = $1 + break + endsw + + if ("$2" == "") then + break + else + shift + endif +end + + +# Error checks. +if ("$url" == "") then + if ("$verb" == "yes") then + echo "ERROR: URL not specified" + endif + exit 1 +endif + +# Get the download filename. Delete an existing copy of the file +if ($fname == "") then + set fname = $url:t +endif +if (-e "$fname") then + /bin/rm -f $fname +endif + +# Ensure URL is an HTTP protocol. +set prot = `echo $url | cut -c1-3` +if ("$prot" == "ftp") then + set u = `echo $url | sed -e 's;ftp://iraf.noao.edu/iraf;http://iraf.noao.edu/ftp;'` + set url = $u +endif + +# Do it. +if ("$exec" == "yes") then + if ("$verb" == "yes") then + echo "Downloading "$url" ...." + endif + + set args = "url='$url' fname='${ddir}${fname}' cache='/tmp' verbose=no extn='' use_cache=no" + if ("$verb" == "no") then + $iraf/bin.$arch/x_system.e urlget ${args} \$nargs=2 >& /dev/null + else + $iraf/bin.$arch/x_system.e urlget ${args} \$nargs=2 + endif + + if ("$verb" == "yes") then + echo "done" + endif +endif + + +# Verify we have the file. +if (! -e $url:t) then + if ("$verb" == "yes") then + echo "Error downloading file '"$fname"'" + endif + exit 1 +else + if ($#argv > 1) then + mv $url:t $2 + endif +endif + +# Normal exit. +exit 0 + + + +#============================================================================= +# Usage +#============================================================================= + +Usage: + echo "Usage: fget [-h] [-n] [-q | -v] url" + echo "" + echo " where -n # no execute" + echo " -q # suppress output" + echo " -v # verbose output" + echo " -h # this message" + +exit 0 diff --git a/unix/hlib/util.csh/iraf_latest b/unix/hlib/util.csh/iraf_latest new file mode 100755 index 00000000..dfde7893 --- /dev/null +++ b/unix/hlib/util.csh/iraf_latest @@ -0,0 +1,91 @@ +#!/bin/csh -f +# +# IRAF_LATEST - Update the system with the latest distribution files. + +unalias grep ls + +set opt = "all" + + +if ($#argv < 1) then + echo "Usage: iraf_latest " + exit 0 +else + set opt = $1 +endif + + +# Called from Makefile, set iraf root. +set iraf = $cwd/ +source $iraf/unix/hlib/irafuser.csh + + +set REPO = `${iraf}/util/pkgrepo` +if ($?IRAFARCH) then + set arch = $IRAFARCH +else + set arch = `${iraf}/unix/hlib/irafarch.csh -actual` +endif + + +echo "iraf_latest: cwd = " $cwd + +# Figure out which binaries are required. +set files = "patch-src.tar.gz" # always need the source .... +set bins = "" +foreach b (linux linux64 macosx macintel) + if (-e "bin.$b/x_images.e") then + set bins = `echo $bins " " $b` + switch ($b) + case linux: + set files = `echo "$files patch.lnux.x86.tar.gz"` + breaksw + case linux64: + set files = `echo "$files patch.lnux.x86_64.tar.gz"` + breaksw + case macosx: + set files = `echo "$files patch.macx.uni.tar.gz"` + breaksw + case macintel: + set files = `echo "$files patch.macx.x86_64.tar.gz"` + breaksw + endsw + endif +end +echo "Updating binaries: " $bins + + +# Download the needed files to /tmp + +set FGET = "${iraf}/util/fget" +set REPO = `util/pkgrepo` +foreach f ($files) + echo -n "Downloading: $f" + ${FGET} -q -d /tmp/ $REPO/$f + if (! (-e /tmp/$f)) then + echo "" + echo "Error downloading $REPO/$f, quitting" + exit + endif + + echo -n " Unpacking ..." + tar zxf /tmp/$f + /bin/rm -f /tmp/$f + + echo " Done." +end + + +# For the initial release, the update procedures haven't yet been defined. +# This script will be replaced by the working version at the first release. + + +if ($opt == "all") then # Update everything + if (-e extern/.installed) then + echo "Update all external packages ..." + (chdir extern ; make update) + endif +endif + +echo "" +exit 0 diff --git a/unix/hlib/util.csh/iraf_update b/unix/hlib/util.csh/iraf_update new file mode 100755 index 00000000..f43ede90 --- /dev/null +++ b/unix/hlib/util.csh/iraf_update @@ -0,0 +1,100 @@ +#!/bin/csh -f +# +# IRAF_UPDATE - Update the core IRAF system with a cumulative patch. + +unalias grep ls + +set opt = "all" +set all = yes +set src_only = no +set list_only = no +set core_only = no +set noao_only = no +set vo_only = no + +if ($#argv < 1) then + set opt = "all" + set all = yes +else + + # Process cmdline flags. + while ("$1" != "") + switch ("$1") + case -all: # clean all package sources + set all = yes + set opt = "all" + breaksw + case -src: # update only source code + set src_only = yes + set opt = "src" + breaksw + case -list: # list files needing updating + set list_only = yes + set opt = "list" + + echo "" + util/check_update + if ($status == 0) then + echo "IRAF is up to date" + else + echo "An IRAF update is available" + endif + echo "" + (chdir util ; ${iraf}/util/pkgupdate -list) + exit 0 + + case -core: # update only core system + set core_only = yes + set opt = "core" + breaksw + case -noao: # update only NOAO package + set noao_only = yes + set opt = "noao" + breaksw + case -vo: # update only VO package + set vo_only = yes + set opt = "vo" + breaksw + default: + echo "Error: Unknown option '"$1"', quitting." + exit 1 + endsw + + shift + end +endif + + +# Called from Makefile, set iraf root. +set iraf = $cwd/ +source $iraf/unix/hlib/irafuser.csh +set irafdir = $iraf + + +set REPO = `${irafdir}/util/pkgrepo` +if ($?IRAFARCH) then + set arch = $IRAFARCH +else + set arch = `${irafdir}/unix/hlib/irafarch.csh -actual` +endif + + +# Init the build scripts as the first update. +#echo "Updating build scripts ...." +util/self_update + + +# Execute the update. +echo "Updating IRAF system ...." +util/iraf_latest $opt + +if ($status == 2) then + echo -n "Update Status: No updates necessary" +else if ($status == 0) then + echo -n "Update Status: Successful " +else + echo -n "Update Status: Fails " +endif +echo "" + +exit 0 diff --git a/unix/hlib/util.csh/mkarch b/unix/hlib/util.csh/mkarch new file mode 100755 index 00000000..ceec0db8 --- /dev/null +++ b/unix/hlib/util.csh/mkarch @@ -0,0 +1,58 @@ +#!/bin/csh -f +# +# MKARCH - Reset the platform architecture. Assumes source-only tree and +# that it's safe to just manually change links. + + +set aarch = `unix/hlib/irafarch.csh -actual` + +if (-e $iraf/unix/bin.$aarch/mkpkg.e) then + # Assume we've got a system with binaries and can use MKPKG. + set use_mkpkg = 1 +else + if ($?IRAFARCH && -e $iraf/unix/bin.$IRAFARCH/mkpkg.e) then + set use_mkpkg = 1 + else + # Change the links manually, but strip all binaries first. + set use_mkpkg = 0 + endif +endif + + +if ($#argv == 1) then + set arch = $1 + +loop_: + echo "Making architecture: "$arch + + if ($use_mkpkg == 1) then + mkpkg $arch + (chdir noao ; mkpkg -p noao $arch) + (chdir vo ; mkpkg -p vo $arch) + else + $iraf/util/mkclean + /bin/rm -rf bin noao/bin unix/bin unix/as vo/bin + + ln -s bin.$arch bin + (chdir vo ; ln -s bin.$arch bin) + (chdir noao ; ln -s bin.$arch bin) + (chdir unix ; ln -s bin.$arch bin) + (chdir unix ; ln -s as.$arch as) + endif + + if ("$arch" == "macintel" || "$arch" == "linux64") then + (chdir unix/hlib ; \ + rm -f iraf.h mach.h ; \ + ln -s iraf64.h iraf.h ; \ + ln -s mach64.h mach.h) + else + (chdir unix/hlib ; \ + rm -f iraf.h mach.h ; \ + ln -s iraf32.h iraf.h ; \ + ln -s mach32.h mach.h) + endif + +else + set arch = $aarch + goto loop_ +endif diff --git a/unix/hlib/util.csh/mkbindist b/unix/hlib/util.csh/mkbindist new file mode 100755 index 00000000..acf4a987 --- /dev/null +++ b/unix/hlib/util.csh/mkbindist @@ -0,0 +1,80 @@ +#!/bin/csh -f + +unset noclobber +onintr cleanup_ +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort which + +setenv path "(/sbin /usr/sbin /bin /usr/bin /usr/5bin /usr/ucb /etc /usr/etc $path /usr/local/bin /opt/local/bin /local/bin /home/local/bin /usr/openwin/bin /usr/X11R6/bin /usr/X11/bin)" + +# Utility aliases. +alias PUT "mv -f \!*; chown $user \!$ " # [MACHDEP] +alias BOLD_ON "(tput bold)" +alias BOLD_OFF "(tput sgr0)" +alias SO_ON "(tput smso)" +alias SO_OFF "(tput sgr0)" + +alias DO_OK "(echo -n '[ '; BOLD_ON; echo -n ' OK '; BOLD_OFF; echo ' ]')" +alias DO_WARN "(echo -n '[ '; BOLD_ON; echo -n 'WARN'; BOLD_OFF; echo ' ]')" +alias DO_FAIL "(echo -n '[ '; SO_ON; echo -n 'FAIL'; SO_OFF; echo ' ]')" + +alias ERRMSG "(echo -n ' ';BOLD_ON;echo -n 'ERROR: ' ;BOLD_OFF; echo \!*)" +alias WARNING "(echo -n ' ';BOLD_ON;echo -n 'WARNING: ';BOLD_OFF; echo \!*)" +alias NEWLINE "(echo '')" + + + +# set echo + +if (! $?iraf) then + echo "" + echo "Error: You must have the iraf env variable defined !" + echo "" + exit 1 +endif + +set exec = yes +set arch = `$iraf/unix/hlib/irafarch.csh -actual` + + +#============================================================================= +# Process any command line arguments. +#============================================================================= +while ("$1" != "") + switch ("$1") + case -n: # no execute + set exec = no + breaksw + default: + ERRMSG "$0: unknown argument $1" + breaksw + endsw + + if ("$2" == "") then + break + else + shift + endif +end + + + +#---------------------------------- +# Determine platform architecture. +#---------------------------------- + +set mach = `$iraf/unix/hlib/irafarch.csh -actual` +set hmach = `$iraf/unix/hlib/irafarch.csh -actual` + +echo "mach = " $mach +echo "hmach = " $hmach + +make generic + +echo -n "Making $arch binary distribution ...." + make generic + if ($exec == "yes") then + tar czf ../${arch}-bin.tar.gz bin.$arch */bin.$arch extern/*/bin.$arch + else + echo "tar czf ../${arch}-bin.tar.gz bin.$arch */bin.$arch extern/*/bin.$arch" + endif +echo " Done" diff --git a/unix/hlib/util.csh/mkclean b/unix/hlib/util.csh/mkclean new file mode 100755 index 00000000..6b7d3198 --- /dev/null +++ b/unix/hlib/util.csh/mkclean @@ -0,0 +1,121 @@ +#!/bin/csh -f +# +# MKCLEAN -- Make a pure source tree and configure the links for the +# current architecture. + + +unset noclobber +onintr cleanup_ +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort which + +setenv path "(/sbin /usr/sbin /bin /usr/bin /usr/5bin /usr/ucb /etc /usr/etc $path /usr/local/bin /opt/local/bin /local/bin /home/local/bin /usr/openwin/bin /usr/X11R6/bin /usr/X11/bin)" + +# Utility aliases. +alias PUT "mv -f \!*; chown $user \!$ " # [MACHDEP] +alias BOLD_ON "(tput bold)" +alias BOLD_OFF "(tput sgr0)" +alias SO_ON "(tput smso)" +alias SO_OFF "(tput sgr0)" + +alias DO_OK "(echo -n '[ '; BOLD_ON; echo -n ' OK '; BOLD_OFF; echo ' ]')" +alias DO_WARN "(echo -n '[ '; BOLD_ON; echo -n 'WARN'; BOLD_OFF; echo ' ]')" +alias DO_FAIL "(echo -n '[ '; SO_ON; echo -n 'FAIL'; SO_OFF; echo ' ]')" + +alias ERRMSG "(echo -n ' ';BOLD_ON;echo -n 'ERROR: ' ;BOLD_OFF; echo \!*)" +alias WARNING "(echo -n ' ';BOLD_ON;echo -n 'WARNING: ';BOLD_OFF; echo \!*)" +alias NEWLINE "(echo '')" + + + +# set echo + +if (! $?iraf) then + echo "" + echo "Error: You must have the iraf env variable defined !" + echo "" + exit 1 +endif + +set exec = yes +set arch = `$iraf/unix/hlib/irafarch.csh` + + +#============================================================================= +# Process any command line arguments. +#============================================================================= +while ("$1" != "") + switch ("$1") + case -n: # no execute + set exec = no + breaksw + default: + ERRMSG "$0: unknown argument $1" + breaksw + endsw + + if ("$2" == "") then + break + else + shift + endif +end + + + + + +#---------------------------------- +# Determine platform architecture. +#---------------------------------- + +set mach = `$iraf/unix/hlib/irafarch.csh -actual` +set hmach = `$iraf/unix/hlib/irafarch.csh -actual` + +echo "mach = " $mach +echo "hmach = " $hmach + +echo -n "Clean host directories ...." + if ($exec == "yes") then + /bin/rm -f unix/bin.$arch/[agm-z]*.e unix/bin.$arch/lib[bco]*.a >& /dev/null + else + /bin/ls -l unix/bin.$arch/[agm-z]*.e unix/bin.$arch/lib[bco]*.a + endif +echo " Done" + + + +echo -n "Clean src directories ...." +foreach i (local math pkg sys noao/[adfimnorst]*) + if ($exec == "yes") then + find $i -type f -name \*.a -exec /bin/rm -f {} \; >& /dev/null + find $i -type f -name \*.e -exec /bin/rm -f {} \; >& /dev/null + find $i -type f -name \*.o -exec /bin/rm -f {} \; >& /dev/null + else + find $i -type f -name \*.a -exec /bin/ls -l {} \; + find $i -type f -name \*.e -exec /bin/ls -l {} \; + find $i -type f -name \*.o -exec /bin/ls -l {} \; + endif +end +echo " Done" + + +echo -n "Clean '$arch' bin directories ...." +if ($exec == "yes") then + /bin/rm -rf bin.$arch/lib[a-z]*.a >& /dev/null + /bin/rm -rf bin.$arch/*.[eoZ] >& /dev/null + /bin/rm -rf noao/bin.$arch/*.[aeoZ] >& /dev/null +else + /bin/ls -l bin.$arch/lib[a-z]*.a >& /dev/null + /bin/ls -l bin.$arch/*.[aeoZ] >& /dev/null + /bin/ls -l noao/bin.$arch/*.[aeoZ] >& /dev/null +endif +echo " Done" + + +echo -n "Cleaning spool files ...." +if ($exec == "yes") then + find . -name spool\* -print -exec /bin/rm -f {} \; >& /dev/null +else + find . -name spool\* -print +endif +echo " Done" diff --git a/unix/hlib/util.csh/mkdist b/unix/hlib/util.csh/mkdist new file mode 100755 index 00000000..2f0711bc --- /dev/null +++ b/unix/hlib/util.csh/mkdist @@ -0,0 +1,25 @@ +#!/bin/csh -f + +foreach i (cygwin freebsd linux linux64 macintel macosx sunos) + touch bin.$i/IRAF.NET + touch noao/bin.$i/IRAF.NET +end + +touch bin.cygwin/IB.CYGW.x86 +touch bin.freebsd/IB.FBSD.x86 +touch bin.linux/IB.LNUX.x86 +touch bin.linux64/IB.LNUX.x86_64 +touch bin.macintel/IB.MACX.x86_64 +touch bin.macosx/IB.MACX.UNI +touch bin.sunos/IB.SSUN.x86 +touch bin.ipad/IB.IPAD.ARM + +touch noao/bin.cygwin/NB.CYGW.x86 +touch noao/bin.freebsd/NB.FBSD.x86 +touch noao/bin.linux/NB.LNUX.x86 +touch noao/bin.linux64/NB.LNUX.x86_64 +touch noao/bin.macintel/NB.MACX.x86_64 +touch noao/bin.macosx/NB.MACX.UNI +touch noao/bin.sunos/NB.SSUN.x86 +touch noao/bin.ipad/NB.IPAD.ARM + diff --git a/unix/hlib/util.csh/mkproto b/unix/hlib/util.csh/mkproto new file mode 100755 index 00000000..f0fe1dbf --- /dev/null +++ b/unix/hlib/util.csh/mkproto @@ -0,0 +1,114 @@ +#!/bin/csh -f +# +# MKPROTO -- Generate the VOS prototype definitions. + +unalias chdir ls egrep wc rm + + +set vos_dir = "sys" +#set math_dir = "math" +set math_dir = "" +set xtools_dir = "pkg/xtools" +set ds_dir = "pkg/images/tv/display pkg/images/tv/wcslab" + +#set vosdirs = "$vos_dir $math_dir $ds_dir" +set vosdirs = "$vos_dir $math_dir $xtools_dir $ds_dir" + +set curdir = `echo $cwd` +set tproto = /tmp/_vosproto.$$ + + +foreach d ($vosdirs) + + # Process each of the subdirectories. + # + foreach sd (`find $d -type d -print`) + + # Skip the IMFORT library and any documentation directories + if ($sd:t != "doc" && "`echo $sd | egrep -e imfort`" == "" && \ + "`echo $sd | egrep -e osb`" == "" && \ + "`echo $sd | egrep -e memdbg`" == "" && \ + "`echo $sd | egrep -e nspp`" == "") then + + chdir $sd # go to subdirectory + + set nf = `ls -1 | egrep -e "\.f" | wc -l` # nfiles to process + set nx = `ls -1 | egrep -e "\.x" | wc -l` # nfiles to process + + echo "Processing: "$nx" "$nf" "$sd + if ($nf > 0 || $nx > 0) then + + # Skip any files beginning with the letters 'zz', e.g. test + # files like zzdebug.x + + foreach f ( [a-z][a-y]*.[xf] ) + if ($f != 'intrp.f' && \ + $f != 'xtpmmap.x' && \ + $f != 'ytpmmap.x') then + xc -c -/P $f >& /dev/null # make prototype + else + echo " Skipping " $f + endif + end + + egrep -h ^extern *.P >> $tproto # save prototypes + /bin/rm -f *.[oP] >& /dev/null # clean up + endif + + chdir $curdir # back to top + + else + echo " Skipping " $sd + endif + end +end + +# Sort the prototype file, exclude certain symbols which are duplicates +# in the VOS but harmless because they occur in places that never conflict, +# e.g. the stdgraph and imd kernels. + +cat $tproto | \ + egrep -v arbpix_ | \ + egrep -v imdgeg_ | \ + egrep -v stxset_ | \ + egrep -v stxpas_ | \ + egrep -v dgt_ | \ + egrep -v sgt_ | \ + egrep -v asider_ | \ + egrep -v asifit_ | \ + egrep -v bndsol_ | \ + egrep -v ffa_ | \ + egrep -v ffs_ | \ + egrep -v fft842_ | \ + egrep -v avdrs_ | \ + egrep -v asigrl_ | \ + egrep -v smooth_ | \ + egrep -v sigl2 | \ + egrep -v sigm2 | \ + egrep -v impcom_ | \ + egrep -v intrp | \ + egrep -v srch | \ + egrep -v codim | \ + egrep -v mrsole | \ + egrep -v mreval | \ + egrep -v \ icg | \ + egrep -v iclisd | \ + egrep -v gscr | \ + egrep -v imdcom | \ + egrep -v getrot | \ + egrep -v gtplot | \ + egrep -v xev | \ + egrep -v ceps | \ + egrep -v sgt | \ + egrep -v sgt | \ + egrep -v U_fp | \ + sort >$iraf/unix/hlib/libc/vosproto.h + +# sigl2* and sigm2* removed because of multiple uses in apps +# impcom removed because imio$dbc/impcom.x conflicts with plot$t_implot.x +# use of 'impcom' as a common +# intrp* removed because it's use is xtools$ was commented out +# srch* removed because it's use is xtools$ was commented out +# mrsole/mreval removed because of duplicate use (splot$deblend.x and +# xtools$numrecipes) +# icguag removed duplicate use in noao$imred/dtoi diff --git a/unix/hlib/util.csh/mksrc b/unix/hlib/util.csh/mksrc new file mode 100755 index 00000000..648b8e7c --- /dev/null +++ b/unix/hlib/util.csh/mksrc @@ -0,0 +1,117 @@ +#!/bin/csh -f +# +# MKSRC -- Make a pure source tree and configure the links for the +# current architecture. + + +unset noclobber +onintr cleanup_ +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort which + +setenv path "(/sbin /usr/sbin /bin /usr/bin /usr/5bin /usr/ucb /etc /usr/etc $path /usr/local/bin /opt/local/bin /local/bin /home/local/bin /usr/openwin/bin /usr/X11R6/bin /usr/X11/bin)" + +# Utility aliases. +alias PUT "mv -f \!*; chown $user \!$ " # [MACHDEP] +alias BOLD_ON "(tput bold)" +alias BOLD_OFF "(tput sgr0)" +alias SO_ON "(tput smso)" +alias SO_OFF "(tput sgr0)" + +alias DO_OK "(echo -n '[ '; BOLD_ON; echo -n ' OK '; BOLD_OFF; echo ' ]')" +alias DO_WARN "(echo -n '[ '; BOLD_ON; echo -n 'WARN'; BOLD_OFF; echo ' ]')" +alias DO_FAIL "(echo -n '[ '; SO_ON; echo -n 'FAIL'; SO_OFF; echo ' ]')" + +alias ERRMSG "(echo -n ' ';BOLD_ON;echo -n 'ERROR: ' ;BOLD_OFF; echo \!*)" +alias WARNING "(echo -n ' ';BOLD_ON;echo -n 'WARNING: ';BOLD_OFF; echo \!*)" +alias NEWLINE "(echo '')" + + + +# set echo + + +if (! $?iraf) then + echo "" + echo "Error: You must have the iraf env variable defined !" + echo "" + exit 1 +endif + + +set exec = yes +set arch = `$iraf/unix/hlib/irafarch.csh` + + +#============================================================================= +# Process any command line arguments. +#============================================================================= +while ("$1" != "") + switch ("$1") + case -n: # no execute + set exec = no + breaksw + default: + ERRMSG "$0: unknown argument $1" + breaksw + endsw + + if ("$2" == "") then + break + else + shift + endif +end + + + + + +#---------------------------------- +# Determine platform architecture. +#---------------------------------- + +echo -n "Clean host directories ...." + if ($exec == "yes") then + /bin/rm -f unix/bin.*/[agm-z]*.e unix/bin.*/lib[bco]*.a >& /dev/null + else + /bin/ls -l unix/bin.*/[agm-z]*.e unix/bin.*/lib[bco]*.a + endif +echo " Done" + + + +echo -n "Clean src directories ...." +foreach i (local math pkg sys noao) + if ($exec == "yes") then + find $i -type f -name \*.a -exec /bin/rm -f {} \; >& /dev/null + find $i -type f -name \*.e -exec /bin/rm -f {} \; >& /dev/null + find $i -type f -name \*.o -exec /bin/rm -f {} \; >& /dev/null + find $i -type f -name OBJS\* -exec /bin/ls -l {} \; >& /dev/null + else + find $i -type f -name \*.a -exec /bin/ls -l {} \; + find $i -type f -name \*.e -exec /bin/ls -l {} \; + find $i -type f -name \*.o -exec /bin/ls -l {} \; + find $i -type f -name OBJS\* -exec /bin/ls -l {} \; + endif +end +echo " Done" + + +echo -n "Clean bin directories ...." +if ($exec == "yes") then + /bin/rm -rf bin.*/*.[aeoZ] noao/bin.*/*.[aeoZ] OBJS* >& /dev/null +else + /bin/ls -l bin.*/*.[aeoZ] noao/bin.*/*.[aeoZ] OBJS* +endif +echo " Done" + + +echo -n "Cleaning spool files ...." +if ($exec == "yes") then + find . -name spool\* -print -exec /bin/rm -f {} \; >& /dev/null + find . -name _spool\* -print -exec /bin/rm -f {} \; >& /dev/null +else + find . -name spool\* -print + find . -name _spool\* -print +endif +echo " Done" diff --git a/unix/hlib/util.csh/mksysgen b/unix/hlib/util.csh/mksysgen new file mode 100755 index 00000000..770bfd3c --- /dev/null +++ b/unix/hlib/util.csh/mksysgen @@ -0,0 +1,50 @@ +#!/bin/csh -f +# + +if (! $?iraf) then + #echo "" + #echo "Error: You must have the iraf env variable defined !" + #echo "" + #exit 1 + + set iraf = $cwd/ +endif + + +set c_start = `date` +/bin/rm -f spool */spool + + +$iraf/util/mkclean # clean old binaries + +cd $iraf/unix # NOVOS bootstrap +source hlib/irafuser.csh +sh -x mkpkg.sh |& tee -a spool + +cd $iraf/ # build NOVOS +mkpkg |& tee -a spool + +cd $iraf/unix # VOS bootstrap +source hlib/irafuser.csh +sh -x mkpkg.sh |& tee -a spool + +cd $iraf/vendor # build vendor libs +(make all |& tee -a ../spool.final) + +cd $iraf/ # build core system +mkpkg |& tee -a ../spool.final + +cd $iraf/noao # build NOAO package +setenv noao $cwd/ +mkpkg -p noao |& tee -a ../spool.final + +/bin/rm -rf bin*/pkgconfig # misc cleanup + +set c_end = `date` + + +echo "" +echo "" +echo "" +echo "Start: $c_start" +echo " End: $c_end" diff --git a/unix/hlib/util.csh/mkup b/unix/hlib/util.csh/mkup new file mode 100755 index 00000000..a55c4faf --- /dev/null +++ b/unix/hlib/util.csh/mkup @@ -0,0 +1,30 @@ +#!/bin/csh -f +# + +set iraf = $cwd/ +source $iraf/unix/hlib/irafuser.csh + +# Reconfigure the system for the proper architecture if needed. +if ($?IRAFARCH) then # use environment value + make $IRAFARCH +else # use actual value + set arch = `$iraf/unix/hlib/irafarch.csh -actual` + set cfgarch = `mkpkg arch` + if ($cfgarch[5] != $arch) then + #make $arch + setenv IRAFARCH $arch + endif +endif + +cd $iraf/ # build core system +mkpkg +mkpkg update + +cd $iraf/noao # build NOAO package +setenv noao $cwd/ +mkpkg -p noao + +cd $iraf/vo # build VO package +setenv vo $cwd/ +cd votools # build VOTOOLS package +mkpkg -p vo update diff --git a/unix/hlib/util.csh/mkupx b/unix/hlib/util.csh/mkupx new file mode 100755 index 00000000..85d73405 --- /dev/null +++ b/unix/hlib/util.csh/mkupx @@ -0,0 +1,15 @@ +#!/bin/csh -f +# + +set iraf = $cwd/ + +cd $iraf/ # build core system +mkpkg -x + +cd $iraf/noao # build NOAO package +setenv noao $cwd/ +mkpkg -x -p noao + +cd $iraf/vo # build VO package +setenv vo $cwd/ +mkpkg -x -p vo diff --git a/unix/hlib/util.csh/pkgclean b/unix/hlib/util.csh/pkgclean new file mode 100755 index 00000000..5dbf50cf --- /dev/null +++ b/unix/hlib/util.csh/pkgclean @@ -0,0 +1,89 @@ +#!/bin/csh -f +# +# PKGCLEAN -- Clean the named package, or all packages from the system. +# +# Usage: pkgclean [-all] [-dist] [-init] +# +# Where -all clean all packages +# package to be removed +# +# ---------------------------------------------------------------------------- + + +unset noclobber +unalias rm + +set all = no +set init = no + +# Process cmdline flags. +while ("$1" != "") + switch ("$1") + case -all: # clean all package sources + set all = yes + breaksw + case -init: # init all packages + set init = yes + breaksw + default: + set pkg = $1 + break + endsw + + shift +end + + +if ("$all" == "yes") then + if (-e ".repo_pkgs") then + foreach p (`cat .repo_pkgs`) + if (-e $p) then + /bin/rm -rf $p + mkdir $p + + echo "" > .installed + echo "" > .zzsetenv.def + endif + end + endif + +else if ("$init" == "yes") then + if (-e ".repo_pkgs") then + foreach p (`cat .repo_pkgs`) + if (-e $p) then + /bin/rm -rf $p + endif + end + endif + /bin/rm -rf Makefile >& /dev/null + /bin/rm -rf .installed >& /dev/null + /bin/rm -rf .repo* >& /dev/null + echo "" > .zzsetenv.def + +else + if (-e $pkg) then + /bin/rm -rf $pkg + mkdir $pkg + else + echo "Package '$pkg' is not currently installed" + exit 1 + endif +endif + + +# Normal exit. +exit 0 + + + +#============================================================================= +# Usage +#============================================================================= + +Usage: + echo "Usage: pkgclean [-all] [-dist] [-init] " + echo "" + echo " Where -all clean all packages" + echo " package to be removed" + +exit 0 diff --git a/unix/hlib/util.csh/pkgdel b/unix/hlib/util.csh/pkgdel new file mode 100755 index 00000000..fc8843d3 --- /dev/null +++ b/unix/hlib/util.csh/pkgdel @@ -0,0 +1,17 @@ +#!/bin/csh -f +# +# PKGDEL -- Delete an external package from the dynamic directory. +# +# + + +set bindir = "`dirname $0`" # get iraf root +set irafdir = $bindir:h + + + +if (-e $1) then + /bin/rm -rf $1 >& /dev/null +endif + +exit 0 diff --git a/unix/hlib/util.csh/pkgenv b/unix/hlib/util.csh/pkgenv new file mode 100755 index 00000000..9d4b9ada --- /dev/null +++ b/unix/hlib/util.csh/pkgenv @@ -0,0 +1,15 @@ +#!/bin/csh -f +# +# PKGENV -- Initialize the package environment + + +/bin/rm -f .installed .zzsetenv.def + +foreach p ( `cat .repo_pkgs` ) + + if (-e $p/.installed) then + cat $p/.installed >> .installed + echo "reset $p = $cwd/$p/" >> .zzsetenv.def + endif +end +echo "keep" >> .zzsetenv.def diff --git a/unix/hlib/util.csh/pkgget b/unix/hlib/util.csh/pkgget new file mode 100755 index 00000000..730485a3 --- /dev/null +++ b/unix/hlib/util.csh/pkgget @@ -0,0 +1,192 @@ +#!/bin/csh -f +# +# PKGGET -- Download the specified URL to the current directory. We use +# a command specific to the system we're on. We assume the URL has been +# properly escaped in the argument list. +# +# Usage: pkgget [-h] [-n] [-v] url +# +# Where -n no-op flag +# -v verbose output +# -h this message +# +# Example: +# % pkgget -q ftp://iraf.noao.edu/iraf/extern/foo-linux.tar.gz +# +# ---------------------------------------------------------------------------- + + +unset noclobber +onintr cleanup_ +unalias cd cp cmp echo ln mv rm sed set grep ls chmod chown pwd touch sort which +unalias ftp wget + +setenv path "(../util /sbin /usr/sbin /bin /usr/bin /usr/5bin /usr/ucb /etc /usr/etc $path /usr/local/bin /opt/local/bin /local/bin /home/local/bin)" + +# Utility aliases. +alias PUT "mv -f \!*; chown $user \!$ " # [MACHDEP] +alias BOLD_ON "(tput bold)" +alias BOLD_OFF "(tput sgr0)" +alias SO_ON "(tput smso)" +alias SO_OFF "(tput sgr0)" + +alias DO_OK "(echo -n '[ '; BOLD_ON; echo -n ' OK '; BOLD_OFF; echo ' ]')" +alias DO_WARN "(echo -n '[ '; BOLD_ON; echo -n 'WARN'; BOLD_OFF; echo ' ]')" +alias DO_FAIL "(echo -n '[ '; SO_ON; echo -n 'FAIL'; SO_OFF; echo ' ]')" + +alias ERRMSG "(echo -n ' ';BOLD_ON;echo -n 'ERROR: ' ;BOLD_OFF; echo \!*)" +alias WARNING "(echo -n ' ';BOLD_ON;echo -n 'WARNING: ';BOLD_OFF; echo \!*)" +alias NEWLINE "(echo '')" + + + +# set echo + + + +############################################################################## +# START OF MACHDEP DEFINITIONS. +############################################################################## + +# MACHDEP definitions which may be reset below. +set VERSION = `cat ../.version` + +# Utility aliases. + + +#---------------------------------- +# Determine platform architecture. +#---------------------------------- + +set UNAME="" +if (-e /usr/bin/uname) then + set uname_cmd = /usr/bin/uname + set UNAME=`/usr/bin/uname | tr '[A-Z]' '[a-z]'` +else if (-e /bin/uname) then + set uname_cmd = /bin/uname + set UNAME=`/bin/uname | tr '[A-Z]' '[a-z]'` +else + WARNING "No 'uname' command found to determine architecture." + exit 1 +endif + +switch ($UNAME) + case linux: + set dlcmd = "/usr/bin/wget" + breaksw + case darwin: # Mac OSX/iOS + case macosx: + case macintel: + case ipad: + #set dlcmd = "/usr/bin/ftp -A" + set dlcmd = "/usr/bin/ftp" + breaksw + + # Other architectures to be added here + + default: + ERRMSG "Unable to determine platform architecture." + exit 1 +endsw + +# If we don't have a download command installed, use our own ..... +if (! -e $dlcmd) then + set dlcmd = `dirname $0`/fget +endif + +############################################################################## +# END OF MACHDEP DEFINITIONS. +############################################################################## + +#============================================================================= +# Declarations and initializations. +#============================================================================= + +set exec = yes +set verb = no +set url = "" + + +# Process cmdline flags. +while ("$1" != "") + switch ("$1") + case -n: # no execute + set exec = no + breaksw + case -v: # be chatty + set verb = yes + set quiet = no + breaksw + case -h: # print help summary + goto Usage + default: + set url = $1 + break + endsw + + if ("$2" == "") then + break + else + shift + endif +end + + +# Error checks. +if ("$url" == "") then + if ("$verb" == "yes") then + echo "ERROR: URL not specified" + endif + exit 1 +endif + + +# Do it. +if ("$exec" == "yes") then + if ("$verb" == "yes") then + echo "Downloading "$url" ...." + endif + + if ("$verb" == "no") then + $dlcmd $url >& /dev/null + else + $dlcmd $url + endif + + if ("$verb" == "yes") then + echo "done" + endif +endif + + +# Verify we have the file. +if (! -e $url:t) then + if ("$verb" == "yes") then + echo "Error downloading file '"$url:t"'" + endif + exit 1 + +else + if ($#argv > 1) then + mv $url:t $2 + endif +endif + +# Normal exit. +exit 0 + + + +#============================================================================= +# Usage +#============================================================================= + +Usage: + echo "Usage: pkgget [-h] [-n] [-q | -v] url" + echo "" + echo " where -n # no execute" + echo " -q # suppress output" + echo " -v # verbose output" + echo " -h # this message" + +exit 0 diff --git a/unix/hlib/util.csh/pkginit b/unix/hlib/util.csh/pkginit new file mode 100755 index 00000000..b93eb61d --- /dev/null +++ b/unix/hlib/util.csh/pkginit @@ -0,0 +1,43 @@ +#!/bin/csh -f +# +# PKGINIT - Initialize the dynamic package directory by fetching the most +# recent repository definition files. + +unalias grep + +set bindir = "`dirname $0`" # get iraf root directory +set irafdir = $bindir:h + +set REPO = `${irafdir}/util/pkgrepo` # get repo url +set man = ".repo_manifest" +set arch = `${irafdir}/unix/hlib/irafarch.csh -actual` + + +$irafdir/util/pkgget ${REPO}/REPO.MANIFEST .repo_manifest +if ($status == 1) then + echo "Cannot download repository manifest file, quitting." + exit $status +endif + +$irafdir/util/pkgget ${REPO}/REPO.DESC .repo_desc +if ($status == 1) then + echo "Cannot download repository description file, quitting." + exit $status +endif + + +# Create a list of packages available for the current platform. We pull +# out the list from the repository manifest of all packages. If we have +# IRAFARCH defined, assumed we're interested in managing multiple +# architectures so don't filter by the current architecture. + +if ($?IRAFARCH) then + cat $man | egrep -v "^#" | awk '{printf("%s\n", $2)}' | uniq > .repo_pkgs + cat $man > .repo_local +else + cat $man | grep "${arch}\ " | awk '{printf("%s\n", $2)}' > .repo_pkgs + cat $man | grep "${arch}\ " > .repo_local +endif + + +exit 0 diff --git a/unix/hlib/util.csh/pkginst b/unix/hlib/util.csh/pkginst new file mode 100755 index 00000000..2111a607 --- /dev/null +++ b/unix/hlib/util.csh/pkginst @@ -0,0 +1,86 @@ +#!/bin/csh -f +# +# PKGINST - Install the named package. + +unalias grep sort uniq ls awk + +if ($#argv < 1) then + exit 0 +else + set pkg = $1 +endif + +set bindir = "`dirname $0`" # get iraf root directory +set irafdir = $bindir:h + +set REPO = `${irafdir}/util/pkgrepo` +if ($?IRAFARCH) then + set arch = $IRAFARCH +else + set arch = `${irafdir}/unix/hlib/irafarch.csh -actual` +endif + +echo "Setting architecture: '$arch' .... " + + +# Get any dependency package names. +set deps=`grep ^$pkg .repo_desc | awk '{printf("%s\n",$2)}' | sed -e 's/,/ /g'` +set pkg_dep = "" +foreach d ( $deps ) + if ("$d" != "none") then + echo "Adding dependency '$d' ...." + set pkg_dep = "$pkg_dep $d" + endif +end + +# Make a unique list of package, i.e. remove multiple instances of a package. +# [Note: Not used, the manifest should have this already. ] +set list = `echo $pkg_dep $pkg|awk 'BEGIN {RS=" |\n";}{print $1;}'|sort|uniq` + +# Process the requested package and any dependencies. +foreach ip ($pkg_dep $pkg) + + set pfile = `grep \ $ip\ .repo_manifest | grep ${arch}\ | head -1 | awk '{printf("%s\n",$4)}'` + + echo $pfile | grep src.tar.gz > /dev/null + if ($status == 0) then + set src_only = 1 + else + set src_only = 0 + endif + + # Remove an existing package file. + if (-e $pfile) then + /bin/rm -f $pfile + endif + + # Download the repo file and unpack it. + echo -n "Installing package '$ip' .... " + ${irafdir}/util/pkgget ${REPO}/$pfile + if ($status == 1) then + echo " [Error]" + exit $status + endif + + if (-e $pfile) then + + tar zxf $pfile + /bin/rm -f $pfile + echo `date +%s`" " ${ip}.${arch} > $ip/.installed.${arch} + echo `date +%s`" " $ip > $ip/.installed + + if ($src_only == 1) then + echo " [SOURCE ONLY]" + echo `date +%s`" " $ip > $ip/.src_only + else + echo " [OK]" + endif + else + echo " [Error]" + endif + + ${irafdir}/util/pkgenv -init + +end + +exit 0 diff --git a/unix/hlib/util.csh/pkgrepo b/unix/hlib/util.csh/pkgrepo new file mode 100755 index 00000000..f87cbe66 --- /dev/null +++ b/unix/hlib/util.csh/pkgrepo @@ -0,0 +1,13 @@ +#!/bin/csh -f +# +# PKGREPO - Get the repository base URI, either from the environment +# variable 'IRAF_REPO' or the default. + + +if ($?IRAF_REPO) then + echo $IRAF_REPO +else + echo "ftp://iraf.noao.edu/iraf/v216/REPO" +endif + +exit 0 diff --git a/unix/hlib/util.csh/pkgupdate b/unix/hlib/util.csh/pkgupdate new file mode 100755 index 00000000..7d93bcd7 --- /dev/null +++ b/unix/hlib/util.csh/pkgupdate @@ -0,0 +1,106 @@ +#!/bin/csh -f +# +# PKGUPDATE - Update the named packages + +unalias grep ls + +set pkg = "" +set all = no +set list_only = no + +if ($#argv < 1) then + exit 0 +else + # Process cmdline flags. + while ("$1" != "") + switch ("$1") + case -all: # clean all package sources + set all = yes + breaksw + case -list: # list packages needing updating + set list_only = yes + breaksw + default: + set pkg = $1 + break + endsw + + shift + end +endif + + +set bindir = "`dirname $0`" # get iraf root directory +set irafdir = $bindir:h + +set REPO = `${irafdir}/util/pkgrepo` +if ($?IRAFARCH) then + set arch = $IRAFARCH +else + set arch = `${irafdir}/unix/hlib/irafarch.csh -actual` +endif + +echo "Updating repository data ...." +../util/pkginit # init repository information + +# Check for a self-update. +if ("$pkg" == "-self") then + echo "Updating utility scripts ...." + /bin/rm -f /tmp/util.tgz + ../util/pkgget ${REPO}/util-universal.tar.gz /tmp/util.tgz + (chdir ../util ; tar zxf /tmp/util.tgz ; /bin/rm -f /tmp/util.tgz) + echo "Done" + exit 0 +endif + +# Check for a extern update. +if ("$pkg" == "-config") then + echo "Updating config script ...." + ../util/pkgget ${REPO}/config-universal configure + chmod 777 configure + echo "Done" + exit 0 +endif + + + +# Process the requested package and any dependencies. +foreach ip ( `cat .repo_pkgs` ) + + if (-e $ip/.installed) then + + set pd = `grep $ip $ip/.installed | awk '{printf("%s\n", $1)}'` + set rd = `grep $ip .repo_manifest | head -1 | awk '{printf("%s\n", $3)}'` + + set alist = `(chdir $ip; ls -1 .inst*.* | sed -e "s/\.installed\.//g")` + + if ($rd > $pd) then + + # Update each installed architecture automatically. + foreach a ( $alist ) + + if ("$list_only" == "yes") then + printf "Package %-12s for %-8s is out of date ....\n" $ip $a + else + if ("$all" == "yes" || "$ip" == "$pkg") then + echo "Updating package '$ip' for '$a' ...." + ../util/pkginst $ip + endif + endif + end + + else + if ("$list_only" == "yes" || $rd <= $pd) then + printf "Package %-12s is current ....\n" $ip + endif + endif + + else + printf "Package %-12s is not installed ....\n" $ip + endif + + ${irafdir}/util/pkgenv -init +end + +echo "Done" +exit 0 diff --git a/unix/hlib/util.csh/self_update b/unix/hlib/util.csh/self_update new file mode 100755 index 00000000..9ba35b43 --- /dev/null +++ b/unix/hlib/util.csh/self_update @@ -0,0 +1,37 @@ +#!/bin/csh -f +# +# SELF_UPDATE - Update the update scripts. + +unalias grep ls + +set iraf = $cwd/ +source $iraf/unix/hlib/irafuser.csh + +chdir $iraf/util + +set REPO = `${iraf}/util/pkgrepo` +if ($?IRAFARCH) then + set arch = $IRAFARCH +else + set arch = `${iraf}/unix/hlib/irafarch.csh -actual` +endif + + +echo -n "Updating utility scripts ...." + +# Delete any existing downloads. +if (-e /tmp/util.tgz) then + /bin/rm -f /tmp/util.tgz +endif + +# Get the latest script distribution. +./fget -o /tmp/util.tgz ${REPO}/util-universal.tar.gz + +# Go to iraf root, unpack and clean up. Using the IRAF root gives us +# the chance to update the toplevel Makefile or other build scripts in +# the system, e.g. in the 'vendor' directory. +(chdir ../ ; tar zxf /tmp/util.tgz ; /bin/rm -f /tmp/util.tgz ) + +echo "Done" + +exit 0 diff --git a/unix/hlib/util.sh b/unix/hlib/util.sh new file mode 100755 index 00000000..be8b7c85 --- /dev/null +++ b/unix/hlib/util.sh @@ -0,0 +1,115 @@ +#!/bin/sh +# +# UTIL.SH -- Utility support script for IRAF commands. +# +# ---------------------------------------------------------------------------- + + +############################################################################## +# Start of MACHDEP definitions. +############################################################################## + +# MACHDEP definitions which may be reset below. +LS() { + /bin/ls # [MACHDEP] +} ; export LS + + +export IRAF_VERSION="V2.16" +export V=`/bin/echo $IRAF_VERSION | cut -c2-5` + +export hilite=1 + + +############################################################################## +# Utility aliases. +############################################################################## + +ECHO() { + if [ "$1" == "-n" ]; then + /bin/echo -n "$2" + else + /bin/echo "$1" + fi +} ; export ECHO + +RM() { + rm -rf $1 +} ; export RM + +LN() { + ln -s $2 $1 +} ; export LN + +BOLD_ON() { + if [ $hilite ]; then tput bold; fi +} ; export BOLD_ON +BOLD_OFF() { + if [ $hilite ]; then tput sgr0; fi +} ; export BOLD_OFF +SO_ON() { + if [ $hilite ]; then tput smso; fi +} ; export SO_ON +SO_OFF() { + if [ $hilite ]; then tput sgr0; fi +} ; export SO_OFF + +DO_OK() { + ECHO -n "[ "; BOLD_ON; ECHO -n " OK "; BOLD_OFF; ECHO " ]" +} ; export DO_OK + +DO_WARN() { + ECHO -n "[ "; BOLD_ON; ECHO -n "WARN"; BOLD_OFF; ECHO " ]" +} ; export DO_WARN + +DO_FAIL() { + ECHO -n "[ "; SO_ON; ECHO -n "FAIL"; SO_OFF; ECHO " ]" +} ; export DO_FAIL + +NEWLINE() { + ECHO '' +} ; export NEWLINE + + + +PUT() { + cp -p $1 $2 +} ; export PUT + +PROMPT() { + BOLD_ON; ECHO -n $1; BOLD_OFF; ECHO -n " (yes): " +} ; export PROMPT + +PROMPT_N() { + BOLD_ON; ECHO -n $1; BOLD_OFF; ECHO -n " (no): " +} ; export PROMPT_N + +MSG() { + ECHO -n " "; BOLD_ON; ECHO -n "*** "; BOLD_OFF; ECHO $1 +} ; export MSG + +MSGB() { + ECHO -n " ";BOLD_ON;ECHO -n "*** ";ECHO $1; BOLD_OFF +} ; export MSGB + +MSGN() { + ECHO -n " ";BOLD_ON;ECHO -n "*** ";BOLD_OFF; ECHO -n $1 +} ; export MSGB + +MSGBN() { + ECHO -n " ";BOLD_ON;ECHO -n "*** ";ECHO -n $1; BOLD_OFF +} ; export MSGB + +ERRMSG() { + ECHO -n " ";BOLD_ON;ECHO -n "ERROR: " ;BOLD_OFF; ECHO $1 +} ; export ERRMSG + +WARNING() { + ECHO -n " "; + BOLD_ON; + ECHO -n "WARNING: "; + BOLD_OFF; + ECHO $1 +} ; export WARNING + + diff --git a/unix/hlib/utime b/unix/hlib/utime new file mode 100644 index 00000000..e69de29b diff --git a/unix/hlib/vocl.csh b/unix/hlib/vocl.csh new file mode 120000 index 00000000..bc54b0f4 --- /dev/null +++ b/unix/hlib/vocl.csh @@ -0,0 +1 @@ +cl.csh \ No newline at end of file diff --git a/unix/hlib/vocl.sh b/unix/hlib/vocl.sh new file mode 100755 index 00000000..2efae89d --- /dev/null +++ b/unix/hlib/vocl.sh @@ -0,0 +1,165 @@ +#!/bin/bash +# +# CL.SH -- Startup the version of the CL executable compiled for the +# architecture or floating point hardware appropriate for the current +# machine. This script can be used to invoke a number of CL flavors +# depending on how it is called. The install script will create a 'cl' +# and 'ecl' command link to this script with the intent that a different +# binary would be started for each command. + + +# Determine CL binary to run based on how we were called. + + +nm=${0##*/} +cl_binary="vocl.e" + +case "$nm" in + "cl" | "cl.sh") + cl_binary="cl.e" + ;; + "ecl" | "ecl.sh") + cl_binary="ecl.e" + ;; + "vocl" | "vocl.sh") + cl_binary="vocl.e" + ;; + *) + if (( $# > 1 )); then + if [ $1 == "-old" -o $1 == "-o" ]; then + cl_binary="cl.e" + elif [ $1 == "-ecl" -o $1 == "-e" ]; then + cl_binary="ecl.e" + elif [ $1 == "-vo" ]; then + cl_binary="vocl.e" + elif [ ${1##*.} == "c" ]; then + # Workaround for autoconf scripts attempting to use this + # command as a valid compiler option. On some systems (mostly + # Debian) a valid CC command can't be found and eventually + # the 'cl' (lisp) compiler is tried. It will always apparently + # have the conftest.c test file, so simply exit with a code to + # tell autoconf it won't work. + exit 1 + fi + fi +esac + +# Determine IRAF root directory (value set in install script). +d_iraf="/iraf/iraf/" +if [ -n $iraf ]; then + if [ ! -e $iraf ]; then + echo "Warning: iraf=$iraf does not exist (check .cshrc or .login)" + echo "Session will default to iraf=$d_iraf" + unset iraf ; sleep 3 + fi +fi +if [ -z $iraf ]; then + export iraf="$d_iraf" +fi + +# Check for a version query. +if [ $# > 1 ]; then + case "$1" in + "-v" | "-V" | "-version" | "--version") + head -1 $iraf/unix/hlib/motd + exit 0 + ;; + *) + ;; + esac +fi + + +# Determine platform architecture. +if [ -e $iraf/unix/hlib/irafarch.sh ]; then + ACTUAL_ARCH=`$iraf/unix/hlib/irafarch.sh -actual` +else + ACTUAL_ARCH=$IRAFARCH +fi + +if [ -n "$IRAFARCH" ]; then + if [ -e $iraf/bin.${IRAFARCH}/${cl_binary} ]; then + MACH=$IRAFARCH + else + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + if [ "$ACTUAL_ARCH" != "$IRAFARCH" ]; then + echo "ERROR: IRAFARCH set to '$IRAFARCH', should be '$ACTUAL_ARCH'" + fi + exit 1 + fi + export arch=".$MACH" + +else + os_mach=`uname -s | tr '[A-Z]' '[a-z]' | cut -c1-6` + + if [ -e $iraf/unix/hlib/irafarch.csh ]; then + MACH=`$iraf/unix/hlib/irafarch.csh` + else + MACH=$os_mach + fi + + if [ "$os_mach" == "linux" ]; then # handle linux systems + if [ `uname -m` == "x86_64" ]; then + export mach="linux64" + else + export mach="linux" + fi + elif [ "$os_mach" == "darwin" ]; then # handle Mac systems + if [ "`uname -m`" == "x86_64" ]; then + export mach="macintel" + else + export mach="macosx" + fi + elif [ "$os_mach" == "cygwin" ]; then + export mach="cygwin" + else + mach=`uname -s | tr '[A-Z]' '[a-z]'` + fi + + export arch=".$MACH" + if [ -z $IRAFARCH ]; then + export IRAFARCH="$MACH" + fi + + if [ ! -e $iraf/bin.${MACH}/${cl_binary} ]; then + echo "ERROR: No $iraf/bin.${IRAFARCH}/${cl_binary} binary found." + exit 1 + fi +fi + + +# Recent linux systems display a problem in how pointer addresses +# interact with the stack and can result in a segfault. Remove the +# stacksize limit for IRAF processes until this is better understood. +if [ "$IRAFARCH" == "redhat" -o \ + "$IRAFARCH" == "linux64" -o \ + "$IRAFARCH" == "linux" ]; then + ulimit -s unlimited +fi + + +# Just run the CL if IRAFARCH already defined. +if [ -n "$IRAFARCH" ]; then + if [ -z $IRAFARCH ]; then + export arch="" + else + export arch=".$IRAFARCH" + fi + + export IRAFBIN=${iraf}bin$arch/ + file=${IRAFBIN}$cl_binary + if [ -e $file ]; then + exec $file + else + echo "$file not found" + fi +fi + + +# Set the architecture to be used. +export IRAFARCH=$MACH +export arch=.$IRAFARCH +export IRAFBIN=${iraf}bin$arch/ + +# Run the desired CL. +exec ${IRAFBIN}$cl_binary diff --git a/unix/hlib/zzsetenv.def b/unix/hlib/zzsetenv.def new file mode 100644 index 00000000..881d9c7c --- /dev/null +++ b/unix/hlib/zzsetenv.def @@ -0,0 +1,119 @@ +# Global IRAF base environment list. + +set pkglibs = "hlib$libc/" + +# The following should be commented out or reset to "no" to enable world +# coordinate support (MWCS) in V2.9. Note however that the IRAF packages +# have not yet been modified to use MWCS, and enabling MWCS may cause these +# packages to misbehave. + +#set nomwcs = yes + +# The following can be used to en/disable the VO modifications in the system. +# The 'use_vo' variable can be used to globally disable features, finer +# grained controls might also be added. + +set use_vo = yes +set use_new_imt = yes +set vo_prefetch = yes +set vo_nthreads = 4 +set vo_runid = "iraf2161" + +set samp_auto = yes +set samp_onstart = no + + +# Default cache directory. +set cache = "tmp$cache/" +set cache_age = 30 + + +# Local system defaults. + +set clobber = no +set imclobber = no +set cmbuflen = 128000 +set editor = vi +set filewait = yes +set glbcolor = "pt=3,fr=9,al=3,tl=6,ax=5,tk=5" +set graphcap = dev$graphcap +set imtype = "fits" +set imextn = "oif:imh fxf:fits,fit,fts plf:pl qpf:qp stf:hhh,??h" +set min_lenuserarea = 64000 +set multversions = no +set printer = lp +set pspage = "letter" +set stdgraph = xgterm +set stdimage = imt512 +set stdimcur = stdimage +set stdplot = lp +set stdvdm = uparm$vdm +set tapecap = dev$tapecap +set termcap = dev$termcap +set terminal = xgterm +set ttybaud = 9600 +set ttyncols = 80 +set ttynlines = 40 +set version = "NOAO/IRAF V2.16.1" + +# System directories. + +set as = "host$as/" +set bin = "iraf$bin(arch)/" +set boot = "host$boot/" +set dev = "iraf$dev/" +set doc = "iraf$doc/" +set hlib = "host$hlib/" +set lib = "iraf$lib/" +set math = "iraf$math/" +set os = "host$os/" +set osb = "sys$osb/" +set pkg = "iraf$pkg/" +set sys = "iraf$sys/" + +set clio = "sys$clio/" +set dbio = "sys$dbio/" +set debug = "sys$debug/" +set etc = "sys$etc/" +set fio = "sys$fio/" +set flib = "sys$flib/" +set fmio = "sys$fmio/" +set fmtio = "sys$fmtio/" +set gio = "sys$gio/" +set gty = "sys$gty/" +set imfort = "sys$imfort/" +set imio = "sys$imio/" +set ki = "sys$ki/" +set libc = "sys$libc/" +set memio = "sys$memio/" +set mtio = "sys$mtio/" +set mwcs = "sys$mwcs/" +set plio = "sys$plio/" +set pmio = "sys$pmio/" +set psio = "sys$psio/" +set qpoe = "sys$qpoe/" +set tty = "sys$tty/" +set vops = "sys$vops/" + +# System package directories. + +set cl = "pkg$cl/" +set clpackage = "hlib$" +set dataio = "pkg$dataio/" +set dbms = "pkg$dbms/" +set images = "pkg$images/" +set language = "pkg$language/" +set lists = "pkg$lists/" +set obsolete = "pkg$obsolete/" +set plot = "pkg$plot/" +set proto = "pkg$proto/" +set softools = "pkg$softools/" +set system = "pkg$system/" +set utilities = "pkg$utilities/" +set xtools = "pkg$xtools/" + + +# Load definitions for any locally added external packages. + +set @hlib$extern.pkg +set @iraf$extern/.zzsetenv.def diff --git a/unix/mc68000/README b/unix/mc68000/README new file mode 100644 index 00000000..e23f067d --- /dev/null +++ b/unix/mc68000/README @@ -0,0 +1,71 @@ +MC68000/IRAF Installation Notes. +18 January 1986 (dct) +------------------------------------------- + +The 4.2BSD VAX version of UNIX/IRAF will run almost without change on a MC68000 +based workstation. In particular, the kernel should not have to be changed. +The changes which are required are due to machine differences, e.g., in the +assemblers and machine constants. The affected files are summarized below. +This documents only the source changes required for a MC68000, not the full +installation procedure required before the system can be compiled and run. + +host/as/*.s + All of the assembler sources are of course different for a VAX and + a 68000 based machine. The various UNIX assemblers for the MC68000 + UNIX implementations are also different, e.g., in the comment + convention, use of $ or # to denote a numeric constant, etc. + Despite the differences there are many similarities, and the + translation is usually not difficult. Note that only a couple of + assembler sources are required, although half a dozen or so should + eventually be implemented for efficiency reasons. + + To modify the AS directory for a MC68000, replace ZSVJMP.S, AMOV.S, + etc. with their MC68xxx versions, and remove all other VAX assembler + sources which you do not plan to implement (e.g., rename the original + AS directory as "vaxas"). Note that only the MC68020 has the bitfield + instructions needed for BITUPK.S and BITPAK.S. + +host/boot/* + No changes should be required. + +host/gdev/* + No changes should be required, unless new graphics devices have to be + interfaced. + +host/hlib/clpackage.cl + Change the default device names. + +host/hlib/mach.h +host/hlib/[dir]mach.f +host/hlib/libc/spp.h (EPSILON) + Change the machine constants to those for the MC68000. If the machine + has IEEE floating point, these constants are independent of the host + operating system (e.g., SUN or ISI). In only the machine + epsilon usually needs to be changed; the values for INDEF, MAX_LONG, + etc. the are the same for most modern minicomputers. + + The utility osb$zzeps.f may be used to determine the machine epsilon. + The values determined for a SUN/MC68010 with software floating point + were the following: + + EPSILONR (1.192e-7) + EPSILOND (2.220d-16) + + For a MC68xxx, the bytes are not swapped: + + BYTE_SWAP2 NO + BYTE_SWAP4 NO + + PORTLIB/[DIR]MACH.F contants: + + (to be determined) + +host/hlib/libc/iraf.h +host/hlib/mkiraf.csh +host/hlib/irafuser.csh + Change the pathnames in these files. + +When installing a new version of UNIX/IRAF it is usually best to install the +new UNIX directories as well, and then modify or replace the above files as +necessary for the 68000. All revisions are thus automatically picked up, and +the modifications required for the 68000 are minor. diff --git a/unix/mc68000/ishift.SUN b/unix/mc68000/ishift.SUN new file mode 100644 index 00000000..cfd6d7e9 --- /dev/null +++ b/unix/mc68000/ishift.SUN @@ -0,0 +1,44 @@ +|# IAND, IOR, ISHIFT -- Bitwise boolean integer functions for the NCAR +|# package. The shift function must rotate the bits left and around +|# if the nbits to shift argument is positive, and zero fill at the left +|# if the shift is negative (right shift). +|# +|# (SUN/UNIX MC68xxx version) + +|# AND -- Bitwise boolean AND: C = AND (A, B) + .text + .globl _iand_ +_iand_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + andl a0@,d0 + rts + + +|# OR -- Bitwise boolean OR: C = OR (A, B) + .text + .globl _ior_ +_ior_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + orl a0@,d0 + rts + + +|# ISHIFT -- Bitwise shift: C = ISHIFT (A, NBITS), +=left + .text + .globl _ishift_ +_ishift_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + movl a0@,d1 + blt L1 + roll d1,d0 |# left rotate (high bits come in at right) + rts +L1: + negl d1 + lsrl d1,d0 |# logical shift right (zero at left) + rts diff --git a/unix/mc68000/zsvjmp.FX b/unix/mc68000/zsvjmp.FX new file mode 100644 index 00000000..1f15102e --- /dev/null +++ b/unix/mc68000/zsvjmp.FX @@ -0,0 +1,49 @@ +|# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +|# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +|# the registers, effecting a call in the context of the procedure which +|# originally called ZSVJMP, but with the new status code. These are Fortran +|# callable procedures. +|# +|# (Alliant/UNIX MC68xxx version) + + .text + .globl _zsvjmp_ + .globl _zdojmp_ + + |# The following has nothing to do with ZSVJMP, and is included here + |# only because this assembler module is loaded with every process. + |# This code sets the value of the symbol MEM (the Mem common) to zero, + |# setting the origin for IRAF pointers to zero rather than some + |# arbitrary value, and ensuring that the MEM common is aligned for + |# all datatypes as well as page aligned. A further advantage is that + |# references to NULL pointers will cause a memory violation. + + .globl _mem_ + _mem_ = 0 + +_zsvjmp_: |# call zsvjmp (jmpbuf, status) + movl a0@(4), sp@- |# save pointer to status variable + movl a0@, sp@- |# save pointer to jmpbuf + + movl a0@, sp@- |# call alliant setcontext proc + movl sp, a0 + pea 1 + jsr _setcontext + addql #8, sp + + movl sp@+, a0 |# A0 = &jmpbuf + movl sp@+, a1 |# A1 = &status + + movl a1, a0@(2240) |# save &status in jmpbuf + clrl a1@ |# set status to zero + lea sp@(4), a1 + movl a1, a0@(68) + movl sp@, a0@(74) + rts + +_zdojmp_: + movl a0@, a1 |# A1 = &jmpbuf + movl a1@(2240), a2 |# A2 = &status + movl a0@(4), a3 |# pointer to status value + movl a3@, a2@ |# set status value + jsr _resetcontext diff --git a/unix/mc68000/zsvjmp.ISI b/unix/mc68000/zsvjmp.ISI new file mode 100644 index 00000000..0e7de609 --- /dev/null +++ b/unix/mc68000/zsvjmp.ISI @@ -0,0 +1,52 @@ +/* + * ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor + * registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores + * the registers, effecting a call in the context of the procedure which + * originally called ZSVJMP, but with the new status code. These are Fortran + * callable procedures. + * + * (ISI/UNIX version for the MC68000) + */ + + .text + .globl _zsvjmp_ + .globl _zdojmp_ + + /* The following has nothing to do with ZSVJMP, and is included here + * only because this assembler module is loaded with every process. + * This code sets the value of the symbol MEM (the Mem common) to zero, + * setting the origin for IRAF pointers to zero rather than some + * arbitrary value, and ensuring that the MEM common is aligned for + * all datatypes as well as page aligned. A further advantage is that + * references to NULL pointers will cause a memory violation. + */ + + .globl _mem_ + .set _mem_, 0 + + .set JMPBUF, 4 + .set STATUS, 8 + .set REGMASK, 0xfcfc /* D2-D7,A2-A5,A6,A7=sp */ + +_zsvjmp_: + movl sp@(JMPBUF),a0 /* set A0 to point to jmpbuf */ + movl sp@(STATUS),a1 /* A1 = status variable */ + movl a1,a0@ /* JB[1] = addr of status variable */ + clrl a1@ /* status = 0 */ + movl sp@+,a1 /* A1 = return address */ + movl a1,a0@(4) /* JB[3] = return address for longjmp */ + moveml #REGMASK,a0@(8) /* save register */ + jmp a1@ /* return from subroutine */ + +_zdojmp_: + movl sp@(STATUS),a0 + movl a0@,d0 /* D0 = status value */ + bne L1 /* branch if not equal to zero */ + moveq #1,d0 /* status must be nonzero */ +L1: + movl sp@(JMPBUF),a0 /* set A0 to point to jmpbuf */ + movl a0@,a1 /* get addr of zsvjmp status variable */ + movl d0,a1@ /* set the status value */ + moveml a0@(8),#REGMASK /* restore registers */ + movl a0@(4),a1 /* get return address of zsvjmp */ + jmp a1@ /* return from zsvjmp */ diff --git a/unix/mc68000/zsvjmp.SUN b/unix/mc68000/zsvjmp.SUN new file mode 100644 index 00000000..4789d053 --- /dev/null +++ b/unix/mc68000/zsvjmp.SUN @@ -0,0 +1,49 @@ +|# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +|# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +|# the registers, effecting a call in the context of the procedure which +|# originally called ZSVJMP, but with the new status code. These are Fortran +|# callable procedures. +|# +|# (SUN/UNIX MC68xxx version) + + .text + .globl _zsvjmp_ + .globl _zdojmp_ + + |# The following has nothing to do with ZSVJMP, and is included here + |# only because this assembler module is loaded with every process. + |# This code sets the value of the symbol MEM (the Mem common) to zero, + |# setting the origin for IRAF pointers to zero rather than some + |# arbitrary value, and ensuring that the MEM common is aligned for + |# all datatypes as well as page aligned. A further advantage is that + |# references to NULL pointers will cause a memory violation. + + .globl _mem_ + _mem_ = 0 + + JMPBUF = 4 + STATUS = 8 + REGMASK = 0xfcfc |# D2-D7,A2-A5,A6,A7=sp + +_zsvjmp_: + movl sp@(JMPBUF),a0 |# set A0 to point to jmpbuf + movl sp@(STATUS),a1 |# A1 = status variable + movl a1,a0@ |# JB[1] = addr of status variable + clrl a1@ |# status = 0 + movl sp@+,a1 |# A1 = return address + movl a1,a0@(4) |# JB[2] = return address for longjmp + moveml #REGMASK,a0@(8) |# save register + jmp a1@ |# return from subroutine + +_zdojmp_: + movl sp@(STATUS),a0 + movl a0@,d0 |# D0 = status value + bne L1 |# branch if not equal to zero + moveq #1,d0 |# status must be nonzero +L1: + movl sp@(JMPBUF),a0 |# set A0 to point to jmpbuf + movl a0@,a1 |# get addr of zsvjmp status variable + movl d0,a1@ |# set the status value + moveml a0@(8),#REGMASK |# restore registers + movl a0@(4),a1 |# get return address of zsvjmp + jmp a1@ |# return from zsvjmp diff --git a/unix/mkpkg b/unix/mkpkg new file mode 100644 index 00000000..66b91f85 --- /dev/null +++ b/unix/mkpkg @@ -0,0 +1,17 @@ +# UNIX/IRAF HSI. + +summary: + $ifeq (HOSTID, unix) + $ifeq (MACH, dsux) + ! grep -v ':$$' spool | grep -v '^xc' | grep -v '^ar'\ + | grep -v '^check file' | grep -v 'never used$' + $else + ! grep -v ':$$' spool | grep -v '^xc' | grep -v '^ar'\ + | grep -v '^check file' | grep -v '^a - '\ + | grep -v '^+ [g]*cc' | grep -v '^+ ar ' | grep -v '^+ rm'\ + | grep -v '^+ f77' + $endif + $else + $echo "mkpkg summary only available on a UNIX system" + $endif + ; diff --git a/unix/mkpkg.sh b/unix/mkpkg.sh new file mode 100644 index 00000000..bf3a5476 --- /dev/null +++ b/unix/mkpkg.sh @@ -0,0 +1,27 @@ +# Bootstrap the UNIX bootstrap utilities and host system interface. +# Note - the environment variables HSI_CF and HSI_FF (compile/link flags) +# are required for the bootstrap; these are defined in hlib$irafuser.csh. +# +# USAGE: `sh -x mkpkg.sh >& spool' to bootstrap the IRAF HSI. + +# Set the HSI architecture. +sh -x setarch.sh + +echo "----------------------- OS -----------------------------" +echo "+"; echo "+" +(cd os; sh -x mkpkg.sh) +echo "----------------------- F2C ----------------------------" +echo "+"; echo "+" +(cd f2c; sh -x mkpkg.sh) +echo "----------------------- BOOT ---------------------------" +echo "+"; echo "+" +(cd boot; sh -x mkpkg.sh) +#echo "----------------------- SHLIB --------------------------" +#echo "+"; echo "+" +#(cd shlib; sh -x mkpkg.sh) +echo "----------------------- GDEV ---------------------------" +(cd gdev; sh -x mkpkg.sh) + +# Install the newly created executables. +echo "install HSI executables in $host/bin.$MACH" +mv -f hlib/*.e bin.$MACH diff --git a/unix/os/README b/unix/os/README new file mode 100644 index 00000000..b097ed92 --- /dev/null +++ b/unix/os/README @@ -0,0 +1,7 @@ +4.2BSD UNIX IRAF Kernel. + + This directory contains the machine dependent routines comprising the IRAF +system interface to UNIX 4.2BSD. Some additional potentially machine dependent +routines (the bit and byte primitives) are in sys$osb. Documentation is in +the System Interface Reference manual doc$Os.ms and the manual pages for the +individual routines are in the subdirectory ./doc. diff --git a/unix/os/alloc.c b/unix/os/alloc.c new file mode 100644 index 00000000..d73c3e9c --- /dev/null +++ b/unix/os/alloc.c @@ -0,0 +1,273 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define import_spp +#define import_alloc +#define import_knames +#include + +/* + * ALLOC -- Unix task to allocate and deallocate devices given their generic + * name. These names are associated with special files in the ALLOCFILE file. + * Allocation is accomplished by setting the device file owner and permissions + * for the /dev entries associated with a particular logical device. + * Although we are called by the IRAF kernel, we are implemented as a task + * rather than as a function since super user permission is required to modify + * directory entries in /dev. + * + * usage: + * $hbin/alloc.e -a aliases allocate device + * $hbin/alloc.e -d aliases deallocate device + * $hbin/alloc.e -s aliases get allocation status + * + * Here, "aliases" are the names of all entries in /dev for the physical device, + * e.g., "mt8", "rmt8", "nrmt8", etc. For security reasons, only device + * files in /dev can be allocated, and the user must already have RW perm + * on the device file. Allocating the file simply changes the file + * ownership to the uid of the caller, and removes access permissions for + * group and world. + * + * NOTE: THIS TASK MUST BE INSTALLED IN HLIB WITH OWNER=ROOT AND + * "set uid on execution" PERMISSION (see mkpkg). + */ + +#define NSFILES 30 /* max number spec files assoc w/dev */ +#define RWOWN 0600 /* -rw------ */ +#define RWALL 0666 /* -rw-rw-rw */ + +struct file { /* special files for "device" */ + char f_name[SZ_FNAME]; /* file name */ + struct stat f_sbuf; /* stat buffer */ +} sfiles[NSFILES]; + +int debug=0; +int nsfiles; /* number of special files */ +int mode; /* 07 mode, ie, 04, 02, or 06 */ + + +/* System prototypes. +*/ +int findsfs (char *argv[]); +int dealloc (char *argv[]); +int alloc (char *argv[], int statonly); + +extern int uid_executing (int uid); + + + +int main (int argc, char *argv[]) +{ + int iexit = DV_ERROR; + + if (geteuid()) { + fprintf (stderr, + "Error: uid of $hbin/alloc.e must be set to 0 (root)\n"); + fprintf (stderr, "(rerun install script $hlib/install, or)\n"); + fprintf (stderr, "(login as root: cd $hbin; chown 0 alloc.e)\n"); + exit (DV_ERROR); + } else if (argc < 3) { + fprintf (stderr, "alloc.e called with invalid argument list\n"); + exit (DV_ERROR); + } + + if (strcmp (argv[1], "-a") == 0) + iexit = alloc (&argv[2], 0); + else if (strcmp (argv[1], "-s") == 0) + iexit = alloc (&argv[2], 1); + else + iexit = dealloc (&argv[2]); + + exit (iexit); +} + + +/* ALLOC -- Allocate device with given generic name if its owner is not + * logged in. + */ +int +alloc ( + char *argv[], + int statonly /* if set, just return device status */ +) +{ + register int ruid, mode, i; + register struct file *fp; + struct passwd *getpwuid(); + int rgid; + + if (findsfs (argv) == 0) + return (DV_ERROR); + + if (debug) + printf ("allocate %d files\n", nsfiles); + + for (i=0; i < nsfiles; i++) { + fp = &sfiles[i]; + ruid = fp->f_sbuf.st_uid; + mode = fp->f_sbuf.st_mode; + + /* We don't really care if the uid when the device is not + * allocated is root, bin, or whatever, so long at it is some + * system uid. + */ + if (ruid < 10) + ruid = 0; + + if (ruid == 0 && (mode & 06) != 06) { + if (!statonly) + printf ("rw access to %s is denied\n", fp->f_name); + return (DV_DEVINUSE); + } else if (ruid && uid_executing(ruid)) { + if (ruid != getuid()) { + if (!statonly) + printf ("%s already allocated to %s\n", + fp->f_name, (getpwuid(ruid))->pw_name); + return (DV_DEVINUSE); + } else + return (statonly ? DV_DEVALLOC : XOK); + } + } + + if (statonly) + return (DV_DEVFREE); + + ruid = getuid(); + rgid = getgid(); + + for (i=0; i < nsfiles; i++) { + fp = &sfiles[i]; + if (debug) + printf ("alloc file `%s'\n", fp->f_name); + if (chmod (fp->f_name, RWOWN) == -1) + printf ("cannot chmod `%s'\n", fp->f_name); + if (chown (fp->f_name, ruid, rgid) == -1) + printf ("cannot chown `%s'\n", fp->f_name); + } + + return (XOK); +} + + +/* DEALLOC -- Deallocate device with given generic name if real uid owns all + * sfiles. + */ +int +dealloc (char *argv[]) +{ + register int uid, ruid, i; + register struct file *fp; + + if (findsfs (argv) == 0) + return (DV_ERROR); + + if (debug) + printf ("deallocate %d files\n", nsfiles); + + ruid = getuid(); + if (ruid) + for (i=0; i < nsfiles; i++) { + fp = &sfiles[i]; + uid = fp->f_sbuf.st_uid; + if (uid && uid != ruid) + return (DV_ERROR); + } + + for (i=0; i < nsfiles; i++) { + fp = &sfiles[i]; + if (fp->f_sbuf.st_uid == 0) + continue; + if (debug) + printf ("dealloc file `%s'\n", fp->f_name); + if (chmod (fp->f_name, RWALL) == -1) + printf ("cannot chmod `%s'\n", fp->f_name); + if (chown (fp->f_name, 0, 0) == -1) + printf ("cannot chown `%s'\n", fp->f_name); + } + + return (XOK); +} + + +/* FINDSFS -- Fill in sfiles table with special file names associated with + * device with given generic name. + */ +int +findsfs (char *argv[]) +{ + register struct file *fp; + register char *argp, *ip; + char *fname; + + for (nsfiles=0; (argp = argv[nsfiles]); nsfiles++) { + fp = &sfiles[nsfiles]; + for (ip=fname=argp; *ip; ip++) + if (!isalnum (*ip)) + fname = ip + 1; + if (*fname == '\0') { + printf ("alloc: cannot fstat %s\n", fname); + continue; + } + + sprintf (fp->f_name, "/dev/%s", fname); + if (stat (fp->f_name, &fp->f_sbuf) == -1) { + sprintf (fp->f_name, "/dev/rmt/%s", fname); + if (stat (fp->f_name, &fp->f_sbuf) == -1) { + printf ("alloc: cannot fstat %s\n", fp->f_name); + continue; + } + } + } + + return (nsfiles); +} + + +#ifdef DEFUNCT +/* This is no longer used since we now read the process table instead. */ +/* LOGGEDIN -- Return 1 if uid is logged in, else 0. + */ +int +loggedin (int uid) +{ + register int i; + static int uidcache[10]; + static int nuid = 0; + struct utmpx ubuf; + struct passwd *pw, *getpwuid(); + FILE *ufp; + + for (i=0; i < nuid; i++) + if (uid == uidcache[i]) + return (1); + + if ((ufp = fopen ("/var/run/utmp", "r")) == NULL) { + printf ("cannot open utmp file\n"); + exit (DV_ERROR); + } + + if ((pw = getpwuid (uid)) == NULL) { + printf ("uid %d not in passwd file\n", uid); + exit (DV_ERROR); + } + + do { + if (fread (&ubuf, sizeof (struct utmpx), 1, ufp) == NULL) + return (0); + } while (strncmp (ubuf.ut_user, pw->pw_name, 8) != 0); + + if (nuid < 10) + uidcache[nuid++] = uid; + + return (1); +} +#endif diff --git a/unix/os/dio.c b/unix/os/dio.c new file mode 100644 index 00000000..3da16505 --- /dev/null +++ b/unix/os/dio.c @@ -0,0 +1,9 @@ +/* + * DIO.C -- Stubbed out version of directio for compatibility on systems + * that don't provide this routine in libc.a (e.g., Solaris 5.5). + */ +int +directio (int fd, int advice) +{ + return (-1); +} diff --git a/unix/os/doc/Mach.notes b/unix/os/doc/Mach.notes new file mode 100644 index 00000000..57b433e4 --- /dev/null +++ b/unix/os/doc/Mach.notes @@ -0,0 +1,32 @@ + +MAX_DIGITS +SZ_FNAME +SZ_LINE +SZ_PATHNAME +SZ_USHORT +SZ_type +INDEFt + +twos_complement +byte_swap2 +byte_swap4 +nbits_byte +sz_vmpage +szb_addr +szb_char + +nbits_int +szb_int +base_int +nbase_int +max_int +min_int + +base_real +nbase_real +ndigits_real +minexp_real +maxexp_real +largest_real +smallest_real +epsilon_real diff --git a/unix/os/doc/os.hd b/unix/os/doc/os.hd new file mode 100644 index 00000000..2a4d7c01 --- /dev/null +++ b/unix/os/doc/os.hd @@ -0,0 +1,71 @@ +# Helpdir for the OS package. + +$os = "host$os/" +$doc = "host$os/doc/" + +zawset hlp = doc$zawset.hlp, src = os$zawset.c +zcall hlp = doc$zcall.hlp, src = os$zcall.c +zclcpr hlp = doc$zclcpr.hlp, src = os$zfiopr.c +zcldir hlp = doc$zcldir.hlp, src = os$zgfdir.c +zcldpr hlp = doc$zcldpr.hlp, src = os$zfiopr.c +zdojmp hlp = doc$zsvjmp.hlp, src = os$zsvjmp.c +zfacss hlp = doc$zfacss.hlp, src = os$zfacss.c +zfaloc hlp = doc$zfaloc.hlp, src = os$zfaloc.c +zfchdr hlp = doc$zfchdr.hlp, src = os$zfchdr.c +zfdele hlp = doc$zfdele.hlp, src = os$zfdele.c +zfgcwd hlp = doc$zfgcwd.hlp, src = os$zfgcwd.c +zfinfo hlp = doc$zfinfo.hlp, src = os$zfinfo.c +zfmkcp hlp = doc$zfmkcp.hlp, src = os$zfmkcp.c +zfpath hlp = doc$zfpath.hlp, src = os$zfpath.x +zfprot hlp = doc$zfprot.hlp, src = os$zfprot.c +zfrnam hlp = doc$zfrnam.hlp, src = os$zfrnam.c +zfsubd hlp = doc$zfsubd.hlp, src = os$zfsubd.x +zfxdir hlp = doc$zfxdir.hlp, src = os$zfxdir.x +zgfdir hlp = doc$zgfdir.hlp, src = os$zgfdir.c +zgtime hlp = doc$zgtime.hlp, src = os$zgtime.c +zgtpid hlp = doc$zgtpid.hlp, src = os$zgtpid.c +zintpr hlp = doc$zintpr.hlp, src = os$zintpr.c +zlocpr hlp = doc$zlocpr.hlp, src = os$zlocpr.c +zlocva hlp = doc$zlocva.hlp, src = os$zlocva.c +zmain hlp = doc$zmain.hlp, src = os$zmain.c +zmaloc hlp = doc$zmaloc.hlp, src = os$zmaloc.c +zmfree hlp = doc$zmfree.hlp, src = os$zmfree.c +zopcpr hlp = doc$zopcpr.hlp, src = os$zfiopr.c +zopdir hlp = doc$zopdir.hlp, src = os$zopdir.c +zopdpr hlp = doc$zopdpr.hlp, src = os$zfiopr.c +zoscmd hlp = doc$zoscmd.hlp, src = os$zoscmd.c +zpanic hlp = doc$zpanic.hlp, src = os$zpanic.c +zraloc hlp = doc$zraloc.hlp, src = os$zraloc.c +zsvjmp hlp = doc$zsvjmp.hlp, src = os$zsvjmp.c +ztslee hlp = doc$ztslee.hlp, src = os$ztslee.c +zxgmes hlp = doc$zxgmes.hlp, src = os$zxgmes.c +zxwhen hlp = doc$zxwhen.hlp, src = os$zxwhen.c + +zfiobf hlp = doc$zfiobf.hlp, src = os$zfiobf.c +zfiotx hlp = doc$zfiotx.hlp, src = os$zfiotx.c +zfioty hlp = doc$zfioty.hlp, src = os$zfioty.c +zfiolp hlp = doc$zfiolp.hlp, src = os$zfiolp.c +zfiopr hlp = doc$zfiopr.hlp, src = os$zfiopr.c +zfiosf hlp = doc$zfiosf.hlp, src = os$zfiosf.c +zfiomt hlp = doc$zfiomt.hlp, src = os$zfiomt.c + +zopntx hlp = doc$zopntx.hlp, src = os$zfiotx.c +zclstx hlp = doc$zclstx.hlp, src = os$zfiotx.c +zgettx hlp = doc$zgettx.hlp, src = os$zfiotx.c +zputtx hlp = doc$zputtx.hlp, src = os$zfiotx.c +zflstx hlp = doc$zflstx.hlp, src = os$zfiotx.c +zsektx hlp = doc$zsektx.hlp, src = os$zfiotx.c +znottx hlp = doc$znottx.hlp, src = os$zfiotx.c +zstttx hlp = doc$zstttx.hlp, src = os$zfiotx.c +zopnbf hlp = doc$zopnbf.hlp, src = os$zfiobf.c +zclsbf hlp = doc$zclsbf.hlp, src = os$zfiobf.c +zardbf hlp = doc$zardbf.hlp, src = os$zfiobf.c +zawrbf hlp = doc$zawrbf.hlp, src = os$zfiobf.c +zawtbf hlp = doc$zawtbf.hlp, src = os$zfiobf.c +zsttbf hlp = doc$zsttbf.hlp, src = os$zfiobf.c +zzopmt hlp = doc$zzopmt.hlp, src = os$zfiomt.c +zzclmt hlp = doc$zzclmt.hlp, src = os$zfiomt.c +zzrdmt hlp = doc$zzrdmt.hlp, src = os$zfiomt.c +zzwrmt hlp = doc$zzwrmt.hlp, src = os$zfiomt.c +zzwtmt hlp = doc$zzwtmt.hlp, src = os$zfiomt.c +zzrwmt hlp = doc$zzrwmt.hlp, src = os$zfiomt.c diff --git a/unix/os/doc/os.ms b/unix/os/doc/os.ms new file mode 100644 index 00000000..61aa14fe --- /dev/null +++ b/unix/os/doc/os.ms @@ -0,0 +1,4249 @@ +.RP +.ND +.TL +A Reference Manual +.br +for the +.br +IRAF System Interface +.AU +Doug Tody +.AI +.K2 "" "" "*" +May 1984 +.AB +The IRAF system interface is the interface between the transportable IRAF +system and the host operating system. An overview of the software design +of the IRAF system is presented, naming the major interfaces and +discussing their relationships. The system interface is shown to consist +of a language interface, the subset preprocessor (SPP), and a procedural +interface, the IRAF kernel. The reasoning which led to the choice of +a Fortran preprocessor for the language interface is reviewed. A reference +manual for the IRAF kernel is presented, followed by the detailed technical +specifications for the kernel procedures. +.AE + +.NH +Introduction +.PP +The IRAF system libraries currently total 42 thousand lines of code. +The applications software adds another 75 thousand lines +of code, about half of which was imported (i.e., the graphics utilities and +math library routines). The UNIX implementation of the machine dependent +portion of the IRAF system consists of some 3300 lines of code, or about +3 percent of the current system. The remainder of the system, i.e., +approximately 97 percent of the current system, is machine and device +independent. It is this 3 percent of the IRAF system which is machine +dependent, known as the \fBsystem interface\fR, which is the focus of this +document. +.PP +The importance of maximizing the transportability of a large software system +cannot be overemphasized. The IRAF system is required to run on +a variety of different computers and operating systems from the time of +its first release to the end of its useful life. The computer the IRAF +system is being developed on is already old technology. Two years from +now when IRAF is a mature system, it will almost certainly contain 20 to +30 manyears of software. With the increasing dependence on computers for +scientific data analysis, and the demand for increasingly powerful software, +it is no longer possible to keep up with demand if we have to throw out +our systems every 5 or 10 years and start over. +.PP +Commercially developed operating systems/programming environments such as +UNIX and ADA offer some hope for the future. At present, however, ADA is +not widely available and there are at least half a dozen versions of UNIX +in use, with no clear cut standard yet to emerge. The different versions +of UNIX resemble each other, but there are many differences. UNIX has been +steadily evolving for ten years and there is no reason to expect that the +process will stop now. +.PP +Many manufacturers offer machine dependent extensions to get around the +inefficiencies of basic UNIX, and it is desirable to be able to take advantage +of these in a production system. Even in a hardcore UNIX system like 4.2BSD, +significant efficiency gains are possible by taking advantage of the +peculiarities of the 4.2BSD kernel, e.g., by always doing file transfers +in units of the machine page size, into buffers aligned on page boundaries. +In a large system it is difficult to take advantage of such machine +peculiarities unless the system has a well defined and well isolated interface +to the host system. There is no denying the fact that despite the many +attractive aspects of UNIX, it is nice to have the option of switching to +a more efficient operating system if IRAF is to be used in a production +environment. +.PP +Perhaps the most powerful argument is that despite the increasingly widespread +use of UNIX, many of the sites for which IRAF is targeted do not or can not +run UNIX on their current computers. The increasing availability of +transportable operating systems will make transporting IRAF easier, but is no +substitute for a well defined and well isolated system interface. +.PP +The \fBsystem interface\fR is the interface between the machine independent +IRAF software and the host operating system. +The system interface consists of a procedural interface, the IRAF +\fBkernel\fR, and a language interface, the IRAF Subset Preprocessor +language (SPP). Both types of interface are required to isolate the +IRAF software from the host system. +.PP +We first present an overview of the structure of the IRAF system, naming the +major interfaces and explaining their functions. The system interface is +introduced and the role it plays in the full system is described. +The choice of an implementation language for IRAF is next discussed, +concentrating on the role the language interface plays in addressing the +transportability problem. Next we define the kernel and discuss its attributes. +The conceptual model of the host operating system, or \fBvirtual machine +model\fR assumed by IRAF is presented. The design and functioning of the +kernel is discussed in detail, followed by the detailed specifications +(\fBmanual pages\fR) for the subroutines constituting the actual interface. +.PP +It is not necessary to carefully read the first part of this document +to implement the IRAF system interface for a new host operating system. +The first part of this document (the \fBreference manual\fR) concentrates on +the role the system interface plays in IRAF, the principles underlying +the design of the interface, and on how and why the interface came to be +what it is. The second part of the document (the \fBmanual pages\fR) +presents the detailed specifications for the individual routines comprising +the system interface, and is intended to be self contained. The reference +manual tells what modules the interface consists of, how they work together, +and why they are designed the way they are. The manual pages tell +precisely \fIwhat\fR each routine does, with no attempt to explain why, +or how the routine fits into the system. +.PP +Interfacing to new \fBgraphics devices\fR is likely to be one of the most +difficult problems to be solved in porting the IRAF system. Nonetheless +the graphics device interface is not (or should not be) part of the system +interface, and is not discussed here. Ideally, a graphics device will be +interfaced to IRAF file i/o as a binary file. The device should +have a data driven interface, rather than a control interface, i.e., +all device control should be effected by inserting control instructions in +the data stream transmitted to the device, rather than by calling system +dependent subroutines. The software required to drive the device should +be device independent, table driven, and fully portable. Virtually all +graphics devices either fit this model, or can be made to fit this model +by writing system dependent device drivers to interpret metacode generated +by the high level, machine and device independent software. + +.NH +Structure of the IRAF System Software +.PP +The major components of the IRAF system are +the high level applications and systems \fBprograms\fR and \fBpackages\fR, +the Command Language (CL), also known as the \fBuser interface\fR, +the \fBprogram interface\fR (library procedures called by programs), +and the \fBsystem interface\fR. The system interface is further subdivided +into the \fBkernel\fR and the \fBlanguage interface\fR. +Other system modules not relevant to our discussion are the math library +and the graphics device interfaces. +.PP +The relationship and relative importance of these modules is strongly +dependent upon one's point of view; all points of view are equally valid. +From the point of view of the (highly idealized) user, looking at the +system from the top level, the user is at the center of the system and +is in command. The CL appears to be the central piece of software, and +applications packages are mere extensions of the CL. To the extent that the +user is aware of the host system, the CL appears to be the interface +between the user and the host system. The user expects the system to behave +predictably and reliably, and be responsive to their commands. +To a first approximation, the user does not care what language programs +are written in, or how they are interfaced to the host system (real users, +of course, are often programmers too, and do care). +.PP +From the point of view of the applications programmer, the program they +are writing is at the center of the system and is in command (and indeed +the program does control the system when it is run). The programmer sees +only the abstract problem to be solved and the environment in which the +solution must be constructed, defined by the program interface and the SPP +language. The CL is an abstract data structure, accessed via the CLIO +library in the program interface. The fact that there is a host system +underlying the program interface is irrelevant, and is of no concern to the +applications programmer. As far as the applications programmer is concerned, +the CL could be CL1, CL2, a file, the host OS command interpreter, Forth, +Lisp, or anything else. Ideally, the applications programmer does not know +that the target language of the SPP is Fortran. +.PP +From the point of view of the systems programmer, the kernel is the center +of the system, with the host operating system below and the program interface +above. The system software is subservient to the program which calls it, +and does exactly what it is told to do and nothing more. The CL and the SPP +compiler are \fIapplications programs\fR which use only the facilities +of the program and system interfaces. +.PP +The structural design of the IRAF software is outlined in the figure below. +In general, control and parameters flow downward and data flows both both +downward and upward (mostly upward). The procedures at one level do +not call procedures at a higher level, e.g., kernel routines are +not permitted to call procedures in the program interface libraries. +A procedure may call other procedures at the same level or in the next +lower level, but calls to routines more than one level lower are avoided, +i.e., a program should not bypass the program interface and talk directly +to the kernel. IRAF applications programs \fInever\fR bypass the system +interface to talk directly to the host system. + +.KS +.ce +\fBStructure of the Major IRAF Interfaces\fR +.sp +.nf + \fIuser interface\fR + high level program + \fIprogram interface\fR + \fIsystem interface\fR + host operating system +.fi +.KE + +.PP +This structure chart illustrates only the control hierarchy of the major +interfaces. Additional structure is imposed on the actual system. +Thus, the CL uses only a small portion of the facilities provided by the +program interface, calling external programs to perform most functions. +Few system or applications programs, on the other hand, use the process +control facilities, the part of the program interface most heavily used +by the CL (apart from file i/o). The CL and external applications +programs are minimally coupled, using only human readable text files for +interprocess communication (interprocess communication is implemented as +a special file in IRAF). +.PP +These restrictions tend to result in more functional programs which can be +combined in many ways at the CL level, and which can be used quite +productively without the CL. In particular, any IRAF program can easily +be debugged without the CL, using the host system debugger, and any IRAF +program can be used productively on a system which cannot support the CL. +The system perceived by the user at the CL level can easily be extended +or modified by the user or by a programmer. +.PP +The \fBprocess structure\fR of the IRAF system, with the CL serving +up and networking all processes, while fundamental to the design of +the IRAF system, is not relevant to a discussion of the system interface +because it is all handled above the system interface, i.e., in the machine +independent code. Many quite different process structures are possible +using the one IRAF system interface. Concentration of most or all of the +complex logic required to implement process control, the CL process cache, +the CL/program interface, pseudofiles, multiprocessing, i/o redirection, +exception handling and error recovery, efficient file access, etc., +into the machine \fIindependent\fR code was a major goal of the IRAF +system design. + +.NH +The IRAF System Interface +.PP +As has already been noted, the IRAF system interface consists of both a +procedural interface or kernel (library of Fortran callable subroutines), +and a language interface (preprocessor for Fortran). All communication +with the host system is routed through the kernel, minimizing the machine +dependence of the system and providing scope for machine dependent +optimizations. Similarly, all code other than existing, imported numerical +Fortran procedures is processed through the language interface, further +minimizing the machine dependence of the system. The language interface, +or subset preprocessor (SPP), isolates IRAF programs from the peculiarities +of the host Fortran compiler, provides scope for optimization by making it +possible to take advantage of the nonstandard features of the compiler +without compromising transportability, and does much to correct for the +defects of Fortran as a programming language. +.NH 2 +The Language Interface +.PP +The kernel alone is not sufficient to solve all the problems of +transporting a large software system. There remain many problems associated +with the programming language itself. The many problems of transporting +even purely numerical software are well known and we will not attempt to +discuss them in detail here. The reasoning which led to the decision to +implement the IRAF system in a Fortran preprocessor language (SPP) is less +obvious, and is probably worth recounting. In the process of retracing +the logic which led to the decision to develop SPP, we will come to understand +the purpose of the language interface. +.PP +For some reason programming languages are one of the most controversial +topics in all of programming. No language is perfect, and it is important +to try to objectively gauge the advantages and disadvantages of a language +for a particular application. It is difficult to make such comparisons +without the injection of opinion, and for that we apologize. In the final +analysis the choice of a language is probably not all that important, +provided the cost of the project is minimized and the resultant code is +reliable, portable, readable, and efficient. Only the Fortran and C languages +are discussed; these were the only candidates seriously considered in 1982, +when the decision to implement the IRAF system in a Fortran preprocessor +language was made. +.NH 3 +Fortran +.PP +Consider the typical scientific applications program. Such a program may +need to talk to the CL, access files, access images, access databases, +dynamically allocate memory, generate graphics, perform vector operations, +and so on. These are all functions provided by the program interface. +In addition, in a scientific program there will often be some central +transformation or numerical computation which will almost certainly be +performed by a Fortran subprogram. There is an enormous amount of high +quality Fortran numerical and graphics software available, both commercially +and in the public domain, which IRAF programs must have access to. A third +of the current IRAF system consists of highly portable, numerical (no i/o) +Fortran code, all of it in the public domain. +.PP +To be useful, these general purpose, numerical Fortran subroutines must +be integrated into an IRAF program to perform some specific function. +Here we run into the first serious problem: while Fortran is great for +numerical procedures, it has many defects as a general purpose programming +language. When it comes to complex systems software, Fortran is vastly +inferior to a modern programming language such as C or Pascal. It is +very difficult to implement complex nonnumerical applications in +standard Fortran; the temptation to use a manufacturer's nonstandard +language extensions is often too difficult to resist, and a nonportable +program results. Clearly, Fortran is not the language of choice for the +IRAF system software, in particular the program interface. +.PP +The next question is what to do about the high level part of the scientific +applications program, the part which talks to the program interface, +performs applications specific functions, and eventually calls the numerical +Fortran procedures. In a large scientific package Fortran subprograms +will almost certainly be used somewhere in the package, sometimes quite +heavily, but the bulk of the software is often very similar to systems +software, concerned with allocating resources, managing data structures, +doing i/o of various kinds, and directing the flow of control. +.PP +This is all nonnumerical programming, for which Fortran is poorly suited. +Many Fortran compilers provide nonstandard language extensions which make +it easier to code nonnumerical applications in Fortran. Most applications +programmers and scientists are not intimately familiar with the Fortran +standard, and are more interested in getting a program working than in making +it portable, and nonportable code will result. In any case, programmers +and scientists should not have to struggle to code an application in +a language which was designed for another purpose. We conclude that Fortran +is not the language of choice for general scientific programming within a +complex system. +.PP +A more serious problem with using Fortran for general scientific programming, +however, is that the high level portion of an IRAF scientific program depends +heavily on the capabilities of the program interface. To produce sophisticated +scientific programs with minimum effort we must have a large and powerful +program interface, providing the capabilities most often needed by scientific +programs. We also need a large and powerful program interface for +\fIsystem\fR programs, and in fact the capabilities required by scientific +programs are not all that different than those of system programs, so +clearly it is desirable if the same program interface can support both +kinds of programs. +.PP +The next step is to explore the implications of the heavy dependence of +a systems or scientific program on the program interface. The program +interface is a large interface, consisting of a dozen subsystems containing +several hundred procedures. To have a sophisticated, high level, efficient +interface, it is necessary to use "include" files to parameterize argument +lists, machine parameters, and data structures, we must use dynamic memory +management (pointers) for buffer allocation, and something has to be done +about error handling and recovery. In short, there is a lot of communication +between high level programs and the program interface. This level of +communication is only feasible if the program interface and the high level +program are written in the \fIsame language\fR. Standard Fortran provides +\fIalmost no language support\fR for these facilities. +.sp +.KS +.LP +To summarize our reasoning to this point: +.RS +.IP \(bu +Fortran must be used extensively in the scientific applications. +.IP \(bu +Fortran is not the language of choice for IRAF systems software, +in particular the program interface. +.IP \(bu +Fortran is not the language of choice for general scientific programming, +because most scientific programming is nonnumerical in nature, i.e., +much like systems programming. +.IP \(bu +A single program interface should support both systems programs and +scientific programs. +.IP \(bu +The level of communication required between a high level program and the +program interface requires that both be written in the same language. +.IP \(bu +Standard Fortran provides almost no language support for include files, +globally defined parameters, dynamic memory management and pointers, +data structures, or error recovery. These facilities are required by +both systems and applications software. +.RE +.KE +.NH 3 +Mixing C and Fortran in the same System +.PP +All of our logic to this point forces us to conclude that standard Fortran +just is not suitable for the bulk of the IRAF software. The complexity of +large applications packages, not to mention that of the system software, +would be unmanageable in straight Fortran. Nonetheless we must +still face the requirement that a third or so of the system be existing, +imported numerical Fortran procedures. The obvious question to be answered +is, if Fortran is such a poor choice for the main programming language +of IRAF, can we program in an appropriate modern structured language like C, +calling the numerical Fortran functions and subroutines from within C programs? +.PP +The answer is sure we can, if our target system supports both a Fortran +compiler and a C compiler, but there are serious portability implications. +Furthermore, when examined closely C turns out to be not that great a +language for general scientific programming either, and the defects of C +cannot easily be fixed, whereas those of Fortran can. +.PP +Mixing two different languages in the same program is straightforward on +many operating systems and possible with difficulty on others. No language +standard could attempt to specify how its subprograms would by called by a +completely different, unspecified language, so the one thing we can be +sure of is that the method used will be system dependent. Even on systems +where mixing subprograms from different languages is straightforward, +there are many potential problems. +.PP +Argument lists present many problems. +A potentially deadly problem is the fact that C is a recursive +language while (standard) Fortran is not. C expects the arguments to a +procedure to be passed on the stack, while Fortran was designed with static +storage of argument lists in mind; static storage is somewhat more efficient. +Arguments pushed on a stack are usually pushed in the reverse of the order +used for static allocation. C is call by value; Fortran is call by +reference. Returning a function value is trivial on many systems, +but can be a problem. The Fortran standard requires that a function be +called as a function (in an expression) and not as a subroutine, while +C permits either type of call (all C procedures are functions). +.PP +The method used to implement Fortran character strings is machine dependent; +some machines may pass two items in the argument list to represent a +character string, while others pass only one. On some machines a Fortran +character string is implemented with a count byte, on others an end of string +marker is used. The C standard requires that a character string be delimited +by a trailing zero byte. Thus, on some systems C and Fortran character strings +will be equivalent; programs written on such a system are not portable +to to systems where strings are implemented differently in the two languages. +.PP +Global variables are likely to be a problem, because Fortran common blocks +and C external variables are quite different types of data structures. +Though it would be poor programming practice to use global variables +or common blocks to pass data between C and Fortran procedures, it is +sometimes justified for control parameters, in particular in connection +with error handling. A C include file cannot be accessed from a Fortran +program. +.PP +Finally, external identifiers have a set of problems all of their own. +On some systems, e.g. VMS and AOS, C and Fortran external identifiers are +equivalent, and a procedure is referred to by the same name in both +languages. This makes it easy to mix calls in the two languages, +but can lead to serious name conflicts in libraries. On other systems, +e.g. UNIX, the external identifiers generated for the two languages are +\fInot\fR equivalent, and a C procedure cannot be called from Fortran +unless special provisions are taken (the UNIX Fortran compiler adds an +underscore to all Fortran external identifiers). +.PP +The problem is not that it is hard to mix the two languages, but that +every one of the points mentioned above is a potential machine dependency +which is not covered by any standard. We conclude that mixing C and +Fortran in the same program is inevitably going to be machine dependent. +The problem is controllable only if the number of procedures common to +the two languages is small, or if some automated technique can be developed +for interfacing the two languages. The former solution is straightforward, +the second requires use of some form of \fIpreprocessor\fR to isolate the +machine dependencies. +.PP +C and Fortran should not be mixed in applications software because the +number of Fortran procedures involved is potentially very large. +Since the number of procedures is large, the effort required to port the +applications is also potentially large, and it is the applications which +change most between system releases. If the applications total, say, +200 thousand lines of code, a new release of the system occurs every 3 months, +and it takes two weeks to make all the changes in the high level software +necessary to port it, then we have a bad situation. Porting the system +should ideally be a simple matter of reading a tape, possibly modifying a +config file or two, and running diagnostics. +.PP +C and Fortran should not be mixed in the program interface (in the system +libraries) because it introduces machine dependency into the program +interface where formerly there was none. Less obviously, the problem +discussed in \(sc3.1.2 of communication between modules written in different +languages is very serious. The modules of the program interface use +global \fBinclude\fR files to communicate with one another, and to +parameterized the characteristics of the host system. To ensure a reliable +and modifiable system, there must be only one copy of these include files +in the system. Furthermore, the IRAF error handling scheme, employed +in all code above the kernel, is based on the use of a Fortran common +and to access this from C code would be awkward and would introduce additional +machine dependence. +.PP +The only remaining alternative is to write applications programs entirely in +Fortran and the system software in C, using a small program interface between +the two parts of the system. The problems with this approach were noted in +the last section. The small program interface will inevitably prove too +restrictive, and more and more scientific programs will be written as +"system" programs. These programs will inevitably want to use the numerical +Fortran libraries, and the problem of a large interface between two languages +resurfaces at a different level in the system. +.NH 3 +Critique of C as a Scientific Language +.PP +The major strengths of C as a programming language are that it lends itself +well to structured, self documenting programming, has great expressive power, +strong compile time type checking, tends to result in highly transportable +code (when not mixed with other languages), and is efficient for a large +range of applications. C has been widely used in computer science research +for a decade, and many high quality systems applications are available in +the public domain. +.PP +As a scientific programming language, however, C has serious shortcomings; +C was not designed to be a scientific programming language. The major problem +with C as a scientific programming language is that the scientific community +already has such a large investment in Fortran, and it is difficult to mix +the two languages, as we have already discussed. Upon close analysis we find +that there are additional problems, and these deserve mention. +.PP +C does not support multidimensional arrays. C provides something similar +using pointers, but the feature is really just a side effect of the +generality of pointers, and is not fully supported by the language. +A multidimensional array cannot be passed to a subprogram along with its +dimensions as it can in Fortran. Few C compilers optimize loops, i.e., +evaluate common subexpressions (such as array subscripts) only once, +or remove constant expressions from inner loops. These problems can +be overcome by sophisticated use of pointers, but such hand optimization +of code is extra work and increases the complexity of the code. +On a machine such as the Cray, which has a Fortran compiler that +recognizes vector operations, the problem would be even more severe. +.PP +Char and short integer (8 and 16 bit) expressions are evaluated using +integer instructions (32 bits on a VAX), and single precision floating +expressions are evaluated using double precision instructions. +In a tight loop, this will require the addition of a type conversion +instruction to promote a variable to the higher precision datatype, +and another to convert back to the original datatype after the evaluation. +This alone can double the size and execution +time of a tight loop. In addition, on many machines double precision +floating is not well supported by the hardware and is several times more +expensive than single precision floating. C does not support the +\fBcomplex\fR datatype, important in some scientific applications. +.PP +The C language does not include support for \fBintrinsic\fR and \fBgeneric\fR +functions. These are used heavily in scientific applications. Typed function +calls are required to access the scientific functions, and to perform +exponentiation. I am not aware of any C standard for the scientific functions, +though most systems appear to have adopted the Fortran standard. +The scientific functions, e.g., the trigonometric functions, are evaluated +in double precision. This could lead to a serious degradation +of performance in a large class of applications. +.PP +Despite these quite serious shortcomings, faced with the task of coding a +large and complex application I would prefer C to Fortran, if I had only +the two languages to choose from. Fortunately there is a third alternative, +the use of a Fortran preprocessor. +This approach preserves the best features of Fortran while providing many +of the nice features of a modern language such as C, and in addition allows +us to provide language level support for the IRAF i/o facilities. +The preprocessor approach provides a means of isolating both systems and +applications code from the underlying host compiler, making portability +a realistic goal. +.NH 3 +The IRAF Subset Preprocessor Language +.PP +The Subset Preprocessor language (SPP) is a precursor to a full language +scheduled for development in 1986. The subset language is a fully defined, +self contained language, suitable both for general programming and for +numerical scientific programming. The basic language is modeled after +both C and Ratfor but is a distinct language and should not be confused +with either. SPP is fully integrated into the IRAF system, i.e., +SPP provides substantial language support for the program interface, +the IRAF system itself is written in SPP, and the SPP compiler is an IRAF +applications program written in SPP and using the facilities provided by +the program interface (this is not true of the original preprocessor but +that is not relevant to the design). The syntax of the SPP language is +nearly identical to that of the IRAF command language. +.PP +The SPP language is defined in the document \fIA Reference Manual for the +IRAF Subset Preprocessor Language\fR. The language provides modern +control flow constructs, a wide range of datatypes, support for both system +and user \fBinclude\fR files, a macro definition facility, free format +input, long (readable) identifiers, C-like character constants and strings, +Fortran-like arrays, access to the standard Fortran intrinsic and generic +functions, powerful error handling facilities, and limited but adequate +support for pointers, automatic storage allocation, and data structuring. +Since the target language is Fortran, there is no problem calling Fortran +subprograms from SPP programs or vice versa. We do require, however, +that the Fortran subprograms be purely numerical in nature, i.e., +no Fortran i/o is permitted. +.PP +The function of the preprocessor is to translate an SPP source file +into a highly portable subset of ANSI-66 Fortran. The transformation is +governed by a set of machine dependent tables describing the characteristics +of the host computer and of the target Fortran compiler. These tables +must be edited to port the preprocessor to a new machine; the tables are +ideally the only part of the preprocessor which is machine dependent. +.PP +Even if it should turn out that all of the necessary machine dependence +has not been concentrated into the tables, however, it will often be possible +to port the hundreds of thousands of lines of code in the system by +modifying or adding a few lines of code to the preprocessor, +\fIbecause we have placed an interface between the language of the IRAF system +and that of the host computer\fR. The language interface provides both +a solution to the problem of transporting software between different +contemporary machines, and protection from future changes in the Fortran +language. +.PP +The principal motivation of the preprocessor approach taken in IRAF is +that it provides a real solution to the transportability problem, i.e., +one which does not depend upon perfect programmers. An additional incentive +is that by defining our own language we can provide excellent support the +IRAF i/o facilities, i.e., they can be more than just subroutines and +functions. +.PP +If one has the freedom of being able to modify the programming language +used by applications programs, one can do things that are impractical to +do any other way. In other words, it becomes feasible to solve problems +that were formerly too difficult to address. An example is the use of +lookup tables to implement blocked storage of images, an alternative to +line storage mode which is superior in a large class of image processing +applications. To do this well requires language support, and it is unlikely +that such support will be found in any standard, general purpose programming +language. The SPP is intended partially to provide a path for the future +development of the IRAF system, in the hope that the system will be able +to evolve and be competitive with new systems in coming years. +.NH 3 +Limitations of the Subset Preprocessor +.PP +No compiled language, SPP included, can guarantee transportability. +SPP programs developed on one machine will normally have to tested on +one or more other machines before they can be declared portable. +SPP suffers from many of the same portability problems as standard +Fortran, the main difference being that the output Fortran is very +simple, and nonstandard language extensions are strictly controlled. +Further discussion of the portability aspects of SPP programs is given +in the document \fIIRAF Standards and Conventions\fR. +.PP +We hope to eventually have IRAF running on several types of machines +at the development centers. New releases will be brought up and tested +on several different machines before distribution. +No large software package developed on a single system is portable; +if it is tested on even two different systems, that is much better. +.PP +The SPP language also depends on certain side effects which are not +specified in the Fortran standard, but which many other systems also +depend upon and which are commonly permitted by Fortran compilers. +These include: +.RS +.IP [1] +It must be possible to reference beyond the bounds of an array. +.IP [2] +It must be possible to reference a subarray in a call to a subprocedure, +i.e., "call copyarray (a[i], b, npix)". +.IP [3] +The compiler should permit a procedure to be called with an actual +argument of type different than that of the corresponding dummy argument +(except type \fBcharacter\fR: SPP does not use this type anywhere). +.IP [4] +It must be possible to store a machine address or the entry point +address of an external procedure in an integer variable. +.RE +.LP +Common language extensions used by the preprocessor in output code include +the nonstandard datatypes such as INTEGER*2, any associated type coercion +functions (INT2), and the boolean intrinsic functions if provided by the +target compiler. +.PP +The output of the current preprocessor is ANSI-66 Fortran only to a first +approximation. The following features of Fortran 77 are also used: +.DS +general array subscripts +zero-trip do loop checking +\fBsave\fR statement +\fBentry\fR statement +generic intrinsic functions (\fBmax\fR rather than \fBamax0\fR, etc.) +.DE +All of these extensions are correctable in the preprocessor itself +except the use of the \fBentry\fR statement, if it should ever prove +necessary. + +.NH 2 +Bootstrapping the System +.PP +Since the SPP is fully integrated into the system -- the program interface +is written in SPP and SPP uses the program interface, one may have been +wondering how to go about getting it all set up in the first place. +The basic procedure for porting IRAF to a new system is as follows. +The actual procedure has not yet been fully defined and will be tailored +to the individual target systems, i.e., there will be a separate +installation guide and distribution package for UNIX, VMS, DG/AOS, +and any other systems supported by the IRAF development team. +.RS +.IP [1] +Implement and test the kernel routines. +.IP [2] +Compile the bootstrap SPP, which has already been preprocessed for the +target machine (the datatype used to implement \fBchar\fR must match that +expected by the kernel procedures). +.IP [3] +Edit the system dependent files \fBiraf.h\fR, \fBconfig.h\fR, and the +preprocessor tables to define the characteristics of the host machine. +.IP [4] +Preprocess and compile the production SPP. +.IP [5] +Do a full \fBsysgen\fR of the system libraries (the program interface etc.). +This takes a couple hours on the VAX/UNIX 11/750 development system; get +the config tables right the first time. +.IP [6] +Run diagnostics on the system library procedures. +.IP [7] +\fBMake\fR the applications packages. +.RE +.PP +Once the system has been ported, installing a new release requires only +steps 5 through 7 (sometimes step 4 may also be required), after reading +the distribution tape. + +.NH 2 +The IRAF Kernel +.PP +The IRAF kernel is a set of Fortran callable subroutines. +Every effort has been made to make these primitives as simple as possible; +the kernel primitives provide raw functionality with minimum overhead. +Ideally the kernel primitives should map directly to the kernel of the +host operating system. The implementation of the kernel primitives +should emphasize simplicity and efficiency; these primitives embody the +machine dependence of IRAF and there is little reason to try to make them +machine independent. Critical routines should be coded in assembler +if a substantial gain in efficiency will result. In IRAF, \fIall\fR +communication with the host system is routed through the kernel, +so kernel efficiency is paramount. +.PP +With very few exceptions, applications programs and high level systems +modules do not talk directly to the kernel. The kernel primitives are +called only by the routines comprising the core of the IRAF \fBprogram +interface\fR, the lowest level of the machine independent part of the +IRAF system. The core of the program interface, i.e, file i/o, process +control, exception handling, memory management, etc., combined with the +kernel, constitute a \fBvirtual operating system\fR, the heart of IRAF. +The virtual operating system approach is the key to maximizing +transportability without sacrificing either functionality or efficiency. +.PP +Ideally all of the machine dependence of the IRAF system is concentrated +into the kernel, which should be as small and efficient as possible while +offering sufficient raw functionality to support a large and sophisticated +system. In practice it is possible to come quite close to this ideal, +although the range of host systems on which the kernel can be implemented is +finite, being inversely proportional to the richness of function +provided by the kernel. We did not consider it acceptable to provide +transportability at the expense of a restrictive and limited program +interface, so IRAF has a large and quite sophisticated program interface +which depends upon a sizable kernel. The IRAF kernel embodies much of +the functionality provided by the typical minicomputer operating system, +and should be implementable on a wide range of such systems. +.NH 2 +The Virtual Machine Model +.PP +The virtual machine model is the conceptual model of the host machine assumed +by the kernel. The difficulty of implementing the kernel on a given host +depends on how closely the model matches the host operating system. In general, +the older large batch oriented machines do not match the model well, +and it will be difficult to port the full IRAF system to such a machine. +At the other end of the scale are the small 16 bit minicomputers; these +machines do not have a sufficiently large memory addressing range to run IRAF. +In the middle are the multiprocessing, multiuser, terminal oriented supermicro +and minicomputers with large address spaces and large physical memories: +these are the machines for which the IRAF system was primarily designed. +.PP +Our intent in this section is to summarize the most important features of +the virtual machine model. Much of the material given +here will be presented again in more detail in later sections. The design +of the IRAF system is such that there are actually two distinct virtual +machine models, the full model and a subset model. The subset model assumes +little more than disk file i/o, and will be presented first. +.NH 3 +The Minimal Host Machine +.PP +Even though it may be difficult to run the \fIfull\fR IRAF system on a large +batch oriented (timesharing) machine, it should still be possible to run most +of the science software on such a system. The IRAF system was designed such +that the science software is placed in separate processes which can be run +independently of the CL and of each other. +These processes actually use only a portion of +the full system interface; most of the system and device dependence is in +the CL and the graphics control processes, i.e., in the user interface, +which is what one has to give up on a batch machine. +.PP +On the typical batch oriented timesharing system, the IRAF applications +programs would be run under control of the host job control language, +reading commands and parameters from an input file, and spooling all +textual output into an output file. The IRAF command language would not +be used at all; this mode of operation is built into the present system. +Little more than file i/o is required to run a program on such a system, +though dynamic memory allocation is highly desirable. Exception handling +and error recovery can be done without if necessary; process control is not +used by applications processes. The i/o subsystems required by an +applications program are CL i/o, image i/o, and database i/o, each of +which is built upon file i/o. +.PP +Applications programs that produce graphics write device independent +metacode instructions, rather than talking directly to a graphics device, +so a graphics device interface is not required to run an applications +program. Graphics output can be discarded, or the output file can be +postprocessed to generate graphics hardcopy. +Graphics input (cursor readback) is parameterized, so any program that +normally reads a cursor can just as easily read coordinates directly from +the input file. +.PP +All of the software in the science modules is Fortran or Fortran based +(C is used only in the CL and in some kernels), so only a Fortran compiler +is required. A C compiler is currently required to compile the command +language, though it is not necessary to have such a compiler on every +physical machine. We can compile the CL on one machine and distribute +the object code or executables to other machines of the same type; this +will be done, for example, for VAX/VMS. +.PP +If it is necessary to port IRAF to a machine which +does not have a C compiler, it is feasible to code a basic, stripped down +command language in SPP in a few weeks. A command language capable of +executing external processes, parsing argument lists, managing parameter +files, and redirecting i/o is sufficient to run most of the IRAF software, +the main loss being CL scripts. Virtually all of the system and science +software is external to the CL and would be unaffected by substitution of +a new CL. +.NH 3 +The Ideal Host Machine +.PP +The minimal IRAF target machine therefore need offer little more than +file i/o and a Fortran compiler. One would have to do without a nice user +interface, but it should still be possible to do science in the fashion it +has traditionally been done on such machines. +Fortunately, however, minicomputers of modern design are widely available today +and will be increasingly available in the future. We expect that most IRAF +implementations will be ports of the full system onto a modern supermicro or +minicomputer. Such a host system should provide the following general classes +of facilities: + +.DS +.RS +.IP \(bu +file i/o, file management +.IP \(bu +process control +.IP \(bu +exception handling +.IP \(bu +memory management +.IP \(bu +date and time +.IP \(bu +bit and byte primitives +.RE +.DE + +Most of the complexity of the kernel is in file i/o, process control, +and exception handling. File management (file deletion, renaming, etc.) +is straightforward on virtually any system. Memory management can be +some work to implement, but many systems provide dynamic allocation +primitives in which case the interface is trivial. The date and time +facilities assume that the host provides some sort of facilities for +reading the clock time (ideally as a high precision integer) and the cpu +time consumed by a process. The bit and byte primitives do not actually +do any i/o, and are included in the interface primarily because Fortran +is difficult to use for such applications. +.PP +The IRAF \fBfile i/o\fR system deals with two types of files. +\fBText files\fR contain only character data, are read and written in +units of records (lines of text), and are maintained in a such a form +that they can be edited with a host editor. +Writing may occur only at the end of file. +Reading is normally sequential, but seeking to the beginning of a line +prior to a read is permitted. The user terminal is interfaced +as a text file, opened by the IRAF main at process startup. Terminal i/o +is generally line oriented, but character at a time input is used by some +programs, and the system expects to be able to send control codes to the +terminal. Text files are accessed synchronously. Character data is always +ASCII within IRAF, with the kernel routines mapping to and from the host +character set (e.g. EBCDIC). +.PP +The second file type is the \fBbinary file\fR. A binary file is an +extendible array of machine bytes. There are two types of binary files, +\fBblocked\fR (random access) binary files and \fBstreaming\fR (sequential) +binary files. Transfers to and from blocked binary files are +always aligned on device block boundaries and are asynchronous. +The size of a transfer may be any integral multiple of the device block +size, up to a device dependent maximum transfer size. +The IRAF file i/o system (FIO) assumes that a file can be extended by +overwriting the end of file, and that a partial record can be written at +the end of file without the host filling the record to the size of a +device block. The device block size is assumed to be device dependent. +Devices with different block sizes may coexist on the same system. +.PP +Streaming binary files are for devices like magtapes and the interprocess +communication (IPC) facilities. Seeks are not permitted on streaming files, +and there are no restrictions on block size and alignment of transfers, +other than an upper limit on the transfer size. The ideal host system will +initiate an asynchronous transfer from either type of binary file directly +from the mass storage device into the buffer pointed to by the kernel +(or vice versa). +.PP +The model does not assume that the host system provides device independent +file i/o. A different set of kernel routines are provided for each device +interfaced to FIO. On a system which does provide device independent i/o +the kernel routines may be coded as calls (or multiple entry points) to a +single set of interface subroutines. Standard file devices include disk +resident text and binary files, the IPC facilities, magtapes, line printers, +and (currently) the image display devices and the batch plotters. +The special devices are normally interfaced to FIO as binary files. +The IPC files are streaming binary files. +.PP +Although it is highly desirable that the host provide a hierarchical files +system, it is not required. IRAF tends to generate and use lots of small files. +FIO maps virtual filenames into machine dependent filenames, and will pass +only filenames acceptable to the host system to the kernel routines. +It should be possible to read filenames from a host directory, +determine if a file exists and is accessible, +delete a file, and rename a file. The model assumes that there are two types +of filenames: files within the current directory (directory name omitted), +and files within a particular directory, and that both types of files can be +simultaneously accessed. The directory name is assumed to be a string which +can be prepended to the filename to produce a pathname. Multiple versions +of a file are neither assumed nor supported. +.PP +\fBMagnetic tape\fR devices are interfaced as streaming binary files. +A magnetic tape is either empty or consists of one or more files, +each delimited by an end of file (EOF) mark, with an end of tape (EOT) +mark following the last file on the tape. +The kernel routine opens the device positioned to +the first record of a specific file or EOT. Tape density may be manually +set on the device, or may be set at allocate time or at open time (the IRAF +software will work regardless of which method is used). A separate file +open is required to access each file on the tape, i.e., FIO will not try +to read or write beyond a tape mark. +.PP +Record and file skipping primitives are desirable for tape positioning in +the kernel open procedure, but are not assumed by the model. Tape records +may be variable in length. No attempt will be made to position the tape +beyond EOT. FIO knows nothing about labeled tapes or multivolume tapes; +if it is necessary to deal with such tapes, the details should be handled +either by the host system or by the kernel routines. All IRAF programs +which read and write magtape files can also be used to read and write disk +files. +.PP +The virtual machine model assumes that a parent process can spawn one or +more child \fBsubprocesses\fR, to execute concurrently with the parent, +with bidirectional streaming binary communications channels connected to +the parent. The IPC facilities are used only to communicate with child +processes; the model does not assume that any one process can talk to any +other process. The model assumes that an IPC channel can only be opened +when a child process is spawned; the two functions are bound into the +same kernel primitive. A child process is assumed to inherit the same +current working directory as the parent. The child is not assumed to +inherit environment or logical name tables, open files, or the parent's +address space. +.PP +\fBException handling\fR is very machine dependent and is difficult to model. +Fortunately the IRAF system will probably still be usable even if the host does +not entirely fit the model, since exceptions are not the norm. +A parent process is assumed to be able to interrupt a child process. For error +recovery and process shutdown to occur properly control should transfer +to an interrupt handler in the child process when the interrupt signal is sent. +.PP +All exceptions occurring during execution of a process should be caught by +the kernel and mapped into the exception classes assumed by the kernel. +The model assumes that all exceptions can be caught, that control can be +transferred to an exception handler, and that execution can resume following +processing of the exception. The host and the kernel should let the high +level software process all exceptions and handle error recovery. +.PP +In summary, IRAF can be used to do science on a limited, batch oriented host +machine, at the expense of a limited user interface and considerable hacking +of the released system. The ideal host system will provide a hierarchical +files system, large asynchronous file transfers directly into process memory, +multiprocessing, efficient binary interprocess communication facilities, +dynamic memory management facilities, and high level exception handling. + +.NH +A Reference Manual for the IRAF Kernel +.PP +The kernel is a set of SPP or Fortran callable subroutines. The syntax +and semantics of these routines, i.e., the external specifications of the +interface, are the same for all machines. The code beneath the interface +will in general be quite different for different operating systems. +Any language may be used to implement the kernel routines, provided the +routines are Fortran callable. Typed functions are avoided in the kernel +where possible to avoid the problems of passing a function value between +routines written in different languages. +.PP +The method chosen to implement a kernel routine for a given host should be +dictated by the characteristics of the host and by the external specifications +of the routine, not by the method chosen to implement the same kernel +routine for some other host. Nonetheless it is often possible to reuse +code from an existing interface when coding an interface for a new host. +This occurs most often in the numerical procedures, e.g., the bit and byte +primitives. Furthermore, some routines are placed in the kernel only +because they are potentially machine dependent; these routines need only be +examined to see if they need to be modified for the new host. +.PP +The kernel routines are found in the \fBOS package\fR, the interface to the +host Operating System (OS). The OS package is maintained in the logical +directory \fBsys$os\fR, and the kernel routines are archived in the +system library \fBlib$libos.a\fR. + +.NH 2 +Conventions +.PP +At the kernel level, data is accessed in units of \fBmachine bytes\fR. +The size of a machine byte in bits and the number of bytes per SPP data +type are both parameterized and are assumed to be machine dependent. +It is fundamentally assumed throughout IRAF that an integral number of bytes +will fit in each of the language datatypes. Conversion between byte units +and SPP units is handled by the high level code; the kernel routines deal +with data in byte units. +.PP +All offsets in IRAF are \fBone-indexed\fR, including in the kernel routines. +Thus, the first byte in a file is at offset 1, and if the device block size +is 512 bytes, the second device block is at offset 513. The first bit in a +word is bit number 1. Many operating systems employ zero-indexing instead +of one-indexing, and the implementor must be especially careful to avoid off +by one errors on such systems. +.PP +All \fBcharacter strings\fR are packed in the high level code before +transmission to the kernel, and strings returned by the kernel are unpacked +by the high level code into SPP strings. The packed string is passed in an +array of SPP type \fBchar\fR. +The format of a packed string is a sequence of zero or more characters +packed one character per byte and delimited by end-of-string (EOS). +SPP strings are ASCII +while packed strings use the host character set. The EOS delimiter occupies +one character unit of storage but is not counted in the length of the string. +Thus if a kernel routine returns a packed string of at most \fImaxch\fR +characters, up to \fImaxch\fR characters are returned followed by an EOS. +.PP +Kernel procedures should call only other kernel procedures or the host +system. Calls to program interface routines are forbidden to avoid problems +with \fBreentrancy\fR and backwards library references (and because code which +references upwards is usually poorly structured). A program crash should +never occur as a result of a call to a kernel procedure. Illegal operations +should result in return of an error status to the routine which called the +kernel procedure. The SPP error handling facilities must not be used in +kernel procedures, even if a kernel procedure can be coded in SPP. +This is because the high level code does not error check kernel procedures, +and because printing an error message involves calls to FIO and possible +reentrancy. +.PP +Any kernel procedure which can fail to perform its function returns an +integer status code as its final argument. Other integer codes are used +to parameterize input arguments, e.g., the file access modes. Codes which +are used only in a particular procedure are documented in the specifications +for that procedure. The codes used extensively in the kernel are shown in +the table below. The magic integer values given in the table must agree +with those in the SPP global include file \fBiraf.h\fR. +.sp 0.08i +.TS +center box; +cb s s +ci | ci | ci +l | c | l. +Kernel Constants +_ +name value usage += +ERR \(mi1 function was unsuccessful +EOS '\\\\0' end of string delimiter +OK 0 function successfully completed +NO 0 no (false) +YES 1 yes (true) +.TE +.sp 0.08i +.PP +The names of kernel routines never exceed six characters, and only alphanumeric +letters are used. The Fortran implicit datatyping convention (I through N for +integer identifiers) is not used in IRAF. The IRAF naming convention is +package prefix plus function plus optional type suffix letter. This convention +is little used in the kernel because there are few functions, but it does occur +in a few places, e.g. the bitwise boolean functions \fBand\fR and \fBor\fR. +The procedure naming convention and other IRAF conventions are further +discussed in the document \fIIRAF Standards and Conventions\fR. + +.NH 2 +Avoiding Library Conflicts +.PP +Only documented OS interface routines should be callable from the high level +SPP and Fortran code. If at all possible, all non-interface kernel +subprocedures and host system calls referenced in the kernel should be +named such that they are not Fortran callable. All external identifiers +used in IRAF code adhere to the Fortran standard, i.e., at most six +alphanumeric characters, the first character being a letter. Non-interface +kernel procedures are guaranteed not to cause library conflicts with the +high level software provided they are not legal Fortran identifiers. +.PP +For example, on UNIX systems, the Fortran compiler appends a hidden underscore +character to all Fortran external identifiers. No standard C library or system +procedures have names ending in an underscore, so library conflicts do not +arise. On a VMS system, the VMS system service procedures all have external +names beginning with the package prefix "sys$", hence the system service +procedures are guaranteed not to cause library conflicts with standard Fortran +identifiers. +.PP +If there is no way to avoid library conflicts by using a naming convention +at the kernel level, it is possible to modify the SPP to map identifiers in +a way which avoids the conflicts (e.g., by use of \fBdefine\fR statements +in the global include file \fBiraf.h\fR). This approach is less desirable +because it involves modification of high level code, and because it does +nothing to avoid library conflicts with Fortran subprograms which are not +preprocessed. Furthermore, it is important that the mapping of SPP +identifiers to plain vanilla Fortran identifiers be simple and predictable, +to ease interpretation of host Fortran compiler error messages, and to make +the host system debugger easy to use with SPP programs. + +.NH 2 +File I/O +.PP +The file i/o subsystem is the most critical i/o subsystem in IRAF. +No process can run without file i/o, and the high level system code and +applications programs are all built upon file i/o. Many programs are i/o +intensive, and an efficient file i/o system is vital to the functioning +of such programs. The high level of functionality and device independence +provided by the IRAF file i/o subsystem is critical to minimizing the +complexity and maximizing the flexibility of all code which uses file i/o. +In particular, the database and image i/o subsystems are heavily dependent +upon file i/o; the IRAF file i/o system was designed expressly to provide +the kinds of facilities required by these and similar applications. +.PP +Most of the complexity of the file i/o system is in the machine independent +FIO interface. FIO handles all buffer allocation and management including +management of buffer caches, record blocking and deblocking, and read ahead +and write behind. FIO makes all files and file storage devices look the same, +and allows new devices to be interfaced dynamically at run time without +modifying the system. The database facilities rely on FIO for efficient +random file access, which requires use of a buffer cache to to minimize file +faults. Image i/o relies on FIO for efficient sequential file access, +which requires asynchronous i/o and large buffers. +.PP +Kernel support for file i/o consists of a few simple file management +primitives, e.g. for file deletion and renaming, plus the "device drivers" for +the standard devices. There are two basic types of files, \fBtext files\fR +and \fBbinary files\fR. The device driver for a text device consists of +8 subroutines; the driver for a binary device consists of 6 subroutines. +A different set of driver subroutines are required for each device interfaced +to FIO. All system and device dependence is hidden within and beneath these +subroutines. Most devices are interfaced to FIO as binary files. Kernel +device drivers are closely matched in capabilities to the actual device +drivers found on many systems. +.PP +The file access modes, device parameters, and other codes used to communicate +with the kernel file i/o primitives are summarized in the table below. + +.TS +center box; +cb s s +ci | ci | ci +l | c | l. +FIO Kernel Constants +_ +name value usage += +BOF \(mi3 beginning of file +EOF \(mi2 end of file +_ +READ_ONLY 1 file access modes +READ_WRITE 2 +WRITE_ONLY 3 +APPEND 4 write at EOF +NEW_FILE 5 create a new file +_ +TEXT_FILE 11 file types +BINARY_FILE 12 +_ +FSTT_BLKSIZE 1 device block size +FSTT_FILSIZE 2 file size, bytes +FSTT_OPTBUFSIZE 3 optimum transfer size +FSTT_MAXBUFSIZE 4 maximum transfer size +.TE +.sp 0.08i + +.NH 3 +Text Files +.PP +A \fBtext file\fR is a sequence of lines of text, i.e., of characters. +Examples of text files are parameter files, list files, program source files, +and \fBterminals\fR. Although it is not strictly required, it is desirable +that text files be maintained in such a form that they can be accessed by the +host system file editor and other host utilities. The principal function +of the text file primitives is to convert text data from the host format +to the IRAF internal format, and vice versa. +.PP +The physical representation of a text file is hidden beneath the kernel +interface and is not known to an IRAF program. +The logical (IRAF) and physical (host system) representations of a text +file will in general be quite different. On some systems +it may be possible to represent a single logical text file in any of several +different physical representations, and the kernel primitives will have to +be able to recognize and deal with all such representations. On other systems +there may be only a single physical format for text files, or there may be no +distinction between text files and binary files. +.PP +The \fBlogical representation\fR of a text file is a sequence of lines of text. +Each line of text consists of zero or more ASCII characters terminated by +the \fBnewline\fR character. The newline character defaults to ASCII LF +(linefeed), but some other character may be substituted if desired. +IRAF assumes that any ASCII character can be stored in a text file; +in particular, case is significant, and control characters may be embedded +in the text. There is no fixed limit on the number of characters per line. +It may not be possible to edit a file containing arbitrarily long lines +or embedded control characters with some host system editors, but such files +are rare. +.PP +Character data is represented within IRAF with the SPP datatype \fBchar\fR. +On many systems, char is implemented as the (nonstandard) Fortran datatype +INTEGER*2. The read and write primitives +for a text file must convert SPP arrays of ASCII char to and from the +internal host representation. This conversion usually involves a packing +or unpacking operation, and may also involve conversion between ASCII and +some other character set, e.g., EBCDIC. Regardless of the precision of the +datatype used to implement char on a given host system, characters are +limited to ASCII values, i.e., 0 to 127 decimal (negative valued characters +are permitted only in SPP variables and arrays). +.PP +The kernel primitives used to access ordinary disk resident text files, +i.e., the "device driver" primitives for an ordinary text file, are shown below. +The calling sequences for other text file devices are identical if the +two character device code for the new device is substituted for the "tx" +suffix shown. A device driver is installed in FIO by passing the entry +points of the subroutines to FIO with \fBfopntx\fR or \fBfdevtx\fR; +the entry point addresses of the 8 subroutines are saved in the FIO device +table. +.PP +The \fBzopntx\fR primitive opens a text file or creates a new one, +returning the channel number (an integer magic number) or ERR as +its status value. +All subsequent references to the file are by this channel number. +The file access modes are listed in the table in \(sc4.3. +Output text is assumed to be buffered; \fBzflstx\fR is called by FIO to flush +any buffered output to the device when the file is closed, or when file output +is flushed by the applications program. +.sp 0.08i +.TS +center; +cb s +n l. +Text File Primitives +.sp +zopntx \&(osfn, mode, chan) open or create a textfile +zclstx \&(chan, status) close a textfile +zgettx \&(chan, text, maxch, status) get next record +zputtx \&(chan, text, nchars, status) put next record +zflstx \&(chan, status) flush output +znottx \&(chan, loffset) note file position +zsektx \&(chan, loffset, status) seek to a line +zstttx \&(chan, param, lvalue) get file status +.TE +.sp 0.08i +.PP +If the physical file is record oriented, there will normally be one newline +delimited line of text per record. A sequence of characters output with +\fBzputtx\fR is however not necessarily terminated with a newline. +The \fBzputtx\fR primitive is called to write the FIO output buffer when +(1) newline is seen, (2) the buffer fills, (3) the output is flushed, +or (4) the file is closed. Thus if a very long line is written, several +calls to \fBzputtx\fR may be required to output the full line. Conversely, +if the input record contains more than \fImaxch\fR characters, \fBzgettx\fR +should return the remainder of the record in the next call. In no case should +more than maxch characters be returned, as the output buffer would be overrun. +.PP +A \fBzgettx\fR call with \fBmaxch=1\fR has a special meaning when the input +device is a terminal. This call will switch the terminal from line mode to +\fBcharacter mode\fR, causing \fBzgettx\fR to return immediately each time a key +is typed on the terminal. This highly interactive mode is useful for programs +like screen editors, and is discussed further in \(sc4.3.4.1. Character mode +applies only to terminal input; if individual characters are to be output, +the output must be flushed after each character is written. +.PP +Text files are virtually always accessed sequentially. Writing is permitted +only at end of file (EOF). A file opened for reading is initially positioned +to the beginning of file (BOF). Seeking to the beginning of any line in the +file is permitted prior to a read. The seek offset must be BOF, EOF, or an +offset returned by a prior call to the \fBznottx\fR primitive, which returns +the file offset of the last text line read or of the next text line to be +written. Seeks on text files are restricted to lines; seeks to individual +characters are not permitted. The long integer file offset returned by +\fBznottx\fR is a magic number, i.e., the value is assumed to be machine +dependent. +.NH 3 +Binary Files +.PP +A \fBbinary file\fR is an extendible array of bytes accessed in segments the +size of a device block. The principal difference between a text file and +a binary file is that character data is converted in some machine dependent +fashion when a text file is accessed, whereas data is copied to and from +a binary file without change. A second difference is that only binary files +are randomly accessible for both reading and writing at any offset. +Binary files are used to implement interprocess communication (IPC) files, +database files (datafiles), picture storage files (imagefiles), and so on. +Special devices such as magtape, the line printer, image display devices, +and process memory are interfaced to FIO as binary files. +.PP +The fundamental unit of storage in a binary file is the \fBmachine byte\fR. +The number of bits per byte is presumed to be machine dependent, although +IRAF has thus far been used only on machines with 8 bit bytes. IRAF assumes +only that there are an integral number of bytes in each SPP or Fortran datatype. +The SPP datatype \fBchar\fR should not be confused with the machine byte. +The char is the fundamental unit of storage in SPP programs; the number +of machine bytes per SPP char is greater than or equal to one and is given +by the machine dependent constant SZB_CHAR, defined in \fBiraf.h\fR. +Though the distinction between chars and machine bytes is important in the +high level system code, it is of no concern in the kernel since the kernel +routines access binary files only in units of machine bytes. +.PP +Binary files are further differentiated into \fBblocked\fR (random access) +binary files and \fBstreaming\fR (sequential) binary files. The most +common blocked binary file is the binary random access disk file. +IPC files and magtape files are typical streaming binary files. +The \fBdevice block size\fR is used to differentiate between blocked and +streaming binary files. A device with a block size greater than or equal +to one byte is understood to be blocked, whereas a device with a block size +of zero is understood to be a streaming file. Transfers to and from blocked +devices are always aligned on device block boundaries. There are no alignment +restrictions for streaming files. +.sp 0.08i +.TS +center; +cb s +n l. +Binary File Primitives +.sp +zopnbf \&(osfn, mode, chan) open or create a binary file +zclsbf \&(chan, status) close a binary file +zardbf \&(chan, buf, maxbytes, loffset) initiate a read at loffset +zawrbf \&(chan, buf, nbytes, loffset) initiate a write at loffset +zawtbf \&(chan, status) wait for transfer to complete +zsttbf \&(chan, param, lvalue) get file status +.TE +.sp 0.08i +.PP +The kernel primitives used to access ordinary disk resident binary files, +i.e., the "device driver" primitives for a binary file, are shown above. +The calling sequences for other binary file devices are identical if the +two character device code for the new device is substituted for the "bf" +suffix shown. The device driver for a binary file is particularly simple +since all buffering is performed at a high level. A binary file is opened +or created with \fBzopnbf\fR, which returns the channel number or ERR as +its final argument. All subsequent references to the file are by channel +number. +.PP +The kernel primitives for a binary file closely approximate the functionality +of the typical host system device driver. +Ideally an asynchronous kernel read or write +to a binary file will translate into a DMA transfer directly from the data +buffer to the device, or vice versa. FIO guarantees that only a single transfer +will be pending on a channel at a time, i.e., that a new i/o request will not be +issued until any previous transfer is completed. There is no \fBseek\fR +primitive for binary files since the absolute file offset is specified in +a read or write request (the file offset argument should be ignored for a +streaming file). There is no \fBnote\fR primitive since there is no concept +of the current file position for a binary file at the kernel level. +.PP +The \fBzardbf\fR and \fBzawrbf\fR (asynchronous read and write) primitives +should initiate a transfer and return immediately. No status value is +returned by these primitives: rather, the number of bytes read or written +or ERR is returned in the next call to \fBzawtbf\fR (asynchronous wait). +A byte count of zero on a read indicates end of file. It is not an error +if fewer than \fBmaxbytes\fR bytes can be read; \fBzardbf\fR should return +immediately with whatever data it was able to read, rather than try to +read exactly maxbytes bytes. In no case should more than maxbytes bytes +be returned, as this would overflow the caller's buffer. If the size of the +input block or record is greater than maxbytes bytes when reading from a +streaming file, data is assumed to be lost. An attempt to read or write +before BOF or after EOF is illegal and will be caught by FIO. +.PP +The status value ERR should be returned for all illegal requests or +i/o errors. FIO will always call \fBzawtbf\fR after a transfer for +synchronization and to check the status value. Repeated calls to \fBzawtbf\fR +after a single i/o transfer should continue to return the same status. +Errors should not "stick", i.e., an error status should be cleared when +the next transfer is initiated. +.PP +It is fundamentally assumed that it is possible to extend a file by +overwriting EOF in a call to \fBzawrbf\fR. It is further assumed that the +last block in a file need not be full. For example, suppose the device +block size is 512 bytes, the FIO buffer size is 512 bytes, and we are +writing to a file 1024 bytes long. We write 18 bytes at file offset 1025, +the fourth block in the file, and then close the file. +When the file is subsequently reopened, FIO will call \fBzsttbf\fR to get +the file size, which should be 1042 bytes. If the program calling FIO +then attempts to write 50 bytes at EOF, FIO will call \fBzardbf\fR to initiate a +read of 512 bytes at file offset 1025, and a subsequent call to \fBzawtbf\fR +will return a byte count of 18. FIO will copy the 50 bytes into the buffer +starting at byte offset 19 and eventually write the buffer to the file +at file offset 1025, overwriting EOF and extending the file. +.PP +.NH 3 +Specifying Device Parameters +.PP +Each device interfaced to FIO has a unique status primitive callable while +the file is open to obtain values for the device parameters. +These parameters reflect the characteristics of the \fIdevice\fR +or \fIfilesystem\fR on which the file is stored. +The status primitives for disk resident text and binary +files are \fBzstttx\fR and \fBzsttbf\fR. These primitives are the only file +status primitives available for a file while it is open; \fBzfinfo\fR is not +called to get information on open files. +.PP +The device block size and file size parameters are currently not used for +text files, although they are read when the file is opened. +The file size parameter is not needed for text files because \fBzsektx\fR +is used to seek to EOF on a text file. All four parameters are required for +binary files. +.sp +.in 1.0i +.ti -0.5i +FSTT_BLKSIZE +.sp 0.04i +The device block size in bytes (binary files only). A block size of zero +indicates a streaming device; no alignment checking will be performed, +and only sequential i/o will be permitted. +If the block size is greater than or equal to one, the device is understood +to be a random access binary file with the indicated device block size. +File reads and writes will be aligned on device block boundaries, +although if the block size is given as 1 byte (e.g., if process memory is +accessed as a file) there is effectively no restriction on block alignment. +.sp +.ti -0.5i +FSTT_FILSIZE +.sp 0.04i +The file size in bytes; zero should be returned for a new file. +Not used for streaming files. FIO will ask for this once, when the file +is opened, if the file is a regular disk resident binary file. +Thereafter FIO keeps track of the file size itself. If necessary the +kernel can get the file size from the host system before opening the file. +.sp +.ti -0.5i +FSTT_OPTBUFSIZE +.sp 0.04i +The optimum transfer or buffer size for "normal" file access. This parameter +defines the default FIO buffer size for both read and write access. +The optimum transfer size typically depends on the characteristics of +the i/o system of the host, and may also depend on the characteristics +of the device or of the file system on which the file is found. +For example, the optimum transfer size of a file system configured for +the storage of images (large files) may well be larger than that for a +file system configured for general use (predominantly small files). +.sp +.ti -0.5i +FSTT_MAXBUFSIZE +.sp 0.04i +The maximum permissible transfer size in a single read or write request. +This parameter determines the maximum FIO buffer size, and hence the +maximum size of a FIO read or write request. +.in -1.0i +.sp +.PP +The optimum buffer size for magtape devices is usually different (larger) +for reading than for writing; the default magtape buffer sizes are set by +system tuning parameters in \fBconfig.h\fR (\(sc6). FIO automatically +adjusts the internal FIO buffer size for a file to be an integral multiple +of the device block size. The FIO buffer size may be further controlled +at a high level by advising FIO that i/o to a file is to be highly random +or highly sequential. With all this going on in the high level code, +it is inadvisable to try to tune the system by adjusting the device +parameters. The file status parameters should reflect the physical +characteristics of the device or files system on which the file is resident. +.PP +For example, consider a random access binary disk file on a UNIX system. +The device block size will typically be 512 bytes and is generally wired +into the status primitive as a constant. The file size may be obtained +at any time from the inode for the file. The optimum buffer size is +512 bytes on V7 UNIX, 1024 bytes on 4.1BSD, and dependent on how a filesystem +is configured on 4.2BSD. There is no maximum transfer size for a disk +file, so the maximum integer value is returned. If the file happens to +be a pipe, the block size would be given as 0, the file size is ignored, +the optimum transfer size is arbitrary, e.g. 2048 bytes, and the maximum +transfer size is typically 4096 bytes. +.NH 3 +Standard File Devices +.PP +The kernel routines for the ordinary text and binary disk files have +already been presented. An arbitrary number of other devices may be +simultaneously interfaced to FIO. The standard devices are disk, memory, +terminal, line printer, IPC, magtape, and the pseudofiles (STDIN, STDOUT, +etc.). The memory and pseudofile interfaces are machine independent and +will not be discussed here. The IRAF development system currently also +supports file interfaces for image display devices and plotters, but the +graphics device interfaces are being redesigned to use the ISO standard +Graphical Kernel System (GKS) graphics device interface, so we will not +discuss those devices here. +.PP +Each device is interfaced with a distinct set of kernel interface routines +to give the implementor maximum scope for tailoring the interface to a +device. If the host system provides device independent file i/o at a low level, +it may be possible to use the same kernel routines for more than one device. +For example, the text file driver might be used for both disk resident text +files and terminals, and the IPC, magtape, and line printer devices might +resolve into calls to the kernel routines for a disk resident binary file. +This approach offers maximum flexibility for minimum effort and should be +followed if the host system permits. On the other extreme, a host might +not have something fundamental like IPC channels, and it might be +necessary to build the driver from the ground up using non-file resources +such as shared memory. +.NH 4 +The User Terminal +.PP +Terminal devices are interfaced to FIO as text files. The device code +is "ty". The driver subroutines are shown below. The legal access +modes for a terminal are READ_ONLY, READ_WRITE, WRITE_ONLY, and APPEND. +Seeking to offsets other than BOF or EOF is illegal; seeks to BOF and +EOF should be ignored. +.sp 0.08i +.TS +center; +cb s +n l. +Terminal Driver +.sp +zopnty \&(osfn, mode, chan) open a terminal file +zclsty \&(chan, status) close a terminal +zgetty \&(chan, text, maxch, status) get next record +zputty \&(chan, text, nchars, status) put next record +zflsty \&(chan, status) flush output +znotty \&(chan, loffset) not used +zsekty \&(chan, loffset, status) not used +zsttty \&(chan, param, lvalue) get file status +.TE +.sp 0.08i +.PP +When an IRAF process is run from the CL it communicates with the CL via +IPC files; when not run from the CL, an IRAF process assumes it is talking +to a terminal. The terminal driver is therefore linked into every IRAF main. +The main assumes that the terminal is already open when an IRAF process +starts up; the \fBzopnty\fR and \fBzclsty\fR routines are used only when +a terminal is directly accessed by a program. +.PP +If possible the terminal driver should be set up so that input can come +from either a terminal or an ordinary text file, allowing IRAF processes +to be run in batch mode taking input from a file. On a batch oriented +system the "terminal" driver would be the same as the text file driver, +and input would always come from a file. +.PP +Terminal input is normally line oriented. The host terminal driver +accumulates each input line, handling character, word, and line deletions and +other editing functions, echoing all normal characters, checking for control +characters (e.g. interrupt), and returning a line of text to \fBzgetty\fR +when carriage return is hit. The line returned by \fBzgetty\fR to the +calling program should always be terminated by a \fBnewline\fR. +.PP +If \fBzgetty\fR is called with \fBmaxch=1\fR the terminal is put into raw +character mode. In this mode \fBzgetty\fR returns each character as it +is typed, control characters have no special significance (as far as possible), +and characters are not automatically echoed to the terminal. A subsequent +call with maxch greater than one causes a mode switch back to line input +mode, followed by accumulation of the next input line. +.PP +The IRAF system includes device independent software for terminal control +and vector graphics, and expects to be able to send device dependent control +sequences to the terminal. Any program which does anything out of the ordinary +with a terminal, e.g., clearing the screen or underlining characters, uses +the TTY interface to generate the device dependent control sequences necessary +to control the terminal. Ordinary output to the terminal, however, is not +processed with the TTY interface. +.PP +The control characters commonly present in ordinary text are \fBnewline\fR, +\fBcarriage return\fR, and \fBtab\fR. The \fBnewline\fR character delimits +lines of text and should result in a carriage return followed by a line feed. +\fBZputtx\fR may be called repeatedly to build up a line of text; the output +line should not be broken until newline is sent. The carriage return character +should cause a carriage return without a line feed. If the host system terminal +driver can conditionally expand tabs, tab characters present in the text +should be passed on to the host driver. The terminal should be allowed +to expand tabs if possible as it is much faster, especially when working +from a modem. On many systems it will be necessary to map newlines upon +output, but all other control characters should be left alone. +.NH 4 +The Line Printer Device +.PP +Line printers are interfaced at the kernel level as binary files. +At the FIO level a line printer may be opened as either a text file or +a binary file. If opened as a text file at the FIO level, textual +output is processed under control of the device independent TTY interface, +generating the control sequences necessary to control the device, +then the output is packed and written to the device as a binary byte +stream. If the printer is opened as a binary file at the high level, +binary data is passed from the applications program through FIO and on +to the kernel without modification. +.sp 0.08i +.TS +center; +cb s +n l. +Line Printer Driver +.sp +zopnlp \&(osfn, mode, chan) open printer or spoolfile +zclslp \&(chan, status) close printer +zardlp \&(chan, buf, maxbytes, notused) initiate a read +zawrlp \&(chan, buf, nbytes, notused) initiate a write +zawtlp \&(chan, status) wait for transfer to complete +zsttlp \&(chan, param, lvalue) get file status +.TE +.sp 0.08i +.PP +The line printer is a streaming device. Currently only APPEND mode +is used, although there is nothing in the FIO interface to prevent +reading from a line printer device. The filename argument is the +\fBlogical name\fR of the printer device, as defined by the CL environment +variable \fBprinter\fR and as found in the \fBdev$termcap\fR file. +These logical device names are quite system dependent, and in general +it will be necessary to add new device entries to the termcap file, +and change the name of the default printer device by modifying the +\fBset printer\fR declaration in \fBlib$clpackage.cl\fR. +.PP +On some systems or for some devices it may be desirable to spool printer +output in an ordinary binary file opened by \fBzopnlp\fR, disposing of +the file to the host system when \fBzclslp\fR is called, or at some +later time. This is desirable when the line printer device is so slow +that asynchronous printing is desired, or when the printer device is +located on some other machine and the spoolfile must be pushed through +a network before it can be output to the device. +.PP +In general it should not be necessary to modify printer data upon output. +The high level code processes form feeds, expands tabs, generates control +sequences to underline characters, breaks long lines, maps newline into +the device end of line sequence, pads with nulls (or any other character) +to generate delays, and so on, as directed by the \fBdev$termcap\fR file. +If the host system driver insists on processing printer output itself, +it may be necessary to modify the termcap entry for the printer to generate +whatever control sequences the host system requires (the newline sequence +is likely to be a problem). The termcap entry for a printer is potentially +machine dependent since raw output to a line printer may not be feasible on +some systems, and it may be easier to edit the termcap file than to filter +the output stream in the driver. +.PP +Part of the reason for implementing the printer interface as a binary file +was to provide a convenient and efficient means of passing bitmaps to printer +devices. If a bitmap is to be written to a printer device, ideally the +device will be data driven and it will be possible to pass data directly +to the device without translation. If this is not the case, the driver +must make the device look like it is data driven by scanning the data +stream for a control sequence indicating a change to bitmap mode, +then poking the host driver to change to bitmap mode. Since the device +is data driven at the kernel level it will still be possible to spool +the output in a file and process it on a remote network node. +.NH 4 +Interprocess Communication +.PP +Interprocess communication (IPC) channels are necessitated by the multiprocess +nature of IRAF. When a subprocess is spawned by the CL (or by any IRAF +process) it is connected to its parent by two IPC channels, one for reading +and one for writing. An IPC channel is a record oriented streaming binary +file. +.sp 0.08i +.TS +center; +cb s +n l. +IPC Driver +.sp +zopnpr \&(osfn, mode, chan) not used +zclspr \&(chan, status) not used +zardpr \&(chan, buf, maxbytes, notused) initiate a read +zawrpr \&(chan, buf, nbytes, notused) initiate a write +zawtpr \&(chan, status) wait for transfer to complete +zsttpr \&(chan, param, lvalue) get file status +.TE +.sp 0.08i +.PP +The IPC channels are set up when a subprocess is spawned, and a process may +use IPC facilities only to talk to its parent and its children (the process +structure is a tree, not a graph). Since the opening of an IPC channel is +bound to the spawning of a subprocess, the open and close primitives are +not used for IPC files. The \fBprconnect\fR procedure (not a kernel primitive), +called by the parent to spawn a subprocess, sets up the IPC channels and +installs the IPC driver in FIO, +returning two binary file descriptors to the calling program. +The \fBprconnect\fR procedure is very much like a file \fBopen\fR, except that +the "file" it opens is active. The IRAF main in the child process senses +that it has been spawned by an IRAF process, and installs the same IPC driver +in its FIO, connecting the IPC channels to the streams CLIN and CLOUT. +.PP +Since the IPC channels are read and written by concurrent processes, +some care is necessary to ensure synchronization and to avoid deadlocks. +Fortunately most of the necessary logic is built into the high level protocols +of the CL interface, and an understanding of these protocols is not necessary +to implement the IPC driver. It is however essential that the low level +protocols of an IPC channel be implemented properly or deadlock may occur. +.PP +An IPC channel is \fBrecord oriented\fR. This means that if \fBzawrpr\fR +is called by process A to write N bytes, and \fBzardpr\fR is called by +process B to read from the same channel, N bytes will be read by process B. +If the IPC facilities provided by the host are sufficiently sophisticated, +records may be \fBqueued\fR in an IPC channel. The writing process should +block when the IPC channel fills and no more records can be queued. The +reading process should block when it attempts to read from an empty channel. +.PP +For example, suppose process A writes an N byte record and then an M byte +record. If \fBzardpr\fR is called by process B to read from the channel, +it should return to its caller the first record of length N bytes. +A second call will be required to read the next record of length M bytes. +On some systems, e.g. UNIX, the IPC facilities are not record oriented and the +first read might return either N bytes or N+M bytes, depending on unpredictable +system timing details. Hence the IPC driver for a UNIX system must impose +a record structure upon the UNIX "pipe" used as the IPC channel. +.PP +On other systems the IPC facilities may be limited to the transfer of single +records, i.e., process B will have to read a record +before process A can transmit the next record. This is the lowest common +denominator, and hence the protocol chosen for the IPC driver. Despite the +use of the lowest common denominator for the low level protocol, a high +bandwidth can be achieved for IPC channels if the maximum transfer size +is large and records are queued. The high level protocol ensures that only +one process will be writing or reading at a time, thus preventing deadlock. +The high level protocol also uses special data records as semaphores to achieve +synchronization and permit record queuing. +.PP +Most modern operating systems provide some sort of interprocess communications +facilities which the IPC driver can use. UNIX calls it a pipe or a socket, +VAX/VMS calls it a mailbox, and DG/AOS calls it an IPC port. If the host +system has no such facility, or if the facility provided by the host is +inefficient, an IPC driver can often be built using shared memory (use a +circular buffer to implement the queue). As a last resort, a real driver +can be coded and installed in the host system. On \fBmulti-processor\fR +systems the IPC facilities should allow the parent and child processes to +reside on different processors. +.NH 4 +Imagefile Access +.PP +Imagefiles, i.e., bulk data files, are a special kind of binary file. +The ordinary disk binary file driver may be used to access imagefiles, +but imagefiles have certain properties which can be exploited on some +systems for increased i/o efficiency. The image i/o software (IMIO) therefore +uses a special kernel driver to access imagefiles. Since this driver is +a special case of the ordinary binary file driver, a transportable version +of the driver which simply calls the ordinary binary file driver is included +in the standard distribution. The transportable driver may easily be replaced +by a machine dependent version to optimize image i/o for the host system. +.PP +Imagefiles differ from ordinary binary files in that the size of the image +is known when the \fBpixel storage file\fR is created. Furthermore, images +do not dynamically change in size at run time. On many systems it is possible +to preallocate the pixel storage file before writing any data into it, +rather than creating the file by writing at EOF. +.PP +Preallocation of a file makes it feasible for the host system to allocate +\fBcontiguous storage\fR for the file. Use of a preallocated, fixed size +file also makes it possible on some systems to map the file into +\fBvirtual memory\fR. If image access is expected to be sequential, or if +the host system does not support virtual memory, it is often possible to +\fBdirectly access\fR the file via the host system device driver, bypassing +the host files system software and significantly reducing the overhead of +file access (e.g., eliminating any intermediate buffering by the host system). +.sp 0.08i +.TS +center; +cb s +n l. +Static File Driver +.sp +zopnsf \&(osfn, mode, chan) open static file +zclssf \&(chan, status) close static file +zardsf \&(chan, buf, maxbytes, loffset) initiate a read +zawrsf \&(chan, buf, nbytes, loffset) initiate a write +zawtsf \&(chan, status) wait for transfer to complete +zsttsf \&(chan, param, lvalue) get file status +.sp +zfaloc \&(osfn, nbytes, status) preallocate a binary file +.TE +.sp 0.08i +.PP +The use of a file i/o interface to implement virtual memory access to files +is desirable to minimize the machine dependence of applications which use +virtual memory. The functional behavior of the static file driver is the +same whether it maps file segments into virtual memory or copies file +segments into physical memory. If IRAF is to be used on a system which does +not provide virtual memory facilities, the image processing software +will work without modification, provided the physical memory requirements +of the software are reasonable. +.PP +FIO divides a file up into segments of equal size, where the size of a segment +is equivalent to the size of a file buffer and is an integral multiple of the +virtual memory page size. IMIO ensures that the pixel data in the pixel +storage file begins on a block boundary, and is an integral number of pages +in length. Furthermore, when FIO allocates a file buffer, it ensures that +the buffer is aligned on a virtual memory page boundary. The virtual memory +page size is parameterized in \fBconfig.h\fR, and is set to 1 on a nonvirtual +machine. +.PP +Provided that the buffer and the file data are both properly aligned, +\fBzardsf\fR may be used to map a file segment into memory. The file buffer +pages are first deleted and then remapped onto the new file segment. +If the buffer is written into, \fBzawrsf\fR will eventually be called to +update the segment, i.e., flush modified pages to the image file (the pages +should not be unmapped). If desired a single FIO buffer may be allocated +the size of the entire image and all reads and writes will reference this +single buffer with minimum overhead. Alternatively the image may be mapped +in segments; reusing the same buffers avoids flushing the system page cache +when sequentially accessing a large image. +.PP +When an image section is read or written by IMIO, the interface returns +a pointer to a buffer containing the pixels. If all of the necessary +conditions are met (e.g., no subsampling, no datatype conversion, etc.), +IMIO will return a pointer directly into the file buffer, otherwise IMIO +extracts the pixels from the file buffer into a separate buffer. If the file +buffer is mapped onto the imagefile, IMIO thus returns a pointer directly into +the imagefile without performing any i/o (until the data is referenced). +Thus it is possible to exploit virtual memory for image access without +restricting the flexibility of programs which operate upon images; general image +sections may be referenced, datatypes need not agree, etc., yet i/o will still +be optimal for simple operations. +.PP +For example, suppose an entire large image is to be mapped into virtual +memory. FIO does not allocate any buffers until the first i/o on a file +occurs. IMIO will be called by the applications program to read a "subraster" +the size of the entire image. If the image can be directly accessed, +IMIO will set the FIO buffer size to the size of the image, then issue a +\fBseek\fR and a \fBread\fR to read the pixels. +FIO will allocate the buffer, aligned on a page boundary, then call +\fBzardsf\fR which maps the buffer onto the pixel storage file. +.PP +If all the necessary conditions are met, IMIO will return a pointer into the +FIO buffer and hence to the segment of memory mapped onto the pixel storage +file. If this is not possible, IMIO will allocate a new buffer of its own +and perform some transformation upon the pixels in the FIO buffer, writing +the transformed pixels into the IMIO buffer. The IMIO pointer will be +dereferenced in an subprogram argument list in the applications program, +and the SPP or Fortran subprogram will see what appears to be a static array. +.PP +Most virtual memory implementations are designed more for random access than +for \fBsequential access\fR. +Some systems, e.g. VAX/VMS, allow a variable number of pages (the page fault +cluster) to be read or written when a page fault occurs. +Other systems, e.g., DG/AOS, read or write a single page for each fault. +Even when the page fault cluster can be made large to minimize faulting +when sequentially accessing a large image, i/o is not optimal because paging +is not asynchronous, and because the heavy faulting tends to flush the process +and system page caches. Thus for sequential image operations conventional +double buffering with large buffers and large DMA transfers direct from +disk to memory is preferable. This level of i/o is available via QIO calls +on VAX/VMS and is feasible via \fIphysio\fR calls on UNIX, if images are +static and contiguous or nearly contiguous. +.PP +If the host system provides both virtual memory facilities and low level +asynchronous i/o, the static file driver should ideally be capable of +performing i/o by either technique. The choice of a technique may be based +upon the alignment criteria and upon the size of the transfer. +If the alignment criteria are not met or if the size of the transfer is +below a threshold, conventional i/o should be used. If the size of the +transfer is large, e.g., some sizable fraction of the working set size, +virtual i/o should be used. Virtual memory should only be used for images +which are to be accessed randomly, so the page fault cluster should be small. +.NH 4 +Magtape Devices +.PP +The magnetic tape device interface is the most complex file device interface +in the IRAF system. Operating systems vary greatly in the type of i/o +facilities provided for magtape access, making it difficult to design a +machine independent interface. Some systems provide primitive access to +the drive, permitting file and record skipping, writing of tape marks, +and so on, while others permit only sequential access in the forward direction. +Magtape access is further complicated by the storage of multiple files on +a tape, by variable size records, the occasional need to swap bytes, +and the need to specify the density. Error recovery is particularly difficult +for magtape devices because it is possible to lose track of the position +of the tape: whereas most binary devices are accessed by absolute offset, +magtapes are accessed relative to the current position. +.PP +To avoid having to deal with this level of complexity in the kernel, +the magtape device driver has been subdivided into a machine independent +part and a unique magtape device interface. The standard streaming +binary file driver subroutines are coded in SPP and are portable. An inner +set of six "zz" routines are defined especially for accessing magtape +devices. The portable driver routines constitute the MTIO interface and +are not part of the kernel. MTIO opens and initializes multiple magtape +devices, keeps track of the file position, and handles error recovery. +The kernel routines are responsible for physically positioning the tape +and for reading and writing records. +.sp 0.08i +.TS +center; +cb s +n l. +Magtape Driver +.sp +zopnmt \&(osfn, mode, chan) open a magtape file +zclsmt \&(chan, status) close magtape device +zardmt \&(chan, buf, maxbytes, notused) initiate a read +zawrmt \&(chan, buf, nbytes, notused) initiate a write +zawtmt \&(chan, status) wait for transfer to complete +zsttmt \&(chan, param, lvalue) get file status +.TE +.sp 0.08i +.PP +A magtape device must be \fBallocated\fR at the CL level before the device +can be accessed. A file on a magtape device is opened by calling the program +interface procedure \fBmtopen\fR in an applications program. +Once opened, a magtape file is accessed via the FIO interface and +hence benefits from the buffer management facilities provided by FIO. +Use of the FIO interface also provides device independence, allowing programs +which access magtape to be used to (sequentially) access any other binary +file. In particular, any IRAF program which commonly accesses magtape may +also be used to access a disk file. This permits use of the FITS reader and +writer, for example, for image transmission between stranger machines in a local +area network. +.PP +When a magtape device is allocated a device \fBlock file\fR is written into +the IRAF public directory \fBdev$\fR by the high level code. In addition to +telling other IRAF processes that the device has been allocated, the lock file +is used to keep track of the tape position while the device is closed. +When a device is closed, either normally or during error recovery, a new lock +file is written recording the current position of the drive as well as various +statistics (owner, time of last access, number of records read or written, +etc.). When a device is opened the lock file is read to determine the +current position. The \fBsystem.devstatus\fR program prints the contents +of the device lock file; if there is no lock file, the IRAF system assumes +that the device has not been allocated. +.PP +Each file on a reel must be opened individually, just as each file on a disk +must be opened individually. A pair of calls to \fBmtopen\fR and \fBclose\fR +(FIO) are required to access each file. +Drives are referred to by the logical names "mta", "mtb", and so on. +The assignment of logical drives to physical devices is system dependent. +The logical drive number, density, absolute file number on the tape, +absolute record number within the file, access mode, and FIO buffer size +(most of which can be defaulted) are specified in the file "name" argument +when the file is opened. For example, the filespec "mtb1600[3,10]" refers +to record 10 of file 3 of logical drive "mtb" at 1600 bpi. The minimum +filespec consists of just the logical drive name; everything else is optional. +.PP +The \fBmtopen\fR procedure parses the magtape filespec to determine whether +a magtape device or a disk binary file is being referenced. If a disk file +is named, \fBmtopen\fR reduces into a conventional call to \fBopen\fR. +If a magtape file is named, the filespec is parsed to determine the logical +drive, density, and the file and record numbers to which the tape is to +be opened. If this information is legal, if the drive is allocated, +and if the drive is not already open, \fBmtopen\fR reads the lock file to +determine the current position. FIO is then called to open the device. +A global common is used to pass device dependent information from \fBmtopen\fR +to \fBzopnmt\fR, since device dependent information cannot be passed through +FIO. +.PP +The magtape kernel primitives are shown below. Our intent here is only to +introduce the routines and discuss the role they fulfill in the MTIO interface. +Detailed specifications for the routines are given in the manual pages. +.sp 0.08i +.TS +center; +cb s +n l. +Magtape Kernel Primitives +.sp +zzopmt \&(drive, density, mode, oldrec, oldfile, newfile, chan) open +zzclmt \&(chan, mode, nrecords, nfiles, status) close +zzrdmt \&(chan, buf, maxbytes) aread +zzwrmt \&(chan, buf, nbytes) awrite +zzwtmt \&(chan, nrecords, nfiles, status) await +zzrwmt \&(chan, status) arewind +.TE +.sp 0.08i +.PP +The \fBzopnmt\fR procedure is called by FIO to open a magtape device. +The only legal access modes for magtape files are READ_ONLY and WRITE_ONLY. +The device parameters are retrieved from the global common prepared by +\fBmtopen\fR and passed on to the kernel primitive \fBzzopmt\fR to physically +open the drive. The kernel open primitive sets the density of the drive and +opens the drive with the desired access mode, leaving the tape positioned to +record 1 of the desired file. +.PP +The exact position of the tape at open time, i.e., both file and record +numbers (one-indexed), is passed to \fBzzopmt\fR to facilitate positioning +the tape. Many systems can skip records and tapemarks in either the forward +or reverse direction, and it is easy to position the tape on such systems +given the current position and the new position. The current record number +is needed to tell \fBzzopmt\fR when the current file is already rewound. +On some systems it is not possible to backspace to the last tapemark, +and the only way to rewind the current file or position to a previous file +is to rewind the tape and read forward. +.PP +Upon input to \fBzzopmt\fR, the \fInewfile\fR argument specifies the number +of the file to which the tape is to be positioned, or the magic number EOT. +Upon output, \fInewfile\fR contains the number of the file to which the +tape was actually positioned. The high level code assumes that the +tape does not move when the device is closed and subsequently reopened; +if this is not the case, \fBzzopmt\fR should ignore the old position arguments. +.PP +The \fBzzrdmt\fR and \fBzzwrmt\fR primitives initiate an asynchronous +read or write of a record at the current tape position. The number of bytes +read or written and the number of records and or files skipped in the operation +are returned in the next call to \fBzzstmt\fR. If a tape mark is seen when +attempting to read the next record, \fBzzwtmt\fR should return a byte count +of zero to signal EOF. It does not matter whether the tape is left positioned +before or after the tape mark, provided the record and file counts are +accurate. +.PP +A file containing zero records marks logical EOT. If physical EOT is seen +either the host system or the kernel should signal the operator to mount +the next reel, returning only after a record has been read or written on +the next reel. The high level code does not try to reread or rewrite +records. Error retry should be handled either by the kernel routines or +preferably by the host driver. The kernel should return ERR only if it +cannot read or write a record. It is not an error if less data is read +than was requested, or if more data was available in the record than was +read, resulting in loss of data. Loss of data is unlikely because FIO +generally allocates a large (16K or 32K) input buffer when reading magtapes. +.PP +If an error occurs when accessing the magtape device, e.g. a keyboard +interrupt, the high level code will mark the position of the tape as +undefined and call \fBzzclmt\fR to close the device. When the device is +subsequently reopened, \fBmtopen\fR will see that the position of the tape +is undefined and will rewind the tape before calling \fBzzopmt\fR to open +and position the drive. Since this is handled by MTIO, the kernel routines +need not be concerned with error recovery except possibly to abort a tape +motion if an interrupt occurs, to prevent runaway (hopefully this will not +be necessary on most systems). +.PP +The \fBzzclmt\fR primitive will be called to close the device upon normal +termination or during error recovery. MTIO assumes that \fBzzclmt\fR will +write an EOT mark (two tapemarks) \fIat the current tape position\fR when +a tape opened with write permission is closed. This is the only way in which +MTIO can write EOF and EOT marks on the tape. To avoid clobbering tapes, +\fBzzopmt\fR may need to open the drive read-only while positioning the tape. +Since an interrupt may occur while the tape is being positioned, \fBzzopmt\fR +should return the OS channel argument immediately after the channel has been +opened, before positioning the tape. +.PP +In summary, the magtape kernel primitives are highly machine independent +because they permit access to only a single file at a time, reading or +writing sequentially in the forward direction. No primitive tape positioning +commands are required except \fBzzrwmt\fR, and that can be implemented +with a call to \fBzzopmt\fR if necessary (the difference is that \fBzzrwmt\fR +may be asynchronous). No assumptions are made about where the tape is left +positioned if an error occurs or if a tapemark is read or written. +All writing of tapemarks is left to the kernel or to the host system. + +.NH 2 +Filename Mapping +.PP +The syntax of a filename is highly system dependent. This poses a major +obstacle to transporting a large system such as IRAF, since the standard +distribution consists of several thousand files in several dozen directories. +Many of those files are referred to by name in the high level program sources, +and use of host system dependent filenames in such a context would make the +IRAF system very difficult to transport. +.PP +To avoid this problem only \fBvirtual filenames\fR (VFNs) are used in IRAF +source files. FIO converts a VFN into a host system dependent filename (OSFN) +whenever a filename is passed to a kernel routine. Conversely, when FIO reads +a directory it converts the list of OS filenames in the host directory into +a list of virtual filenames. The kernel routines see only machine dependent +filenames packed as Fortran character constants. +.PP +While it is not necessary to study filename mapping to implement the kernel, +filename mapping is a vital part of the system interface and an understanding +of the mapping algorithm employed is necessary to adjust the machine dependent +parameters controlling the mapping. The filename mapping parameters are given +in the system configuration file \fBlib$config.h\fR. +.NH 3 +Virtual Filenames +.PP +A VFN consists of three fields, the \fBdirectory\fR, the \fBroot\fR, +and the \fBextension\fR. Directories are specified by a \fBlogical +directory\fR name followed by a \fBpathname\fR to a subdirectory. +Either the logical directory name or the pathname may be omitted. +If the logical directory field is omitted the current directory is assumed. +The extension field is optional and is used to specify the file type, +e.g., CL source, SPP source, object module, and so on. Either the logical +directory delimiter character \fB$\fR or the subdirectory delimiter +character \fB/\fR may delimit the directory field, and a period delimits +the root and extension fields. +.DS + \fIdir\fR \fB$\fR \fIpath\fR \fB/\fR \fIroot\fR \fB.\fR \fIextn\fR +.DE +.PP +The combined length of the root and extension fields is limited to 32 +characters. The legal character set is \fBA-Za-z0-9_.\fR, i.e., +the upper and lower case alphanumerics (case is significant), underscore, +and period. Other characters may be permitted on some systems, but if +present the filename is machine dependent. The first character of a filename +is not special, i.e., the first character may be a number, underscore, +or any other filename character. Purely numeric filenames are permitted. +The VFN syntax does not support VAX/VMS-like version numbers. A file naming +syntax would not be sufficient to emulate versions; extensive FIO support +would also be required on systems other than VMS. +.PP +The following are all legal virtual filenames (avoiding directory specifications +for the moment). +.DS + 20 + 02Jan83 + Makefile + 10.20.11 + M92_data.Mar84 + extract_spectrum.x + _allocate +.DE +.NH 4 +Logical Directories and Pathnames +.PP +The use of logical directories and pathnames is perhaps best explained by +an example. Consider the VFN \fBplot$graph.x\fR, specifying the file +\fBgraph.x\fR in the logical directory \fBplot\fR. +The logical directory \fBplot\fR is +defined in the CL environment (file \fBlib$clpackage.cl\fR) as follows. +.DS + \fBset plot = "pkg$plot/"\fR + \fBset pkg = "iraf$pkg/"\fR +.DE +These definitions state that \fBplot\fR is a subdirectory of \fBpkg\fR, +and that \fBpkg\fR is a subdirectory of \fBiraf\fR, the root directory of +the IRAF system. The definition for the root directory is necessarily +both machine and configuration dependent. On a VAX/VMS system \fBiraf\fR +might be defined as follows: +.DS + \fBset iraf = "dra0:[iraf]"\fR +.DE +Recursively expanding the original VFN produces the following partially +machine dependent filename: +.DS + \fBdra0:[iraf]pkg/plot/graph.x\fR +.DE +The final, fully translated, machine dependent filename is produced by +folding the subdirectory names into the VMS directory prefix, mapping +the remaining filename (which does not change in this case), and concatenating: +.DS + \fBdra0:[iraf.pkg.plot]graph.x\fR +.DE +.PP +The important thing here is that while there may be many directories in the +system, \fIonly the definition of the IRAF root directory is machine +dependent\fR. Filenames in package script tasks, in the \fBhelp\fR database, +in makefiles, and so on inevitably include references to subdirectories, +hence the VFN syntax must recognize and map subdirectory references to fully +address the problems of machine independence. +.PP +Even when porting the system to another host running the same operating +system the root directory may (and usually will) change. +Since all logical directories and filenames are defined in +terms of the root directory, since the root is defined at runtime, and since +filenames are mapped at runtime, the system may be ported to another machine +running the same operating system by editing only one file, \fIwithout having +to recompile the system\fR. The importance of not having to recompile the +system becomes clear when the local hardware configuration changes or when +installing periodic updates at a site with multiple host computers all running +the same operating system. +.sp 0.08i +.TS +center; +cb s +n l. +Filename Mapping Primitives +.sp +zfsubd \&(osdir, subdir, new_osdir, maxch, nchars) fold subdir into osdir +zfxdir \&(osfn, osdir, maxch, nchars) get directory prefix +zfpath \&(osfn, pathname, maxch, nchars) get absolute pathname +.TE +.sp 0.08i +.PP +The primitives used to map filenames are shown above. The \fBzfsubd\fR +primitive folds a subdirectory name into a machine dependent directory +name (OSDIR), producing the OSDIR name of the subdirectory as output. +The subdirectory name ".." refers to the next higher directory in the +hierarchy, allowing upwards directory references. The form of a host +directory name is undefined, hence the primitive \fBzfxdir\fR is required +to extract a machine dependent directory prefix from a host filename (OSFN). +Directory expansion does not guarantee that the OSFN produced is independent +of the current working directory, hence the \fBzfpath\fR primitive is provided +to convert OSFNs into absolute pathnames. +.NH 4 +Filename Extensions +.PP +Filename \fBextensions\fR, like directories, pose a problem because different +operating systems use different extensions for the same logical file types. +Thus a Fortran source file might have the extensions ".f", ".f77", and +".for" on various systems. IRAF defines a standard set of file extensions +to be used in virtual filenames. Filename extensions are mapped by string +substitution when a file is referenced; unrecognized extensions are left alone. +The standard extensions used in IRAF virtual filenames are essentially those +used by UNIX, plus extensions for the special IRAF file types (e.g., +CL script files and parameter files). +.PP +To illustrate the mapping of filename extensions, consider the IRAF system +library \fBlib$libos.a\fR, which contains the kernel routines in object form. +On a UNIX system this might be expanded as "\fB/usr/iraf/lib/libos.a\fR", +whereas on a VMS system it might be converted to \fBdra0:[iraf.lib]libos.olb\fR. +.PP +The standard IRAF filename extensions are listed in the table below. +Those which are system dependent and are normally mapped are marked +at the right. +.sp +.TS +center box; +cb s s +c | c c +c | l c. +Standard Filename Extensions += +Extension Usage Mapped +_ +\\.a Library file (archive) ** +\\.c C language source ** +\\.cl Command Language script file +\\.com Global common declaration +\\.db database file +\\.e executable image ** +\\.f Fortran 77 source file ** +\\.h SPP header file +\\.hlp \fILroff\fR format help text +\\.ms \fITroff\fR format text +\\.o object module ** +\\.par CL parameter file +\\.pix pixel storage file +\\.x SPP language source +.TE +.sp +.PP +For the convenience of the user working interactively within the IRAF +environment, FIO permits virtual and host system dependent filenames +to be used interchangeably. Any arbitrary file or directory in the host +system may be referenced as an argument to an IRAF program, even if the +host directory has not been assigned a logical name. The filename mapping +scheme thus provides indirect support for pathnames, by permitting the +use of OS dependent pathnames to specify files when working interactively. +If a machine dependent filename is given, mapping of the root and extension +fields is disabled. +.NH 3 +Filename Mapping Algorithm +.PP +The primary requirement for filename mapping is that the process be +reversible, i.e., it must be possible to map a VFN to an OSFN and later +recover the original VFN by applying the reverse mapping. The following +additional requirements led to the selection of the algorithm described +in this section. +.sp 0.08i +.RS +.IP \(bu +There should be no efficiency penalty for simple filenames. +.IP \(bu +The algorithm must permit multiple processes to access the same directory +without contention. +.IP \(bu +The mapping must be transparent, i.e., reversible by inspection of the +host system directory, making it easy to work with directories and files +at the host system level. +.IP \(bu +The reverse mapping (OSFN to VFN) should be efficient, i.e., there must +not be a serious degradation of performance for template expansion and +directory listings. +.IP \(bu +The mapping should permit use of IRAF, with some loss of efficiency, +on a computer with a flat directory system. +.RE +.sp 0.08i +.PP +The algorithm selected consists of two phases. If the maximum information +content of a host system filename is sufficiently large, the first phase will +succeed in generating a unique mapping with no significant overhead. +If the first phase fails, the second phase guarantees a unique mapping on +any system with minimal overhead. The first phase maps the VFN into the +OSFN character set using \fBescape sequences\fR to map non-OSFN characters, +preserving the information content of a filename by increasing its length. +If the length of the OSFN thus generated exceeds the maximum filename length +permitted by the host system, the second phase accesses an \fBauxiliary +hidden file\fR to recover the excess information. +.PP +The operation of the mapping algorithm differs slightly depending on whether +an existing file is to be accessed or a new file is to be created. +The procedure followed to generate a unique OSFN when opening an existing +file is outlined below. The complications caused by multiple logical +directories, filename extensions, and transparency to machine dependent +filenames are not relevant to the algorithm and are omitted. +.sp +.DS +.cs 1 18 +\fBalgorithm\fR vfn_to_osfn +.sp .05 +\fBbegin\fR + # Phase one: encode VFN using only legal OSFN characters. +.sp 0.05i + map vfn to osfn using escape sequence encoding + \fBif\fR (length of osfn is within host limit) + \fBreturn\fR (osfn) +.sp 0.05i + # Phase two. Access or read auxiliary file to get OSFN. +.sp 0.05i + squeeze osfn to legal host filename length + \fBif\fR (squeezed osfn is degenerate) { + extract unique_osfn for named vfn from mapping file + \fBreturn\fR (unique_osfn) + } \fBelse\fR + \fBreturn\fR (osfn) +\fBend\fR +.DE +.cs 1 +.sp +.PP +\fBEscape sequence encoding\fR is a technique for mapping illegal characters +into sequences of legal characters. A single illegal character is mapped into +two legal characters. Strings of illegal characters, e.g., a sequence of +characters of the wrong case, are prefixed by a font change sequence. +For example, suppose the host system permits only upper case alphanumeric +characters in filenames. Lower case is the dominant case in VFNs, so case +will be inverted in the mapping and upper case in a VFN must be escaped. +If we pick the letter Y as our escape character, the following mappings might +be established (these are the defaults for VMS and AOS): +.sp 0.08i +.DS +.TS +ci ci ci +c c l. +vfn osfn usage +.sp +y Y0 the escape character itself +tolower Y1 switch to primary case +toupper Y2 switch to secondary case +\\_ Y3 underscore +\\. Y4 period +A-Z YA-YZ upper case letters +.TE +.DE +.sp 0.08i +.PP +The use of escape sequences can result in confusing mappings, +but if the escape character is chosen carefully such cases will be rare. +Most filenames are quite ordinary and will map with at most a case conversion. +Some examples of filenames which do not map trivially are given below. +The maximum length of a filename extension on the host system is assumed +to be 3 characters in these examples. +Any host limit on the maximum number of characters in the root is ignored. +For the purposes of illustration, we assume that the first character of the +OS filename cannot be a number, necessitating use of a no-op sequence. +.sp 0.08i +.in 0.8i +.TS +l l. +20 Y120 +02Jan83 Y102YJAN83 +Makefile YMAKEFILE +10.20.11 Y110Y420.11 +M92_data.Mar84 YM92Y3DATAY4YMAR84 +extract_spectrum.x EXTRACTY3SPECTRUM.X +_allocate Y3ALLOCATE +yy.tab.c Y0Y0Y4TAB.C +README Y2README +.TE +.in -0.8i +.sp 0.08i +.PP +Escape sequence encoding will probably suffice for most filename mapping, +particularly if the host system permits long filenames (e.g., AOS/VS currently +permits filenames of up to 32 characters). If the encoded filename is +too long for the host system, auxiliary files must be used to store the +excess information. A single \fBmapping file\fR is used for the entire +directory to permit efficient inverse mapping when expanding filename templates +and listing directories, and to avoid wasting disk space by generating many +small files. +.PP +If escape sequence encoding produces an OSFN longer than the maximum OS +filename length N, then characters must be discarded to produce an N character +filename. This is done by squeezing the long OSFN, preserving the first few +and final characters of the root, and the first character of the extension +(if any). For example, if the OSFN is CONCATENATE.PAR and N is 9, +the squeezed OSFN will be CONCATEEP.PAR (the mapping is the same as that +employed for long identifiers in the SPP, except that the first character +of the extension is appended). Once this is done, of course, the mapping +is no longer guaranteed to be unique. +.PP +More often than not a squeezed OSFN will be unique within the context +of a single directory. If this is the case it is not necessary to read the +mapping file to convert a VFN to an OSFN, although it is always necessary to +read the mapping file to carry out the inverse transformation. If the mapping +is unique within a directory, a null file with the same root name as the +primary file but with the (default) extension \fB.zmu\fR is created to +indicate that the mapping is unique (e.g., CONCATEEP.ZMU and CONCATEEX.ZMU). +If a second file is created with the same root OSFN and the mapping is no +longer unique, the \fB.zmu\fR directory entry is simply deleted, and the +mapping file will have to be read whenever either file is accessed. +.PP +The utility of the \fB.zmu\fR file is based on the assumption that the +determining the existence of a file is a much less expensive operation on +most systems than opening, reading, and closing the mapping file. +Furthermore, the \fB.zmu\fR file is a null length file, i.e., just an +entry in a directory, so no disk space is wasted. +Use of the advisory \fB.zmu\fR file does however involve an assumption that the +host system permits filename extensions. If this is not the case, +set the maximum length of a filename extension to zero in \fBconfig.h\fR, +and FIO will not generate the files. +.PP +The mapping file is effectively an extension of the directory and hence +will lead to contention problems when \fBconcurrent processes\fR try to +access the same directory. +A process must not be allowed to read the mapping file +while another process is modifying it, and under no circumstances may two +processes write to the mapping file at the same time. This requires that +a process which wishes to modify the mapping file place a lock on the +file before accessing it, and that a process be capable of waiting if the +mapping file is locked. The mapping data must not be buffered, i.e., +the file should be reread every time a (degenerate) file is accessed. +Fortunately contention should be rare since most file accesses to not +require use of the mapping file. +.PP +In summary, the overhead of the filename mapping algorithm should be +insignificant when (1) accessing files with simple names, +and (2) accessing files with long names for which the mapping is unique. +A small but fixed overhead is incurred when a file with a long name is +created or deleted, when a directory is read, and when a file is accessed +for which the mapping is degenerate. If the host computer has a decent +files system the algorithm will incur negligible overhead for all operations. + +.NH 2 +Directory Access +.PP +The capability to read filenames from a host directory is required for +the expansion of filename templates and for the directory listing program. +At the program interface level a directory appears to be a simple text file, +i.e., an unordered list of virtual filenames. A directory file is opened +at the applications level with \fBdiropen\fR and successive VFNs are read +with \fBgetline\fR. The driver procedures used to interface a directory to +FIO as a text file are machine independent. The kernel primitives called +to read OS filenames from a directory are machine dependent and are summarized +below. +.sp 0.08i +.TS +center; +cb s +n l. +Directory Access Primitives +.sp +zopdir \&(osfn, chan) open a directory +zcldir \&(chan, status) close directory +zgfdir \&(chan, osfn, maxch, status) get next OSFN +.TE +.sp 0.08i +.PP +Directory files are read-only and are accessed sequentially. +A single filename is returned in each call to \fBzgfdir\fR as a +packed string, returning as status the length of the string or EOF. +Filenames may be returned in any order; all filenames in the directory +should be returned (there are no "hidden" files at this level). +Raw OS dependent filenames should be returned. The inverse mapping +from OSFN to VFN is carried out in the machine independent code. +.PP +If the host system does not permit direct access to a directory file, +or does not provide a primitive which returns successive filenames, +it may be necessary to read the entire contents of the directory +into a buffer at \fBzopdir\fR time, returning successive filenames +from the internal buffer in \fBzgfdir\fR calls, and deleting the buffer +at \fBzcldir\fR time. + +.NH 2 +File Management Primitives +.PP +The kernel provides a number of general file management primitives for +miscellaneous operations upon files and directories. These are summarized +in the table below. These primitives are all alike in that they operate +upon files by name rather than by channel number. +The file management primitives +read, write, create, and delete the \fIdirectory entries\fR for files; +none access the actual file data. No primitive which operates upon a file +by name will be called while the file is open for i/o. +.sp 0.08i +.TS +center; +cb s +n l. +File Management Primitives +.sp +zfacss \&(osfn, mode, type, status) access file +zfchdr \&(new_directory, status) change directory +zfdele \&(osfn, status) delete a file +zfinfo \&(osfn, out_struct, status) get info on a file +zfmkcp \&(old_osfn, new_osfn, status) make null copy of a file +zfpath \&(osfn, pathname, maxch, status) osfn to pathname +zfprot \&(osfn, prot_flag, status) file protection +zfrnam \&(old_osfn, new_osfn, status) rename a file +.TE +.sp 0.08i +.PP +The \fBzfacss\fR primitive is used to determine whether or not a file +exists, is accessible with the given permissions, or is a text or binary +file. The \fBzfinfo\fR primitive returns a data structure defining the +file type, access modes, owner, size, creation date, time of last modify, +and so on. Information not returned includes whether the file is a text +or binary file, and whether or not the file is protected from deletion, +because this information is expensive to determine on some systems. +The \fBzfprot\fR primitive is called to place or remove delete protection +on a file, and to test whether or not a file is protected. +.PP +Primitives for accessing directories are limited to \fBzfpath\fR, which +returns the pathname of a file or of the current working directory, +and \fBzfchdr\fR, which changes the current directory. There are no +primitives for creating or deleting new subdirectories: thus far no program +has needed such a primitive. Directory creation and manipulation is +probably best left to the host system. +.PP +The assumption that there are only two basic file types, text and binary, +is overly simplistic when it comes to copying an arbitrary file. If an +executable file is copied as a binary file, for example, the copy will +not be executable. The problem is that a conventional binary file copy +operation copies only the file data: the directory entry is not copied, +and information is lost. The \fBzfmkcp\fR primitive makes a zero length +file which inherits all the system dependent attributes of another file, +excluding the filename, length, and owner. The new file is subsequently +opened for appending as either a text or binary file, and the file data +is copied in the conventional manner. Directory files cannot be copied. + +.NH 2 +Process Control +.PP +Process control, interprocess communication, exception handling, and error +recovery are probably the most complex and subtle services provided by the +IRAF virtual operating system, and the most likely to be machine dependent. +Despite the effort to isolate the machine dependence into the kernel and to +make the kernel primitives as simple and self contained as possible, a high +level understanding of the subtleties of process control may be necessary +to debug system problems. An introduction to process control in IRAF is +therefore presented to supplement the specifications for the kernel primitives. +It should be possible for a systems programmer implementing the kernel to +skim or skip most of this section, referring to it only to resolve ambiguities +in the kernel specifications. +.PP +The CL is currently the only process in the IRAF system which spawns other +processes. In this section we present an overview of process control in the +CL, defining important terms, discussing the conceptual model of a subprocess +as a command file, and describing the architecture of the process control +subsystem. The synchronous protocol for communicating with subprocesses +is discussed, as is the asynchronous file oriented protocol for communicating +with background jobs. The function of the IRAF main is described, including +error recovery and implementation strategies for interfacing asynchronous +processes to a host system window manager or job status terminal. The kernel +primitives for process control are presented at the end of the section. +.NH 3 +Overview and Terminology +.PP +From the point of view of the CL, an executable program is a \fBcommand file\fR +containing a sequence of commands to be parsed and executed. Once opened or +\fBconnected\fR, a compiled program is equivalent to a script task or the +user terminal; the CL does not know or care where the commands are coming from. +Any CL command that can be executed from the user terminal can also be executed +by a compiled program or a script task. Calls to external programs, script +tasks, the terminal, or any other \fBlogical task\fR may be nested until the +CL runs out of file descriptors or stack space. +.PP +A \fBprogram\fR is a compiled logical task. An arbitrary number of programs +may be linked together to form a single physical \fBprocess\fR, i.e., +executable file. When an IRAF process is executed the \fBIRAF Main\fR +(main routine or driver procedure) in the subprocess initializes the process +data structures and then enters an interpreter loop awaiting a command from +the input file, which may be an IPC file (the CL), a terminal, or a text file. +Hence, not only does a subprocess look like a file to the CL, the CL looks +like a file to a subprocess. +.PP +Task termination occurs when the CL reads either end of file (EOF) or the +command \fBbye\fR. When a script task terminates the script file is closed; +when a program terminates the associated process may be \fBdisconnected\fR. +A subprocess is disconnected by sending the command \fBbye\fR to the +IRAF Main in the subprocess. The IRAF main cleans up the files system and +dynamic memory, calls any procedures posted by the user program with +\fBonexit\fR, and then returns to its caller (the \fBprocess main\fR), +causing process exit. +.PP +When a process spawns a subprocess, the original process is called +the \fBparent\fR process, and the subprocess is called the \fBchild\fR process. +A parent process may have several child processes, but a child process may +have only a single parent, hence the process structure of IRAF is a rooted +tree. The root process is the interactive CL; the user terminal (or a window +manager process) is the parent of the CL. Since the CL is the only process +which spawns other processes, an IRAF process tree has only two levels. +.PP +Processes communicate with each other only via \fBIPC channels\fR or +ordinary disk files. Since the only way to open an IPC channel is to connect +a subprocess, a process may communicate only with its parent or with one of its +children. Separate channels are used for reading and writing, rather than +a single read-write channel, to conform to the logical model of a subprocess +as a text file and to facilitate record queueing in the write channel. +Since only IPC channels and ordinary files are used for interprocess +communication and synchronization, the parent and child processes may reside +on separate processors in a \fBmultiple processor\fR system configuration. +.PP +The IPC channels are used to pass commands, data, and control parameters. +While a program is executing it sends commands to the CL, +most commonly to get or put the values of \fBCL parameters\fR. +In a get parameter operation the CL responds by printing the value of the +parameter on its output, just as it does when the +same command is typed in interactively. The output of the CL is connected +to the input IPC channel of the child process, which reads and decodes the +value of the parameter, returning the binary value to the calling program. +.PP +The standard input, standard output, standard error output, standard graphics +output, etc. of the child process are known as \fBpseudofiles\fR because the +actual files are opened and controlled entirely by the CL. A read or write +to a pseudofile in the child process is converted into a command to read or +write a binary block of data and sent over the IPC channel along with the +binary data block. Hence, even though most traffic on the IPC channels is +ASCII text, the channels are implemented as binary files. A large transfer +block size is used for all pseudofiles except STDERR to maximize throughput. +All parameter i/o and pseudofile i/o is multiplexed into a single command stream +and transmitted over the two IPC channels. +.PP +To minimize process connects, the CL maintains a \fBprocess cache\fR of +connected but generally idle subprocesses. A process is connected and placed +in the cache when a program in that process is run. A process will remain +in the cache, i.e., remain connected to the CL process, until either a new +process connect forces the process out of the cache or until the cache +is flushed. Since programs execute serially, at most one cached process will be +active at a time. Since several subprocesses may simultaneously be connected +and each subprocess may contain an arbitrary number of programs, the cache +can greatly reduce the average overhead required to run an external program, +while permitting dynamic linking of programs at run time. +.PP +The CL executes programs serially much as a program executes subroutines +serially. The protocol used to communicate with a connected subprocess is +synchronous. To execute a program or general command block as a +\fBbackground job\fR, i.e., asynchronously, the CL spawns a copy of itself +which executes independently of the parent CL. The child CL inherits the +full interior state of the parent CL, including the metacode for the command +to be executed, all loaded packages and parameter files, the environment list, +and the dictionary and stacks. Open files are not inherited, the child CL +is not connected to the parent CL, and the CL subprocess is not placed in the +process cache of the parent. The child CL manages its own process cache +and executes external programs using the synchronous protocol. A child CL +may spawn a child CL of its own. +.NH 3 +Synchronous Subprocesses +.PP +The sequence of actions required to synchronously execute an external compiled +program are summarized below. Only those actions required to execute a +program are shown; the process cache is a local optimization hidden within the +CL which is not relevant to a discussion of the synchronous subprogram protocol. +Everything shown is machine independent except the process main and the +IPC driver. Only a single process may be in control at any one time. +.PP +A process may be spawned by another IRAF process or by the host command +interpreter or JCL. When a process is spawned the host system transfers +control to a standard place known as the \fBprocess main\fR. The process +main must determine what type of parent it has and open the type of input +and output channels required by the parent. If the parent is another process +IPC channels are opened. The process main then calls the IRAF Main which +initializes IRAF i/o and enters the Main interpreter loop to read commands +from the parent. +.sp 0.05i +.DS +.ce +\fBProcess Startup\fR +.sp +\fIParent process:\fR + spawn the subprocess + open IPC channels between parent and child + send commands to initialize environment list in child +.sp +\fIProcess Main in child:\fR + determine whether input device is a terminal, text file, or process + open input and output channels (e.g. the IPC channels) + call the IRAF Main +.sp +\fIIRAF Main in child:\fR + save process status for error restart + initialize file i/o, dynamic memory, and error handling + post default exception handlers + enter interpreter loop, reading commands from parent +.DE +.sp +.PP +An IRAF process will interpret and execute successive commands in its input +file until it encounters either EOF or the command \fBbye\fR. The first +block of commands read by the Main will normally be a sequence of \fBset\fR +statements initializing the process environment (defining logical directories +and devices, etc.). A number of calls to the programs resident in the process +will normally follow. When a program runs it assumes control and begins +issuing commands to the parent to read and write parameters and pseudofiles. +The IRAF i/o system is reset to its default initial state each time a program +terminates (this can be overridden by a program if desired). +.sp +.DS +.ce +\fBProcess Execution\fR +.sp +\fIParent process:\fR + send name of program to be run to the IRAF Main in the child process + redirect command input to child, i.e., transfer control to the + program in the child process +.sp +\fIProgram in child process:\fR + (we were called by the interpreter in the IRAF Main) + execute, sending commands to parent to read and write parameters + and pseudofiles + return to caller (the IRAF Main) when done +.sp +\fIIRAF Main:\fR + flush STDOUT, close any open files, etc. + send the command \fBbye\fR to parent to signal that program has + completed and to return control to the parent + enter interpreter loop, reading commands from parent +.DE +.sp +.PP +A process shuts down or exits only when commanded to do so by the parent, +i.e., when an input file read returns EOF or the command \fBbye\fR is executed. +Any user defined procedures posted with \fBonexit\fR calls during process +execution will be executed during process shutdown. Control eventually +returns to the process main which takes whatever system dependent actions +are required to terminate the process. +.sp +.DS +.ce +\fBProcess Shutdown\fR +.sp +\fIParent process:\fR + if no further programs are to be run, send the command \fBbye\fR + to the child to initiate process shutdown +.sp +\fIIRAF Main:\fR + disable IPC output (parent is no longer reading) + call any user procedures posted with \fBonexit\fR, i.e., flagged + to be executed upon process shutdown + return to caller (the process main) when done +.sp +\fIProcess Main:\fR + terminate subprocess +.sp +\fIParent process:\fR + disconnect child process +.DE +.sp 0.05i +.PP +If a process issues a read request on an IPC channel +and there is no input in the channel, the reading process will block, hence +reading from an empty IPC channel causes process synchronization. Successive +writes are queued until the channel is full, hence writing is generally +asynchronous and some degree of overlapped execution is possible. +Traffic on the IPC channels is restricted to the small set of commands +described in the next section. +.NH 3 +Standard IPC Commands +.PP +Although in principle a subprocess may send any legal CL command to the CL +process, in practice only a small subset of commands are permitted in order to +minimize the size of the interface. A larger interface would mean more +dependence upon the characteristics of a particular CL, making it more +difficult to modify the CL and to support several different versions of the CL. +.PP +The IPC interface commands described in this section are a high level protocol +implemented entirely above the kernel routines to support execution of external +programs by the CL. If the parent process were not the CL and if a new IRAF +Main were implemented (the IRAF Main is an ordinary SPP procedure), then a +quite different protocol could be devised. +.PP +The \fBIRAF Main requests\fR, i.e., the IPC commands sent to the IRAF Main by +the parent process, are shown below in the order in which they are normally +sent to the child process. Italicized text denotes dummy parameters to be +replaced by the name or value of the actual parameter when the command is +issued. Keywords are shown in boldface. Optional characters or arguments are +delimited by square brackets. All commands are ASCII lines of text terminated +by the \fBnewline\fR character. +.sp +.in 1.0i +.KS +.ti -0.5i +\fBset\fR \fIvariable\fR = \fIstring\fR +.ti -0.5i +\fBset\fR @\fIfname\fR +.sp 0.04i +Set the value of an environment variable or set the environment from a file. +If the variable does not exist it is created; if it does exist the new value +silently replaces the old value. The \fBset\fR statement is used to pass +the environment list of the parent to the child process when the subprocess +is connected. The second form of the \fBset\fR statement reads a list of +\fBset\fR declarations from a text file, and is especially useful in debug +mode. +.KE +.sp +.KS +.ti -0.5i +\fB?\fR +.sp 0.04i +Print the names of all user programs linked into the process in tabular +form (i.e. print a menu) on the standard output. This command is not +currently used by the CL; it is most useful when debugging a process run +directly from the host command interpreter. +.KE +.sp +.ti -0.5i +[\fB$\fR] \fIprogram\fR [<[\fIfname\fR]], [[\fIstream\fR[(T|B)]]>[\fIfname\fR]], [[\fIstream\fR]>>[\fIfname\fR]] +.sp 0.04i +Execute the named program. The environment should have been initialized by +the time a program is run. If a dollar sign is prefixed to the command +name, the cpu and clock time consumed by the process are printed on the +standard error output when the task terminates. +If a pseudofile stream has been redirected by the parent or is to be +redirected by the child, this should be indicated on the command line. +Thus the IRAF Main command +.DS +count < +.DE +would run the program \fIcount\fR, informing the IRAF Main that the standard +input has already been redirected by the parent (some programs need to know). +If redirection to or from a named file is indicated, the IRAF Main will open +the file and redirect the indicated stream before running the program. +Pseudofiles streams are denoted by the numerals 1 through 6, corresponding +to STDIN, STDOUT, STDERR, STDGRAPH, STDIMAGE, and STDPLOT. If output is +being redirected into a new file and \fBT\fR or \fBB\fR appears in the +argument (e.g., "4B>file"), a text or binary file will be created as specified. +If the file type suffix is omitted and the output stream is STDOUT or STDERR +a text file will be created, otherwise a binary file is created. +For example, the command +.DS +count <, > file +.DE +directs the Main to flag the standard input as redirected, open the new text +file "file" as the standard output of the the program \fIcount\fR, and then +run the program. When the program terminates the Main will automatically +close the output file. +.sp +.KS +.ti -0.5i +\fBbye\fR +.sp 0.04i +Commands the subprocess to shutdown and exit. The subprocess must not read +or write the IPC channels once this command has been received; the CL +disconnects the subprocess immediately after sending \fBbye\fR. User +procedures posted with \fBonexit\fR are called during process shutdown. +If an irrecoverable error occurs during normal process shutdown it will cause +an immediate \fBpanic shutdown\fR of the process. The kernel writes an +error message to the process standard error channel (e.g. the user terminal) +when a panic shutdown occurs. +.KE +.sp +.in -1.0i +.PP +Although it might appear that initialization of the process environment +list via a sequence of \fBset\fR commands is inefficient, +the \fBset\fR commands are buffered and transmitted to the child process +in large binary IPC blocks to minimize the overhead. +The amount of data transmitted is not significantly +different than it would be if the environment list were transmitted as a +binary array, and matching of the internal environment list data structures in +the two processes is not required. Furthermore, the \fBset\fR command is +ideal when debugging a process or when running a process in batch mode +with a previously prepared command input file. +.PP +The IRAF Main commands are used both by the CL to run an external compiled +program and by the programmer when debugging a process at the host system +level. The IRAF Main knows whether it is being used interactively or not, +and modifies the interface protocol slightly when used interactively to +provide a better user interface. For example, the Main issues a command +prompt only when being used interactively. The form of a parameter request +and of a pseudofile read or write request is also slightly different in the +two cases. +.PP +The \fBCL requests\fR, i.e., the commands sent by a running program to the CL +(or any other parent process) are shown below. These are the only commands +which the child can legally send to the parent, and hence the only commands the +interpreter in the parent need recognize. The noninteractive syntax is shown. +If the parent process is not the CL a completely different protocol can be +used. When a subprocess is run interactively the \fBxmit\fR and \fBxfer\fR +requests are omitted (only the data is sent) and the newline is omitted after a +parameter read request. +.sp +.in 1.0i +.KS +.ti -0.5i +\fIparam\fR = +.sp 0.04i +The parent process is directed to print the single-line value of the +named parameter in ASCII on the child's input IPC channel. The child +decodes the response line and returns a binary value to the program. +.KE +.sp +.KS +.ti -0.5i +\fIparam\fR = \fIvalue\fR +.sp 0.04i +The parent process is directed to set the value of the named parameter to +the indicated ASCII value. The child does not expect a response, and parameter +write requests may be queued in the output IPC channel. +.KE +.sp +.KS +.ti -0.5i +\fBxmit\fR (\fIpseudofile\fR, \fInchars\fR) +.sp 0.04i +The parent process is directed to read exactly \fInchars\fR chars of binary +data from the IPC channel and transmit it without interpretation to the +indicated pseudofile. The child does not expect a response, and pseudofile +write requests may be queued in the output IPC channel. Pseudofiles are +denoted by the numerals 1 through 6, corresponding to STDIN, STDOUT, STDERR, +STDGRAPH, STDIMAGE, and STDPLOT. +.KE +.sp +.KS +.ti -0.5i +\fBxfer\fR (\fIpseudofile\fR, \fImaxchars\fR) +.sp 0.04i +The parent process is directed to read up to \fImaxchars\fR chars of binary +data from the indicated pseudofile and transmit it without interpretation to the +input IPC channel of the child. The binary data block should be preceded +by an ASCII integer count of the actual number of chars in the data block. +.KE +.sp +.KS +.ti -0.5i +\fBbye\fR +.sp 0.04i +Normal program termination. Control is transferred from the +child to the parent. The child returns to the interpreter loop in the +IRAF Main, awaiting the next command from the parent. +.KE +.sp +.KS +.ti -0.5i +\fBerror\fR (\fIerrnum\fR, "\fIerrmsg\fR") +.sp 0.04i +Abnormal program termination. +An irrecoverable error has occurred during the execution of the program +(or of the IRAF Main), and the CL is directed to take an error action for +error number \fIerrnum\fR. The child returns to the interpreter loop in the +IRAF Main, awaiting the next command from the parent. If the error is not +caught and handled by an error handler in a CL script, the error message +\fIerrmsg\fR is printed on the standard error output of the CL and the +child process is commanded to shutdown. +.KE +.sp +.in -1.0i +.NH 3 +Example +.PP +By this point process control probably sounds much more complicated than it +actually is. A brief example should illustrate the simplicity +of the CL/IPC interface. Consider the CL command +.DS +cl> \fBset | match tty\fR +.DE +which prints the values of all environment entries containing the substring +\fBtty\fR. The CL task \fBset\fR is a builtin function of the CL and +hence does not use the IPC interface. We assume that the process +\fBsystem$x_system.e\fR, which contains the program \fImatch\fR, +has already been connected so that it is not necessary to pass the +environment to the child. The traffic over the IPC channels is shown below. +If a running IRAF system is available the process side of this example can +be duplicated by typing \fBecho=yes\fR followed by the command shown above. +.sp 0.08i +.TS +center; +ci ci +l l. +CL Process +.sp +\fBmatch <\fR + \fBpattern=\fR +tty + \fBmetacharacters=\fR +yes + \fBstop=\fR +no + \fBxfer(1,1024)\fR +1024 +\fI(1024 chars of data sent to child)\fR + \fBxfer(1,1024)\fR +368 +\fI(368 chars of data sent to child)\fR + \fBxmit(2,63)\fR + \fI(63 chars of data sent to CL)\fR + \fBbye\fR +.TE +.sp 0.08i +.PP +Each line of text shown in the example is transmitted through the appropriate +IPC channel as a single distinct record. Commands are shown in boldface. +The italicized records represent raw data blocks. +The process \fBsystem$x_system.e\fR contains the fifty or so executable programs +in the \fBsystem\fR package and hence is a good example of the use of +multitasking and the process cache to minimize process connects (as well as +disk space for executable images). +.NH 3 +Background Jobs +.PP +IRAF process control does not support fully asynchronous subprocess execution +for the following reasons: +.sp +.RS +.IP \(bu +The parent and child processes are tightly bound, i.e., while an external +program is executing the CL process is subservient to the applications program. +The fact that the CL is a separate process is an irrelevant detail to +the applications program. From the point of view of the applications program +the CL is a database interface called by CLIO. Applications programs are not +fully functional unless connected to a CL at run time, and a synchronous, +interactive interface between the two processes is assumed. +.IP \(bu +From the point of view of the user or of a CL script, external programs are +subroutines. Subroutines execute serially in the context of the calling +program. In this case the context is defined by the state of the data +structures of the CL, i.e., the dictionary, environment list, loaded packages +and tasks, parameters, and so on. +.IP \(bu +The user does not care whether a task is a subprocess or a CL script, +and tends to think in terms of \fBcommand blocks\fR rather than individual +commands. A command block is a user specified sequence of commands to +be compiled and executed as a single unit. Asynchronous subprocesses +are not interesting; what we want is an asynchronous command block. +.IP \(bu +It is much more difficult to define a machine independent process control +interface for asynchronous subprocesses than for synchronous subprocesses. +The problem is similar to that of designing +a multiprocessing operating system, with the CL acting as the operating system +kernel and the user as the cpu. Asynchronous subprocess execution is +inconsistent with the conceptual model of subprocesses and users as command +files, and is extremely difficult to implement in a portable system in any case. +.RE +.sp +.PP +For these and other reasons, background job execution is implemented in +IRAF by spawning a copy of the foreground CL which executes as a +\fBdetached process\fR, rather than as a connected subprocess. +The child CL manages its own process cache independently of the parent. +All connected subprocesses execute synchronously, i.e., only one process +in a tree of connected processes may be active at a time. +Since the child is never connected to the parent, the background CL may +execute at any time (e.g. in a batch queue), and may continue to execute +after the parent process has terminated (if the host system permits). +.PP +The child CL inherits the data structures of the parent as they existed +immediately after translating the command block into metacode and just prior +to execution. The parent's data structures are propagated to the child by +writing them into a binary file which is subsequently opened and read by the +child. Open files are not inherited. The command block executes in the +child in exactly the same context as it would have had if executed in the +parent, with exactly the same results. +.PP +On many systems background job execution will be predominantly noninteractive, +particularly if background jobs are placed into a batch queue. +Even if a background job is run noninteractively, however, there is no +guarantee that the job will not require interaction during execution, +for example if the user forgot to set the value of a parameter when the +job was submitted. Rather than aborting a background job which needs to +query for a parameter, the CL provides a limited but portable method for +servicing queries from background jobs. Extensive interaction with background +jobs is beyond the capabilities of the portable IRAF system but is not ruled +out; interfacing to \fBwindow management\fR facilities is straightforward +if the host system provides such facilities, and is described in the next +section. +.PP +The CL has a builtin capability for generating and servicing queries from +noninteractive background jobs. Such queries might be normal and expected, +e.g. if a background job executes concurrently with the interactive CL and +limited interaction is desired, or might be a failsafe, e.g. if a background +job has consumed several hours of cpu time and the job would have to be +resubmitted if it were to abort because it could not satisfy a parameter +request. +.PP +The CL will automatically initiate a query request sequence whenever it is +executing in the background and an attempt to service a query by reading +from the process standard input returns EOF. To initiate a query request +the CL writes the query prompt into a \fBservice request file\fR, +writes a status message to the standard error output of the CL process +noting that the job is stopped waiting for parameter input, +and enters a loop waiting for the \fBquery response file\fR to be created. +When the query response file becomes accessible the CL opens it, +reads the contents to satisfy the original read request, +deletes the file, and continues normal execution. +.PP +If there is no response the background CL will eventually timeout, writing +a fatal error message to the standard error output of the process. +Queries from background jobs are normally satisfied from an interactive CL +using the builtin task \fBservice\fR, which types the service request file +on the terminal, deletes the file, reads the user's response from the terminal, +and writes the response into the query response file. +If the query response is unacceptable another query will be generated and +the interchange is repeated. The use of simple text files for interprocess +communication makes the technique very general, and in principle there is +nothing to prevent the technique from being used to service requests from +jobs run either as detached subprocesses or in batch queues. +.NH 3 +The Process and IRAF Mains +.PP +The roles of the Process and IRAF Mains should already be clear from the +previous sections. The process main is machine dependent and is called by +the host operating system when a process is executed. The IRAF Main is +a portable SPP procedure which is called by the process main +during process startup, which acts as a simple command interpreter during +process execution, and which returns control to the process main during +process shutdown. +.NH 4 +The Process Main +.PP +The \fBprocess main\fR is a part of the kernel, but unlike any other kernel +procedure it is not Fortran callable (in fact it is not necessarily a procedure +at all). The process main further differs from any other kernel procedure +in that it calls a high level procedure, the IRAF Main. Since the process +main is not Fortran callable, however, there is no possibility of recursion. +.PP +The primary functions of the process main are to open and initialize the +process i/o channels and to call the IRAF Main. +The process i/o channels are the standard input, standard output, and standard +error output of the process. The process or device to which the channels +are connected is both system dependent and dependent on how the process was +spawned. +.PP +The process main can be coded in assembler if necessary on almost any system. +Typically the host operating system will upon process entry transfer control +to a predefined address or external identifier, and this entry point should be +the process main. On many modern systems it will be possible to code the +main in a high level language; this is desirable provided the high level +language does not have a main of its own which necessitates loading a lot +of extraneous code which will never be used (since IRAF does all i/o via +the IRAF kernel). On a UNIX system, for example, the process main is +implemented as the C procedure "main" with no overhead, so there is nothing +to be gained by coding the process main in assembler. +.sp +.cs 1 18 +.nf +\fBprocedure\fR process_main + +input_chan: process standard input channel +output_chan: process standard output channel +errout_chan: process standard error output channel + +\fBbegin\fR + # Determine type of output device and connect channels. + + \fBif\fR (we are a connected subprocess) { + connect input_chan and output_chan to IPC channels + connect errout_chan to the user terminal (i.e, to the + standard error output channel of the parent process) + + } \fBelse if\fR (we are a detached process) { + \fBif\fR (window management facilities are available) + connect all channels to window manager + \fBelse\fR { + connect input_chan such that a read will return EOF + \fBif\fR (we are executing in a batch queue) + connect output channels to files + \fBelse\fR { + connect both output_chan and errout_chan to the user + terminal (i.e, to the standard error output channel + of the parent process, if the terminal can be + written to by multiple processes) + } + } + + } \fBelse if\fR (we were run from the host command interpreter) { + \fBif\fR (we were called interactively) + connect channels to user terminal + \fBelse\fR { + connect input_chan and output_chan to job input + and output files, and errout_chan to operator + console or system dayfile. + } + } + + # Call the IRAF Main, the command interpreter or driver of an + # IRAF process. + + call iraf_main, passing the channel numbers and identifying + the driver and protocol to be used by the Main + + # We get here only after the parent has commanded the IRAF + # Main to shutdown, and after shutdown has successfully + # completed. Fatal termination occurs elsewhere. + + close channels if necessary + normal exit, i.e., terminate process +\fBend\fR +.cs 1 +.fi +.sp +.PP +An IRAF process may easily be used in a completely batch mode by connecting +the process channels to text files. On an interactive system the channels +of a detached process may be connected directly to the user terminal, +but it can be annoying for the user if background processes are intermittently +writing to the terminal while the user is trying to do something else +(e.g. trying to edit a file using a screen editor). Having multiple processes +trying to simultaneously read from a terminal is disastrous. +.PP +The best solution to the problem of multiple processes trying to read or +write from the user terminal is some sort of \fBwindow manager\fR. +A simple window manager which can handle output from multiple simultaneous +IRAF processes but which will only allow a single process to read is not +difficult to code on many systems, provided one admits that the capability +is machine dependent. A full up window manager such as is provided on many +modern microcomputers is a much more difficult problem and should not be +attempted as an add-on, as it really needs to be integrated into the +operating system to work well. A better approach is to buy a microcomputer +which comes with a bit-mapped terminal and a fully integrated window manager, +or to buy a smart terminal which has window management capabilities. +.PP +If a window manager is to be provided as an add-on to a system which does +not already have one, it should be implemented as a single process handling all +i/o to the terminal. The CL will be run from the window manager process +and detached processes will talk directly to the window manager process +using multiplexed IPC channels. Such an add-on window manager is unlikely +to be fully usable for non-IRAF processes (e.g. the host system screen editor) +unless the host operating system is modified in fundamental ways. If the +window manager has to be built from scratch consider coding it as an IRAF +process with an extended system interface, so that it will be at least +partially portable. +.NH 4 +The IRAF Main +.PP +The IRAF Main is the "main program" of an IRAF process. The primary function +of the Main is to interpret and execute commands from the standard input +of the CL process (the stream CLIN) until either EOF is seen or the command +\fBbye\fR is received by the Main (as opposed to a program called by the Main). +The Main is mechanically generated by the SPP compiler when the \fBtask\fR +statement is encountered in an SPP program; the source is in the file +\fBmain.x\fR in the logical directory \fBsys$system\fR. +.PP +The secondary functions of the Main are to initialize the IRAF i/o system +and participate in error recovery. The first time the Main is called it +initializes the i/o system and posts a default set of \fBexception handlers\fR. +The Main can only be called again (without recursion) during an \fBerror +restart\fR. If an irrecoverable error occurs during error restart, +a panic exit occurs, i.e., the process dies. +.PP +Error restart takes place when a uncaught hardware or software exception +occurs, or when an error action is taken by a program and no user +\fBerror handler\fR is posted. All exceptions and errors may ideally be +caught and processed by a user exception handler or error handler, without error +restart occurring. When error restart occurs the hardware stack is +reset and control transfers to the marked position within the process main. +The process main calls the IRAF Main, which knows that it has been called +during error restart. +.PP +When the IRAF Main is called during error restart the first thing it does +is call any user procedures posted with \fBonerror\fR. If an irrecoverable +error occurs during execution of an \fBonerror\fR error recovery procedure, +\fBerror recursion\fR occurs and a panic exit results. +When the \fBonerror\fR procedures have successfully executed the Main sends +the \fBerror\fR statement to the CL (i.e., to the stream CLOUT) and reenters +its interpreter loop, awaiting the next command from the CL. +If no user error handler is posted at the CL level (error handling was not +implemented at the CL level at the time when this was written), then the +CL will direct the child process to shutdown to ensure that dynamic memory +space is reclaimed, and to ensure that a user program is not left in a bad +state by the error. +.NH 3 +Process Control Primitives +.PP +We are now in a position to define and understand the kernel primitives +necessary to implement process control. There are 9 such primitives, +excluding the process main and the exception handling primitives. +The mnemonic "pid" refers to the \fBprocess id\fR, a unique magic integer +assigned by the host operating system at process creation time. +.sp 0.08i +.TS +center; +cb s +n l. +Process Control Primitives +.sp +zopcpr \&(process, inchan, outchan, pid) open connected subprocess +zclcpr \&(pid, exit_status) close connected subprocess +zintpr \&(pid, exception, status) interrupt connected subprocess +.sp +zopdpr \&(process, bkgfile, jobnum) open or queue detached process +zcldpr \&(jobnum, killflag, exit_status) close or dequeue detached process +.sp +zgtpid \&(pid) get process id of current process +zpanic \&(errcode, errmsg) panic exit +zsvjmp \&(jumpbuf, status) save process status +zdojmp \&(jumpbuf, status) restore process status +.TE +.sp 0.08i +.PP +Separate sets of primitives are defined for connected and detached +subprocesses. A subprocess is connected with \fBzopcpr\fR, which spawns +the subprocess and opens the IPC channels. The child is assumed +to inherit the current working directory of the parent. +Connection of the IPC channels to FIO and transmission of the environment +list to the subprocess is left to the high level code. +.PP +A connected subprocess is disconnected with \fBzclcpr\fR, which waits +(indefinitely) for the subprocess to exit and returns the exit status code, +e.g. OK. The high level code must command the subprocess to shutdown +before calling \fBzclcpr\fR or deadlock will occur. +The high level code guarantees that \fBzclcpr\fR will be called to close +any subprocess opened with \fBzopcpr\fR. The \fBzintpr\fR primitive +raises the interrupt exception X_INT in a connected subprocess. +.PP +A detached process is spawned or submitted to a batch queue with \fBzopdpr\fR. +It is up to \fBzopdpr\fR to pass the name of the background file on to the +child by some means (the background file tells the detached process what +to do). A detached process may be killed or removed from the batch queue +by a call to \fBzcldpr\fR. The high level code will call \fBzcldpr\fR if +the detached process terminates while the parent is still executing, +but there is no guarantee that a detached process will be closed. +.PP +The remaining primitives are used by all processes. The \fBzgtpid\fR primitive +returns the process id of the process which calls it; this is useful for +constructing unique temporary file names. The \fBzpanic\fR primitive is +called when error recovery fails, i.e., when an error occurs during error +recovery, causing error recursion. A panic shutdown causes immediate process +termination, posting an error message to the process standard error output +and returning an integer error code to the parent process. +.PP +The IRAF main calls \fBzsvjmp\fR to save the process control status for +error restart. The process status is saved in \fIjumpbuf\fR, +allowing several jump points to be simultaneously defined. +A subsequent call to \fBzdojmp\fR restores +the process status, causing a return from the matching \fBzsvjmp\fR call +\fIin the context of the procedure which originally called \fBzsvjmp\fR. +The \fIstatus\fR argument is input to \fBzdojmp\fR and output by \fBzsvjmp\fR, +and is zero on the first call to \fBzsvjmp\fR, making it possible for the +procedure which calls \fBzsvjmp\fR to determine how it was entered. +These extremely machine dependent routines are patterned after the UNIX +\fBsetjmp\fR and \fBlongjmp\fR primitives, but are Fortran callable. +They will almost certainly have to be written in assembler since they fiddle +with the hardware stack and registers. +.PP +On a \fBmultiple processor\fR system it should be possible to spawn both +connected and detached processes on a remote processor. For example, +if the parent process resides on a diskless node in a cluster, it may be +desirable to run subprocesses that do heavy i/o on the remote file server +processor which has a high i/o bandwidth to disk. On such a system +advice on the optimal processor type should be encoded as extra information +in the process file name passed to \fBzopcpr\fR or \fBzopdpr\fR; this will +require modification of the CL \fBtask\fR statement for such processes. + +.NH 2 +Exception Handling +.PP +An exception is an asynchronous event, i.e., an interrupt. +Typical \fBhardware exceptions\fR are an attempt to access an unmapped region +of memory, illegal instruction, integer overflow, or divide by zero. +A hardware exception occurs when the hardware detects an error condition +while executing a hardware instruction. Typical \fBsoftware exceptions\fR are +interrupt and kill. A software exception occurs when a program, e.g., +the terminal driver or an applications program like the CL, sends an +interrupt or \fBsignal\fR to a process. When an exception occurs program +execution is interrupted and control transfers to an \fBexception handler\fR, +i.e., to a previously posted system or user procedure. +.PP +The ability to post an exception handler or to send a signal to a process +is fundamental in any multiprocessing operating system, but regrettably there +are still some older systems that do not make such facilities available to +applications code. Hopefully yours is not such a system. Even if a system +provides exception handling facilities, the set of exceptions defined for +a particular computer or operating system is very system dependent. +Exception handling can be subtly machine dependent, e.g., it is not always +possible to disable an exception, and it is not always possible to resume +program execution (restart the interrupted instruction) following an exception. +.PP +The IRAF Main posts a default set of exception handlers during process startup. +All host system exceptions that might occur during the execution of an IRAF +process should be catchable by one of the default exception handlers. +If an exception is not caught and is instead handled by the host, +the process will almost certainly die without the knowledge of the CL, +leading at best to a cryptic "write to a subprocess with no reader" error +message, and at worst to deadlock. Since error recovery and process shutdown +will be skipped if an uncatchable exception occurs, disk data structures may +be corrupted. +.PP +The virtual system recognizes only four classes of exceptions; all possible +host system exceptions should either be mapped into one of these exceptions +or caught in the kernel and mapped into ERR. +.sp 0.08i +.TS +center box; +cb s s +ci | ci | ci +l | c | l. +Virtual Machine Exceptions +_ +exception code meaning += +X_ACV 501 access violation +X_ARITH 502 arithmetic error +X_INT 503 interrupt +X_IPC 504 write to IPC with no reader +.TE +.sp 0.08i +.PP +The largest class of exceptions on many systems will be the access violations. +This class includes such things as illegal memory reference, illegal +instruction, illegal system call, and so on. +Arithmetic exceptions include divide by zero, integer overflow, and the like. +Interrupt is the exception raised by \fBzintpr\fR or by the +host system terminal driver when the interrupt sequence is typed (e.g. ctrl/c). +.sp 0.08i +.TS +center; +cb s +n l. +Exception Handling Primitives +.sp +zxwhen \&(exception, handler, old_handler) post an exception +zxgmes \&(os_exception, outstr, maxch) get OS code and message +.TE +.sp 0.08i +.PP +An exception handler is posted for a virtual exception with the primitive +\fBzxwhen\fR. All host exceptions in the indicated virtual exception class +are affected. The argument \fIhandler\fR is either the entry point address +of the new user exception handler or the magic value X_IGNORE (null). +The address of the old handler or X_IGNORE is returned as the third argument, +making it possible for the high level code to chain exception handlers +or repost old exception handlers. The calling sequence for a user exception +handler is as follows: +.DS +user_handler (exception, next_handler) +.DE +.LP +The user exception handler is called with the integer code for the actual +virtual exception as the first argument. The integer code of the last +machine exception and a packed character string describing the exception +may be obtained by a subsequent call to \fBzxgmes\fR. A program which uses +a machine exception code is machine dependent, but machine exception codes +can be parameterized and some programs need to know. +The CL, for example, has to be able to recognize the machine exception for +a write to a process (an IPC channel) with no reader. +.PP +When an exception occurs control actually transfers to the \fBkernel exception +handler\fR, which maps the machine exception into a virtual exception, +looks at the kernel exception table to determine what type of action is +required, and then calls the user exception handlers. A user exception +handler is expected to handle the exception in some application dependent +way and then either change the process context by calling \fBzdojmp\fR or +\fBzrestt\fR, or return control to the kernel exception handler. +If control returns to the kernel handler the output argument \fBnext_handler\fR +will contain either the entry point address of the next exception handler +or X_IGNORE. The high level code assumes that once an exception handler +is posted it stays posted, i.e., is not reset when an exception occurs. +.PP +Few programs actually post exception handlers; most just post an error handler +with \fBonerror\fR. Such an error handler will be called by the IRAF Main +either when an exception occurs or when an error action is taken, i.e., +when a program is aborted for whatever reason. If a user exception handler +is not posted the default handler will be called, causing error restart of the +Main, calls to all \fBonerror\fR procedures, and transmission of the \fBerror\fR +statement to the CL. If the CL is interrupted while executing an external +program it passes the interrupt on to the child with \fBzintpr\fR and then +resumes normal processing. The external program retains control, and therefore +can choose to either ignore the interrupt or take some application dependent +action. + +.NH 2 +Memory Management +.PP +The IRAF system relies heavily on memory management for dynamic buffer +allocation in both system and applications software. +Both stack and heap storage are provided at the program interface level. +The \fBstack\fR is used primarily for "automatic" storage allocation, +i.e., for buffers which are allocated upon entry to a procedure and deallocated +upon exit from the procedure. Stack management incurs very little overhead +for small buffers. The \fBheap\fR is a more general storage mechanism; +buffers may be allocated and deallocated in any order, and allocation and +deallocation may occur in different procedures. A heap buffer may be +reallocated, i.e., changed in size. The stack is implemented portably in terms +of the heap, and hence need not concern us further here. +.sp 0.08i +.TS +center; +cb s +n l. +Memory Management Primitives +.sp +zmaloc \&(buffer, nbytes, status) allocate a buffer +zmfree \&(buffer, status) deallocate a buffer +zraloc \&(buffer, nbytes, status) reallocate a buffer +zlocva \&(variable, address) get address of a variable +zawset \&(bestsize, newsize, oldsize, textsize) adjust working set size +.TE +.sp 0.08i +.PP +Buffer space is allocated on the heap by the primitive \fBzmaloc\fR. +The address of a buffer at least \fInbytes\fR in size is returned +as the argument \fIbuffer\fR. Nothing is assumed about the alignment of +the buffer. The contents of the buffer are not assumed to be initialized. +.PP +The buffer address returned by \fBzmaloc\fR is in units of SPP \fBchars\fR +rather than in physical units. The \fBzlocva\fR primitive returns the +address of a \fBcsilrd\fR variable, array, or array element in the same +units. By using char address units and by doing all pointer dereferencing +by subscripting Fortran arrays, we avoid building knowledge of the memory +addressing characteristics of the host system into SPP programs. +The zero point of a char address is undefined; negative addresses are +possible depending on the implementation. It must be possible to store an +address in an integer variable, and it must be possible to perform +\fIsigned integer\fR comparisons and arithmetic on addresses. +.PP +A buffer allocated with \fBzmaloc\fR may be reallocated with \fBzraloc\fR. +In this case the \fIbuffer\fR argument is used both for input and for output. +If the input value is NULL a new buffer should be allocated, otherwise the +size of the buffer should be either increased or decreased depending on the +value of \fInbytes\fR. The buffer may be moved if necessary, provided the +contents of the buffer are preserved. This primitive may be implemented as +a call to \fBzmaloc\fR followed by an array copy and a call to \fBzmfree\fR +if desired, saving one kernel primitive, with significant loss of efficiency +in some applications. +.PP +A buffer allocated with \fBzmaloc\fR is deallocated with \fBzmfree\fR. +Deallocation need not involve physically returning memory pages to the +operating system; if the buffer is small this will not be possible. The buffer +being deallocated need not be at the end of the process address space. +.PP +The \fBzlocva\fR primitive returns the address in char units of the first +argument as the integer value of the second argument. Since Fortran is +call by reference, this is a simple matter of copying the pointer to the +first argument (as opposed to the value pointed to) to the integer location +pointed to by the second argument. +Only arguments of datatypes \fBcsilrd\fR are permitted in calls to \fBzlocva\fR. +Arguments of Fortran type COMPLEX, CHARACTER, and EXTERNAL are sometimes passed +using more than one physical argument (depending on the host compiler) +and hence cannot be used in procedures that operate upon an arbitrary datatype. +.PP +The \fBzawset\fR primitive is used both to determine and to change the amount +of physical memory in machine bytes available to a process, i.e., the +\fBworking set size\fR on a virtual memory machine. +If called with a \fIbestsize\fR of zero the current working set size and text +segment size is returned. If called with nonzero \fIbestsize\fR on a +virtual memory machine the working set size will be adjusted up or down +as indicated, returning the actual new working set size in \fInewsize\fR +and the old working set size in \fIoldsize\fR. +It is not an error if the amount of memory requested cannot be allocated; +the high level code will ask for what it wants but take what it gets. +High level routines which need lots of memory rely on this primitive to +avoid running out of memory on nonvirtual machines and to avoid thrashing +on virtual machines. +.PP +The high level code (\fBmalloc\fR) converts the address returned +by the kernel primitives into an integer valued offset (array index) into +the \fBMem\fR common. +The dynamically allocated buffer (which has nothing to do with the Mem common) +is referenced by indexing off the end of an \fBMem\fR array. +The portable MEMIO code ensures alignment between the physical buffer and +the "pointer" returned to the user (index into Mem). This technique should +work on any machine which permits referencing off the end of an array. +.PP +There is one place in the system code, however, which does something trickier +and which should be checked on a new system. +The \fBstropen\fR routine in FIO uses the +same pointer technique (for efficiency reasons) to reference a \fIstatically\fR +allocated \fBchar\fR array in the user program. If the compiler does not +guarantee that a statically allocated \fBchar\fR array will be aligned with +the array \fBMemc\fR in the Mem common this will not work, +and \fBstropen\fR will have to be modified. +.NH 2 +Procedure Call by Reference +.PP +Fortran allows an external procedure to be passed by reference to a +subprogram via the subprogram argument list. An external procedure passed +as an argument to a subprogram may be called by the subprogram but may not be +saved and called at some later time. IRAF (e.g. FIO and IMIO) requires the +capability to save a reference to a procedure in an integer variable for +execution at some later time. +.PP +The \fBzlocpr\fR primitive is used to determine the entry point address +(EPA) of an external procedure. IRAF assumes that the EPA of a procedure +may be stored in an integer variable and that two procedures with the same +EPA are identically the same procedure. No other operations are permitted +on EPA values, e.g., signed comparisons and arithmetic are not permitted. +.sp 0.08i +.TS +center; +cb +n. +Call by Reference Primitives +.sp +zlocpr \&(proc, entry_point_address) get address of a procedure +zcall1 \&(procedure, arg1) +zcall2 \&(procedure, arg1, arg2) +zcall3 \&(procedure, arg1, arg2, arg3) +zcall4 \&(procedure, arg1, arg2, arg3, arg4) +zcall5 \&(procedure, arg1, arg2, arg3, arg4, arg5) +.TE +.sp 0.08i +.PP +A \fBzcall\fIn\fR primitive is used to call an external subroutine +referenced by the integer variable \fIprocedure\fR, the entry point address +of the procedure returned in a prior call to \fBzlocpr\fR. +Only subroutines may be called by reference; there is no comparable facility +for functions. The datatypes of the arguments are unspecified but are +restricted to the SPP datatypes \fBcsilrd\fR. + +.NH 2 +Date and Time +.PP +Kernel primitives are required to read the system clock, to determine the +amount of cpu time consumed by a process (for performance measurements), +and to generate time delays. +.sp 0.08i +.TS +center; +cb s +n l. +Date and Time Primitives +.sp +zgtime \&(local_time, cpu_time) get clock time and cpu time +ztslee \&(delay) countdown timer +.TE +.sp 0.08i +.PP +The \fBzgtime\fR primitive returns two long integer arguments. The local +standard time in integer seconds since midnight on January 1, 1980 is +returned as the first argument (the "clock" time). The second argument +is the total cpu time consumed by the process since process execution, +in units of milliseconds. The countdown timer primitive \fBztslee\fR +suspends execution of the calling process for the specified number of +integer seconds. There is currently no provision for generating delays +of less than one second. + +.NH 2 +Sending a Command to the Host OS +.PP +The ability to send an explicitly machine dependent command to the host +system command interpreter is required by the CL and by some of the system +utilities. Any program which uses this command is bypassing the system +interface and is system dependent. Nonetheless it is very useful for the +\fIuser\fR to be able to send a command to the host without leaving the +IRAF environment, and certain of the system utilities are much easier to +code given the capability (e.g., \fBdiskspace\fR and \fBspy\fR). These +utilities help provide a consistent user interface on all systems, and in +many cases such a utility program can be built in a few minutes for a new +system. No science program or essential system utility bypasses the system +interface in this fashion. +.sp 0.08i +.TS +center; +cb s +n l. +Host OS Command Primitive +.sp +zoscmd \&(cmd, stdout, stderr, status) send a command to the host OS +.TE +.sp 0.08i +.PP +The command \fIcmd\fR may be any packed string acceptable to the host +system. The call does not return until the command has been executed. +The status OK or ERR is returned indicating success or failure. +If either of the filename strings \fIstdout\fR or \fIstderr\fR is nonnull +the associated output stream of the command will be directed (if possible) +to the named text file. + +.NH +Bit and Byte Primitives +.PP +The bit and byte primitives are not considered true kernel procedures since +they are purely numerical and are only potentially machine dependent. +These primitives are more properly part of the \fBprogram interface\fR than +the kernel, since they are callable from ordinary applications programs. +Both SPP or Fortran and C versions of most of the routines are supplied +with the system which will port to most modern minicomputers and some large +computers. The source directory is \fBsys$osb\fR. +The following classes of routines are required: +.sp 0.05i +.DS +\(bu bitwise boolean operations (and, or, etc.) +\(bu bitfield insertion and extraction +\(bu byte primitives (copy, swap, string pack/unpack) +\(bu type conversion for byte, unsigned short datatypes +\(bu machine independent integer format conversions +.DE +.sp 0.05i +.PP +The IRAF system uses 8 standard datatypes in compiled SPP programs, +as shown in the table below. Variables and arrays may be declared and +accessed conventionally using any of these datatypes. Data may additionally +be stored on disk, in images, and in memory in packed char or integer arrays +in the exotic datatypes \fBunsigned byte\fR, \fBunsigned short\fR, +and \fBpacked string\fR. +.sp 0.08i +.TS +center box; +cb s s +ci | ci | ci +lb | c | l. +Standard SPP Datatypes +_ +name suffix Fortran equivalent += +bool b LOGICAL +char c nonstandard +short s nonstandard +int i INTEGER +long l nonstandard +real r REAL +double d DOUBLE PRECISION +complex x COMPLEX +.TE +.sp 0.08i +.PP +The char and short datatypes are commonly implemented as INTEGER*2, +and long as INTEGER*4, but all could be implemented as the standard +INTEGER if necessary. To save space char may be implemented using a +signed byte datatype if the host Fortran compiler provides one, +provided the special datatype chosen may be equivalenced with the +standard datatypes (the minimum precision of a char is 8 bits signed). +IRAF assumes that the 7 types \fBcsilrdx\fR may be equivalenced in common +(e.g. in \fBMem\fR). The standard type suffixes \fBbcsilrdx\fR are +commonly appended to procedure names to identify the datatype or datatypes +upon which the procedure operates. +.NH 2 +Bitwise Boolean Primitives +.PP +The bitwise boolean primitives are used to set and clear bits or bitfields +in integer variables. The practice is portable provided the minimum +precision of an integer variable (16 bits) is not exceeded. Primitives +are provided for the 3 integer datatypes, i.e., short, int, and long, +denoted by the suffix \fB[sl]\fR in the table below. In other words, +the notation \fBand[sl]\fR refers to the procedures \fBands\fR and \fBandl\fR. +These quasi-primitives, unlike the true kernel primitives, are user callable +and are implemented as \fIfunctions\fR. +.sp 0.08i +.TS +center; +cb s +n n. +Bitwise Boolean Primitives +.sp +and,and[sl] \&(a, b) int = and \&(a, b) +or,or[sl] \&(a, b) int = or \&(a, b) +xor,xor[sl] \&(a, b) int = xor \&(a, b) +not,not[sl] \&(a, b) int = not \&(a, b) +.TE +.sp 0.08i +.PP +Bitwise boolean primitives are provided in many Fortran compilers +as integer intrinsic functions. If this is the case it suffices (and +is more efficient) to place a \fBdefine\fR statement in \fBiraf.h\fR to +map the IRAF name for the function to that recognized by the host Fortran +compiler. For example, +.DS +\fBdefine\fR and iand +.DE +would cause all occurrences of the identifier \fBand\fR in SPP programs to +be replaced by \fBiand\fR in the Fortran output, which the host compiler +would hopefully compile using inline code. +.NH 2 +Bitfield Primitives +.PP +A \fBbitfield\fR is an unsigned integer segment of a bit array, where the +number of bits in the segment must be less than or equal to NBITS_INT, +the number of bits in an integer. A \fBbit array\fR is a sequence of +bits stored one bit per bit in a char or integer array. The essential +thing about a bit array is that byte and word boundaries are irrelevant, +i.e., a bitfield may straddle a word boundary. +.sp 0.08i +.TS +center; +cb s +n n. +Bitfield Primitives +.sp +bitpak \&(intval, bit_array, bit_offset, nbits) integer \(-> bitfield +int = bitupk \&(bit_array, bit_offset, nbits) bitfield \(-> integer +.TE +.sp 0.08i +.PP +Bit offsets range from 1, not 0, to MAX_INT. A bitfield is zero-extended +when unpacked by \fBbitupk\fR, and unset bits are zeroed when an integer +is packed into a bitfield by \fBbitpak\fR. If the integer is too large +to fit in the bitfield it is truncated. These primitives should be +implemented in assembler on a machine like the VAX which has bitfield +instructions. +.NH 2 +Byte Primitives +.PP +The byte primitives are difficult to use portably in high level code +without building knowledge of the sizes of the SPP datatypes in bytes +into the code. Fortunately the byte primitives are rarely used; the most +common usage is in programs used to transport data between machines (e.g., +a magtape reader program). A number of machine constants are defined +in \fBiraf.h\fR to allow parameterization of programs which operate on +data in units of bytes. +.sp 0.08i +.TS +center box; +cb s +ci | ci +l | l. +Machine Parameters for Byte Data +_ +name definition += +SZB_CHAR machine bytes per char +NBITS_BYTE nbits in a machine byte +SZ_\fItype\fR size of datatype \fItype\fR (upper case) in chars +.TE +.sp 0.08i +.PP +On most machines the byte primitives can be written in Fortran by +representing a byte array as an array of CHARACTER*1. This suffices for +programs which merely move bytes around, but not for programs which +do numerical comparisons and arithmetic operations upon character data +using CHAR and ICHAR, because the collating sequence for CHARACTER data +in Fortran is not necessarily ASCII. +.PP +Nonetheless CHAR and ICHAR can be used on most machines to operate upon bytes, +i.e., upon non-CHARACTER data stored in CHARACTER*1 arrays. +Of course we are asking for trouble using CHARACTER for non-CHARACTER +operations, so routines which do so are potentially machine dependent. +Both Fortran and C versions of most of the byte primitives are supplied. +The \fBbytmov\fR primitive should be written in assembler on a machine such +as the VAX which can perform the operation in a single instruction +(it is even more important to perform this optimization for the \fBamov\fR +vector operators, which are more widely used). +.sp 0.08i +.TS +center; +cb s +n l. +Byte Primitives +.sp +bytmov \&(a, aoff, b, boff, nbytes) move an array of bytes +bswap2 \&(a, b, nbytes) swap every pair of bytes +bswap4 \&(a, b, nbytes) swap every 4 bytes +chrpak \&(a, aoff, b, boff, nchars) pack chars into bytes +chrupk \&(a, aoff, b, boff, nchars) unpack bytes into chars +strpak \&(a, b, maxchars) SPP string \(-> byte-packed string +strupk \&(a, b, maxchars) byte-packed string \(-> SPP string +.TE +.sp 0.08i +.PP +The \fBbytmov\fR primitive moves a portion of a byte array into a portion +of another byte array. The move is nondestructive, i.e., if the input +and output arrays overlap data must not be destroyed. The \fBzlocva\fR +primitive may be used to determine if the arrays will overlap. +Byte swapping is performed by the \fBbswap2\fR and \fBbswap4\fR primitives, +which swap every 2 bytes or every 4 bytes, respectively, regardless of the +number of bytes per short or long integer on the host machine. These routines +are used primarily to swap bytes in interchange data before is it unpacked into +host integers (or after packing into interchange format), hence the primitives +are defined independently of the host word size. A 2 byte swap interchanges +successive pairs of bytes; a 4 byte swap of two 4 byte integers rearranges +the bytes as 12345678 \(-> 43218765. +.PP +The \fBchrpak\fR and \fBchrupk\fR primitives pack and unpack SPP chars +into bytes, performing sign extension in the unpacking operation. +The mapping is nondestructive, i.e., the input and output arrays may +be the same, and the numeric value of a character is not changed +by the mapping (the collating sequence is not changed by the mapping). +If SZB_CHAR is 1, \fBchrpak\fR and \fBchrupk\fR are equivalent, and if +the input and output arrays are the same or do not overlap they are +equivalent to \fBbytmov\fR. +.PP +The \fBstrpak\fR and \fBstrupk\fR primitives pack and unpack SPP strings +into packed strings. A packed string is a sequence of zero or more characters, +packed one character per byte, delimited by end-of-string (EOS). +While SPP strings are always ASCII the collating sequence of a packed string +is whatever is used for character data by the host machine. +The mapping is nondestructive in the sense that the input and output arrays +may be the same. Since the collating sequence may be changed in the mapping +and the mapping need not be one-to-one, information may be lost if an +arbitrary string is packed and later unpacked. +.PP +A packed string is not the same as a Fortran CHARACTER variable or constant. +Many Fortran compilers use two physical arguments to pass a Fortran CHARACTER +argument to a subprocedure, while a packed string is always passed by reference +like an ordinary integer array. There is no machine independent way to fake +a Fortran string in an argument list. Furthermore, packed strings are heavily +used in the kernel for machine dependent filenames, and these file names +typically contain characters not permitted by the restrictive Fortran standard +character set. The packed string format is equivalent to that expected by +the C language. +.NH 2 +Vector Primitives +.PP +Nearly all of the operators in the vector operators package +(VOPS, \fBsys$vops\fR) are machine independent. The exceptions are the +\fBacht\fR primitives used to change the datatype of a vector to or from +one of the special datatypes \fBunsigned byte\fR and \fBunsigned short\fR. +An \fBacht\fR operator is provided for every possible type conversion +in the set of datatypes \fBcsilrdx\fR plus unsigned byte (\fBB\fR) and +unsigned short (\fBU\fR), for a total of 9 squared or 81 operators in all. +The \fBbool\fR datatype is not supported by VOPS. +.PP +Two type suffixes are used to specify the type conversion performed by an +operator; for example, \fBachtir\fR will convert an integer array into a +real array. In the table below the underscore stands for the set of +datatypes \fBUBcsilrdx\fR, hence each the operators shown is actually +a generic operator consisting of 9 type specific operators. +Both C and Fortran sources are provided for all primitives, the C sources +being more efficient. The Fortran operators will work on many hosts +but are potentially machine dependent and should be checked. The C versions +are more efficient since Fortran does not support the unsigned datatypes +and a masking operation must be performed to undo sign extension when +converting from unsigned to signed. +.sp 0.08i +.TS +center; +cb s +n l. +Machine Dependent Vector Primitives +.sp +acht_b \&(a, b, npix) SPP datatype \(-> unsigned byte +acht_u \&(a, b, npix) SPP datatype \(-> unsigned short +achtb_ \&(a, b, npix) unsigned byte \(-> SPP datatype +achtu_ \&(a, b, npix) unsigned short \(-> SPP datatype +.TE +.sp 0.08i +.PP +Many of the conversions do not preserve precision, i.e., double to real +or integer to unsigned byte. The imaginary part of a complex number is +discarded when converting to some other datatype, and the imaginary part +is set to zero when converting a non-complex datatype to complex. +All type conversion operators allow the conversion to be performed in +place, i.e., the input and output arrays may be the same. +.NH 2 +MII Format Conversions +.PP +The Machine Independent Integer format (MII) is used to transport binary +integer data between computers. The format is independent of the transmission +medium, and hence might be used to transport data via magnetic tape, over a +local area network, or over a modem. The MII integer format is equivalent +to that defined by the FITS image interchange format. The MII primitives are +used in the IRAF FITS reader and writer programs and will probably be used +in the GKS (Graphical Kernel System) software to implement a machine +independent VDM (Virtual Device Metafile). +.PP +MII defines 3 integer datatypes, 8 bit unsigned integer, 16 bit twos-complement +signed integer, and 32 bit twos-complement signed integer. An integer array +in MII format may be thought of as a stream of 8-bit bytes. In each 2 and +4 byte integer successive bytes are written in order of decreasing significance. +The sign bit is in the first byte of each 2 or 4 byte integer. For example, +two 16 bit integers would be represented in MII format as the following +sequence of 4 bytes. +.sp 0.08i +.TS +center; +ci ci +l l. +byte significance +.sp +1 high byte of first integer, including sign bit +2 low byte of first integer +3 high byte of second integer, including sign bit +4 low byte of second integer +.TE +.PP +The order of the bits within a byte is (must be) standardized at the +hardware level, else we would not be able to transmit character data via +cardimage tapes and modems. Hence the sign bit is bit 200B (octal) of the +first byte of an MII integer, the most significant bit is bit 100B of the +first byte, and so on. +.sp 0.08i +.TS +center; +cb s +n l. +MII Primitives +.sp +miipak \&(spp, mii, nelems, spp_type, mii_type) SPP \(-> MII +miiupk \&(mii, spp, nelems, mii_type, spp_type) MII \(-> SPP +intlen = miilen \&(n_mii_elements, mii_type) get size of array +.TE +.sp 0.08i +.PP +SPP or Fortran integer data is converted to MII format with \fBmiipak\fR, +and MII data is converted to SPP format with \fBmiiupk\fR. +The argument \fIspp\fR refers to an SPP integer array of datatype +\fIspp_type\fR, and \fImii\fR refers to an MII byte stream of MII datatype +\fImii_type\fR. The legal integer values of \fImii_type\fR are 8, 16, +and 32. MII data is stored in an SPP array of type \fBint\fR. +The length of the SPP integer array required to store \fIn_mii_elements\fR +of MII type \fImii_type\fR is returned by the primitive \fBmiilen\fR. +.PP +An SPP implementation of the MII primitives which should work for all +host machines with 16 or 32 bit twos-complement signed integer datatypes +is supplied with the system. Most modern minicomputers fall into this class. +All one need do to use the supplied MII primitives is determine whether or +not byte swapping is necessary. If the parameter BYTE_SWAP2 is defined +as YES in \fBiraf.h\fR then \fBbswap2\fR will be called to swap 2 byte +MII integers, producing an SPP \fBshort\fR as output. If the parameter +BYTE_SWAP4 is defined as YES then \fBbswap4\fR will be called to swap 4 +byte MII integers, producing an SPP \fBlong\fR as output. +.NH 2 +Machine Constants for Mathematical Libraries +.PP +The most often used machine constants are parameterized in include files +for use within SPP programs. Defined constants are the most readable +and efficient way to represent machine constants, but not the most accurate +for floating point quantities. Furthermore, SPP defined constants cannot +be used within Fortran procedures; functions returning the machine constants +are often used instead. The most widely used set of such functions appears +to be those developed at Bell Laboratories for the \fIPort\fR mathematical +subroutine library. +.sp 0.08i +.TS +center; +cb s +n l. +Mathematical Machine Constants +.sp +int = i1mach \&(parameter) get INTEGER machine constants +real = r1mach \&(parameter) get REAL machine constants +double = d1mach \&(parameter) get DOUBLE PRECISION machine constants +.TE +.sp 0.08i +.PP +These routines are used in many numerical packages, including the IEEE +signal processing routines and the NCAR graphics software. Documentation +is given in the Fortran sources; values of the constants have already been +prepared for most of the computers used at scientific centers. The integer +codes of the machine parameters are parameterized in \fBlib$mach.h\fR for +use in SPP programs. + +.NH +System Parameterization and Tuning +.PP +All machine dependent system and language parameters are defined in the two +SPP include files \fBlib$iraf.h\fR and \fBlib$config.h\fR, in the C include +file \fBcl$config.h\fR, and in the CL script file \fBlib$clpackage.cl\fR. +Additional machine dependent include files will often be used (\fIshould\fR +be used) to implement the kernel for a particular machine but these are too +host specific to be described here. +.PP +The include file \fBlib$iraf.h\fR is automatically loaded by the SPP whenever +an SPP source file is preprocessed, hence the defines in \fBiraf.h\fR are +effectively part of the SPP language. This global include file defines +the language parameters (e.g., EOF, ERR) as well as many machine constants. +The two configuration files \fBlib$config.h\fR and \fBcl$config.h\fR define +additional constants pertaining to the host OS as well as various size limiting +and heuristic parameters used to tune IRAF for optimum performance on a given +host system. The CL script file \fBlib$clpackage.cl\fR contains \fBset +environment\fR declarations for all system directories and default devices. +.PP +Documentation for the individual machine constants and system tuning parameters +is maintained directly in the source files to ensure that it is up to date. +Some of the parameters in \fBconfig.h\fR pertain only to the inner workings +of the program interface and changes can be expected in successive releases +of the IRAF system, without corresponding changes to the external +specifications of the program interface. + +.NH +Other Machine Dependencies +.PP +In the ideal world all of the machine dependence of the system would be +concentrated into the kernel and a few include files. While this has been +achieved for the scientific software some of the system utilities currently +bypass the system interface and are machine dependent. +This is not necessarily a bad thing; if a certain capability is only needed +by one or two system utilities the machine dependence of the system will often +be less if we take the simple way out and write a system dependent program +than if we further expand the formal system interface. +.PP +The machine dependent utilities are in the packages \fBsystem\fR and +\fBsoftools\fR. All machine dependent procedures are listed in the README +files in the package directories. The string MACHDEP is placed in the source +files to mark any machine dependent code segments. The machine dependent +utilities are not essential to the use of the system, but are useful for +maintaining the system. Examples of machine dependent software utilities +include \fBmake\fR, \fBxcompile\fR, and the generic preprocessor. These +utilities will all eventually be replaced by portable programs. +Machine dependent system utilities include \fBallocate\fR and \fBdeallocate\fR, +\fBedit\fR (the interface to the host editor), and \fBdiskspace\fR. +These utilities are actually just command level interfaces to the host +system command interpreter, and are easy to modify for a new host. +.NH 2 +Machine Dependencies in the CL +.PP +As noted earlier, from a structural design point of view the Command Language +is an IRAF applications program; as such it is highly portable. The CL is not +completely portable because it is written in C. Since the CL is written in +C it cannot reference the standard include files \fBiraf.h\fR and +\fBconfig.h\fR, and therefore has its own machine dependent \fBconfig.h\fR +include file instead. Since the CL requires file i/o, process control and +exception handling, formated i/o, the TTY interface, etc., it is interfaced +to the IRAF program interface (the CL has a special Main of its own but this +is portable). +.PP +The C code in the CL is purely numeric, like the Fortran in SPP based +applications programs. All communication with the host system is via the +IRAF program interface. The program interface is written in SPP, i.e., +Fortran, and Fortran procedures +cannot portably be called from C (see \(sc3.1.2). To render the bulk of the +code portable a special C callable subset of the program interface is +defined for the CL, and all CL calls to program interface routines are via +this interface. Efficiency is not a problem because the CL does little i/o; +the CL is the control center of the system, and tends to be compute bound when +it is not idle waiting for a command. +.PP +In summary, to interface the CL to a new system it is necessary to first edit +the \fBcl$config.h\fR, which parameterizes the characteristics of the host +system and which contains the system tuning parameters affecting the CL. +The CL interface to the subset program interface consists of a set of +rather simple interface procedures in the file \fBcl$machdep.h\fR. +If you are lucky these will not have to be changed to port the CL to your host +computer, but even if the routines have to be modified they are few in number +and quite simple in nature. +.NH +Specifications for the Kernel Procedures +.PP +The remainder of this document consists of a summary of the machine dependent +procedures, followed by the detailed technical specifications for each +procedure. Only the specifications for the kernel primitives are given; +the bitwise boolean primitives are part of the program interface and are +documented elsewhere. Most likely either the Fortran or C code supplied for +the bitwise primitives will be usable on a new host system without significant +modification. +.PP +While the kernel consists of quite a few procedures, this does not necessarily +mean that it is going to be harder to implement than if there were only a +quarter or a third as many procedures. Our design goal was to minimize the +complexity and size of the kernel, and we felt that it was more important to +define simple, single function primitives than to minimize the \fInumber\fR +of primitives. +.PP +A large part of the kernel consists of device driver +subroutines; on a system which provides device independent i/o these may map +to the same low level procedures and a count of the number of driver +subroutines will have little meaning. On a system which does not have device +independent i/o it will be easier to implement separate procedures for each +device than to try to make the host system look like it has device independent +i/o (FIO already does that anyhow). Furthermore, the provision for separate +drivers makes it easy to optimize i/o for a particular device, and makes it +possible to dynamically interface new devices to FIO without modifying the +basic system. +.PP +All kernel procedures are called by virtual operating system procedures +in the program interface. The kernel procedures are \fInot\fR callable +directly from applications code. Extensive error checking is performed by +the high level code before a kernel procedure is called, hence error +checking in kernel procedures is largely redundant and should be omitted +if it will significantly compromise performance. Do not get clever +with kernel procedures; \fIkeep it simple\fR. +.sp 0.08i +.TS +center box; +cb s s +ci | ci | ci +l | c | l. +Summary of Kernel Constants +_ +name value usage += +APPEND 4 write at EOF +BINARY_FILE 12 +BOF \(mi3 beginning of file +EOF \(mi2 end of file +EOS '\\\\0' end of string delimiter +ERR \(mi1 function was unsuccessful +FI_DIRECTORY 2 directory file (\fBzfinfo\fR) +FI_EXECUTABLE 3 executable file +FI_REGULAR 1 ordinary file +FI_SPECIAL 4 special file +FSTT_BLKSIZE 1 device block size +FSTT_FILSIZE 2 file size, bytes +FSTT_MAXBUFSIZE 4 maximum transfer size +FSTT_OPTBUFSIZE 3 optimum transfer size +LEN_JUMPBUF ?? integer length of \fBzsvjmp\fR buffer +NEW_FILE 5 create a new file +NO 0 no (false) +OK 0 function successfully completed +PR_CONNECTED 1 connected subprocess +PR_DETACHED 2 detached process +PR_HOST 3 process spawned by host +QUERY_PROTECTION 2 query file protection (\fBzfprot\fR) +READ_ONLY 1 file access modes +READ_WRITE 2 +REMOVE_PROTECTION 0 remove file protection (\fBzfprot\fR) +SET_PROTECTION 1 set file protection (\fBzfprot\fR) +SZ_LINE 161 default textfile line length +TEXT_FILE 11 file types +WRITE_ONLY 3 +X_ACV 501 access violation +X_ARITH 502 arithmetic error +X_INT 503 interrupt +X_IPC 504 write to IPC with no reader +YES 1 yes (true) +.TE +.sp 0.08i + + +.bp +.LG +.ce +\fBSummary of Machine Dependent Procedures\fR +.NL +.sp 2 +.TS +center; +cb s +n l. +Kernel Primitives +.sp +\fBzawset\fR \&(bestsize, newsize, oldsize, textsize) adjust working set size +\fBzcall\fIn\fR \&(procedure, arg1,...,arg\fIn\fR) call by reference +\fBzclcpr\fR \&(pid, exit_status) close connected subprocess +\fBzcldir\fR \&(chan, status) close directory +\fBzcldpr\fR \&(jobcode, killflag, exit_status) close or dequeue detached process +\fBzdojmp\fR \&(jumpbuf, status) restore process status +\fBzfacss\fR \&(osfn, mode, type, status) access file +\fBzfaloc\fR \&(osfn, nbytes, status) preallocate a binary file +\fBzfchdr\fR \&(new_directory, status) change directory +\fBzfdele\fR \&(osfn, status) delete a file +\fBzfgcwd\fR \&(osdir, maxch, status) get current working directory +\fBzfinfo\fR \&(osfn, out_struct, status) get info on a file +\fBzfmkcp\fR \&(old_osfn, new_osfn, status) make null copy of a file +\fBzfpath\fR \&(osfn, pathname, maxch, status) osfn to pathname +\fBzfprot\fR \&(osfn, prot_flag, status) file protection +\fBzfrnam\fR \&(old_osfn, new_osfn, status) rename a file +\fBzfsubd\fR \&(osdir, subdir, new_osdir, maxch, nchars) get subdirectory name +\fBzfxdir\fR \&(osfn, osdir, maxch, status) extract OS directory prefix +\fBzgfdir\fR \&(chan, osfn, maxch, status) get next OSFN from directory +\fBzgtime\fR \&(local_time, cpu_time) get clock time and cpu time +\fBzgtpid\fR \&(pid) get process id of current process +\fBzintpr\fR \&(pid, exception, status) interrupt connected subprocess +\fBzlocpr\fR \&(proc, entry_point_address) get EPA of a procedure +\fBzlocva\fR \&(variable, address) get address of a variable +\fBzmaloc\fR \&(buffer, nbytes, status) allocate a buffer +\fBzmfree\fR \&(buffer, status) deallocate a buffer +\fBzopcpr\fR \&(process, inchan, outchan, pid) open connected subprocess +\fBzopdir\fR \&(osfn, chan) open a directory +\fBzopdpr\fR \&(process, bkgfile, jobcode) open or queue detached process +\fBzoscmd\fR \&(cmd, stdout, stderr, status) send a command to the host JCL +\fBzpanic\fR \&(errcode, errmsg) panic exit +\fBzraloc\fR \&(buffer, nbytes, status) reallocate a buffer +\fBzsvjmp\fR \&(jumpbuf, status) save process status +\fBztslee\fR \&(delay_in_seconds) countdown timer +\fBzxgmes\fR \&(os_exception, errmsg, maxch) get exception code and message +\fBzxwhen\fR \&(exception, new_handler, old_handler) post an exception +.TE +.sp 2 +.TS +center box; +cb s s s s s s s s s +ci | ci | ci ci ci ci ci ci ci ci +l | c | c c c c c c c c. +Text File Device Drivers +_ +device code opn cls get put fls not sek stt += +normal (disk) tx * * * * * * * * +terminal ty * * * * * * +.TE +.sp 2 +.TS +center box; +cb s s s s s s s +ci | ci | ci ci ci ci ci ci +l | c | c c c c c c. +Binary File Device Drivers +_ +device code opn cls ard awr awt stt += +normal (disk) bf * * * * * * +line printer lp * * * * * +IPC pr * * * * +static file sf * * * * * * +magtape mt * * * * * * +.TE +.sp 2 +.TS +center; +cb s +n l. +Magtape Device Primitives +.sp +\fBzzopmt\fR \&(drive, density, mode, oldrec, oldfile, newfile, chan) open +\fBzzclmt\fR \&(chan, mode, nrecords, nfiles, status) close +\fBzzrdmt\fR \&(chan, buf, maxbytes) aread +\fBzzwrmt\fR \&(chan, buf, nbytes) awrite +\fBzzwtmt\fR \&(chan, nrecords, nfiles, status) await +\fBzzrwmt\fR \&(chan, status) arewind +.TE +.sp 2 +.TS +cb s +n l. +Bit and Byte Primitives +.sp +\fBand,and[sl]\fR \&(a, b) bitwise and +\fBor,or[sl]\fR \&(a, b) bitwise or +\fBxor,xor[sl]\fR \&(a, b) exclusive or +\fBnot,not[sl]\fR \&(a, b) complement +\fBbitpak\fR \&(intval, bit_array, bit_offset, nbits) integer \(-> bitfield +int = \fBbitupk\fR \&(bit_array, bit_offset, nbits) bitfield \(-> integer +\fBbytmov\fR \&(a, aoff, b, boff, nbytes) move an array of bytes +\fBbswap2\fR \&(a, b, nbytes) swap every pair of bytes +\fBbswap4\fR \&(a, b, nbytes) swap every 4 bytes +\fBchrpak\fR \&(a, aoff, b, boff, nchars) pack chars into bytes +\fBchrupk\fR \&(a, aoff, b, boff, nchars) unpack bytes into chars +\fBstrpak\fR \&(a, b, maxchars) SPP string \(-> byte-packed string +\fBstrupk\fR \&(a, b, maxchars) byte-packed string \(-> SPP string +\fBacht_b\fR \&(a, b, npix) SPP datatype \(-> unsigned byte +\fBacht_u\fR \&(a, b, npix) SPP datatype \(-> unsigned short +\fBachtb_\fR \&(a, b, npix) unsigned byte \(-> SPP datatype +\fBachtu_\fR \&(a, b, npix) unsigned short \(-> SPP datatype +\fBmiipak\fR \&(spp, mii, nelems, spp_type, mii_type) SPP \(-> MII +\fBmiiupk\fR \&(mii, spp, nelems, mii_type, spp_type) MII \(-> SPP +intlen = \fBmiilen\fR \&(n_mii_elements, mii_type) get length of MII array +int = \fBi1mach\fR \&(parameter) get int machine constants +real = \fBr1mach\fR \&(parameter) get real machine constants +double = \fBd1mach\fR \&(parameter) get double machine constants +.TE diff --git a/unix/os/doc/ostoc.ms b/unix/os/doc/ostoc.ms new file mode 100644 index 00000000..686039fd --- /dev/null +++ b/unix/os/doc/ostoc.ms @@ -0,0 +1,130 @@ +.RP +.ND +.TL +Contents +.PP +Hi there. +.pn 0 +.bp +.ce +\fBContents\fR +.sp 3 +1.\h'|0.4i'\fBIntroduction\fP\l'|5.6i.'\0\01 +.sp +2.\h'|0.4i'\fBStructure of the IRAF System Software\fP\l'|5.6i.'\0\02 +.sp +3.\h'|0.4i'\fBThe IRAF System Interface\fP\l'|5.6i.'\0\04 +.br +\h'|0.4i'3.1.\h'|0.9i'The Language Interface\l'|5.6i.'\0\04 +.br +\h'|0.9i'3.1.1.\h'|1.5i'Fortran\l'|5.6i.'\0\05 +.br +\h'|0.9i'3.1.2.\h'|1.5i'Mixing C and Fortran in the same System\l'|5.6i.'\0\06 +.br +\h'|0.9i'3.1.3.\h'|1.5i'Critique of C as a Scientific Language\l'|5.6i.'\0\08 +.br +\h'|0.9i'3.1.4.\h'|1.5i'The IRAF Subset Preprocessor Language\l'|5.6i.'\0\09 +.br +\h'|0.9i'3.1.5.\h'|1.5i'Limitations of the Subset Preprocessor\l'|5.6i.'\0\010 +.br +\h'|0.4i'3.2.\h'|0.9i'Bootstrapping the System\l'|5.6i.'\0\011 +.br +\h'|0.4i'3.3.\h'|0.9i'The IRAF Kernel\l'|5.6i.'\0\011 +.br +\h'|0.4i'3.4.\h'|0.9i'The Virtual Machine Model\l'|5.6i.'\0\012 +.br +\h'|0.9i'3.4.1.\h'|1.5i'The Minimal Host Machine\l'|5.6i.'\0\012 +.br +\h'|0.9i'3.4.2.\h'|1.5i'The Ideal Host Machine\l'|5.6i.'\0\013 +.sp +4.\h'|0.4i'\fBA Reference Manual for the IRAF Kernel\fP\l'|5.6i.'\0\015 +.br +\h'|0.4i'4.1.\h'|0.9i'Conventions\l'|5.6i.'\0\016 +.br +\h'|0.4i'4.2.\h'|0.9i'Avoiding Library Conflicts\l'|5.6i.'\0\017 +.br +\h'|0.4i'4.3.\h'|0.9i'File I/O\l'|5.6i.'\0\017 +.br +\h'|0.9i'4.3.1.\h'|1.5i'Text Files\l'|5.6i.'\0\018 +.br +\h'|0.9i'4.3.2.\h'|1.5i'Binary Files\l'|5.6i.'\0\020 +.br +\h'|0.9i'4.3.3.\h'|1.5i'Specifying Device Parameters\l'|5.6i.'\0\021 +.br +\h'|0.9i'4.3.4.\h'|1.5i'Standard File Devices\l'|5.6i.'\0\023 +.br +\h'|1.5i'4.3.4.1.\h'|2.2i'The User Terminal\l'|5.6i.'\0\023 +.br +\h'|1.5i'4.3.4.2.\h'|2.2i'The Line Printer Device\l'|5.6i.'\0\024 +.br +\h'|1.5i'4.3.4.3.\h'|2.2i'Interprocess Communication\l'|5.6i.'\0\025 +.br +\h'|1.5i'4.3.4.4.\h'|2.2i'Imagefile Access\l'|5.6i.'\0\026 +.br +\h'|1.5i'4.3.4.5.\h'|2.2i'Magtape Devices\l'|5.6i.'\0\028 +.br +\h'|0.4i'4.4.\h'|0.9i'Filename Mapping\l'|5.6i.'\0\031 +.br +\h'|0.9i'4.4.1.\h'|1.5i'Virtual Filenames\l'|5.6i.'\0\032 +.br +\h'|1.5i'4.4.1.1.\h'|2.2i'Logical Directories and Pathnames\l'|5.6i.'\0\032 +.br +\h'|1.5i'4.4.1.2.\h'|2.2i'Filename Extensions\l'|5.6i.'\0\033 +.br +\h'|0.9i'4.4.2.\h'|1.5i'Filename Mapping Algorithm\l'|5.6i.'\0\034 +.br +\h'|0.4i'4.5.\h'|0.9i'Directory Access\l'|5.6i.'\0\037 +.br +\h'|0.4i'4.6.\h'|0.9i'File Management Primitives\l'|5.6i.'\0\038 +.br +\h'|0.4i'4.7.\h'|0.9i'Process Control\l'|5.6i.'\0\039 +.br +\h'|0.9i'4.7.1.\h'|1.5i'Overview and Terminology\l'|5.6i.'\0\039 +.br +\h'|0.9i'4.7.2.\h'|1.5i'Synchronous Subprocesses\l'|5.6i.'\0\040 +.br +\h'|0.9i'4.7.3.\h'|1.5i'Standard IPC Commands\l'|5.6i.'\0\043 +.br +\h'|0.9i'4.7.4.\h'|1.5i'Example\l'|5.6i.'\0\045 +.br +\h'|0.9i'4.7.5.\h'|1.5i'Background Jobs\l'|5.6i.'\0\046 +.br +\h'|0.9i'4.7.6.\h'|1.5i'The Process and IRAF Mains\l'|5.6i.'\0\048 +.br +\h'|1.5i'4.7.6.1.\h'|2.2i'The Process Main\l'|5.6i.'\0\048 +.br +\h'|1.5i'4.7.6.2.\h'|2.2i'The IRAF Main\l'|5.6i.'\0\050 +.br +\h'|0.9i'4.7.7.\h'|1.5i'Process Control Primitives\l'|5.6i.'\0\051 +.br +\h'|0.4i'4.8.\h'|0.9i'Exception Handling\l'|5.6i.'\0\052 +.br +\h'|0.4i'4.9.\h'|0.9i'Memory Management\l'|5.6i.'\0\054 +.br +\h'|0.4i'4.10.\h'|0.9i'Procedure Call by Reference\l'|5.6i.'\0\055 +.br +\h'|0.4i'4.11.\h'|0.9i'Date and Time\l'|5.6i.'\0\056 +.br +\h'|0.4i'4.12.\h'|0.9i'Sending a Command to the Host OS\l'|5.6i.'\0\056 +.sp +5.\h'|0.4i'\fBBit and Byte Primitives\fP\l'|5.6i.'\0\057 +.br +\h'|0.4i'5.1.\h'|0.9i'Bitwise Boolean Primitives\l'|5.6i.'\0\057 +.br +\h'|0.4i'5.2.\h'|0.9i'Bitfield Primitives\l'|5.6i.'\0\058 +.br +\h'|0.4i'5.3.\h'|0.9i'Byte Primitives\l'|5.6i.'\0\058 +.br +\h'|0.4i'5.4.\h'|0.9i'Vector Primitives\l'|5.6i.'\0\060 +.br +\h'|0.4i'5.5.\h'|0.9i'MII Format Conversions\l'|5.6i.'\0\060 +.br +\h'|0.4i'5.6.\h'|0.9i'Machine Constants for Mathematical Libraries\l'|5.6i.'\0\061 +.sp +6.\h'|0.4i'\fBSystem Parameterization and Tuning\fP\l'|5.6i.'\0\062 +.sp +7.\h'|0.4i'\fBOther Machine Dependencies\fP\l'|5.6i.'\0\062 +.br +\h'|0.4i'7.1.\h'|0.9i'Machine Dependencies in the CL\l'|5.6i.'\0\063 +.sp +8.\h'|0.4i'\fBSpecifications for the Kernel Procedures\fP\l'|5.6i.'\0\063 diff --git a/unix/os/doc/zalocd.hlp b/unix/os/doc/zalocd.hlp new file mode 100644 index 00000000..3b98944c --- /dev/null +++ b/unix/os/doc/zalocd.hlp @@ -0,0 +1,53 @@ +.help zalocd Aug85 "System Interface" +.ih +NAME +zalocd -- set, remove, or query device allocation +.ih +SYNOPSIS +.nf +zalocd (device, action, status) + +packed char device[ARB] # device 1 +int action # operation to be performed +int status +.fi +.ih +DESCRIPTION +The named logical device is either allocated or deallocated, or the device +allocation status is queried, depending upon the value of the \fIaction\fR +argument. + +.nf + DEALLOCATE_DEVICE 0 + ALLOCATE_DEVICE 1 + QUERY_ALLOCATION 2 +.fi + +By allocating a device we mean that [1] the device is reserved for use by the +owner of the process issuing the request, and [2] the device is readied for +opening by the process issuing the request, or by a subprocess of the process +issuing the request. If the device is a tape drive the drive should be +mounted foreign (unlabeled) and the density should be set if so indicated +in the + +It is not an error to attempt to allocate a device which is already allocated, +nor is it an error to attempt to deallocate a device which is not currently +allocated. +.ih +RETURN VALUE +OK is returned if a set_protection or remove_protection operation is +successful. YES (protected) or NO (not protected) is returned in response +to a query. ERR is returned if the named file does not exist or if +the operation cannot be performed. +.ih +NOTES +FIO will query for file protection before attempting to delete a file. +If the host system does not provide file protection facilities they can +often be faked by creating a hidden file in the same directory; the existence +of the file will indicate that the file is protected. If the hidden file +technique is used, the hidden file should not be seen when the directory +is read by the high level code. +.ih +SEE ALSO +zfdele +.endhelp diff --git a/unix/os/doc/zardbf.hlp b/unix/os/doc/zardbf.hlp new file mode 100644 index 00000000..086d17bb --- /dev/null +++ b/unix/os/doc/zardbf.hlp @@ -0,0 +1,56 @@ +.help zardbf May84 "System Interface" +.ih +NAME +zardbf -- asynchronous read from a binary file +.ih +SYNOPSIS +.nf +zardbf (chan, buf, maxbytes, loffset) + +int chan # OS channel assigned to file +char buf[maxbytes] # output buffer +int maxbytes # maximum number of bytes to read +long loffset # file offset of first byte +.fi +.ih +DESCRIPTION +Initiate a read of at most \fImaxbytes\fR bytes from channel \fIchan\fR into +the buffer \fIbuf\fR. If the file associated with \fIchan\fR is a blocked file +the transfer begins at the one-indexed file offset \fIloffset\fR, specified +in units of bytes. The file offset must be greater than or equal to 1 and +less than or equal to the size of the file in bytes plus one. If the file is +a streaming file the file offset argument is ignored. If the file is blocked +\fIloffset\fR must be an integral multiple of the device block size, +i.e., the transfer must be aligned on a device block boundary. +At most \fImaxbytes\fR bytes are read. If the physical file block is +larger than \fImaxbytes\fR bytes the additional data is discarded. + +A read from a streaming file returns the next physical block in the file. +Successive blocks may vary in size; the size of a block is fixed when the +block is written (appended) to the file by \fBzawrbf\fR. If \fBzawrbf\fR +writes a block of length N bytes, the corresponding call to \fBzardbf\fR will +return either N bytes or \fImaxbytes\fR bytes, whichever is smaller, +discarding any additional data if \fImaxbytes\fR is less than N. +.ih +RETURN VALUE +The wait primitive \fBzawtbf\fR must be called after every asynchronous read +to get the transfer status. ERR is returned if a read error occurs or if the +channel number or file offset is illegal. If the read operation is successful +the actual number of bytes read is returned; zero is returned for a read at EOF. +.ih +NOTES +The transfer is NOT guaranteed to be asynchronous and the calling program +must not assume that \fBzardbf\fR will return immediately. +The \fBzawtbf\fR primitive must be called and the status checked before +another i/o request is issued to the channel. Only a single request may +be pending on a channel at a time. + +This primitive is called by the FIO routine \fBaread\fR which verifies that +the transfer is aligned and in-bounds, that a transfer is not already in +progress, and so on before calling \fBzardbf\fR. +A request to read zero bytes will not be passed to \fBzardbf\fR +and should be considered an error to avoid confusion with a read at EOF. +.ih +SEE ALSO +zawtbf, zawrbf, zfiobf +.endhelp diff --git a/unix/os/doc/zawrbf.hlp b/unix/os/doc/zawrbf.hlp new file mode 100644 index 00000000..8ff1b017 --- /dev/null +++ b/unix/os/doc/zawrbf.hlp @@ -0,0 +1,56 @@ +.help zawrbf May84 "System Interface" +.ih +NAME +zawrbf -- asynchronous write to a binary file +.ih +SYNOPSIS +.nf +zawrbf (chan, buf, nbytes, loffset) + +int chan # OS channel assigned to file +char buf[nbytes] # buffer to be copied to file +int nbytes # number of bytes to be written +long loffset # file offset of first byte +.fi +.ih +DESCRIPTION +Initiate a write of exactly \fInbytes\fR bytes from the buffer \fIbuf\fR +to the channel \fIchan\fR. If the file associated with \fIchan\fR is a +blocked file the transfer begins at the one-indexed file offset \fIloffset\fR, +specified in units of bytes. The file offset must be greater than or equal +to 1 and less than or equal to the size of the file in bytes plus one. +If the file is a streaming file the file offset argument is ignored. +If the file is blocked \fIloffset\fR must be an integral multiple of the +device block size, i.e., the transfer must be aligned on a device block +boundary. A request to write zero bytes is ignored. + +If writing entirely within the interior of the file \fInbytes\fR must be an +integral multiple of the device block size. If writing at EOF any number of +bytes may be written (provided the maximum transfer size is not exceedd). +A file may be extended by writing at EOF or by overwriting EOF in a large +transfer. If the last block in the file is a partial block the file must +be extended by reading the partial block into memory, appending the new data, +and then overwriting EOF with the larger block. File offsets must be explicit +byte offsets, i.e., the constants BOF and EOF are not recognized for binary +file offsets. +.ih +RETURN VALUE +The wait primitive \fBzawtbf\fR must be called after every asynchronous write +to get the transfer status. ERR is returned if a write error occurs or if the +channel number or file offset is illegal. If the write operation is successful +the actual number of bytes written is returned. +.ih +NOTES +The transfer is NOT guaranteed to be asynchronous and the calling program +must not assume that \fBzawrbf\fR will return immediately. +The \fBzawtbf\fR primitive must be called and the status checked before +another i/o request is issued to the channel. Only a single request may +be pending on a channel at a time. + +This primitive is called by the FIO routine \fBawrite\fR which verifies that +the transfer is aligned and in-bounds, that a transfer is not already in +progress, and so on before calling \fBzawrbf\fR. +.ih +SEE ALSO +zawtbf, zardbf, zfiobf +.endhelp diff --git a/unix/os/doc/zawset.hlp b/unix/os/doc/zawset.hlp new file mode 100644 index 00000000..7d85bc5e --- /dev/null +++ b/unix/os/doc/zawset.hlp @@ -0,0 +1,42 @@ +.help zawset May84 "System Interface" +.ih +NAME +zawset -- adjust working set size +.ih +SYNOPSIS +.nf +zawset (requested_size, newsize, oldsize, textsize) + +int requested_size # desired working set size, bytes +int newsize # working set allocated, bytes +int oldsize # old working set size, bytes +int textsize # size of text segment +.fi +.ih +DESCRIPTION +Adjust the amount of physical memory allocated to a process, i.e., the +working set size on a virtual memory machine. The amount of additional +data space that can be allocated and used by a process without thrashing +on a virtual memory machine is \fInewsize\fR bytes minus some fraction +of the text segment size (executable instructions) and minus the data space +already in use. + +The actual working set size returned in \fInewsize\fR need not be what was +requested. The old working set size \fIoldsize\fR may be used to reset the +working set size of the process to its original value when the space is no +longer needed. If \fIrequested_size\fR is negative or zero the current size is +returned in both output arguments and the working set size is not changed. +On a nonvirtual memory machine the "working set size" is a machine constant +fixed by the addressing range of the hardware, hence the requested size is +ignored. +.ih +RETURN VALUE +Valid \fInewsize\fR, \fIoldsize\fR and \fBtextsize\fR are always returned. +.ih +NOTES +It is up to the high level code to supply the necessary heuristics to avoid +thrashing on a virtual memory machine. +.ih +SEE ALSO +zmalloc, zmfree, zraloc +.endhelp diff --git a/unix/os/doc/zawtbf.hlp b/unix/os/doc/zawtbf.hlp new file mode 100644 index 00000000..cf387772 --- /dev/null +++ b/unix/os/doc/zawtbf.hlp @@ -0,0 +1,34 @@ +.help zawtbf May84 "System Interface" +.ih +NAME +zawtbf -- wait for an asynchronous i/o transfer to complete +.ih +SYNOPSIS +.nf +zawtbf (chan, status) + +int chan # OS channel assigned to file +int status # number of bytes read or written +.fi +.ih +DESCRIPTION +If a transfer is in progress on the channel \fIchan\fR, process execution +is suspended until the transfer completes. If the channel is inactive +control returns immediately. +.ih +RETURN VALUE +ERR is returned if an i/o error occurred during the last transfer. +If the transfer was successful the number of bytes read or written is +returned. A read at EOF returns a status value of zero. +Repeated calls to \fBzawtbf\fR following a single i/o request continue +to return the same value. +.ih +NOTES +FIO guarantees that \fBzawtbf\fR will be called after every asynchronous +i/o transfer and that only a single i/o request will be posted to a channel +at a time. If an i/o error occurs on the channel it should be cleared by +the next request, i.e., errors should not "stick". +.ih +SEE ALSO +zardbf, zawrbf, zfiobf +.endhelp diff --git a/unix/os/doc/zcall.hlp b/unix/os/doc/zcall.hlp new file mode 100644 index 00000000..ae7af4ff --- /dev/null +++ b/unix/os/doc/zcall.hlp @@ -0,0 +1,39 @@ +.help zcall,zcall1,zcall2,zcall3,zcall4,zcall5 May84 "System Interface" +.ih +NAME +zcall -- call an external procedure by reference +.ih +SYNOPSIS +.nf +zcall1 (procedure, arg1) +zcall2 (procedure, arg1, arg2) +zcall3 (procedure, arg1, arg2, arg3) +zcall4 (procedure, arg1, arg2, arg3, arg4) +zcall5 (procedure, arg1, arg2, arg3, arg4, arg5) + +int procedure # reference to external procedure +arb arg1, ..., arg\fIn\fR # arguments for external procedure +.fi +.ih +DESCRIPTION +The subroutine referenced by the magic integer passed as the first argument +is called as a subprocedure. The \fIn\fR arguments to \fBzcall\fR are passed +to the subprocedure by reference; the datatypes of the actual arguments are +unknown but the number and datatypes of the arguments must match those +expected by the subprocedure. The arguments are restricted to variables, +constants, arrays, and array elements of datatypes \fBcsilrd\fR. The magic +integer \fIprocedure\fR must have been obtained by a prior call to \fBzlocpr\fR. +.ih +RETURN VALUE +Any of the arguments may be used to return a value depending on the +significance of the argument to the subprocedure called. +The procedure itself may not return a value, i.e., \fBzcall\fR may not +be used to call a function. +.ih +NOTES +The arguments to \fIprocedure\fR must not be Fortran CHARACTER variables +or constants, external procedures, or objects of datatype complex. +.ih +SEE ALSO +zlocpr +.endhelp diff --git a/unix/os/doc/zclcpr.hlp b/unix/os/doc/zclcpr.hlp new file mode 100644 index 00000000..55574785 --- /dev/null +++ b/unix/os/doc/zclcpr.hlp @@ -0,0 +1,33 @@ +.help zclcpr May84 "System Interface" +.ih +NAME +zclcpr -- close or disconnect a connected subprocess +.ih +SYNOPSIS +.nf +zclcpr (pid, exit_status) + +int pid # process id (a magic integer) +int exit_status # termination code from process +.fi +.ih +DESCRIPTION +Disconnect a subprocess previously connected with \fBzopcpr\fR, +i.e., close the IPC channels and wait for the subprocess to terminate. +Control does not return until the child process has terminated. + +If the child process attempts to write to the parent after the IPC channels +have been closed the X_IPC exception will be raised in the child process. +If the child attempts to read from the parent after the parent has +disconnected, the child will see EOF on the read and will shutdown. +.ih +RETURN VALUE +The integer termination code of the child process is returned in +\fIexit_status\fR. A status of OK (zero) indicates normal termination. +ERR is returned for an illegal \fIpid\fR. +If the child terminates abnormally, i.e., if a panic exit occurs, the positive +integer error code of the error which caused process termination is returned. +.ih +SEE ALSO +zopcpr, zintpr, zxwhen +.endhelp diff --git a/unix/os/doc/zcldir.hlp b/unix/os/doc/zcldir.hlp new file mode 100644 index 00000000..1503611c --- /dev/null +++ b/unix/os/doc/zcldir.hlp @@ -0,0 +1,28 @@ +.help zcldir May84 "System Interface" +.ih +NAME +zcldir -- close a directory file +.ih +SYNOPSIS +.nf +zcldir (chan, status) + +int chan # OS channel of directory file +int status +.fi +.ih +DESCRIPTION +Close a directory file previously opened for reading with \fBzopdir\fR. +.ih +RETURN VALUE +ERR is returned in \fIstatus\fR for an illegal \fIchan\fR. OK is returned +if the operation is successful. +.ih +NOTES +A directory file is not accessed as an ordinary file; the significance of +\fIchan\fR is unknown to the high level code and need not refer to a physical +host i/o channel. +.ih +SEE ALSO +zopdir, zgfdir +.endhelp diff --git a/unix/os/doc/zcldpr.hlp b/unix/os/doc/zcldpr.hlp new file mode 100644 index 00000000..5e80700c --- /dev/null +++ b/unix/os/doc/zcldpr.hlp @@ -0,0 +1,38 @@ +.help zcldpr May84 "System Interface" +.ih +NAME +zcldpr -- close a detached process +.ih +SYNOPSIS +.nf +zcldpr (jobcode, killflag, exit_status) + +int jobcode # code by which job is known to system +int killflag # if YES, kill bkg job +int exit_status # exit status of bkg job +.fi +.ih +DESCRIPTION +If \fIkillflag\fR is NO, process execution will be suspended until +the background job terminates. If \fIkillflag\fR is YES the background +job is dequeued if it has not yet been run, or is killed if it is currently +executing. The integer \fIjobcode\fR is the magic number assigned the +job by the \fBzopdpr\fR primitive. +.ih +RETURN VALUE +ERR is returned for an illegal \fIjobcode\fR or for an attempt to kill +a job without the necessary permissions. If the operations completes +successfully the exit status of the process, i.e., OK or a positive integer +error code, is returned in \fIexit_status\fR. +.ih +NOTES +The CL calls this procedure whenever it detects that a background job has +terminated, since a background job may be run as a subprocess on some systems +and since it may be necessary to perform special actions after a subprocess has +terminated. The CL also calls this procedure whenever the user \fBkills\fR a +background job, or when the user wishes to \fBwait\fR for a background job to +terminate. +.ih +SEE ALSO +zopdpr +.endhelp diff --git a/unix/os/doc/zclsbf.hlp b/unix/os/doc/zclsbf.hlp new file mode 100644 index 00000000..1d436a59 --- /dev/null +++ b/unix/os/doc/zclsbf.hlp @@ -0,0 +1,32 @@ +.help zclsbf May84 "System Interface" +.ih +NAME +zclsbf -- close a binary file +.ih +SYNOPSIS +.nf +zclsbf (chan, status) + +int chan # OS channel of binary file +int status +.fi +.ih +DESCRIPTION +The binary file associated with the channel \fIchan\fR is closed, i.e., +the file is disassociated from the process which opened it and freed for +access by some other process, and the channel is freed for use with another +file. A binary file must be closed before process termination or the integrity +of the file is not guaranteed. +.ih +RETURN VALUE +ERR is returned in \fIstatus\fR for an illegal \fIchan\fR. OK is returned +if the operation is successful. +.ih +NOTES +The IRAF Main guarantees that all files will be closed prior to process +shutdown. The Main will also close all open files at program termination +unless the program explicitly indicates that a file is to be left open. +.ih +SEE ALSO +zopnbf, zfiobf +.endhelp diff --git a/unix/os/doc/zclstx.hlp b/unix/os/doc/zclstx.hlp new file mode 100644 index 00000000..1eeb184e --- /dev/null +++ b/unix/os/doc/zclstx.hlp @@ -0,0 +1,35 @@ +.help zclstx May84 "System Interface" +.ih +NAME +zclstx -- close a text file +.ih +SYNOPSIS +.nf +zclstx (chan, status) + +int chan # OS channel of text file +int status +.fi +.ih +DESCRIPTION +The text file associated with the channel \fIchan\fR is closed, i.e., +the file is disassociated from the process which opened it and freed for +access by some other process, and the channel is freed for use with another +file. A text file must be closed before process termination or the integrity +of the file is not guaranteed. +.ih +RETURN VALUE +ERR is returned in \fIstatus\fR for an illegal \fIchan\fR. OK is returned +if the operation is successful. +.ih +NOTES +FIO does not assume that \fBzclstx\fR will flush any buffered output; +FIO will explicitly flush buffered output before calling \fBzclstx\fR to +close a file. The IRAF Main guarantees that all files will be closed prior +to process shutdown. The Main will also close all open files at program +termination unless a program explicitly indicates that a file is to be +left open. +.ih +SEE ALSO +zopntx, zfiotx +.endhelp diff --git a/unix/os/doc/zfacss.hlp b/unix/os/doc/zfacss.hlp new file mode 100644 index 00000000..206d05e4 --- /dev/null +++ b/unix/os/doc/zfacss.hlp @@ -0,0 +1,37 @@ +.help zfacss May84 "System Interface" +.ih +NAME +zfacss -- determine the accessibility and type of a file +.ih +SYNOPSIS +.nf +zfacss (osfn, mode, type, status) + +packed char osfn[] # host filename +int mode # access mode to be checked +int type # file type to be tested +int status # is file accessible as specified +.fi +.ih +DESCRIPTION +Determine if a file is accessible with the indicated access modes and whether +or not the file is of the indicated type. If either \fImode\fR or \fItype\fR is +zero it is not checked; if both are zero, only the existence of the file +is checked. Legal access modes are 0, READ_ONLY, READ_WRITE, WRITE_ONLY, and +APPEND. Legal file types are 0, TEXT_FILE, and BINARY_FILE. +.ih +RETURN VALUE +YES is returned if the file is accessible with the indicated mode and type; +NO is returned otherwise. +.ih +NOTES +On some systems (e.g. UNIX) it is necessary to actually read part of the file +to test whether or not it is a text file, since the OS does not discriminate +between text and binary files. Hence use of \fBzfacss\fR to check the file +type is an expensive operation on some systems. +There is no guarantee that the accessibility of a file will not change between +the time \fBzfacss\fR is called and before the file is opened. +.ih +SEE ALSO +zfinfo, zfprot +.endhelp diff --git a/unix/os/doc/zfaloc.hlp b/unix/os/doc/zfaloc.hlp new file mode 100644 index 00000000..c22efb62 --- /dev/null +++ b/unix/os/doc/zfaloc.hlp @@ -0,0 +1,34 @@ +.help zfaloc May84 "System Interface" +.ih +NAME +zfaloc -- preallocate space for a binary file +.ih +SYNOPSIS +.nf +zfaloc (osfn, nbytes, status) + +packed char osfn[] # host filename +long nbytes # file size in bytes +int status +.fi +.ih +DESCRIPTION +Create and allocate storage for a file of the indicated size. The actual amount +of storage allocated will be the requested size rounded up to an integral +number of device blocks. Contiguous storage will be allocated if possible. +File data is unitialized. +.ih +RETURN VALUE +ERR is returned if the file cannot be created or if the requested amount of +storage cannot be allocated. OK is returned if there are no errors. +.ih +BUGS +On some systems it is necessary to physically write to a file to allocate +storage; preallocation of file storage is very expensive on such systems and +should be avoided. On other systems storage will appear to have been +allocated but physical storage will not be allocated until file blocks are +accessed at run time. +.ih +SEE ALSO +A discussion of the static file driver and imagefile access. +.endhelp diff --git a/unix/os/doc/zfchdr.hlp b/unix/os/doc/zfchdr.hlp new file mode 100644 index 00000000..08b6c4ca --- /dev/null +++ b/unix/os/doc/zfchdr.hlp @@ -0,0 +1,29 @@ +.help zfchdr May84 "System Interface" +.ih +NAME +zfchdr -- change the current working directory +.ih +SYNOPSIS +.nf +zfchdr (new_directory, status) + +packed char new_directory[] # osfn of new directory +int status +.fi +.ih +DESCRIPTION +The current working directory is changed to the directory specified +by the packed OS pathname given as the first argument. +.ih +RETURN VALUE +ERR is returned if the new directory does not exist or cannot be accessed. +OK is returned if the operation is successful. +.ih +NOTES +On a host system with a flat directory structure the kernel will have to map +the hierarchical directory structure assumed by IRAF onto the linear directory +structure provided by the host. +.ih +SEE ALSO +zfpath, zopdir, zgfdir, zfsubd +.endhelp diff --git a/unix/os/doc/zfdele.hlp b/unix/os/doc/zfdele.hlp new file mode 100644 index 00000000..5016a2b5 --- /dev/null +++ b/unix/os/doc/zfdele.hlp @@ -0,0 +1,29 @@ +.help zfdele May84 "System Interface" +.ih +NAME +zfdele -- delete a file +.ih +SYNOPSIS +.nf +zfdele (osfn, status) + +packed char osfn[] # host filename +int status +.fi +.ih +DESCRIPTION +The named file is deleted. +.ih +RETURN VALUE +ERR is returned if the file does not exist or cannot be deleted. +OK is returned if the operation is successful. +.ih +NOTES +A protected file cannot be deleted. FIO checks for file protection before +calling the kernel to delete a file. FIO will not attempt to delete a file +while the file is open by the current process. If an attempt is made to +delete a file which is open by another process the result is system dependent. +.ih +SEE ALSO +zfprot +.endhelp diff --git a/unix/os/doc/zfgcwd.hlp b/unix/os/doc/zfgcwd.hlp new file mode 100644 index 00000000..11fb5735 --- /dev/null +++ b/unix/os/doc/zfgcwd.hlp @@ -0,0 +1,26 @@ +.help zfgcwd May84 "System Interface" +.ih +NAME +zfgcwd -- get current working directory +.ih +SYNOPSIS +.nf +zfgcwd (pathname, maxch, status) + +packed char pathname[maxch] # receives pathname of cwd +int maxch, status +.fi +.ih +DESCRIPTION +The pathname of the current working directory is returned as a packed string, +suitable for concatenation with a filename to produce the pathname of the file. +.ih +RETURN VALUE +ERR is returned if the output string overflows or if the name of the current +working directory cannot be obtained for some reason. If the operation is +successful the number of characters in the output string is returned, +excluding the EOS delimiter. +.ih +SEE ALSO +zfxdir, zfsubd, zfpath +.endhelp diff --git a/unix/os/doc/zfinfo.hlp b/unix/os/doc/zfinfo.hlp new file mode 100644 index 00000000..7738de94 --- /dev/null +++ b/unix/os/doc/zfinfo.hlp @@ -0,0 +1,66 @@ +.help zfinfo May84 "System Interface" +.ih +NAME +zfinfo -- get directory information for the named file +.ih +SYNOPSIS +.nf +include + +zfinfo (osfn, out_struct, status) + +packed char osfn[] # host filename +long out_struct[LEN_FINFO] # output structure +int status +.fi +.ih +DESCRIPTION +A binary structure is returned describing the named file. + +.nf + struct finfo { + long fi_type # file type + long fi_size # file size, bytes + long fi_atime # time of last access + long fi_mtime # time of last modify + long fi_ctime # time of file creation + long fi_perm # file permission bits + char fi_owner[15] # name of file owner + } + +File types: + + FI_REGULAR 1 # ordinary file + FI_DIRECTORY 2 # directory file + FI_EXECUTABLE 3 # executable image + FI_SPECIAL 4 # terminals etc. +.fi + +The file owner name is returned as a packed string. Times are in long integer +seconds since midnight Jan 1, 1980 LST. File permissions are encoded in +bits 1-6 of \fIfi_perm\fR as follows: + +.nf + bit 1,2 owner r,w + bit 3,4 group r,w + bit 5,6 world r,w +.fi + +An ordinary file may be either a text file or a binary file. A directory file +is the entry for a subdirectory of the directory referenced by \fBzfinfo\fR. +An executable file is a file marked executable by the host (the exact +significance of an executable file is machine dependent). +Everything else is a special file. +.ih +RETURN VALUE +ERR is returned if the named file does not exist or cannot be accessed. +OK is returned if the operation is successful. +.ih +NOTES +\fBZfinfo\fR is not used to determine if a file is protected from deletion +or to determine whether a file is a text or binary file. \fBZfinfo\fR should +not be called to obtain information on an open file. +.ih +SEE ALSO +zfprot, zfacss +.endhelp diff --git a/unix/os/doc/zfiobf.hlp b/unix/os/doc/zfiobf.hlp new file mode 100644 index 00000000..96fd2022 --- /dev/null +++ b/unix/os/doc/zfiobf.hlp @@ -0,0 +1,53 @@ +.help zfiobf May84 "System Interface" +.ih +NAME +zfiobf -- binary file driver +.ih +SYNOPSIS +.nf +zopnbf (osfn, mode, chan) # open or create binary file +zclsbf (chan, status) # close binary file +zardbf (chan, buf, maxbytes, loffset) # asynchronous read +zawrbf (chan, buf, nbytes, loffset) # asynchronous write +zawtbf (chan, status) # wait for transfer +zsttbf (chan, param, lvalue) # get file/device status + +packed char osfn[] +char buf[] +int mode, chan, maxbytes, nbytes, param, status +long loffset, lvalue +.fi +.ih +DESCRIPTION +A binary file is an extendable array of machine bytes. There are two types +of binary files: \fBblocked\fR files, which are randomly accessible in chunks +the size of a device block, and \fBstreaming\fR binary files, which are +restricted to sequential access and characterized by a variable block size. +A binary file is effectively an extension of host memory, i.e., arbitrary +regions of memory may be written to a binary file and later restored +(possibly at a different location) without modification of the data. +Unlike the text file, there are no restrictions on the contents of a binary +file. +.ih +RETURN VALUES +When a binary file is opened the kernel assigns a channel to the file +and all subsequent file operations refer to the file by the channel number. +The asynchronous read and write primitives do not return a status value; +the number of bytes read or written or ERR is returned in a subsequent +call to \fBzawtbf\fR. Every i/o transfer must be followed by a call to +\fBzawtbf\fR. Only one transfer is permitted on a file at a time. +.ih +NOTES +If a file is accessed by name (rather than by channel number) while the file +is open the results are machine dependent. +If a file is blocked reads and writes must be aligned on block boundaries; +file offsets are one-indexed. A binary file may be extended by writing at +EOF or by overwriting EOF. All blocks but the last in a blocked file are the +same size; the last block may be partially full. A write to a streaming +file appends a new block of size \fInbytes\fR to the file; successive blocks +may vary in size. Each read from a streaming file returns a single variable +length block. +.ih +SEE ALSO +zfiotx, manual pages for the individual routines +.endhelp diff --git a/unix/os/doc/zfiolp.hlp b/unix/os/doc/zfiolp.hlp new file mode 100644 index 00000000..d3c4167e --- /dev/null +++ b/unix/os/doc/zfiolp.hlp @@ -0,0 +1,54 @@ +.help zfiolp May84 "System Interface" +.ih +NAME +zfiolp -- line printer driver +.ih +SYNOPSIS +.nf +zopnlp (osfn, mode, chan) # open line printer +zclslp (chan, status) # close line printer +zardlp (chan, buf, maxbytes, loffset) # asynchronous read +zawrlp (chan, buf, nbytes, loffset) # asynchronous write +zawtlp (chan, status) # wait for transfer +zsttlp (chan, param, lvalue) # get file/device status + +packed char osfn[] +char buf[] +int mode, chan, maxbytes, nbytes, param, status +long loffset, lvalue +.fi +.ih +DESCRIPTION +The line printer devices are interfaced as binary files. Except where noted +herein, the line printer driver is functionally equivalent to the driver for +an ordinary streaming binary file. + +A line printer device is opened with \fBzopnlp\fR and closed with \fBzclslp\fR. +The name of the device to be opened is given by \fIosfn\fR and is host system +dependent. The names of the printer devices recognized by \fBzopnlp\fR must +agree with those in the CL environment list and in the printer capability file +\fBdev$printcap\fR. Only the APPEND and WRITE_ONLY modes are supported by +most printer devices. Depending on the location and characteristics of the +device, \fBzopnlp\fR may or may not open the device directly. Often a +binary spoolfile is opened instead, and the spoolfile is (asynchronously) +disposed of to the physical device when \fBzclspr\fR is called. + +Binary data is copied to the printer device without modification, hence all +control functions (including newline) must have been fully translated into +device dependent control sequences by the time \fBzawrlp\fR is called to +output the data to the device. Either character data or binary bitmap data +(graphics) may be transmitted to a printer device. +.ih +NOTES +If the printer device is very fast it will not be desirable to spool printer +output when printing large text files due to the additional expense of writing +a large spoolfile. A better approach is to write directly to the device if +it is available, spooling only if the device is already in use at \fBzopnlp\fR +time. A second virtual device can be defined which writes to the same +physical device but which always spools the output. If the line printer +device is shared in a local area network it may be necessary to spool the +output and copy the spoolfile to a remote host for disposal to the printer. +.ih +SEE ALSO +zfiobf, lpopen, dev$printcap, manual pages for the binary file driver +.endhelp diff --git a/unix/os/doc/zfiomt.hlp b/unix/os/doc/zfiomt.hlp new file mode 100644 index 00000000..717524a4 --- /dev/null +++ b/unix/os/doc/zfiomt.hlp @@ -0,0 +1,65 @@ +.help zfiomt May84 "System Interface" +.ih +NAME +zfiomt -- magtape driver primitives +.ih +SYNOPSIS +.nf +zzopmt (drive, density, mode, oldrec, oldfile, newfile, chan) +zzclmt (chan, mode, nrecords, nfiles, status) +zzrdmt (chan, buf, maxbytes) +zzwrmt (chan, buf, nbytes) +zzwtmt (chan, nrecords, nfiles, status) +zzrwmt (chan, status) + +int drive, density, mode, oldrec, oldfile, newfile, chan +int nfiles, maxbytes, nbytes, nrecords, nfiles, status +char buf[] +.fi +.ih +DESCRIPTION +Magnetic tape is interfaced to FIO as a streaming binary file. +The conventional set of six binary file driver routines (suffix "mt") are +used, but due to the complexity of the driver the machine dependence has +been further concentrated into the six primitives shown above. The standard +driver routines are machine independent and are included in the standard +distribution. + +Since the magtape primitives are unique, separate manual pages are provided +for each primitive. The most complex primitive is \fBzzopmt\fR, which opens +a single file on a magtape device. To maximize the machine and device +independence of magtape i/o, only a single file may be accessed per open. +Aside from the rewind primitive \fBzzrwmt\fR there are no explicit tape +positioning commands. The tape is positioned ready to read or write the +first record of a file by \fBzzopmt\fR, and thereafter the tape moves only +when it is read or written. All magtape i/o is sequential, and a file may +be opened for reading or for writing but not for both. +.ih +RETURN VALUES +The \fIchan\fR and \fIstatus\fR parameters are identical to those for any +other streaming binary file. Magtape i/o is unique in that the high level +code is charged with keeping track of the position of the tape at all times. +The \fInrecords\fR and \fInfiles\fR return values tell the high level code +how much the tape was moved each time a primitive is called. +.ih +NOTES +To IRAF programs a magtape is a sequence of zero or more files separated +by end of file marks (filemarks, EOF) with an end of tape mark (tapemark, EOT) +following the last file on the tape. Each file consists of one or more +data blocks. Successive data blocks may vary in size; very short blocks +and odd size blocks (block size not commensurate with the size of an SPP char) +can cause problems. The high level code tries hard to deal with odd size +blocks and such but success is not guaranteed. A tapemark is a double end +of file mark. As far as the i/o system is concerned tapes are unlabeled +and files do not have headers; everything but filemarks and tapemarks is data. + +There is no explicit provision for multivolume sets. It is assumed that either +the host system or the kernel will provide the necessary functionality to deal +with multivolume sets. We assume that if physical end of tape is encountered +while reading or writing a tape block the process of informing the operator to +mount the new volume, rereading or rewriting the block, etc., will be performed +transparently to the high level code. +.ih +SEE ALSO +zfiobf, mtopen +.endhelp diff --git a/unix/os/doc/zfiopr.hlp b/unix/os/doc/zfiopr.hlp new file mode 100644 index 00000000..555deccd --- /dev/null +++ b/unix/os/doc/zfiopr.hlp @@ -0,0 +1,58 @@ +.help zfiopr May84 "System Interface" +.ih +NAME +zfiopr -- IPC driver +.ih +SYNOPSIS +.nf +zopnpr (osfn, mode, chan) # ** NOT USED ** +zclspr (chan, status) # ** NOT USED ** +zardpr (chan, buf, maxbytes, loffset) # asynchronous read +zawrpr (chan, buf, nbytes, loffset) # asynchronous write +zawtpr (chan, status) # wait for transfer +zsttpr (chan, param, lvalue) # get file/device status + +packed char osfn[] +char buf[] +int mode, chan, maxbytes, nbytes, param, status +long loffset, lvalue +.fi +.ih +DESCRIPTION +The IPC driver is used to read and write the inter-process communications +channels connecting parent and child processes. Except where noted herein, +the specifications of the IPC driver are equivalent to those of the ordinary +streaming binary file driver. + +The \fBzopnpr\fR and \fBzclspr\fR primitives are not used by the IPC driver +and should not be supplied. The process connect and disconnect primitives +\fBzopcpr\fR and \fBzclcpr\fR are used to open and close the IPC channels +to a subprocess and perform other process control functions as well. + +The IPC channels, like all other streaming binary files, read and write data +blocks. Thus, if process A calls \fBzawrpr\fR to write a binary block of length +N bytes into an IPC channel, an N byte block will be returned by \fBzardpr\fR +to process B at the other end of the channel. Data blocks may be queued +in a channel until the storage capacity of the channel is reached. +If process A writes an N byte block and an M byte block into a channel with +successive \fBzawrpr\fR calls, process B will read an N byte block and an M +byte block in successive \fBzardpr\fR calls. + +If a process tries to write into a full channel process execution will be +suspended until enough data has been read from the channel to permit +completion of the write. If a process tries to read from an empty channel +it will be suspended until the process at the other end writes into the +channel or until the writing process closes the channel, in which case the +reader sees EOF. If the IPC driver is fully asynchronous process execution +will not be suspended until \fBzawtpr\fR is called. The wait primitive +returns when the data block has been written into the channel, rather than +when the data has been read by the process at the other end. +.ih +NOTES +If a process writes into a channel with no reader (the reading process has +died, e.g., in a \fBzpanic\fR exit), the exception X_IPC will be raised in +the writing process. This is necessary to avoid deadlock. +.ih +SEE ALSO +zfiobf, zopcpr, zclcpr, zintpr, zxwhen +.endhelp diff --git a/unix/os/doc/zfiosf.hlp b/unix/os/doc/zfiosf.hlp new file mode 100644 index 00000000..e618031c --- /dev/null +++ b/unix/os/doc/zfiosf.hlp @@ -0,0 +1,51 @@ +.help zfiosf May84 "System Interface" +.ih +NAME +zfiosf -- static file driver +.ih +SYNOPSIS +.nf +zopnsf (osfn, mode, chan) # open static file +zclssf (chan, status) # close static file +zardsf (chan, buf, maxbytes, loffset) # asynchronous read +zawrsf (chan, buf, nbytes, loffset) # asynchronous write +zawtsf (chan, status) # wait for transfer +zsttsf (chan, param, lvalue) # get file/device status + +packed char osfn[] +char buf[] +int mode, chan, maxbytes, nbytes, param, status +long loffset, lvalue +.fi +.ih +DESCRIPTION +The static file driver is used to randomly access binary files which do not +change in size once created, hence the term static. Except where noted +herein, the specifications of the static file driver are equivalent to those +of the ordinary random access binary file driver. + +A static binary file is created by the kernel primitive \fBzfaloc\fR, +hence \fBzopnsf\fR cannot be used to create a new file (NEW_FILE mode is not +supported). The asynchronous read and write primitives behave conventionally +except that writing at EOF or overwriting EOF is not permitted. +.ih +NOTES +The static file driver should provide the lowest possible level of binary +file i/o for maximum efficiency. Since the file size is known at file creation +time it is often possible to allocate a contiguous file. Given a contiguous or +nearly contiguous file which does not change in size it is sometimes possible +to bypass the host files system once the file has been created, i.e., to +map the \fBzfiosf\fR primitives directly into calls to the disk driver on the +host machine. + +On a virtual memory machine it may also be possible to map the static file +into virtual memory, i.e., defer i/o until the file data is actually used. +If a virtual memory interface is implemented \fBzardsf\fR will remap pages +of memory, \fBzawrsf\fR will update pages of memory, \fBzawtsf\fR will do +nothing but return status, and \fBzclssf\fR will update and unmap any +mapped pages and close the file. See the reference manual for further +discussion of static file implementation strategies. +.ih +SEE ALSO +zfiobf, manual pages for the binary file driver +.endhelp diff --git a/unix/os/doc/zfiotx.hlp b/unix/os/doc/zfiotx.hlp new file mode 100644 index 00000000..e65ce6fe --- /dev/null +++ b/unix/os/doc/zfiotx.hlp @@ -0,0 +1,44 @@ +.help zfiotx May84 "System Interface" +.ih +NAME +zfiotx -- text file driver +.ih +SYNOPSIS +.nf +zopntx (osfn, mode, chan) # open or create text file +zclstx (chan, status) # close text file +zgettx (chan, text, maxch, status) # get next record +zputtx (chan, text, nchars, status) # put record +zflstx (chan, status) # flush output +znottx (chan, loffset) # note file position +zsektx (chan, loffset, status) # seek to a line +zstttx (chan, param, lvalue) # get file status + +packed char osfn[] +char text[] +int mode, chan, maxch, nchars, status, param +long loffset, lvalue +.fi +.ih +DESCRIPTION +All text file i/o is via these primitives. The detailed specifications +of the individual routines are given in separate manual pages. +A text file must be opened or created with \fBzopntx\fR before any i/o +can take place. Text file i/o is record (line) oriented and is sequential +in nature. Character data is maintained in ASCII SPP chars above the kernel +and in the host character format below the kernel. +The newline character delimits each line of text. +Seeking is permitted prior to a write but only to the beginning of a line +or to BOF or EOF. The seek offset of a line may only be determined by a +prior call to \fBznottx\fR when actually reading or writing the file. +Writing is permitted only at EOF. Output is assumed to be buffered. +.ih +RETURN VALUES +Once a file is opened all references to the file are by the channel number +\fIchan\fR, a magic integer. A file may not be accessed by name while it +is open. The i/o primitives return the number of characters read or written +as the status value; 0 is returned when reading at EOF. +.ih +SEE ALSO +zfioty, the manual pages for the individual routines +.endhelp diff --git a/unix/os/doc/zfioty.hlp b/unix/os/doc/zfioty.hlp new file mode 100644 index 00000000..de0f0752 --- /dev/null +++ b/unix/os/doc/zfioty.hlp @@ -0,0 +1,75 @@ +.help zfioty May84 "System Interface" +.ih +NAME +zfioty -- terminal driver +.ih +SYNOPSIS +.nf +zopnty (osfn, mode, chan) # open terminal +zclsty (chan, status) # close terminal +zgetty (chan, text, maxch, status) # get next record +zputty (chan, text, nchars, status) # put record +zflsty (chan, status) # flush output +znotty (chan, loffset) # note offset +zsekty (chan, loffset, status) # seek to offset +zsttty (chan, param, lvalue) # get file status + +packed char osfn[] +char text[] +int mode, chan, maxch, nchars, status, param +long loffset, lvalue +.fi +.ih +DESCRIPTION +Except where noted herein, the terminal driver is functionally equivalent to +the text file driver \fBzfiotx\fR. Terminal data is normally quite volatile, +hence the \fBznotty\fR and \fBzsekty\fR functions are generally not usable with +terminals. If seeking is not supported on a terminal \fBznotty\fR may return +anything, and \fBzsekty\fR will return ERR. + +Terminal input is normally accumulated in the host system terminal driver +and returned by \fBzgetty\fR a line at a time. If \fImaxch\fR is greater than +one but less than the length of the line typed at the terminal, the line is +buffered by the kernel and substrings are returned in successive calls to +\fBzgetty\fR until the line is exhausted, just as for any other text file. +Control characters may be intercepted by the host driver and interpreted +as line editing commands, commands to change the driver state, and so on. + +If \fBzgetty\fR is called with \fImaxch=1\fR the terminal is put into raw +character mode. In this mode \fBzgetty\fR returns each character as it is +typed, control characters have no special significance (as far as possible), +and characters are not echoed to the terminal. The switch to character mode +will only occur at the beginning of a line, i.e., any character data buffered +internally in \fBzgetty\fR will be exhausted before switching to character +mode. A subsequent call with \fImaxch\fR greater than one causes a switch +back to line mode. + +There is nothing corresponding to character mode for \fBzputty\fR. To write +to the terminal a character at a time one need only call \fBzflsty\fR after +each character is written with \fBzputty\fR. All control characters except +tab and newline (linefeed) may be sent to the terminal without modification. +Tab characters may be expanded by the driver, and newline is converted into +carriage return linefeed upon output. +.ih +NOTES +Separate channels are used for reading and writing to simplify buffering +and to provide device independence. The access modes READ_WRITE and NEW_FILE +are not supported for terminals. A terminal file, unlike most other files, +may be simultaneously opened on two different channels if both read and write +access is desired. + +The mode switch on \fImaxch\fR seems like a potentially unwanted side effect +but this is not the case since \fBzgetty\fR is called only by FIO. +In normal use FIO will always call \fBzgetty\fR with \fImaxch\fR equal to +the size of the FIO line buffer, i.e., SZ_LINE. This is the case even if the +calling program calls \fBgetc\fR to read a character at a time. At the FIO +level the switch to and from character mode is possible only by an explicit +call to \fBfset\fR to change the default behavior of FIO for the file. +When character mode is in effect on a text file opened for reading (be it a +terminal or not) FIO merely fakes itself into thinking the size of the FIO +buffer is 1 char, forcing a call to \fBzgetty\fR for each character read from +the file. +.ih +SEE ALSO +zfiotx, manual pages for the text file driver. +.endhelp diff --git a/unix/os/doc/zflstx.hlp b/unix/os/doc/zflstx.hlp new file mode 100644 index 00000000..7abbd8a8 --- /dev/null +++ b/unix/os/doc/zflstx.hlp @@ -0,0 +1,33 @@ +.help zflstx May84 "System Interface" +.ih +NAME +zflstx -- flush any buffered text file output +.ih +SYNOPSIS +.nf +zflstx (chan, status) + +int chan # OS channel of text file +int status +.fi +.ih +DESCRIPTION +Any output data buffered within the kernel or host system is flushed to +the output device. +.ih +RETURN VALUE +ERR is returned in the event of a write error. OK is returned if the flush +is successful. There is no way to tell if any data was actually written to +the output device. +.ih +NOTES +FIO assumes that text file output is buffered and that \fBzflstx\fR must be +called to ensure that data written with \fBzputtx\fR is actually sent to +the device. When \fBzflstx\fR is called all buffered text should be output +whether or not a newline has been seen. FIO assumes that it can build up +an output line a character at a time, calling \fBzputtx\fR followed by +\fBzflstx\fR for each individual character. +.ih +SEE ALSO +zfiotx, zputtx +.endhelp diff --git a/unix/os/doc/zfmkcp.hlp b/unix/os/doc/zfmkcp.hlp new file mode 100644 index 00000000..bf5094ca --- /dev/null +++ b/unix/os/doc/zfmkcp.hlp @@ -0,0 +1,40 @@ +.help zfmkcp May84 "System Interface" +.ih +NAME +zfmkcp -- make a zero length copy of a file +.ih +SYNOPSIS +.nf +zfmkcp (osfn, new_osfn, status) + +packed char osfn[] # name of original file +packed char new_osfn[] # name of new file +int status +.fi +.ih +DESCRIPTION +A zero length file is created which inherits all the machine dependent +attributes (so far as is possible) of the original file. No file data +is copied. The new file need not reside in the same directory as the +original file. +.ih +RETURN VALUE +ERR is returned if the original file cannot be accessed, if the new file +cannot be created, or if the file cannot be accessed as either a text or binary +file. OK is returned if the operation is successful. +.ih +NOTES +The newly created file is normally opened for writing as a text or binary +file immediately after creation with \fBzfmkcp\fR. The IRAF system has +no knowledge of the machine dependent attributes of a file, e.g., execute +permission, cross-directory links, special permissions, and so on. + +FIO ensures that a file will not already exist named \fInew_osfn\fR when +\fBzfmkcp\fR is called. If such a file exists and file clobber is enabled, +FIO will delete the file before calling \fBzfmkcp\fR. If file clobber +is disabled and a file already exists with the new name, FIO will take an +error action. +.ih +SEE ALSO +zopnbf, zopntx +.endhelp diff --git a/unix/os/doc/zfpath.hlp b/unix/os/doc/zfpath.hlp new file mode 100644 index 00000000..920caab3 --- /dev/null +++ b/unix/os/doc/zfpath.hlp @@ -0,0 +1,32 @@ +.help zfpath May84 "System Interface" +.ih +NAME +zfpath -- convert an OSFN into an absolute pathname +.ih +SYNOPSIS +.nf +zfpath (osfn, pathname, maxch, status) + +char osfn[ARB] # OS filename +char pathname[maxch] # absolute pathname equiv. of OSFN +int maxch, status +.fi +.ih +DESCRIPTION +Return the absolute pathname equivalent of an OS filename. An absolute pathname +is an OSFN which does not depend on the current working directory. +If the argument \fIosfn\fR is null the pathname of the current working +directory is returned. +.ih +RETURN VALUE +ERR is returned if the translation cannot be performed for any reason, +or if the output string overflows. If the operation is successful the +number of characters in the output string is returned. +.ih +NOTES +This primitive is normally coded in SPP since it does not communicate +with the host system. Character string arguments are therefore not packed. +.ih +SEE ALSO +zfxdir, zfsubd +.endhelp diff --git a/unix/os/doc/zfprot.hlp b/unix/os/doc/zfprot.hlp new file mode 100644 index 00000000..dd989268 --- /dev/null +++ b/unix/os/doc/zfprot.hlp @@ -0,0 +1,47 @@ +.help zfprot May84 "System Interface" +.ih +NAME +zfprot -- set, remove, or query file delete protection +.ih +SYNOPSIS +.nf +zfprot (osfn, protflag, status) + +packed char osfn[ARB] # OS filename +int protflag # operation to be performed +int status +.fi +.ih +DESCRIPTION +A protected file cannot be deleted, accidentally or otherwise. +Protecting a file does not remove write permission. +File protection is set, removed, or queried as specified by the \fIprotflag\fR +argument, which has the following values: + +.nf + REMOVE_PROTECTION 0 + SET_PROTECTION 1 + QUERY_PROTECTION 2 +.fi + +It is not an error to attempt to protect a file which is already protected, +nor is it an error to attempt to remove protection from a file which is not +protected. +.ih +RETURN VALUE +OK is returned if a set_protection or remove_protection operation is +successful. YES (protected) or NO (not protected) is returned in response +to a query. ERR is returned if the named file does not exist or if +the operation cannot be performed. +.ih +NOTES +FIO will query for file protection before attempting to delete a file. +If the host system does not provide file protection facilities they can +often be faked by creating a hidden file in the same directory; the existence +of the file will indicate that the file is protected. If the hidden file +technique is used, the hidden file should not be seen when the directory +is read by the high level code. +.ih +SEE ALSO +zfdele +.endhelp diff --git a/unix/os/doc/zfrnam.hlp b/unix/os/doc/zfrnam.hlp new file mode 100644 index 00000000..3a253e66 --- /dev/null +++ b/unix/os/doc/zfrnam.hlp @@ -0,0 +1,40 @@ +.help zfrnam May84 "System Interface" +.ih +NAME +zfrnam -- rename a file +.ih +SYNOPSIS +.nf +zfrnam (old_osfn, new_osfn, status) + +packed char old_osfn[] # OS name of existing file +packed char new_osfn[] # new OS name of file +int status +.fi +.ih +DESCRIPTION +The name of file \fIold_osfn\fR is changed to \fInew_osfn\fR. +All file attributes are preserved by the rename operation. +.ih +RETURN VALUE +ERR is returned if the old file does not exist or if the rename operation +cannot be performed. OK is returned if the operation is successful. +If the operation is unsuccessful the original file is not affected in any +way. +.ih +NOTES +Ideally the rename operation should be successful even if the new filename +does not reference the same directory as the old filename, allowing a file +to be moved from one directory to another without physically copying the +file. If this is not possible ERR should be returned and the high level +code (e.g., \fBsystem.movefiles\fR) must physically copy the file. + +FIO ensures that a file will not already exist named \fInew_osfn\fR when +\fBzfrnam\fR is called. If such a file exists and file clobber is enabled, +FIO will delete the file before calling \fBzfrnam\fR. If file clobber +is disabled and a file already exists with the new name, FIO will take an +error action. File protection does not prevent renaming a file. +.ih +SEE ALSO +zfprot, zfdele +.endhelp diff --git a/unix/os/doc/zfsubd.hlp b/unix/os/doc/zfsubd.hlp new file mode 100644 index 00000000..1e58f36b --- /dev/null +++ b/unix/os/doc/zfsubd.hlp @@ -0,0 +1,76 @@ +.help zfsubd May84 "System Interface" +.ih +NAME +zfsubd -- get host name of a subdirectory +.ih +SYNOPSIS +.nf +zfsubd (osdir, subdir, new_osdir, maxch, nchars) + +char osdir[ARB] # directory pathname +char subdir[ARB] # subdirectory of osdir +char new_osdir[maxch] # pathname of osdir/subdir +int maxch # maximum length of new_osdir +int nchars # length of new_osdir +.fi +.ih +DESCRIPTION +Given \fIosdir\fR, the machine dependent name of a host directory, +and \fIsubdir\fR, the filename of a subdirectory of \fIosdir\fR, \fBzfsubd\fR +returns the machine dependent name of the subdirectory. +The machine dependent directory specification \fInew_osdir\fR may be +concatenated with a filename to produce an OSFN, or may be used in another +call to \fBzfsubd\fR to generate the name of a directory lower in the hierarchy. + +If \fIosdir\fR is null the current working directory is assumed. +If \fIsubdir\fR is null or has the value "." \fIosdir\fR is either copied to +the output or modified as necessary to return a concatenatable directory +prefix string. If \fIsubdir\fR has the value ".." the name of the next +\fIhigher\fR directory is returned, i.e., the directory in which \fIosdir\fR +appears as a subdirectory. +.ih +RETURN VALUE +ERR is returned if the translation cannot be performed (but the existence of +the new directory is not checked). If the translation is successful the number +of characters in the string \fInew_osdir\fR is returned, excluding the EOS +delimiter. +.ih +NOTES +This primitive is used by FIO to convert subdirectory references in virtual +filenames into machine dependent directory specifications. +An arbitrary virtual pathname is translated by repeatedly calling \fBzfsubd\fR +to add successive / delimited subdirectory names into the OS directory name. +The new OS directory name is not necessarily an absolute pathname; on some +systems it may be a pathname relative to the current directory. If an absolute +pathname is desired an additional call should be made to \fBzfpath\fR to +convert \fInew_osdir\fR into an absolute pathname. +This primitive is normally coded in SPP hence all strings are normal SPP +character strings rather than packed Fortran strings. +.ih +EXAMPLE +Consider the following VFN: + + pkg$images/imdelete.x + +The logical directory "pkg" is defined in the environment as "iraf$pkg/". +Assume the host system is VMS and "iraf", the root directory of the IRAF +system, is defined as "dra0:[iraf]". Recursive expansion of logical +directories will result in the following virtual pathname: + + dra0:[iraf]pkg/images/imdelete.x + +FIO will next call \fBzfxdir\fR to extract the OSDIR "dra0:[iraf]", +followed by \fBzfsubd\fR to combine this OSDIR and the subdirectory +name "pkg" to produce the new OSDIR "dra0:[iraf.pkg]". The process is +repeated until the final OSFN is generated: + + dra0:[iraf.pkg.images]imdelete.x +.ih +BUGS +We assume that an OSFN can be generated by a simple concatenation of an OS +directory specification and a filename. This assumption is valid on all +systems we are familiar with, but may be false on some unfamiliar host. +.ih +SEE ALSO +zfxdir, zfpath +.endhelp diff --git a/unix/os/doc/zfxdir.hlp b/unix/os/doc/zfxdir.hlp new file mode 100644 index 00000000..19477bec --- /dev/null +++ b/unix/os/doc/zfxdir.hlp @@ -0,0 +1,31 @@ +.help zfxdir May84 "System Interface" +.ih +NAME +zfxdir -- extract OS directory prefix from OSFN +.ih +SYNOPSIS +.nf +zfxdir (osfn, osdir, maxch, status) + +char osfn[ARB] # OS filename +char osdir[maxch] # OS directory prefix +int maxch, status +.fi +.ih +DESCRIPTION +The OS directory prefix, if any, is extracted from the OS filename +and returned as \fIosdir\fR. +.ih +RETURN VALUE +ERR is returned if the output string overflows. If \fIosfn\fR is null +or does not contain a directory prefix a status of zero is returned, +otherwise the number of characters in the output string is returned. +If there is no directory prefix the null string is returned in \fIosdir\fR. +.ih +NOTES +This routine is normally written in SPP since it does not communicate with +the host system. Character string arguments are therefore not packed. +.ih +SEE ALSO +zfpath, zfsubd, zfgcwd +.endhelp diff --git a/unix/os/doc/zgettx.hlp b/unix/os/doc/zgettx.hlp new file mode 100644 index 00000000..2a5b6bb6 --- /dev/null +++ b/unix/os/doc/zgettx.hlp @@ -0,0 +1,57 @@ +.help zgettx May84 "System Interface" +.ih +NAME +zgettx -- get next line from a text file +.ih +SYNOPSIS +.nf +zgettx (chan, text, maxch, status) + +int chan # OS channel of file +char text[maxch] # output record buffer +int maxch # capacity of buffer +int status +.fi +.ih +DESCRIPTION +At most \fImaxch\fR chars are read from the next line of the text file +connected to channel \fIchan\fR into the buffer \fItext\fR. +A line of text is a sequence of zero or more characters terminated by the +\fBnewline\fR character (normally linefeed). If \fImaxch\fR is less than +the length of the line the next read will return the remainder of the line +or \fImaxch\fR characters, whichever is smaller. The newline character +counts as one character and is returned as the final character in \fItext\fR +when end of line is reached. The \fBzgettx\fR primitive always returns ASCII +character data unpacked into the SPP char array \fItext\fR. The \fItext\fR +array is not EOS delimited. +.ih +RETURN VALUE +ERR is returned for a read error or for an illegal call. If the read is +successful the number of characters read (including the newline) is returned +in \fIstatus\fR. When EOF is reached successive reads will return nothing, +i.e., the number of characters read will be zero. +.ih +NOTES +There is no fixed upper limit on the length of a line. In normal usage FIO +calls \fBzputtx\fR to write out the internal FIO fixed size line buffer +whenever it sees a newline in the output. If an applications program writes +a very long line, the line buffer in FIO will overflow and \fBzputtx\fR will +be called to write out the contents of the buffer without a newline terminator. +FIO will also write out a partial line when the output is explicitly flushed. +On input FIO uses the same fixed size line buffer, and several calls to +\fBzgettx\fR may be required to read a full line. + +If the host system does not use the ASCII character set \fBzgettx\fR will +convert characters to ASCII upon input. The full ASCII character set is +permitted, i.e., control characters may be embedded in the text. +.ih +BUGS +Individual IRAF and host system utilities may place their own limits on the +maximum length of a line of text. The lower bound on the size of a line +of text in IRAF programs is globally defined by the parameter SZ_LINE in +\fBiraf.h\fR and may easily be adjusted by the system installer. A sysgen +of the entire system is required as SZ_LINE is used everywhere. +.ih +SEE ALSO +zfiotx, zputtx +.endhelp diff --git a/unix/os/doc/zgfdir.hlp b/unix/os/doc/zgfdir.hlp new file mode 100644 index 00000000..7c5412cf --- /dev/null +++ b/unix/os/doc/zgfdir.hlp @@ -0,0 +1,37 @@ +.help zgfdir May84 "System Interface" +.ih +NAME +zgfdir -- get next filename from a directory +.ih +SYNOPSIS +.nf +zgfdir (chan, osfn, maxch, status) + +int chan # OS channel of directory file +packed char osfn[maxch] # output filename +int maxch, status +.fi +.ih +DESCRIPTION +The next machine dependent filename is returned from the directory file +connected to \fIchan\fR. Filenames are not returned in any particular order. +The filename is returned as an EOS delimited packed string with no newline. +.ih +RETURN VALUE +The number of characters in the filename excluding the EOS delimiter is +returned for a successful read. EOF is returned when the directory is +exhausted. ERR is returned if there is something wrong with \fIchan\fR, +if a read error occurs, or if the output string overflows. +.ih +NOTES +Although this primitive returns simple, raw host filenames, it will not +necessarily return all of the filenames in a directory. On a UNIX system +for example, filenames which begin with the character "." are skipped over +when reading from a directory. On a VMS system only the most recent version +of a file should be returned (with the version label stripped). The kernel +may employ hidden files for special purposes; normally these should be +hidden from the high level code and from the user. +.ih +SEE ALSO +zopdir, zcldir, zfinfo, zfacss +.endhelp diff --git a/unix/os/doc/zgtime.hlp b/unix/os/doc/zgtime.hlp new file mode 100644 index 00000000..37c45a49 --- /dev/null +++ b/unix/os/doc/zgtime.hlp @@ -0,0 +1,28 @@ +.help zgtime May84 "System Interface" +.ih +NAME +zgtime -- get clock and cpu times +.ih +SYNOPSIS +.nf +zgtime (clock_time, cpu_time) + +long clock_time # LST, long integer seconds +long cpu_time # cpu time consumed, milliseconds +.fi +.ih +DESCRIPTION +The \fBzgtime\fR primitive returns the local standard time (clock time) +in long integer seconds since midnight on January 1, 1980, and the +cpu time consumed by the calling process and all subproceses since process +creation in milliseconds. No allowance is made for time zones or daylight +savings time. +.ih +BUGS +When daylight savings time goes into effect there is a one hour interval +during which the time base is ambiguous. A different time base whould have +to be used for a distributed system spanning several time zones. +.ih +SEE ALSO +ztslee +.endhelp diff --git a/unix/os/doc/zgtpid.hlp b/unix/os/doc/zgtpid.hlp new file mode 100644 index 00000000..899c653f --- /dev/null +++ b/unix/os/doc/zgtpid.hlp @@ -0,0 +1,25 @@ +.help zgtpid May84 "System Interface" +.ih +NAME +zgtpid -- get unique process-id number +.ih +SYNOPSIS +.nf +zgtpid (pid) + +int pid # process id number +.fi +.ih +DESCRIPTION +The magic integer value by which the current process is known to the host +operating system is returned as the argument \fIpid\fR. The process-id +is used by all process control operators to uniquely identify the process +to be operated upon. +.ih +NOTES +The process id number is also used by \fBmktemp\fR to generate unique temporary +filenames. +.ih +SEE ALSO +zopcpr, zclcpr, zintpr, zopdpr, zcldpr +.endhelp diff --git a/unix/os/doc/zintpr.hlp b/unix/os/doc/zintpr.hlp new file mode 100644 index 00000000..6899c8e1 --- /dev/null +++ b/unix/os/doc/zintpr.hlp @@ -0,0 +1,34 @@ +.help zintpr May84 "System Interface" +.ih +NAME +zintpr -- interrupt a process +.ih +SYNOPSIS +.nf +zintpr (pid, exception, status) + +int pid # process id of process to be interrupted +int exception # exception to be raised +int status +.fi +.ih +DESCRIPTION +The indicated virtual exception is raised in the process associated with +the process-id \fIpid\fR. Currently only the interrupt exception X_INT +may be sent to a process. +.ih +RETURN VALUE +ERR is returned for a bad process-id. OK is returned if the operation +is successful. +.ih +NOTES +The exception X_INT is also raised by the host terminal driver when +the interrupt control sequence is typed by the user at the terminal. +If the identical exception cannot be raised by a user process it may +be possible to use a different exception and have the kernel map both +to X_INT. In principle it should be possible for a process to interrupt +itself, though this capability may be machine dependent. +.ih +SEE ALSO +zxwhen +.endhelp diff --git a/unix/os/doc/zlocpr.hlp b/unix/os/doc/zlocpr.hlp new file mode 100644 index 00000000..6136d34b --- /dev/null +++ b/unix/os/doc/zlocpr.hlp @@ -0,0 +1,35 @@ +.help zlocpr May84 "System Interface" +.ih +NAME +zlocpr -- get the entry point address of a procedure +.ih +SYNOPSIS +.nf +zlocpr (procedure, address) + +extern procedure() # external procedure +int address # address of the procedure +.fi +.ih +DESCRIPTION +The entry point address (EPA) of \fIprocedure\fR is returned in the integer +variable or integer array element \fIaddress\fR. +.ih +RETURN VALUE +The EPA of a procedure is a magic integer value. Two EPA values may be +compared for equality to determine if they refer to the same procedure, +and a procedure referenced by an EPA may be executed by passing the EPA +and any arguments to a \fBzcall\fR primitive. +.ih +NOTES +A legal EPA may not have the value NULL, which is reserved for flagging +uninitialized EPA variables. The Fortran 77 alternate return from subroutine +feature may not be used with \fBzlocpr\fR and \fBzcall\fR because it involves +an extra hidden argument on some systems. The alternate return feature is +inadvisable for other reasons as well and is forbidden in SPP programs. +Only untyped procedures are permitted, i.e., \fBzlocpr\fR may not be used +with functions. +.ih +SEE ALSO +zcall, zlocva +.endhelp diff --git a/unix/os/doc/zlocva.hlp b/unix/os/doc/zlocva.hlp new file mode 100644 index 00000000..1239fa40 --- /dev/null +++ b/unix/os/doc/zlocva.hlp @@ -0,0 +1,47 @@ +.help zlocva May84 "System Interface" +.ih +NAME +zlocva -- get the memory address of a variable +.ih +SYNOPSIS +.nf +zlocva (object, address) + +arb object # reference to variable +int address # value of the reference +.fi +.ih +DESCRIPTION +The memory address of \fIobject\fR in char storage units is returned as +the value of the integer variable \fIaddress\fR. The referenced object +may be a variable or array element of actual datatype \fBcsilrdx\fR. +The referenced object may \fInot\fR be a procedure or a Fortran character +variable. +.ih +RETURN VALUE +The memory address returned references the process logical address space +\fIin units of SPP chars\fR. No zero point is assumed. +.ih +NOTES +We assume that the maximum address in char units will fit into a signed +integer variable. The high level code assumes that it can do signed integer +comparisons and arithmetic operations (additions and subtractions) upon the +addresses returned by \fBzlocva\fR to check arrays for equality and overlap +and to compute offsets when generating pointers into Mem. +Negative addresses are permitted provided the signed arithmetic and +comparison operations work properly, i.e., provided the negative addresses +are assigned to the first half of the process logical address space. +The following relationship must hold: + +.nf + call locva (Memc[1], addr1) + call locva (Memc[2], addr2) + if (addr2 - addr1 == 1 for all possible locations of Memc) + locva conforms to the standard +.fi + +\fBMemc\fR is an SPP char array in the global common \fBMem\fR. +.ih +SEE ALSO +zmaloc, zlocpr +.endhelp diff --git a/unix/os/doc/zmain.hlp b/unix/os/doc/zmain.hlp new file mode 100644 index 00000000..3b0c4406 --- /dev/null +++ b/unix/os/doc/zmain.hlp @@ -0,0 +1,62 @@ +.help zmain May84 "System Interface" +.ih +NAME +zmain -- process main +.ih +SYNOPSIS +.nf +not applicable +.fi +.ih +DESCRIPTION +The process main is the procedure or code segment which first gains control +when a process is executed by the host system. The process main must determine +whether the process was called as a connected subprocess, as a detached process, +or by the host system. If spawned as a connected subprocess the standard input +and output of the process are connected to IPC channels leading to the parent +process, otherwise the devices to which the process channels are connected are +machine dependent. + +After connecting the process standard input, standard output, and standard +error output \fBzmain\fR calls the IRAF Main, an SPP procedure. +The calling sequence of the IRAF Main is as follows: + +.nf + main (inchan, outchan, driver, prtype, bkgfile, jobcode) + + int inchan # standard input channel + int outchan # standard output channel + int driver # EPA of device driver for channels + int prtype # process type code + packed char bkgfile[] # name of bkgfile, if detached process + int jobcode # bkg jobcode, if detached process +.fi + +The IPC driver, text file driver, and binary file driver are resident in +every process. The \fBdriver\fR argument is the entry point address of +the read primitive of the appropriate driver, as returned by \fBzlocpr\fR. +The process type code is selected from the following: + +.nf + PR_CONNECTED 1 # connected subprocess + PR_DETACHED 2 # detached subprocess + PR_HOST 3 # process run from host +.fi + +The process type determines the type of protocol to be used by the IRAF Main. +The background file and jobcode are used only if the process was spawned as +a detached process. +.ih +RETURN VALUE +None. +.ih +NOTES +Currently only the CL may be run as a detached process, and only ordinary +SPP processes may be run as connected subprocesses. Either may be run directly +by the host system. The CL uses a nonstandard Main. Error recovery is +handled entirely by the IRAF Main. +.ih +SEE ALSO +zfiopr, zfiotx, and the discussion of the process and IRAF mains in the +reference manual. +.endhelp diff --git a/unix/os/doc/zmaloc.hlp b/unix/os/doc/zmaloc.hlp new file mode 100644 index 00000000..7863741b --- /dev/null +++ b/unix/os/doc/zmaloc.hlp @@ -0,0 +1,71 @@ +.help zmaloc May84 "System Interface" +.ih +NAME +zmaloc -- allocate memory +.ih +SYNOPSIS +.nf +zmaloc (buffer, nbytes, status) + +int buffer # address of buffer +int nbytes # size of buffer +int status +.fi +.ih +DESCRIPTION +An uninitialized region of memory at least \fInbytes\fR in size is dynamically +allocated. The address of the newly allocated buffer in units of SPP chars +is returned in \fIbuffer\fR. +.ih +RETURN VALUE +XERR is returned in \fIstatus\fR if the buffer cannot be allocated. +XOK is returned if the operation is successful. +.ih +NOTES +The integer \fIbuffer\fR is a memory address in SPP char units with an +arbitrary zero point, i.e., the type of address returned by \fBzlocva\fR. +The high level code converts the buffer address into an offset into \fBMem\fR, +i.e., into an SPP pointer. + +.nf + char_pointer_into_Mem = buffer - zlocva(Memc) + 1 + Memc[char_pointer] = first char of buffer +.fi + +Since the buffer address is returned in char units the buffer must be aligned +to at least the size of a char; no greater degree of alignment is guaranteed +nor required. See the specifications of \fBzlocva\fR for additional information +about addresses and address arithmetic. + +If the host system does not provide buffer management primitives (heap +management facilities), but can dynamically allocate memory to a process, +it will be necessary to build a memory allocator. This is normally done +by dynamically changing the top of the process address space. The region +between the highest address allocated at process creation time and the +current top of the process address space is the region used by the heap. +A simple and adequate heap management technique is to implement the heap +as a circular singly linked list of buffers. Each buffer is preceded by +a pointer to the next buffer and a flag telling whether or not the buffer +is currently allocated. Successive unused buffers are periodically collected +together into a single large buffer to minimize fragmentation. A buffer is +allocated by searching around the circular list for either the first fit +or the best fit. If an unused buffer of sufficient size is not found, +additional physical memory is allocated to the process and linked into the +list. + +On a system which cannot dynamically allocate memory to a process it will be +necessary to statically allocate a large \fBMem\fR common. The heap +management algorithm described above will work just as effectively for a +static array as for a dynamic region. If a heap manager has to be coded for +more than one machine we should add a semi-portable version to the system +(all current IRAF target machines provide heap management facilities at the +host level so we have not coded a portable memory allocator). + +Dynamic memory allocation may be used in the kernel implementation as well +as in the portable system and applications code. In general it is necessary +to use the same memory allocator in both the kernel and the high level +code to avoid trashing memory. +.ih +SEE ALSO +zmfree, zraloc, zlocva +.endhelp diff --git a/unix/os/doc/zmfree.hlp b/unix/os/doc/zmfree.hlp new file mode 100644 index 00000000..6762eba4 --- /dev/null +++ b/unix/os/doc/zmfree.hlp @@ -0,0 +1,36 @@ +.help zmfree May84 "System Interface" +.ih +NAME +zmfree -- free memory +.ih +SYNOPSIS +.nf +zmfree (buffer, status) + +int buffer # buffer address +int status +.fi +.ih +DESCRIPTION +Free a buffer previously allocated with \fBzmaloc\fR or \fBzraloc\fR, +i.e., return the space so that it may be reused by the same process or by +another process. The integer argument \fIbuffer\fR must be the buffer +address returned by the primitive which originally allocated the buffer. +.ih +RETURN VALUE +ERR is returned if there is something wrong with \fIbuffer\fR. OK is returned +if the operation is successful. +.ih +NOTES +When a buffer is deallocated memory space may or may not be returned to the +host operating system depending upon the address of the buffer and upon the +characteristics of the host system. If physical memory space can be +efficiently allocated to a process at runtime it is desirable to immediately +return deallocated space to the host so that it may be reused by another +process. Otherwise the space will remain physically allocated to the process +but will be placed on the memory allocator free list so that it may be +reallocated in a subsequent call to \fBmalloc\fR. +.ih +SEE ALSO +zmaloc, zraloc, zlocva +.endhelp diff --git a/unix/os/doc/znottx.hlp b/unix/os/doc/znottx.hlp new file mode 100644 index 00000000..20317566 --- /dev/null +++ b/unix/os/doc/znottx.hlp @@ -0,0 +1,45 @@ +.help znottx May84 "System Interface" +.ih +NAME +znottx -- note position in text file for a later seek +.ih +SYNOPSIS +.nf +znottx (chan, loffset) + +int chan # OS channel of text file +long loffset # magic seek offset +.fi +.ih +DESCRIPTION +The absolute seek offset of the "current line" is returned in the long integer +variable \fIloffset\fR. If the file is opened for reading the offset +of the line which was just read or which is currently being read is returned. +If the file is opened for writing the offset of the next line to be written +or of the line currently being written is returned. In all cases the +offset points to the first character in a line, i.e., the first character +following the newline line delimiter character. +.ih +RETURN VALUE +If the operation is successful a magic integer describing the current file +offset is returned in \fIloffset\fR. If seeking is illegal on the device +associated with \fIchan\fR the return value is undefined. It is not an error +to call \fIznottx\fR on a file which does not permit seeks; if no seek is +ever performed no error has occurred. +.ih +NOTES +Depending on the host system, \fIloffset\fR might be a zero indexed byte +offset, the logical record number, the file block number and char offset +within the block packed into a long integer, or some other machine dependent +quantity. The high level code must do nothing with \fIloffset\fR but +request it with \fBznottx\fR and pass the value on to \fBzsektx\fR to perform +a seek. Seek offsets may be compared for equality but no other arithmetic +or logical operations are permissible. For example, if the offset of line A +is numerically less than the offset of line B, one \fIcannot\fR conclude that +line A is nearer the beginning of file than line B. +The only way to generate a seek offset for a text file (other than +to BOF or EOF) is to note the file position while reading or writing the file. +.ih +SEE ALSO +zsektx, zfiotx +.endhelp diff --git a/unix/os/doc/zopcpr.hlp b/unix/os/doc/zopcpr.hlp new file mode 100644 index 00000000..4addc55a --- /dev/null +++ b/unix/os/doc/zopcpr.hlp @@ -0,0 +1,33 @@ +.help zopcpr May84 "System Interface" +.ih +NAME +zopcpr -- open a connected subprocess +.ih +SYNOPSIS +.nf +zopcpr (process_file, inchan, outchan, pid) + +packed char process_file[] # executable file +int inchan # input from child +int outchan # output to child +int pid # pid of child +.fi +.ih +DESCRIPTION +The executable file \fIprocess_file\fR is spawned as a child process and +connected to the parent via the IPC (inter-process communication) channels +\fIinchan\fR and \fIoutchan\fR. +.ih +RETURN VALUE +ERR is returned if the named subprocess cannot be connected. If the connection +succeeds the process-id of the child is returned in \fIpid\fR. +.ih +NOTES +Only the IPC driver may be used to read and write the IPC channels. +A process spawned with \fBzopcpr\fR must be closed with \fBzclcpr\fR. +On a multi-processor system the OSFN \fIprocess_file\fR may be used to +specify the processor on which the child process is to be spawned. +.ih +SEE ALSO +zclcpr, zintpr, zopdpr +.endhelp diff --git a/unix/os/doc/zopdir.hlp b/unix/os/doc/zopdir.hlp new file mode 100644 index 00000000..6df42214 --- /dev/null +++ b/unix/os/doc/zopdir.hlp @@ -0,0 +1,34 @@ +.help zopdir May84 "System Interface" +.ih +NAME +zopdir -- open a directory file +.ih +SYNOPSIS +.nf +zopdir (osfn, chan) + +packed char osfn[] # directory file name +int chan # channel assigned to file +.fi +.ih +DESCRIPTION +The named directory file is opened for sequential access in READ_ONLY mode. +.ih +RETURN VALUE +ERR is returned in \fIchan\fR if the named file does not exist, is not a +directory, or cannot be accessed. A positive nonzero magic integer is +returned if the operation is successful. +.ih +NOTES +A directory file is opened at the kernel level with \fBzopdir\fR, +is read with \fBzgfdir\fR, and is closed with \fBzcldir\fR. +A directory file is viewed by the high level code as a simple list of +OS filenames; a directory file is interfaced to FIO as a text file and +successive filenames are read by the high level code with \fBgetline\fR. +The text file driver for a directory file is machine independent and +serves only as an interface between FIO and the three directory access +primitives. +.ih +SEE ALSO +zgfdir, zcldir +.endhelp diff --git a/unix/os/doc/zopdpr.hlp b/unix/os/doc/zopdpr.hlp new file mode 100644 index 00000000..acf90a30 --- /dev/null +++ b/unix/os/doc/zopdpr.hlp @@ -0,0 +1,37 @@ +.help zopdpr May84 "System Interface" +.ih +NAME +zopdpr -- open a detached process +.ih +SYNOPSIS +.nf +zopdpr (process_name, bkgfile, jobcode) + +packed char process_name[] # executable file name +packed char bkgfile[] # job file +int jobcode # job number of bkg job +.fi +.ih +DESCRIPTION +A background job is queued for execution at some unspecifiable future time. +The process named by the executable file \fIprocess_name\fR will eventually +execute as a detached process, i.e., independently of the parent process. +When the process runs it will read the file \fIbkgfile\fR to determine what +to do. The format of the background file is application dependent. +Deletion of the background file indicates that the background job +has terminated. +.ih +RETURN VALUE +ERR is returned if the background job cannot be queued for some reason. +If the operation is successful \fIjobcode\fR contains the positive nonzero +magic integer assigned by the kernel or by the host system to the job. +.ih +NOTES +The background job may execute immediately or may be placed in a queue +and executed at some later time, depending on the implementation chosen +for a particular host system. The significance of \fIjobcode\fR is +machine dependent. +.ih +SEE ALSO +zcldpr, zopcpr +.endhelp diff --git a/unix/os/doc/zopnbf.hlp b/unix/os/doc/zopnbf.hlp new file mode 100644 index 00000000..11adc331 --- /dev/null +++ b/unix/os/doc/zopnbf.hlp @@ -0,0 +1,53 @@ +.help zopnbf May84 "System Interface" +.ih +NAME +zopnbf -- open a binary file +.ih +SYNOPSIS +.nf +zopnbf (osfn, mode, chan) + +packed char osfn[] # OS filename +int mode # access mode +int chan # OS channel assigned to file +.fi +.ih +DESCRIPTION +File \fIosfn\fR is opened with access mode \fImode\fR and connected to +channel \fIchan\fR for binary file i/o. The legal access modes for a +binary file are as follows: + +.nf + READ_ONLY 1 open existing file for reading + READ_WRITE 2 open existing file for both r&w + WRITE_ONLY 3 open existing file for writing + APPEND 4 open or create file for appending + NEW_FILE 5 create a new file for both r&w +.fi + +APPEND mode is the same as WRITE_ONLY for most devices, except that in APPEND +mode a new file will be created if none already exists. +.ih +RETURN VALUE +ERR is returned if the named file does not exist or cannot be created, +if insufficient permission is available for the access mode requested, +or if an unknown access mode is specified. If the operation is successful +the magic integer channel number assigned to the channel is returned +in \fIchan\fR (a nonnegative integer value). +.ih +NOTES +FIO will not call \fBzopnbf\fR to open a new file if a file with the same +name already exists. FIO will instead either delete the file (if file clobber +is enabled) or take an error action. + +The file access permissions (owner, group, world permissions) of a new file +are initialized by the kernel to either host system default values or to user +definable values when the file is created. +The technique by which this is done is machine dependent. +Many systems provide an automatic system default set of permissions, +e.g., read permission for everyone but write permission only +for the owner, but give the user the option of globally overriding the default. +.ih +SEE ALSO +zclsbf, zfiobf, zopntx +.endhelp diff --git a/unix/os/doc/zopntx.hlp b/unix/os/doc/zopntx.hlp new file mode 100644 index 00000000..b2f008e1 --- /dev/null +++ b/unix/os/doc/zopntx.hlp @@ -0,0 +1,55 @@ +.help zopntx May84 "System Interface" +.ih +NAME +zopntx -- open a text file +.ih +SYNOPSIS +.nf +zopntx (osfn, mode, chan) + +packed char osfn[] # OS filename +int mode # access mode +int chan # OS channel assigned to file +.fi +.ih +DESCRIPTION +The text file \fIosfn\fR is opened with access mode \fImode\fR and +assigned the channel \fIchan\fR. The legal access modes for text files +are as follows: + +.nf + READ_ONLY 1 open existing file for reading + READ_WRITE 2 ** NOT SUPPORTED FOR TEXT FILES ** + WRITE_ONLY 3 same as append mode + APPEND 4 open or create for appending + NEW_FILE 5 create for appending +.fi + +If a nonexistent text file is opened for appending the file is created, +i.e., appending to a nonexistent file is equivalent to mode NEW_FILE. +READ_WRITE mode is not supported for text files since text file i/o is +sequential. +.ih +RETURN VALUE +ERR is returned if the named file does not exist, cannot be opened with the +specified access mode, cannot be created, or if an illegal mode is specified. +If the operation is successful the nonegative magic channel number assigned +by the kernel to the file is returned in \fIchan\fR. +.ih +NOTES +FIO will not call \fBzopntx\fR to open a new file if a file with the same +name already exists. FIO will instead either delete the file (if file clobber +is enabled) or take an error action. FIO does not assume anything about the +file position at open time; \fBzsektx\fR is called shortly after \fBzopntx\fR +to position the file to either BOF or EOF depending on the access mode. + +The file access permissions (owner, group, world permissions) of a new file +are set by the kernel to either host system default values or to user definable +values when the file is created. The technique by which this is done is machine +dependent. Many systems provide an automatic system default set of +permissions, e.g., read permission for everyone but write permission only +for the owner, but give the user the option of globally overriding the default. +.ih +SEE ALSO +zclstx, zfiotx, zopnbf +.endhelp diff --git a/unix/os/doc/zoscmd.hlp b/unix/os/doc/zoscmd.hlp new file mode 100644 index 00000000..3526506d --- /dev/null +++ b/unix/os/doc/zoscmd.hlp @@ -0,0 +1,36 @@ +.help zoscmd May84 "System Interface" +.ih +NAME +zoscmd -- send a command to the host operating system +.ih +SYNOPSIS +.nf +zoscmd (cmd, stdout, stderr, status) + +packed char cmd[] # command for host JCL +packed char stdout[] # standard output filename +packed char stderr[] # standard error filename +int status # termination status +.fi +.ih +DESCRIPTION +The machine dependent command \fIcmd\fR is executed by the standard host +command interpreter. Control does not return until the host has finished +executing the command. If either of the filenames \fIstdout\fR or \fIstderr\fR +is nonnull the kernel will attempt to append the referenced output stream +to the named textfile, which will be created if necessary. +.ih +RETURN VALUE +ERR is returned if an error occurred during execution of the command. +OK is returned if the command was executed successfully. +.ih +NOTES +This primitive may not be available in all implementations and any program +which uses it is nonportable. +.ih +BUGS +The output spooling feature cannot be relied upon. +.ih +SEE ALSO +clio.clcmd +.endhelp diff --git a/unix/os/doc/zpanic.hlp b/unix/os/doc/zpanic.hlp new file mode 100644 index 00000000..cc8d3454 --- /dev/null +++ b/unix/os/doc/zpanic.hlp @@ -0,0 +1,32 @@ +.help zpanic May84 "System Interface" +.ih +NAME +zpanic -- terminate process execution unconditionally +.ih +SYNOPSIS +.nf +zpanic (errcode, errmsg) + +int errcode # exit status +packed char errmsg[] # error message +.fi +.ih +DESCRIPTION +The error message \fIerrmsg\fR is written to the process standard error +output and the process terminates, returning \fIerrcode\fR to the parent +process as the exit status. +.ih +RETURN VALUE +This procedure does not return. +.ih +NOTES +The process standard error output is not well-defined. The kernel implementor +may hook the process standard error stream to whatever device seems most +appropriate on the host system. If the process was spawned interactively +this will probably be the user terminal. If the process is running in a +batch queue a file might be a better choice. Do not confuse the process +standard error output with the pseudofile STDERR. +.ih +SEE ALSO +zclcpr, zcldpr +.endhelp diff --git a/unix/os/doc/zputtx.hlp b/unix/os/doc/zputtx.hlp new file mode 100644 index 00000000..d04df541 --- /dev/null +++ b/unix/os/doc/zputtx.hlp @@ -0,0 +1,59 @@ +.help zputtx May84 "System Interface" +.ih +NAME +zputtx -- put next line to a text file +.ih +SYNOPSIS +.nf +zputtx (chan, text, nchars, status) + +int chan # OS channel of file +char text[nchars] # text data to be output +int nchars # number of characters in buffer +int status +.fi +.ih +DESCRIPTION +Exactly \fInchars\fR chars are written from the SPP char array \fItext\fR +to the text file connected to channel \fIchan\fR. Output is normally a line +of text, i.e., a sequence of zero or more characters terminated by the +\fBnewline\fR character (normally linefeed), although there is no guarantee +that the newline delimiter will be present. If the newline delimiter is +present it must be the final character and it must be counted in \fInchars\fR. +A blank line is output by calling \fBzputtx\fR with a single newline character +in \fItext\fR and with \fInchars\fR equal to one. Only ASCII data may be +written to a text file, i.e., the value of a char must be constrained to the +range 0 to 127. Writing is permitted only at EOF. +.ih +RETURN VALUE +ERR is returned for a write error or for an illegal call. If the write is +successful the number of characters written (including the newline) is returned +in \fIstatus\fR. +.ih +NOTES +There is no fixed upper limit on the length of a line. In normal usage FIO +calls \fBzputtx\fR to write out the internal FIO fixed size line buffer +whenever it sees a newline in the output. If an applications program writes +a very long line, the line buffer in FIO will overflow and \fBzputtx\fR will +be called to write out the contents of the buffer without a newline terminator. +FIO will also write out a partial line when the output is explicitly flushed. +On input FIO uses the same fixed size line buffer, and several calls to +\fBzgettx\fR may be required to read a full line. + +If the host system does not use the ASCII character set \fBzputtx\fR will +convert characters from ASCII to the host character set upon output. +The full ASCII character set is permitted, i.e., control characters may be +embedded in the text. For efficiency reasons character data is not checked +to verify that it is in the range 0 to 127. If non-ASCII data is input the +results are unpredictable. +.ih +BUGS +Individual IRAF and host system utilities may place their own limits on the +maximum length of a line of text. The lower bound on the size of a line +of text in IRAF programs is globally defined by the parameter SZ_LINE in +\fBiraf.h\fR and may easily be adjusted by the system installer. A sysgen +of the entire system is required as SZ_LINE is used everywhere. +.ih +SEE ALSO +zfiotx, zgettx +.endhelp diff --git a/unix/os/doc/zraloc.hlp b/unix/os/doc/zraloc.hlp new file mode 100644 index 00000000..5b423295 --- /dev/null +++ b/unix/os/doc/zraloc.hlp @@ -0,0 +1,45 @@ +.help zraloc May84 "System Interface" +.ih +NAME +zraloc -- reallocate memory +.ih +SYNOPSIS +.nf +zraloc (buffer, nbytes, status) + +int buffer # address of buffer +int nbytes # size of buffer +int status +.fi +.ih +DESCRIPTION +The size of the previously allocated buffer pointed to by \fIbuffer\fR is +changed to \fInbytes\fR. The buffer pointer must be the SPP char address +returned by a previous call to \fBzmaloc\fR or \fBzraloc\fR. +If necessary the buffer will be moved and the buffer pointer \fIbuffer\fR +modified to point to the new buffer. If the buffer is moved the contents of +the buffer are preserved. +.ih +RETURN VALUE +XERR is returned if the buffer pointer is invalid or if the buffer cannot be +reallocated. XOK is returned if the operation is successful. +.ih +NOTES +The integer \fIbuffer\fR is a memory address in SPP char units with an +arbitrary zero point, i.e., the type of address returned by \fBzlocva\fR. +The high level code converts the buffer address into an offset into \fBMem\fR, +i.e., into an SPP pointer. + +.nf + char_pointer_into_Mem = buffer - zlocva(Memc) + 1 + Memc[char_pointer] = first char of buffer +.fi + +Since the buffer address is returned in char units the buffer must be aligned +to at least the size of a char; no greater degree of alignment is guaranteed +nor required. See the specifications of \fBzlocva\fR for additional information +about addresses and address arithmetic. +.ih +SEE ALSO +zmaloc, zmfree, zlocva +.endhelp diff --git a/unix/os/doc/zsektx.hlp b/unix/os/doc/zsektx.hlp new file mode 100644 index 00000000..ad9c0020 --- /dev/null +++ b/unix/os/doc/zsektx.hlp @@ -0,0 +1,43 @@ +.help zsektx May84 "System Interface" +.ih +NAME +zsektx -- seek on a text file +.ih +SYNOPSIS +.nf +zsektx (chan, loffset, status) + +int chan # OS channel of text file +long loffset # magic seek offset +int status +.fi +.ih +DESCRIPTION +Text files are normally accessed sequentially, but random access is possible +when reading if \fBzsektx\fR is used to adjust the file position. +The primitive \fBzsektx\fR may be used to set the file position to BOF, EOF, +or to the beginning of any line in the file provided the offset of the line +was determined in a prior call to \fBznottx\fR while reading or writing the +file. +.ih +RETURN VALUE +ERR is returned if there is something wrong with \fIchan\fR or if seeks are +illegal on the device and the seek is to a file position other than BOF or +EOF. If seeks are illegal on the device a request to seek to BOF or EOF is +ignored. OK is returned if the seek is successful. +.ih +NOTES +Depending on the host system, \fIloffset\fR might be a zero indexed byte +offset, the logical record number, the file block number and char offset +within the block packed into a long integer, or some other machine dependent +quantity. The high level code must do nothing with \fIloffset\fR but +request it with \fBznottx\fR and pass the value on to \fBzsektx\fR to perform +a seek. The only way to generate a seek offset for a text file (other than +to BOF or EOF) is to note the file position while reading or writing the file. + +A note followed by a seek while reading or writing a line (newline not yet +seen) rewinds the line. +.ih +SEE ALSO +znottx, zfiotx +.endhelp diff --git a/unix/os/doc/zsttbf.hlp b/unix/os/doc/zsttbf.hlp new file mode 100644 index 00000000..5cca693e --- /dev/null +++ b/unix/os/doc/zsttbf.hlp @@ -0,0 +1,53 @@ +.help zsttbf May84 "System Interface" +.ih +NAME +zsttbf -- get file status for a binary file +.ih +SYNOPSIS +.nf +zsttbf (chan, param, lvalue) + +int chan # OS channel assigned to file +int param # parameter to be returned +long lvalue # return value of parameter +.fi +.ih +DESCRIPTION +The \fBzsttbf\fR primitive is used to obtain file, device, and machine +dependent information for the binary file (and device) connected to the +channel \fIchan\fR. The integer argument \fIparam\fR selects the parameter +to be returned; a separate call is required to access each parameter. +.ls +.ls FSTT_BLKSIZE (=1) +If the file is a blocked file, the size of a device block in bytes. +A streaming file is indicated by a device block size of zero. +Variable size records may be read from or written to a streaming file. +A blocked file with a block size of one byte denotes a randomly addressable +file with no blocking restrictions. +.le +.ls FSTT_FILSIZE (=2) +The current file size in machine bytes. FIO uses this parameter when +appending to blocked binary files. The file size is undefined for streaming +files. FIO will ask for this parameter once when the file is opened, +and thereafter FIO will keep track of the file size internally. +.le +.ls FSTT_OPTBUFSIZE (=3) +The optimum, i.e. default, buffer size for a FIO file buffer for "regular" +i/o. Should be an integral multiple of the device block size. +FIO will create a larger or smaller buffer if advised that i/o is to be +abnormally sequential or random in nature. The optimum transfer size is +expected to be both device and machine dependent. +.le +.ls FSTT_MAXBUFSIZE (=4) +The maximum size of a FIO file buffer, i.e., the maximum permissible +transfer size. If there is no maximum value zero is returned. +.le +.le +.ih +RETURN VALUE +ERR is returned (coerced into a long integer) if \fIchan\fR or \fIparam\fR +is illegal. The legal \fIlvalues\fR are all nonnegative integer values. +.ih +SEE ALSO +zfiobf +.endhelp diff --git a/unix/os/doc/zstttx.hlp b/unix/os/doc/zstttx.hlp new file mode 100644 index 00000000..59ac6e5a --- /dev/null +++ b/unix/os/doc/zstttx.hlp @@ -0,0 +1,50 @@ +.help zstttx May84 "System Interface" +.ih +NAME +zstttx -- get file status for a text file +.ih +SYNOPSIS +.nf +zstttx (chan, param, lvalue) + +int chan # OS channel assigned to file +int param # magic code for parameter +long lvalue # return value of parameter +.fi +.ih +DESCRIPTION +The \fBzstttx\fR primitive is used to obtain file, device, and machine +dependent information for the text file (and device) connected to the +channel \fIchan\fR. The magic integer \fIparam\fR selects the parameter +to be returned; a separate call is required to access each parameter. +.ls +.ls FSTT_BLKSIZE (=1) +Not used for text files; return value is undefined (but must be >= 0). +.le +.ls FSTT_FILSIZE (=2) +The current file size in machine bytes, possibly including space for record +headers. This parameter is purely informative and must not be used to +direct the flow of control, since the current file size is not a well defined +quantity for a text file. +.le +.ls FSTT_OPTBUFSIZE (=3) +The optimum, i.e. default, buffer size for a FIO text file line buffer. +Normally the same as SZ_LINE. +.le +.ls FSTT_MAXBUFSIZE (=4) +The maximum buffer size for a FIO text file line buffer. +Normally the maximum record size for the output device. +If there is no maximum value zero is returned. +.le +.le +.ih +RETURN VALUE +ERR is returned (coerced into a long integer) if \fIchan\fR or \fIparam\fR +is illegal. The legal \fIlvalues\fR are all nonnegative integer values. +.ih +NOTES +The file size is meaningless if the file is a terminal. +.ih +SEE ALSO +zfiotx +.endhelp diff --git a/unix/os/doc/zsvjmp.hlp b/unix/os/doc/zsvjmp.hlp new file mode 100644 index 00000000..50e229f7 --- /dev/null +++ b/unix/os/doc/zsvjmp.hlp @@ -0,0 +1,65 @@ +.help zsvjmp,zdojmp May84 "System Interface" +.ih +NAME +zsvjmp, zdojmp -- non-local goto +.ih +SYNOPSIS +.nf +include + +zsvjmp (jumpbuf, status) # save context for jump +zdojmp (jumpbuf, status) # restore context and jump + +int jumpbuf[LEN_JUMPBUF] # context saved by \fBzsvjmp\fR +int status # code returned by \fBzsvjmp\fR +.fi +.ih +DESCRIPTION +These primitives are used principally to restart interpreters (e.g. the IRAF +Main and the CL) following an error abort. +When an error occurs deep in a procedure calling sequence and the interpreter +(a higher level procedure) must be restarted, the hardware stack or stacks +and registers must be restored to their earlier state. + +The \fBzdojmp\fR primitive restores the context of the procedure which +originally called \fBzsvjmp\fR, causing control to return from \fBzsvjmp\fR +as if it had just been called. The calling procedure must not itself have +returned in the interim. +.ih +RETURN VALUE +The integer code \fIstatus\fR is zero the first time \fBzsvjmp\fR returns, +i.e., when \fBzsvjmp\fR is called by the main procedure to initialize +\fIjumpbuf\fR. When \fBzdojmp\fR is subsequently called to "goto" the +main procedure it should be called with a nonzero \fIstatus\fR to tell +the main procedure that it has been reentered at the point immediately +following the call to \fBzsvjmp\fR. +.ih +NOTES +Only the hardware stack and registers are restored by \fBzdojmp\fR. +Buffers which have been allocated since the first call to \fBzsvjmp\fR +will still be allocated, newly posted exception handlers will still be +posted, and so on. It is up to the high level code to clean up following +error restart. +.ih +EXAMPLE +Procedure A, the main (highest level) procedure, calls \fBzsvjmp\fR to +save its context for a subsequent restart, then calls procedure B. +Procedure B calls procedure C which directly or indirectly calls +\fBzdojmp\fR. The \fIjumpbuf\fR storage area is global. + +.ks +.nf +A: call zsvjmp (jumpbuf, status) + 99 if (status == error_code) + we were called from C + call B + +B: call C + +C: call zdojmp (jumpbuf, error_code) [e.g., goto 99] +.fi +.ke +.ih +SEE ALSO +A discussion of the IRAF Main and error recovery. +.endhelp diff --git a/unix/os/doc/ztslee.hlp b/unix/os/doc/ztslee.hlp new file mode 100644 index 00000000..fc1e61bf --- /dev/null +++ b/unix/os/doc/ztslee.hlp @@ -0,0 +1,31 @@ +.help ztslee May84 "System Interface" +.ih +NAME +ztslee -- suspend process execution (sleep) +.ih +SYNOPSIS +.nf +ztslee (nseconds) + +int nseconds # number of seconds to sleep +.fi +.ih +DESCRIPTION +Process execution is suspended for \fInseconds\fR seconds. +If \fInseconds\fR is negative or zero control returns immediately. +.ih +RETURN VALUE +None. +.ih +NOTES +The maximum number of seconds that a process can be put to sleep is +given by the machine constant MAX_INT. +.ih +BUGS +There is currently no way to generate a delay of less than a second. +An applications program cannot reliably slice time that fine on a +multiuser timesharing operating system. +.ih +SEE ALSO +zgtime +.endhelp diff --git a/unix/os/doc/zxgmes.hlp b/unix/os/doc/zxgmes.hlp new file mode 100644 index 00000000..6d0fc2da --- /dev/null +++ b/unix/os/doc/zxgmes.hlp @@ -0,0 +1,35 @@ +.help zxgmes May84 "System Interface" +.ih +NAME +zxgmes -- get info on most recent exception +.ih +SYNOPSIS +.nf +zxgmes (os_exception, errmsg, maxch) + +int os_exception # machine dependent exception code +packed char errmsg[maxch] # machine dependent error message +.fi +.ih +DESCRIPTION +A description of the most recent hardware or software exception is returned. +The integer code \fIos_exception\fR is the machine dependent code for the +exception, and \fIerrmsg\fR is a specific, machine dependent string +describing the exception. A program which merely calls \fBzxgmes\fR +to fetch and print the error message can be informative without compromising +portability (e.g., the default exception handlers do this). +.ih +RETURN VALUE +OK is returned for \fIos_exception\fR if no exception has occurred since +process startup or since the last call to \fBzxgmes\fR. If \fBzxgmes\fR +is called repeatedly following a single exception all calls after the first +will return OK. +.ih +NOTES +Any program which uses machine dependent exception codes is machine dependent. +The usage should be parameterized and documented in one of the system config +files. +.ih +SEE ALSO +zxwhen, zintpr +.endhelp diff --git a/unix/os/doc/zxwhen.hlp b/unix/os/doc/zxwhen.hlp new file mode 100644 index 00000000..17310a56 --- /dev/null +++ b/unix/os/doc/zxwhen.hlp @@ -0,0 +1,70 @@ +.help zxwhen May84 "System Interface" +.ih +NAME +zxwhen -- post an exception handler +.ih +SYNOPSIS +.nf +include + +zxwhen (exception, new_handler, old_handler) + +int exception # virtual exception code +int new_handler # EPA of new handler +int old_handler # EPA of old handler +.fi +.ih +DESCRIPTION +The exception handler procedure \fInew_handler\fR is posted for the specified +virutal exception, i.e., \fInew_handler\fR will be called if the indicated +exception should occur. The integer value of \fInew_handler\fR must be either +the entry point address (EPA) of a procedure as returned by \fBzlocpr\fR, or the +integer constant X_IGNORE (zero), used to disable exceptions. The recognized +virtual exceptions, defined in , are as follows: + +.nf + X_ACV 501 # access violation + X_ARITH 502 # arithmetic error + X_INT 503 # keyboard interrupt + X_IPC 504 # write to IPC with no reader +.fi + +In general many host-specific exceptions may be mapped to a single virtual +exception. All host exceptions which are not caught internally by the kernel +are mapped to one of the four virtual exceptions. An exception handler +remains posted after it has been called. The user exception handler must +have the following calling sequence: + + user_handler (exception, next_handler) + +The kernel calls the user handler procedure with the integer code of the +virtual exception which actually occurred as the first argument; thus a +single handler may be posted to more than one exception. The user handler +may either directly or indirectly call \fBzdojmp\fR to initiate error +recovery, in which case the procedure does not return. If the handler +procedure returns, \fInext_handler\fR must be set either to X_IGNORE or to the +EPA of the next_handler, i.e., to the value of \fIold_handler\fR received +when the current handler was posted. If X_IGNORE is returned execution +will continue normally. If the EPA of another handler procedure is returned +that handler will receive control, hence a chain of handlers may be called +to handle an exception. +.ih +RETURN VALUE +A panic exit occurs if an unknown \fIexception\fR is specified. If the +operation is successful \fIold_handler\fR will contain either X_IGNORE or +the EPA of the previous handler. +.ih +NOTES +The IRAF Main posts a default exception handler to all four exceptions upon +process startup. The default handler allows arithmetic exceptions to be +caught by inline error handlers (i.e., \fBiferr\fR statements) in user code. +Access violations and interrupts may only be caught by posting an exception +handler. If an exception is not caught program execution is aborted, +error restart occurs, and any user procedures posted with \fBonerror\fR are +callled. See the System Interface reference manual and the SPP reference +manual for a more detailed discussion of exception and error handling in +the high level code. +.ih +SEE ALSO +zxgmes, zintpr, zfiopr, onerror, SPP \fBiferr\fR and \fBerror\fR statements +.endhelp diff --git a/unix/os/doc/zzclmt.hlp b/unix/os/doc/zzclmt.hlp new file mode 100644 index 00000000..d3eb69f7 --- /dev/null +++ b/unix/os/doc/zzclmt.hlp @@ -0,0 +1,47 @@ +.help zzclmt May84 "System Interface" +.ih +NAME +zzclmt -- close a magtape file +.ih +SYNOPSIS +.nf +zzclmt (chan, mode, nrecords, nfiles, status) + +int chan # OS channel of magtape file +int mode # access mode of file +int nrecords # number of records skipped +int nfiles # number of filemarks skipped +int status +.fi +.ih +DESCRIPTION +The magtape file associated with the channel \fIchan\fR is closed, i.e., the +magtape device is freed for use by another process and the channel is freed +for use with another file. Closing a magtape file does not free the magtape +device for use by another user; the drive must also be \fBdeallocated\fR +before it can be accessed by another user. If \fImode\fR is WRITE_ONLY an +end of tape (EOT) mark is written at the current position of the tape. +.ih +RETURN VALUE +ERR is returned in \fIstatus\fR if \fIchan\fR is invalid or if the tapemark +could not be written. +The number of file records skipped when the tape was closed in returned +in \fInfiles\fR. +The number of filemarks skipped when the tape was closed in returned +in \fInfiles\fR. +A negative value is returned if the tape was backspaced. +.ih +NOTES +If error recovery occurs while positioning the tape, i.e., during a call +to \fBzzopmt\fR, \fBzzclmt\fR will be called with \fImode\fR set to READ_ONLY. +Otherwise the mode given is that given when the tape was opened. + +If a magtape file is opened for writing and immediately closed without writing +anything a zero length file may be written, i.e., an EOT mark. If another +file is then appended the new file will be unreachable once the tape is +rewound. To avoid this problem the high level code writes a short record +containing the ASCII string "NULLFILE" before closing the tape. +.ih +SEE ALSO +zzopmt, zfiomt, system.deallocate +.endhelp diff --git a/unix/os/doc/zzopmt.hlp b/unix/os/doc/zzopmt.hlp new file mode 100644 index 00000000..d739a9a3 --- /dev/null +++ b/unix/os/doc/zzopmt.hlp @@ -0,0 +1,62 @@ +.help zzopmt May84 "System Interface" +.ih +NAME +zzopmt -- open a magtape file +.ih +SYNOPSIS +.nf +zzopmt (drive, density, mode, oldrec, oldfile, newfile, chan) + +int drive # logical drive number (1, 2,...) +int density # e.g. 0, 800, 1600, 6250 +int mode # access mode (RO or WO) +int oldrec # current record number within file +int oldfile # current file number on tape +int newfile # requested/actual new file number +int chan # OS channel assigned to file +.fi +.ih +DESCRIPTION +The magnetic tape on logical drive number \fIdrive\fR is opened positioned to +record 1 (the first record) of file number \fInewfile\fR. The logical drive +numbers 1 through N, where N is the number of logical tape drives on the host +system, are associated with the user interface logical drive names "mta", +"mtb", etc. by the high level code. +The current position of the tape at open time is +given by the arguments \fIoldrec\fR and \fIoldfile\fR. When the tape is +rewound it is positioned to record 1 of file 1. The file number \fInewfile\fR +is either the number of the desired file on the tape (newfile >= 1) or EOT +(newfile <= 0). There is no way to position beyond EOT. The \fIdensity\fR +is a magic number of significance only to the user and to the kernel. +The tape is opened with a device dependent default density if \fIdensity\fR +is zero. The legal access modes for a magtape file are READ_ONLY and +WRITE_ONLY. +.ih +RETURN VALUE +ERR is returned in \fIchan\fR if there is no such drive, if the drive +does not support the requested density, if the tape cannot be positioned, +or if the drive cannot be physically opened. It is not an error if the +file number is out of range; the actual number of the file to which the tape +was positioned is returned in \fInewfile\fR. If the tape contains N files +and \fBzzopmt\fR is called to open the tape positioned to EOT, \fInewfile\fR +will have the value N+1 when the procedure exits. +.ih +NOTES +The high level procedure \fBmtopen\fR verifies that the drive has been +allocated and that the drive is not already open before calling \fBzzopmt\fR. +The \fIchan\fR argument should be set when the drive is physically opened, +rather than upon exit from \fBzzopmt\fR, in case an exception occurs while +the tape is being positioned (the high level error recovery code must have +the channel number to close the device). If the drive is to be opened +WRITE_ONLY the kernel should open the drive READ_ONLY to position to the +desired file, then close the drive and reopen for writing. This prevents +truncation of the tape from writing a tape mark if error recovery occurs while +the tape is being positioned (error recovery will call \fBzzclmt\fR). +.ih +BUGS +The tape may runaway if the density is incorrectly specified or if a blank +tape is opened for reading or appending. +.ih +SEE ALSO +zfiomt, mtopen, system.allocate, system.devstatus +.endhelp diff --git a/unix/os/doc/zzrdmt.hlp b/unix/os/doc/zzrdmt.hlp new file mode 100644 index 00000000..aea7cf74 --- /dev/null +++ b/unix/os/doc/zzrdmt.hlp @@ -0,0 +1,37 @@ +.help zzrdmt May84 "System Interface" +.ih +NAME +zzrdmt -- asynchronous read from a magtape file +.ih +SYNOPSIS +.nf +zzrdmt (chan, buf, maxbytes) + +int chan # OS channel of magtape file +char buf[maxbytes] # output buffer to receive data +int maxbytes # capacity of buffer +.fi +.ih +DESCRIPTION +Initiate a read of at most \fImaxbytes\fR bytes from channel \fIchan\fR into +the buffer \fIbuf\fR. If the physical file block is larger than \fImaxbytes\fR +bytes the additional data will be discarded. Each call to \fBzzrdmt\fR reads +one tape block. Successive tape blocks may vary in size. +.ih +RETURN VALUE +The wait primitive \fBzzwtmt\fR must be called after every asynchronous read +to get the transfer status. ERR is returned if a read error occurs or if the +channel number is illegal. If the read operation is successful the actual +number of bytes read is returned; zero is returned for a read at EOF. +.ih +NOTES +The transfer is NOT guaranteed to be asynchronous and the calling program +must not assume that \fBzzrdmt\fR will return immediately. +The \fBzzwtmt\fR primitive must be called and the status checked before +issuing another i/o request to the channel. Only a single request may be +pending on a channel at a time. A request to read zero bytes is considered +to be an error to avoid confusion with a read at EOF. +.ih +SEE ALSO +zzopmt, zzwtmt, zfiomt +.endhelp diff --git a/unix/os/doc/zzrwmt.hlp b/unix/os/doc/zzrwmt.hlp new file mode 100644 index 00000000..b771b506 --- /dev/null +++ b/unix/os/doc/zzrwmt.hlp @@ -0,0 +1,31 @@ +.help zzrwmt May84 "System Interface" +.ih +NAME +zzrwmt -- rewind magtape +.ih +SYNOPSIS +.nf +zzrwmt (chan, status) + +int chan # OS channel of magtape +int status +.fi +.ih +DESCRIPTION +A rewind of the magnetic tape opened on channel \fIchan\fR is initiated. +.ih +RETURN VALUE +ERR is returned if the tape is offline or if \fIchan\fR is illegal. +OK is returned if the operation is successful. +.ih +NOTES +The rewind is not guaranteed to be asynchronous. There is no wait primitive +for the rewind operation; it is assumed that the host driver or the kernel +will automatically suspend any further tape motion commands issued before +the rewind is completed. If the host system does not have the ability to +asynchronously rewind a magtape then \fBzzrwmt\fR is equivalent to a call +to \fBzzopmt\fR to open file 1 on a tape. +.ih +SEE ALSO +zzopmt, zfiomt +.endhelp diff --git a/unix/os/doc/zzwrmt.hlp b/unix/os/doc/zzwrmt.hlp new file mode 100644 index 00000000..1b4b01c5 --- /dev/null +++ b/unix/os/doc/zzwrmt.hlp @@ -0,0 +1,36 @@ +.help zzwrmt May84 "System Interface" +.ih +NAME +zzwrmt -- asynchronous write to a magtape file +.ih +SYNOPSIS +.nf +zzwrmt (chan, buf, nbytes) + +int chan # OS channel of magtape file +char buf[nbytes] # buffer containing the data +int nbytes # number of bytes to be written +.fi +.ih +DESCRIPTION +Initiate a write of exactly \fInbytes\fR bytes from the buffer \fIbuf\fR to +the magtape channel \fIchan\fR. Each call to \fBzzwrmt\fR writes one tape +block. Successive tape blocks may vary in size. A request to write zero +bytes is ignored. +.ih +RETURN VALUE +The wait primitive \fBzzwtmt\fR must be called after every asynchronous write +to get the transfer status. ERR is returned if a write error occurs or if the +channel number is illegal. If the write operation is successful the actual +number of bytes written is returned. +.ih +NOTES +The transfer is NOT guaranteed to be asynchronous and the calling program +must not assume that \fBzzwrmt\fR will return immediately. +The \fBzzwtmt\fR primitive must be called and the status checked before +issuing another i/o request to the channel. Only a single request may be +pending on a channel at a time. +.ih +SEE ALSO +zzopmt, zzwtmt, zfiomt +.endhelp diff --git a/unix/os/doc/zzwtmt.hlp b/unix/os/doc/zzwtmt.hlp new file mode 100644 index 00000000..3a975055 --- /dev/null +++ b/unix/os/doc/zzwtmt.hlp @@ -0,0 +1,41 @@ +.help zzwtmt May84 "System Interface" +.ih +NAME +zzwtmt -- wait for i/o on a magtape file +.ih +SYNOPSIS +.nf +zzwtmt (chan, nrecords, nfiles, status) + +int chan # OS channel of magtape file +int nrecords # nrecords skipped +int nfiles # nfiles skipped +int status +.fi +.ih +DESCRIPTION +If a transfer is in progress on the channel \fIchan\fR process execution +is suspended until the transfer completes. +.ih +RETURN VALUE +ERR is returned in \fIstatus\fR if a read or write error occurred in the +last i/o transfer to the magtape device. +The number of tape records (blocks) and/or filemarks skipped in the last +read or write operation is returned in \fInrecords\fR and \fInfiles\fR. +The number of bytes read or written is returned in \fIstatus\fR. +In an ordinary read or write operation \fInrecords\fR will be positive one, +\fInfiles\fR will be zero, and \fIstatus\fR will be a positive number. +An attempt to read at EOF will result in a \fIstatus\fR of zero (zero bytes +were read). Repeated calls to \fBzzwtmt\fR will continue to return the +same values. +.ih +NOTES +The \fInfiles\fR parameter will not necessarily be set to 1 when a filemark +is read, hence it cannot be used to test for EOF. Some systems will leave +the tape positioned to just before a filemark when a filemark is encountered +in a read operation, while others will leave the tape positioned to just +after the filemark. +.ih +SEE ALSO +zzrdmt, zzwrmt, zfiomt +.endhelp diff --git a/unix/os/getproc.c b/unix/os/getproc.c new file mode 100644 index 00000000..fc1c5921 --- /dev/null +++ b/unix/os/getproc.c @@ -0,0 +1,134 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#ifdef SUNOS + +#include +#include +#include +#include +#include +#include + +#define SYMBOLS "/vmunix" +#define KMEM "/dev/kmem" + + +/* UID_EXECUTING -- Search the process table to determine if the given UID + * belongs to any currently running processes. + */ +int +uid_executing (int uid) +{ + register struct proc *pt; + register int found, kmem, i; + struct proc *get_processtable(); + int nproc; + + if ((kmem = open (KMEM, 0)) == -1) { + fprintf (stderr, "Cannot open kernel memory\n"); + return (-1); + } else if ((pt = get_processtable (kmem, &nproc)) == NULL) + return (-1); + + for (found=0, i=0; i < nproc; i++) + if ((&pt[i])->p_stat) + if ((&pt[i])->p_uid == uid) { + found++; + break; + } + + free ((char *)pt); + close (kmem); + + return (found); +} + + +/* GET_PROCESSTABLE -- Take a snapshot of the current kernel process table. + */ +struct proc * +get_processtable ( + int kmem, /* fd of kernel memory file */ + int *o_nproc /* number of processes in output table */ +) +{ + char *symbols = SYMBOLS; + struct proc *pt = NULL; + struct nlist nl[3]; + int nproc, nb; + long proc; + + /* Check that the kernel symbol table file exists. */ + if (access (symbols, R_OK) < 0) { + fprintf (stderr, "Cannot open symbol file %s\n", symbols); + return (NULL); + } + + /* Get addresses of symbols '_proc' and '_nproc'. */ + nl[0].n_name = "_proc"; + nl[1].n_name = "_nproc"; + nl[2].n_name = NULL; + nlist (symbols, nl); + if (nl[0].n_value == -1) { + fprintf (stderr, "Cannot read symbol file %s\n", symbols); + return (NULL); + } + + /* Get values of these symbols from the kernel. */ + lseek (kmem, (long)nl[0].n_value, 0); + if (read (kmem, &proc, sizeof(proc)) <= 0) { +kerr: fprintf (stderr, "Cannot read kernel memory\n"); + return (NULL); + } + lseek (kmem, (long)nl[1].n_value, 0); + if (read (kmem, &nproc, sizeof(nproc)) <= 0) + goto kerr; + + /* Read the kernel process table. */ + if (nproc > 0) { + nb = nproc * sizeof(struct proc); + pt = (struct proc *) malloc (nb); + lseek (kmem, proc, 0); + if (read (kmem, pt, nb) < nb) + goto kerr; + } + + *o_nproc = nproc; + return (pt); +} + +#else /* Solaris */ + +#include +#include +#include +#include + + +/* UID_EXECUTING -- Search the process table to determine if the given UID + * belongs to any currently running processes. This is straightfoward for + * Solaris since each process has a file entry in /proc. + */ +int +uid_executing (int uid) +{ + register struct dirent *direntp; + register DIR *dirp; + char fname[256]; + struct stat st; + + dirp = opendir ("/proc"); + while ((direntp = readdir(dirp)) != NULL) { + sprintf (fname, "/proc/%s", direntp->d_name); + if (stat (fname, &st)) + return (0); + else if (st.st_uid == uid) + return (1); + } + (void) closedir (dirp); + + return (0); +} + +#endif diff --git a/unix/os/gmttolst.c b/unix/os/gmttolst.c new file mode 100644 index 00000000..cfe7c0a4 --- /dev/null +++ b/unix/os/gmttolst.c @@ -0,0 +1,73 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#ifdef SYSV +#include +#else +#include +#include +#endif + +#ifdef MACOSX +#include +#endif + +#define SECONDS_1970_TO_1980 315532800L +static long get_timezone(); + +/* GMT_TO_LST -- Convert gmt to local standard time, epoch 1980. + */ +time_t +gmt_to_lst (gmt) +time_t gmt; +{ + struct tm *localtime(); + time_t time_var; + long gmtl; + + /* Subtract seconds westward from GMT */ + time_var = gmt - get_timezone(); + + /* Correct for daylight savings time, if in effect */ + gmtl = (long)gmt; + +#ifndef MACOSX + /* Mac systems already include the DST offset in the GMT offset */ + if (localtime(&gmtl)->tm_isdst) + time_var += 60L * 60L; +#endif + + return (time_var - SECONDS_1970_TO_1980); +} + + +/* _TIMEZONE -- Get the local timezone, measured in seconds westward + * from Greenwich, ignoring daylight savings time if in effect. + */ +static long +get_timezone() +{ +#ifdef CYGWIN + extern long _timezone; + tzset(); + return (_timezone); +#else +#ifdef SYSV + extern long timezone; + tzset(); + return (timezone); +#else +#ifdef MACOSX + struct tm *tm; + time_t clock = time(NULL); + tm = localtime (&clock); + return (-(tm->tm_gmtoff)); +#else + struct timeb time_info; + ftime (&time_info); + return (time_info.timezone * 60); +#endif +#endif +#endif +} diff --git a/unix/os/irafpath.c b/unix/os/irafpath.c new file mode 100644 index 00000000..d498be4b --- /dev/null +++ b/unix/os/irafpath.c @@ -0,0 +1,165 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#define import_spp +#define import_kernel +#define import_knames +#include + +#define SZ_ULIBSTR 512 +#define ULIB "IRAFULIB" + +extern char *getenv(); + + +/* IRAFPATH -- Determine the pathname of the given IRAF library file. If the + * file is found the full pathname is returned, else the given filename is + * returned. A list of user directories is first searched if defined, followed + * by the IRAF system directories, allowing users to have custom versions of + * the system files, e.g., for testing purposes. + */ +char * +irafpath (fname) +char *fname; /* simple filename, no dirs */ +{ + static char pathname[SZ_PATHNAME+1]; + PKCHAR ulibs[SZ_ULIBSTR+1]; + PKCHAR hostdir[SZ_LINE+1]; + PKCHAR irafdir[SZ_LINE+1]; + PKCHAR ldir[SZ_FNAME+1]; + XINT sz_ulibs=SZ_ULIBSTR; + XINT x_maxch=SZ_LINE, x_status; + char *ip, *op, *irafarch; + + extern int ZGTENV(); + + + /* Search any user libraries first. */ + strcpy ((char *)ldir, ULIB); + (void) ZGTENV (ldir, ulibs, &sz_ulibs, &x_status); + if (x_status > 0) + for (ip=(char *)ulibs; *ip; ) { + /* Get next user directory pathname. */ + while (isspace (*ip)) + ip++; + if (!*ip) + break; + for (op=pathname; *ip && !isspace(*ip); ) + *op++ = *ip++; + if (*(op-1) != '/') + *op++ = '/'; + *op = '\0'; + + strcat (pathname, fname); + if (access (pathname, 0) == 0) + return (pathname); + } + + /* Get the root pathnames. */ + strcpy ((char *)ldir, "host"); + ZGTENV (ldir, hostdir, &x_maxch, &x_status); + if (x_status <= 0) + return (fname); + strcpy ((char *)ldir, "iraf"); + ZGTENV (ldir, irafdir, &x_maxch, &x_status); + if (x_status <= 0) + return (fname); + + /* Look first in HBIN. + */ + strcpy (pathname, (char *)hostdir); + strcat (pathname, "bin."); + +#ifdef LINUXPPC + strcat (pathname, "linuxppc"); +#else +#ifdef CYGWIN + strcat (pathname, "cygwin"); +#else +#ifdef LINUX64 + strcat (pathname, "linux64"); +#else +#ifdef REDHAT + strcat (pathname, "redhat"); +#else +#ifdef LINUX + strcat (pathname, "linux"); +#else +#ifdef BSD + strcat (pathname, "freebsd"); +#else +#ifdef IPAD + strcat (pathname, "ipad"); +#else +#ifdef MACOSX + /* Setup for cross-compilation, default to 'macintel'. + */ + if ((irafarch = getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) + strcat (pathname, "macosx"); + else if (strcmp (irafarch, "macintel") == 0) + strcat (pathname, "macintel"); + else + strcat (pathname, "macosx"); + } else + strcat (pathname, "macintel"); +#else +#ifdef SOLARIS +#ifdef X86 + strcat (pathname, "sunos"); +#else + strcat (pathname, "ssol"); +#endif +#else +#ifdef sparc + strcat (pathname, "sparc"); +#else +#endif +#endif +#endif +#endif +#endif +#endif +#endif +#endif +#endif +#endif + + strcat (pathname, "/"); + strcat (pathname, fname); + if (access (pathname, 0) == 0) + return (pathname); + + /* Try HLIB */ + strcpy (pathname, (char *)hostdir); + strcat (pathname, "hlib/"); + strcat (pathname, fname); + if (access (pathname, 0) == 0) + return (pathname); + + /* Try BIN - use IRAFARCH if defined. */ + if ( (irafarch = getenv("IRAFARCH")) ) { + strcpy (pathname, (char *)irafdir); + strcat (pathname, "bin."); + strcat (pathname, irafarch); + strcat (pathname, "/"); + } else { + strcpy (pathname, (char *)irafdir); + strcat (pathname, "bin/"); + } + strcat (pathname, fname); + if (access (pathname, 0) == 0) + return (pathname); + + /* Try LIB */ + strcpy (pathname, (char *)irafdir); + strcat (pathname, "lib/"); + strcat (pathname, fname); + if (access (pathname, 0) == 0) + return (pathname); + + return (fname); +} diff --git a/unix/os/mkpkg b/unix/os/mkpkg new file mode 100644 index 00000000..379da65f --- /dev/null +++ b/unix/os/mkpkg @@ -0,0 +1,98 @@ +# Make the 4.2BSD UNIX IRAF kernel. All modules are also dependent on the +# header file . + +$checkout libos.a hlib$ +$update libos.a +$checkin libos.a hlib$ +$exit + +alloc: + !cc -O alloc.c getproc.c -o alloc.e; chmod 4755 alloc.e;\ + mv -f alloc.e ../hlib + ; + +libos.a: + $set XFLAGS = "-cd $(HSI_XF)" + + $ifdef (DEBUG) + $iffile (as$zsvjmp_p.s) + as$zsvjmp_p.s + $else + as$zsvjmp.s + $endif + $else + as$zsvjmp.s + $endif + + #"as$enbint.s" + + # Do not put zmain.o in the library if it is linked explicitly as a .o + # on the host machine. Having it in the library prevents use of the + # libos library in Fortran on a UNIX system as the linker will use the + # iraf zmain (C "main") rather than the Fortran one. + + $ifeq (USE_LIBMAIN, no) + zmain.c + $endif + + irafpath.c + gmttolst.c + prwait.c + zalloc.c + zawset.c + zdojmp.c + zcall.c + zfunc.c + zfacss.c + zfaloc.c + zfchdr.c + zfdele.c + zfgcwd.c + zfinfo.c + zfiobf.c + zfioks.c + zfiolp.c + zfiond.c + zfiomt.c + zfiopl.c + zfiopr.c + zfiosf.c + zfiotx.c + zfioty.c + zfmkcp.c + zfmkdr.c + zfnbrk.c + zfpath.c + zfpoll.c + zfprot.c + zfrnam.c + zfrmdr.c + zfsubd.c + zfutim.c + zfxdir.c + zgcmdl.c + zghost.c + zglobl.c + zgmtco.c + zgtenv.c + zgtime.c + zgtpid.c + zintpr.c + zlocpr.c + zlocva.c + zmaloc.c + zmfree.c + zopdir.c + zopdpr.c + zoscmd.c + zpanic.c + zraloc.c + zshlib.c + zwmsec.c + zxwhen.c + zzepro.c + zzexit.c + zzpstr.c + zzsetk.c + zzstrt.c + ; diff --git a/unix/os/mkpkg.sh b/unix/os/mkpkg.sh new file mode 100644 index 00000000..5507468e --- /dev/null +++ b/unix/os/mkpkg.sh @@ -0,0 +1,42 @@ +# Bootstrap the LIBOS.A library. + +echo "--------------------- OS ----------------------" + + +$CC -c $HSI_CF -Wall alloc.c getproc.c +$CC $HSI_LF -Wall alloc.o getproc.o $HSI_OSLIBS -o alloc.e +chmod 4755 alloc.e +mv -f alloc.e ../hlib +rm -f alloc.o + + +if test "$IRAFARCH" != "macosx"; then + for i in zsvjmp ;\ + do $CC -c $HSI_CF -Wall ../as/$i.s -o $i.o ;\ + done +fi + + +for i in gmttolst.c irafpath.c prwait.c z*.c ;\ + do $CC -c $HSI_CF -Wall $i ;\ +done + +#ar rv libos.a *.o; ar dv libos.a zmain.o; rm *.o + +if [ "$IRAFARCH" = "macosx" ]; then +## $CC -c -O -DMACOSX -w -Wunused -arch ppc ../as/zsvjmp_ppc.s -o zsvjmp.o ;\ +## libtool -a -T -o libos.a zsvjmp.o +## rm -f zsvjmp.o + $CC -c -O -DMACOSX -w -Wunused -m32 -arch i386 ../as/zsvjmp_i386.s -o zsvjmp.o ;\ + ar r libos.a *.o; + ranlib libos.a + rm -f zsvjmp.o zmain.o + +else + rm -f zmain.o + ar r libos.a *.o; + ranlib libos.a +fi + +rm *.o +mv -f libos.a ../bin diff --git a/unix/os/mkproto b/unix/os/mkproto new file mode 100755 index 00000000..4a59b252 --- /dev/null +++ b/unix/os/mkproto @@ -0,0 +1,5 @@ +#!/bin/sh + +flags="-DLINUX -DREDHAT -DPOSIX -DSYSV -DLINUX64" + +cproto -e $flags *.c > ../hlib/libc/kproto64.h diff --git a/unix/os/net/README b/unix/os/net/README new file mode 100644 index 00000000..af93d174 --- /dev/null +++ b/unix/os/net/README @@ -0,0 +1,90 @@ +NETwork interface. 08Oct85 dct +------------------------------------ + +This directory contains the network interface software required to support the +ZFIOKS FIO driver (for the kernel interface) in a TCP/IP environment. The only +facilities required are those already provided by the IRAF kernel (i.e., to +read the host name table, a text file), plus the standard TCP network functions +provided by any system that supports TCP/IP. The interface is self contained, +requiring only the host TCP/IP facilities and the file "uhosts" in iraf$dev, +used to map host names to network addresses (see gethostbyname). The code +supplied here is coded for Berkeley UNIX and works fine, but a much simpler +Berkeley UNIX dependent version of ZFIOKS is what is actually used on a +Berkeley host. + +The networking interface is not required to run IRAF and the contents of this +directory may be ignored if the IRAF system is to be configured without +networking. On a system configured without networking the entry points of the +ZFIOKS driver must be present but may be stubbed out. Additional information +on configuration details is given in the discussion of the kernel interface, +e.g., in sys$ki. + + +STRUCTURE + + The structure of the network interface software is as follows: + + + ZFIOKS FIO device driver for the kernel server (in ..) + | + REXEC remote execution of a shell command + | + TCP_xxx encapsulation of TCP interface + | + (host TCP/IP) host networking facilities + + +This software is machine dependent but is designed to be reusable, i.e., the +machine dependence has been isolated into simple procedures and definitions +whenever possible. On a Berkeley UNIX system the TCP procedures map directly +into the system services of 4.2 Berkeley UNIX (and no doubt later versions as +well). On a VMS system running EUNICE the TCP procedures map easily into +QIOW type device driver calls; EUNICE implements the TCP facilties in the +network device driver. Similar mappings should be possible on other systems +with TCP/IP support. + + +TCP INTERFACE + + The TCP interface package consists of the following procedures. On a +Berkeley UNIX system these TCP functions map directly into calls to the UNIX +system services. + + + tcp_gethostbyname get internet code for a host by name + tcp_getsockname get socket name + + tcp_socket create and bind a socket (client or server) + tcp_connect connect to a socket (client) + tcp_listen listen for connections on a socket (server) + tcp_accept accept a connection (server) + tcp_read read from a socket (synchronous) + tcp_write write to a socket (synchronous) + tcp_close close a socket (client or server) + + +The usual sequence of calls used by a client process to connect to and +communicate with a server process is the following. + + + gethostbyname;involves scan of hostname table + + make a socket + connect to the socket + (connect returns when the server has accepted the connection) + read & write data packets + (etc.) + close the socket + + +A server does much the same thing, except that the server will listen() for +connections by client processes, accept() a connection when one occurs, and +then begin exchanging packets with the client. + +------------------------------------ +NOTE -- This directory contains software which is adapted from the Berkeley UNIX +networking software, hence a UNIX source license is required to use this +software. Nonetheless, about 90% of the source herein is new; at some point +the remainder (only 100-200 lines) should be rewritten from scratch to eliminate +the proprietary restrictions. This was not done initially since the network +interface is not expected to be included in the standard distribution. diff --git a/unix/os/net/accept.c b/unix/os/net/accept.c new file mode 100644 index 00000000..578c1eba --- /dev/null +++ b/unix/os/net/accept.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +extern int tcperrno; + +/* TCP_ACCEPT -- Accept a connection on a socket. Accept extracts the first + * connection from the queue of pending connections (set up with LISTEN), + * creates a new socket with the same properties as S and allocates a new + * file descriptor NS for the socket. + */ +u_sock +tcp_accept (s, addr, addrlen) +u_sock s; /* the socket */ +struct sockaddr *addr; /* endpoint of communications */ +int *addrlen; /* sizeof (addr) */ +{ + u_sock ns; + + /* MACHDEP */ + ns = accept (s, addr, addrlen); + tcperrno = errno; + return (ns); +} diff --git a/unix/os/net/connect.c b/unix/os/net/connect.c new file mode 100644 index 00000000..aeb2b959 --- /dev/null +++ b/unix/os/net/connect.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +int tcperrno; + +/* TCP_CONNECT -- Initiate a connection on a socket. Returns when the server + * accepts the connection and a full duplex connection has been established. + * Zero is returned if the connection succeeds; -1 is returned if the connection + * fails. The sockaddr argument is necessary because a socket may be used to + * talk to multiple endpoints. + */ +tcp_connect (s, name, namelen) +u_sock s; /* the socket */ +struct sockaddr *name; /* endpoint of communications */ +int namelen; /* sizeof(name) */ +{ + int status; +eprintf("connect\n"); + + /* MACHDEP */ + status = connect (s, name, namelen); + tcperrno = errno; + return (status); +} diff --git a/unix/os/net/ctype.h b/unix/os/net/ctype.h new file mode 100644 index 00000000..3a1569c3 --- /dev/null +++ b/unix/os/net/ctype.h @@ -0,0 +1,4 @@ +#define isdigit(c) ((c)>='0'&&(c)<='9') +#define isxdigit(c) (isdigit(c)||(c)>='a'&&(c)<='f'||(c)>='A'&&(c)<='F') +#define islower(c) ((c)>='a'&&(c)<='z') +#define isspace(c) ((c)==' '||(c)=='\t'||(c)=='\n') diff --git a/unix/os/net/eprintf.c b/unix/os/net/eprintf.c new file mode 100644 index 00000000..4f6bbf06 --- /dev/null +++ b/unix/os/net/eprintf.c @@ -0,0 +1,15 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +/* EPRINTF -- Formatted print to the standard error output. + */ +/* VARARGS */ +eprintf (format, argp) +char *format; /* format specification */ +int **argp; /* pointer to arg list */ +{ + _doprnt (format, &argp, stderr); + fflush (stderr); +} diff --git a/unix/os/net/ghostbynm.c b/unix/os/net/ghostbynm.c new file mode 100644 index 00000000..42c9fb4a --- /dev/null +++ b/unix/os/net/ghostbynm.c @@ -0,0 +1,37 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "netdb.h" + +#define import_kernel +#define import_knames +#define import_spp +#include + + +/* TCP_GETHOSTBYNAME -- Scan the host name table to get the internet address + * of the named host. + */ +struct hostent * +tcp_gethostbyname (name) +register char *name; +{ + register struct hostent *p; + register char **cp; + struct hostent *tcp_ghostent(); + +eprintf("gethostbyname %s\n", name); + tcp_ophnt(); + + while (p = tcp_ghostent()) { + if (strcmp (p->h_name, name) == 0) + break; + for (cp = p->h_aliases; *cp != 0; cp++) + if (strcmp (*cp, name) == 0) + goto found; + } +found: + tcp_clhnt(); + return (p); +} diff --git a/unix/os/net/ghostent.c b/unix/os/net/ghostent.c new file mode 100644 index 00000000..484e2640 --- /dev/null +++ b/unix/os/net/ghostent.c @@ -0,0 +1,137 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include "types.h" +#include "netdb.h" +#include "socket.h" + +#define import_kernel +#define import_knames +#define import_spp +#include + +#define MAXALIASES 35 +#define MAXADDRSIZE 14 +#define LINSIZ 80 + +static int hostf = NULL; +static char line[LINSIZ+1]; +static char hostaddr[MAXADDRSIZE]; +static struct hostent host; +static char *host_aliases[MAXALIASES]; +static char *tcp_locate(); + + +/* TCP_GHOSTENT -- Return the next entry (line) in the host name table + * decoded into a hostent structure. + * + * The format of an entry in the host name table (e.g., /etc/hosts on a UNIX + * system) is as follows: + * + * ddd.ddd alias1 alias2 ... aliasN + */ +struct hostent * +tcp_ghostent() +{ + register char *cp, **q; + u_long tcp_inetaddr(); + char *p, *tcp_hostdb(); + char *ku_fgets(); + + if (hostf == NULL && (hostf = ku_fopen (tcp_hostdb(), "r" )) == NULL) + return (NULL); + +again: + if ((p = ku_fgets (line, LINSIZ, hostf)) == NULL) + return (NULL); +eprintf("..%s", line); + + if (*p == '#') + goto again; + cp = tcp_locate (p, "#\n"); + if (cp == NULL) + goto again; + + *cp = '\0'; + cp = tcp_locate (p, " \t"); + if (cp == NULL) + goto again; + *cp++ = '\0'; + + /* THIS STUFF IS INTERNET SPECIFIC. + */ + host.h_addr = hostaddr; + *((u_long *)host.h_addr) = tcp_inetaddr (p); + host.h_length = sizeof (u_long); + host.h_addrtype = AF_INET; + + while (*cp == ' ' || *cp == '\t') + cp++; + host.h_name = cp; + + q = host.h_aliases = host_aliases; + cp = tcp_locate (cp, " \t"); + if (cp != NULL) + *cp++ = '\0'; + + while (cp && *cp) { + if (*cp == ' ' || *cp == '\t') { + cp++; + continue; + } + if (q < &host_aliases[MAXALIASES - 1]) + *q++ = cp; + cp = tcp_locate (cp, " \t"); + if (cp != NULL) + *cp++ = '\0'; + } + + *q = NULL; + + return (&host); +} + + +/* TCP_OPHNT -- Open the host name table, a text file. + */ +tcp_ophnt() +{ + char *tcp_hostdb(); + +eprintf ("ophnt %s\n", tcp_hostdb); + if (hostf == NULL) + hostf = ku_fopen (tcp_hostdb(), "r"); +} + + +/* TCP_CLHNT -- Close the host name table file. + */ +tcp_clhnt() +{ + if (hostf) { + ku_fclose (hostf); + hostf = NULL; + } +} + + +/* TCP_LOCATE -- Return a pointer to the first character in the indicated + * character class. + */ +static char * +tcp_locate (cp, match) +register char *cp; +char *match; +{ + register char *mp, c; + + while (c = *cp) { + for (mp = match; *mp; mp++) + if (*mp == c) + return (cp); + cp++; + } + + return ((char *)0); +} diff --git a/unix/os/net/gsocknm.c b/unix/os/net/gsocknm.c new file mode 100644 index 00000000..453fdb70 --- /dev/null +++ b/unix/os/net/gsocknm.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +extern int tcperrno; + +/* TCP_GSOCKNAME -- Get socket name. Return the current network name for the + * indicated socket. + */ +tcp_gsockname (s, name, namelen) +u_sock s; /* the socket */ +struct sockaddr *name; /* endpoint of communications */ +int namelen; /* maxlen in; actual len out */ +{ + int status; + + /* MACHDEP */ + status = getsockname (s, name, namelen); + tcperrno = errno; + return (status); +} diff --git a/unix/os/net/hostdb.c b/unix/os/net/hostdb.c new file mode 100644 index 00000000..3006c56e --- /dev/null +++ b/unix/os/net/hostdb.c @@ -0,0 +1,39 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +/* MACHDEP */ +#define HOSTDB "/etc/hosts" /* change to "" if not UNIX */ + + +/* TCP_HOSTDB -- Return the machine dependent pathname of the host name table + * file. On a Berkeley UNIX host system this is "/etc/hosts", but to avoid + * hidden machine pathnames in the code we reference "iraf$dev/uhosts" instead. + */ +char * +tcp_hostdb() +{ + static char hostdb[SZ_FNAME+1] = HOSTDB; + PKCHAR osfn[SZ_FNAME+1]; + + /* If HOSTDB is explicitly defined, use it, else return OSFN of the + * the file "dev$uhosts". If the filename generation fails (e.g., + * because IRAF is not defined in the host environment) return + * anything. In this case anything is the pathname of the Berkeley + * UNIX hosts file, which will cause a file open failure on most + * systems. + */ + if (hostdb[0] == '\0') { + if (ku_mkfname ("iraf", "dev", "uhosts", osfn, SZ_FNAME) == ERR) + strcpy ((char *)osfn, "/etc/hosts"); + strcpy (hostdb, (char *)osfn); + } + + return (hostdb); +} diff --git a/unix/os/net/htonl.c b/unix/os/net/htonl.c new file mode 100644 index 00000000..e9c57280 --- /dev/null +++ b/unix/os/net/htonl.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* HTONL -- [MACHDEP] Convert a long integer in host format to net format. + */ +htonl (lword) +long lword; +{ + register char *ip, *op; + static long hostw, netw; + + hostw = lword; + ip = (char *)&hostw; + op = (char *)&netw + 4; + + *--op = *ip++; + *--op = *ip++; + *--op = *ip++; + *--op = *ip++; + + return (netw); +} diff --git a/unix/os/net/htons.c b/unix/os/net/htons.c new file mode 100644 index 00000000..9f390c29 --- /dev/null +++ b/unix/os/net/htons.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* HTONS -- [MACHDEP] Convert a short integer in host format to net format. + */ +htons (word) +short word; +{ + register char *wp; + static short w; + + w = word; + wp = (char *)&w; + + return ((wp[0] << 8) | wp[1]); +} diff --git a/unix/os/net/in.h b/unix/os/net/in.h new file mode 100644 index 00000000..825a9d39 --- /dev/null +++ b/unix/os/net/in.h @@ -0,0 +1,134 @@ +/* in.h 6.1 83/07/29 */ + +/* + * Constants and structures defined by the internet system, + * Per RFC 790, September 1981. + */ + +/* + * Protocols + */ +#define IPPROTO_ICMP 1 /* control message protocol */ +#define IPPROTO_GGP 2 /* gateway^2 (deprecated) */ +#define IPPROTO_TCP 6 /* tcp */ +#define IPPROTO_PUP 12 /* pup */ +#define IPPROTO_UDP 17 /* user datagram protocol */ +#define IPPROTO_ND 77 /* UNOFFICIAL net disk proto */ + +#define IPPROTO_RAW 255 /* raw IP packet */ +#define IPPROTO_MAX 256 + +/* + * Port/socket numbers: network standard functions + */ +#define IPPORT_ECHO 7 +#define IPPORT_DISCARD 9 +#define IPPORT_SYSTAT 11 +#define IPPORT_DAYTIME 13 +#define IPPORT_NETSTAT 15 +#define IPPORT_FTP 21 +#define IPPORT_TELNET 23 +#define IPPORT_SMTP 25 +#define IPPORT_TIMESERVER 37 +#define IPPORT_NAMESERVER 42 +#define IPPORT_WHOIS 43 +#define IPPORT_MTP 57 + +/* + * Port/socket numbers: host specific functions + */ +#define IPPORT_TFTP 69 +#define IPPORT_RJE 77 +#define IPPORT_FINGER 79 +#define IPPORT_TTYLINK 87 +#define IPPORT_SUPDUP 95 + +/* + * UNIX TCP sockets + */ +#define IPPORT_EXECSERVER 512 +#define IPPORT_LOGINSERVER 513 +#define IPPORT_CMDSERVER 514 +#define IPPORT_EFSSERVER 520 + +/* + * UNIX UDP sockets + */ +#define IPPORT_BIFFUDP 512 +#define IPPORT_WHOSERVER 513 +#define IPPORT_ROUTESERVER 520 /* 520+1 also used */ + +/* + * Ports < IPPORT_RESERVED are reserved for + * privileged processes (e.g. root). + */ +#define IPPORT_RESERVED 1024 + +/* + * Link numbers + */ +#define IMPLINK_IP 155 +#define IMPLINK_LOWEXPER 156 +#define IMPLINK_HIGHEXPER 158 + +/* + * Internet address (old style... should be updated) + */ +struct in_addr { + union { + struct { u_char s_b1,s_b2,s_b3,s_b4; } S_un_b; + struct { u_short s_w1,s_w2; } S_un_w; + u_long S_addr; + } S_un; +#define s_addr S_un.S_addr /* can be used for most tcp & ip code */ +#define s_host S_un.S_un_b.s_b2 /* host on imp */ +#define s_net S_un.S_un_b.s_b1 /* network */ +#define s_imp S_un.S_un_w.s_w2 /* imp */ +#define s_impno S_un.S_un_b.s_b4 /* imp # */ +#define s_lh S_un.S_un_b.s_b3 /* logical host */ +}; + +/* + * Definitions of bits in internet address integers. + */ +#define IN_CLASSA(i) ((((long)(i))&0x80000000)==0) +#define IN_CLASSA_NET 0xff000000 +#define IN_CLASSA_NSHIFT 24 +#define IN_CLASSA_HOST 0x00ffffff + +#define IN_CLASSB(i) ((((long)(i))&0xc0000000)==0x80000000) +#define IN_CLASSB_NET 0xffff0000 +#define IN_CLASSB_NSHIFT 16 +#define IN_CLASSB_HOST 0x0000ffff + +#define IN_CLASSC(i) ((((long)(i))&0xc0000000)==0xc0000000) +#define IN_CLASSC_NET 0xffffff00 +#define IN_CLASSC_NSHIFT 8 +#define IN_CLASSC_HOST 0x000000ff + +#define INADDR_ANY 0x00000000 + +/* + * Socket address, internet style. + */ +struct sockaddr_in { + short sin_family; + u_short sin_port; + struct in_addr sin_addr; + char sin_zero[8]; +}; + +#if !defined(vax) +/* + * Macros for number representation conversion. + */ +#define ntohl(x) (x) +#define ntohs(x) (x) +#define htonl(x) (x) +#define htons(x) (x) +#endif + +#ifdef KERNEL +extern struct domain inetdomain; +extern struct protosw inetsw[]; +#endif diff --git a/unix/os/net/inetaddr.c b/unix/os/net/inetaddr.c new file mode 100644 index 00000000..9d96d252 --- /dev/null +++ b/unix/os/net/inetaddr.c @@ -0,0 +1,92 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ctype.h" +#include "types.h" +#include "in.h" + +/* TCP_INETADDR -- Internet address interpretation routine. Decode a network + * address from the host name table. The value returned is in network order. + */ +u_long +tcp_inetaddr (cp) +register char *cp; +{ + register u_long val, base, n; + register char c; + u_long parts[4], *pp = parts; + +again: + /* Collect number up to ``.''. + * Values are specified as for C: + * 0x=hex, 0=octal, other=decimal. + */ + val = 0; base = 10; + if (*cp == '0') + base = 8, cp++; + if (*cp == 'x' || *cp == 'X') + base = 16, cp++; + + while (c = *cp) { + if (isdigit(c)) { + val = (val * base) + (c - '0'); + cp++; + continue; + } + if (base == 16 && isxdigit(c)) { + val = (val << 4) + (c + 10 - (islower(c) ? 'a' : 'A')); + cp++; + continue; + } + break; + } + + if (*cp == '.') { + /* Internet format: + * a.b.c.d + * a.b.c (with c treated as 16-bits) + * a.b (with b treated as 24 bits) + */ + if (pp >= parts + 4) + return (-1); + *pp++ = val, cp++; + goto again; + } + + /* Check for trailing characters. + */ + if (*cp && !isspace(*cp)) + return (-1); + *pp++ = val; + + /* Concoct the address according to + * the number of parts specified. + */ + n = pp - parts; + switch (n) { + + case 1: /* a -- 32 bits */ + val = parts[0]; + break; + + case 2: /* a.b -- 8.24 bits */ + val = (parts[0] << 24) | (parts[1] & 0xffffff); + break; + + case 3: /* a.b.c -- 8.8.16 bits */ + val = (parts[0] << 24) | ((parts[1] & 0xff) << 16) | + (parts[2] & 0xffff); + break; + + case 4: /* a.b.c.d -- 8.8.8.8 bits */ + val = (parts[0] << 24) | ((parts[1] & 0xff) << 16) | + ((parts[2] & 0xff) << 8) | (parts[3] & 0xff); + break; + + default: + return (-1); + } + + val = htonl(val); + return (val); +} diff --git a/unix/os/net/kutil.c b/unix/os/net/kutil.c new file mode 100644 index 00000000..3e7ddb0d --- /dev/null +++ b/unix/os/net/kutil.c @@ -0,0 +1,342 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + + +/* + * KUTIL -- Miscellaneous utilities required by the network interface. + * Most of these are either portable (no i/o) or are built upon the kernel + * i/o routines. + */ + +/* KU_FOPEN -- Open a text file. + */ +ku_fopen (fname, mode) +char *fname; +char *mode; +{ + PKCHAR osfn[SZ_PATHNAME+1]; + XINT fmode, chan; + + strcpy ((char *)osfn, fname); + + if (mode[0] == 'r') + fmode = READ_ONLY; + else + return (ERR); + + ZOPNTX (osfn, &fmode, &chan); + + return (chan); +} + + +/* KU_FCLOSE -- Close a text file. + */ +ku_fclose (fd) +int fd; +{ + XINT chan=fd, status; + + ZCLSTX (&chan, &status); + return (status); +} + + +/* KU_FGETS -- Get a newline delimited line from a text file. The semantics of + * this procedure are like the unix FGETS. + */ +char * +ku_fgets (obuf, maxch, fd) +char *obuf; +int maxch; +int fd; +{ + register XCHAR *ip; + register char *op; + register int n; + XCHAR lbuf[SZ_LINE+1]; + XINT maxchars, status, chan; + + maxchars = (maxch > SZ_LINE) ? SZ_LINE : maxch; + chan = fd; + + ZGETTX (&chan, lbuf, &maxchars, &status); + if (status <= 0) + return (NULL); + + for (ip=lbuf, op=obuf, n=status; --n >= 0; ) + *op++ = *ip++; + *op++ = EOS; + + return (obuf); +} + + +/* KU_GPASSWD -- Read a line from the terminal in raw mode (no echo), e.g., + * when reading a password. + */ +ku_gpasswd (prompt, passwd, maxch) +char *prompt; /* user prompt string */ +char *passwd; /* receives password */ +int maxch; +{ + XCHAR text[SZ_LINE+1], ch; + XINT mode=READ_WRITE, chan, status, nchars; + register char *ip; + register XCHAR *op; + register int n; + + /* Open terminal. */ + strcpy ((char *)text, TTYNAME); + ZOPNTY (text, &mode, &chan); + if (chan < 0) { + passwd[0] = EOS; + return (ERR); + } + + /* Write prompt string. */ + for (ip=prompt, op=text, nchars=0; (*op++ = *ip++) != EOS; ) + nchars++; + ZPUTTY (&chan, text, &nchars, &status); + ZFLSTY (&chan, &status); + + /* Read line in raw mode. */ + nchars = 1; + for (n=0; n < maxch; n++) { + ZGETTY (&chan, &text, &nchars, &status); + ch = text[0]; + if (status <= 0 || ch == '\n' || ch == '\r') + break; + passwd[n] = ch; + } + passwd[n] = EOS; + + /* Echo the newline. */ + ch = '\n'; + ZPUTTY (&chan, &ch, &nchars, &status); + + /* Disable raw mode. */ + nchars = LEN_RAWCMD; + for (ip=RAWOFF, op=text, n=LEN_RAWCMD; --n > 0 && (*op++ = *ip++); ) + ; + ZPUTTY (&chan, text, &nchars, &status); + ZCLSTY (&chan, &status); + + return (n); +} + + +/* KU_MKFNAME -- Make an OSFN, given a logical directory name (either "iraf" + * or "home"), a subdirectory name, and a filename. + */ +ku_mkfname (ldir, subdir, fname, osfn, maxch) +char *ldir; /* logical directory name */ +char *subdir; /* subdirectory */ +char *fname; /* filename */ +char *osfn; /* receives pathname */ +int maxch; +{ + PKCHAR pkname[SZ_PATHNAME+1]; + PKCHAR temp[SZ_FNAME+1]; + XINT maxchars=SZ_PATHNAME, nchars; + + if (ku_mapdir (ldir, (char *)pkname, SZ_PATHNAME) == ERR) + return (ERR); + + strcpy ((char *)temp, subdir); + ku_strupk (pkname, pkname, &maxchars); + ku_strupk (temp, temp, &maxchars); + ZFSUBD (pkname, &maxchars, temp, &nchars); + ku_strpak (pkname, pkname, &maxchars); + + strcat ((char *)pkname, fname); + strncpy (osfn, (char *)pkname, maxch); + osfn[maxch-1] = EOS; + + return (OK); +} + + +/* KU_ITOC -- Encode a simple positive integer in a decimal radix, returning + * a pointer to the encoded numeric string. + */ +char * +ku_itoc (num) +int num; +{ + register int dig, n; + register char *op; + static char buf[15]; + + op = &buf[15]; + *--op = '\0'; + + for (n=num; dig = n % 10; n /= 10) + *--op = dig + '0'; + + return (op); +} + + +/* KU_BCOPY -- Copy a byte array. + */ +ku_bcopy (a, b, nbytes) +char *a; /* input byte array */ +char *b; /* output byte array */ +int nbytes; /* number of bytes to move */ +{ + register char *ip, *op; + register int n = nbytes; + + /* If the two arrays are the same return immediately. If the move is + * to the left then copy left to right, else copy right to left. + */ + if (a == b) { + return; + } else if (b < a) { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } else { + for (ip = &a[n], op = &b[n]; --n >= 0; ) + *--op = *--ip; + } +} + + +/* KU_SLEEP -- Suspend process execution. + */ +ku_sleep (nseconds) +int nseconds; +{ + int mseconds = nseconds*1000; + + ZWMSEC (&mseconds); +} + + +/* KU_ERROR -- [MACHDEP] Print an error message somewhere where the user can + * see it (but do not abort or interrupt execution). + */ +ku_error (message) +char *message; +{ + write (2, message, strlen(message)); + write (2, "\n", 1); +} + + +/* KU_MAPDIR -- Return the OSFN of the named logical directory, which can + * be either "iraf" or "home". The IRAF root directory is either given in + * the host system environment and returned by ZGTENV, or is defined as + * IRAF in . The user's login directory "home" is the host + * system login directory, not the IRAF login directory. On a UNIX system + * the pathname of this directory is given in the UNIX file /etc/passwd. + * On other systems, e.g., VMS, the ZGTENV mechanism can be used to define + * the user's home directory. + */ +ku_mapdir (ldir, osfn, maxch) +char *ldir; /* logical directory name */ +char *osfn; /* receives filename */ +int maxch; +{ + PKCHAR pkname[SZ_FNAME+1]; + PKCHAR valstr[SZ_PATHNAME+1]; + XINT maxchars=SZ_PATHNAME, status; + + /* Look in the host environment first. + */ + strcpy ((char *)pkname, ldir); + ZGTENV (pkname, valstr, &maxchars, &status); + + if (status > 0) { + strncpy (osfn, (char *)valstr, maxch); + osfn[maxch-1] = EOS; + return (OK); + } else if (strncmp (ldir, "iraf", 4) == 0) { + strncpy (osfn, IRAF, maxch); + osfn[maxch-1] = EOS; + return (OK); + } else if (strncmp (ldir, "home", 4) != 0) { + osfn[0] = EOS; + return (ERR); + } + + /* If we get here the ldir is "home" and no definition was found in the + * host environment. Determine host login directory by some system + * dependent means. [MACHDEP]. + */ + strcpy ((char *)pkname, "LOGNAME"); + ZGTENV (pkname, valstr, &maxchars, &status); + if (status <= 0) { + osfn[0] = EOS; + return (ERR); + } else { + strcpy (osfn, ":udd:"); + strcat (osfn, (char *)valstr); + strcat (osfn, ":"); + return (OK); + } +} + + +/* STRPAK -- Pack an SPP character string into a C string, i.e., a sequence + * of characters stored one per byte, delimited by EOS='\0'. The operation + * may be performed in place. This version assumes that the host character + * set is ASCII and hence no lookup table reference to map character sets is + * needed. If this is not the case, code must be added to convert to the host + * character set. + * + * N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, + * and the operation is being performed in place, then this procedure should + * do nothing. + */ +ku_strpak (instr, outstr, maxch) +XCHAR *instr; +PKCHAR *outstr; +XINT *maxch; +{ + register XCHAR *ip = instr; + register char *op = (char *)outstr; + register int n = *maxch; + + while ((*op++ = *ip++) != XEOS && --n >= 0) + ; + *--op = EOS; +} + +/* STRUPK -- Unpack a kernel (C style) string into an SPP string. The unpacking * operation can be performed in place. A kernel string consists of a sequence + * of host characters stored one character per byte, delimited by EOS='\0'. + * We assume here that the host character set is ASCII. If this is not the + * case code must be added to convert from the host character set to ASCII in + * the unpacked string. + * + * N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, + * and the operation is being performed in place, then this procedure should + * do nothing. + */ +ku_strupk (instr, outstr, maxch) +PKCHAR *instr; +XCHAR *outstr; +XINT *maxch; +{ + register char *ip = (char *)instr; + register XCHAR *op = outstr; + register int n; + + /* Is is necessary to determine the length of the string in order to + * be able to unpack the string in place, i.e., from right to left. + */ + n = strlen (ip); + n = (n < *maxch) ? n : *maxch; + op[n] = XEOS; + + while (--n >= 0) + op[n] = ip[n]; +} diff --git a/unix/os/net/listen.c b/unix/os/net/listen.c new file mode 100644 index 00000000..02f75651 --- /dev/null +++ b/unix/os/net/listen.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +extern int tcperrno; + +/* TCP_LISTEN -- Listen for connections on a socket. Returns immediately, + * i.e., listen does not block the calling process. + */ +tcp_listen (s, backlog) +u_sock s; /* the socket */ +int backlog; /* max queued connects */ +{ + int status; + + /* MACHDEP */ + status = listen (s, backlog); + tcperrno = errno; + return (status); +} diff --git a/unix/os/net/mkpkg b/unix/os/net/mkpkg new file mode 100644 index 00000000..a534884b --- /dev/null +++ b/unix/os/net/mkpkg @@ -0,0 +1,25 @@ +# Make the ZFIOKS-REXEC-TCP/IP network interface package. + +$set XFLAGS = "-c $(HSI_XF)" + +libos.a: + accept.c types.h + connect.c types.h + ghostbynm.c netdb.h + ghostent.c types.h netdb.h socket.h + gsocknm.c types.h + hostdb.c + htonl.c + htons.c + inetaddr.c ctype.h in.h types.h + kutil.c + listen.c types.h + ntohl.c + ntohs.c + rexec.c in.h netdb.h socket.h types.h + socket.c types.h + tcpclose.c types.h + tcpread.c types.h + tcpwrite.c types.h + zfioks.c ctype.h types.h in.h + ; diff --git a/unix/os/net/netdb.h b/unix/os/net/netdb.h new file mode 100644 index 00000000..cddd2305 --- /dev/null +++ b/unix/os/net/netdb.h @@ -0,0 +1,44 @@ +/* %M% %I% %E% */ +/* + * Structures returned by network + * data base library. All addresses + * are supplied in host order, and + * returned in network order (suitable + * for use in system calls). + */ +struct hostent { + char *h_name; /* official name of host */ + char **h_aliases; /* alias list */ + int h_addrtype; /* host address type */ + int h_length; /* length of address */ + char *h_addr; /* address */ +}; + +/* + * Assumption here is that a network number + * fits in 32 bits -- probably a poor one. + */ +struct netent { + char *n_name; /* official name of net */ + char **n_aliases; /* alias list */ + int n_addrtype; /* net address type */ + int n_net; /* network # */ +}; + +struct servent { + char *s_name; /* official service name */ + char **s_aliases; /* alias list */ + int s_port; /* port # */ + char *s_proto; /* protocol to use */ +}; + +struct protoent { + char *p_name; /* official protocol name */ + char **p_aliases; /* alias list */ + int p_proto; /* protocol # */ +}; + +struct hostent *gethostbyname(), *gethostbyaddr(), *gethostent(); +struct netent *getnetbyname(), *getnetbyaddr(), *getnetent(); +struct servent *getservbyname(), *getservbyport(), *getservent(); +struct protoent *getprotobyname(), *getprotobynumber(), *getprotoent(); diff --git a/unix/os/net/ntohl.c b/unix/os/net/ntohl.c new file mode 100644 index 00000000..34d6b07a --- /dev/null +++ b/unix/os/net/ntohl.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* NTOHL -- [MACHDEP] Convert a long integer in net format to host format. + */ +ntohl (lword) +long lword; +{ + register char *ip, *op; + static long hostw, netw; + + netw = lword; + ip = (char *)&netw; + op = (char *)&hostw + 4; + + *--op = *ip++; + *--op = *ip++; + *--op = *ip++; + *--op = *ip++; + + return (hostw); +} diff --git a/unix/os/net/ntohs.c b/unix/os/net/ntohs.c new file mode 100644 index 00000000..02a956a6 --- /dev/null +++ b/unix/os/net/ntohs.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* NTOHS -- [MACHDEP] Convert a short integer in net format to host format. + */ +ntohs (word) +short word; +{ + register char *wp; + static short w; + + w = word; + wp = (char *)&w; + + return ((wp[0] << 8) | wp[1]); +} diff --git a/unix/os/net/rexec.c b/unix/os/net/rexec.c new file mode 100644 index 00000000..4f851fb9 --- /dev/null +++ b/unix/os/net/rexec.c @@ -0,0 +1,160 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" +#include "socket.h" +#include "in.h" +#include "netdb.h" + +/* TCP_REXEC -- Execute a command on a remote node via the network. This is + * an implementation of the Berkeley UNIX procedure of the same name for a + * machine independent TCP network interface. Unlike the UNIX rexec, + * however, we require that the user login name and password be given as + * input arguments, in addition to the host name and port number and the + * command to be executed. + * + * REXEC assumes that it is talking to an REXECD server on the remote node. + * The TCP EXEC port on the remote node spawns the REXECD server which reads and + * authenticates the user login and password, sets up the error socket if so + * indicated, changes the current directory to the user's home directory, and + * then executes the command. The command syntax is determined by the shell + * REXECD spawns to execute the command, and is implementation dependent. + * Currently the REXECD daemons are either UNIX hosted or UNIX emulated, hence + * the command syntax is the UNIX shell (Bourne shell usually). The command + * executes with its standard input and output (and error output if fd2p=0) + * connected to the socket returned by REXEC. + * + * Note that the shell spawned by the REXEC daemon may be used to spawn a user + * specified server process using a shell command, e.g. "run server.e arg arg". + * In this case the daemon is used to login and set the current directory and + * pass args to the user server, at the expense of one additional process spawn + * for the shell. + */ +tcp_rexec (ahost, rport, name, pass, cmd, fd2p) +char **ahost; /* alias of server node */ +int rport; /* IP port number (for EXEC) */ +char *name, *pass; /* user login and password */ +char *cmd; /* command to be executed */ +int *fd2p; /* error channel */ +{ + struct hostent *tcp_gethostbyname(); + struct sockaddr_in sin, sin2, from; + struct hostent *hp; + int timo = 1; + u_sock s, s3; + char c; + short port; +eprintf("rexec %s %s %s %s\n", *ahost, name, pass, cmd); + + /* Read host name table for the local network to get the internet + * address of the named host. + */ + hp = tcp_gethostbyname (*ahost); + if (hp == 0) { + ku_error ("unknown network host"); + return (-1); + } + + /* Set up a full duplex TCP socket to the TCP/EXEC server process + * on the remote node. + */ +retry: + s = tcp_socket (AF_INET, SOCK_STREAM, 0); + if (s < 0) { + ku_error ("rexec: cannot make socket"); + return (-1); + } + + sin.sin_family = hp->h_addrtype; + sin.sin_port = rport; + ku_bcopy (hp->h_addr, (caddr_t)&sin.sin_addr, hp->h_length); + + if (tcp_connect (s, &sin, sizeof(sin)) < 0) { + if (timo <= 16) { + tcp_close (s); + ku_sleep (timo); + timo *= 2; + goto retry; + } + ku_error ("rexec: connect failure"); + return (-1); + } + + /* If no output error channel variable was given instruct the REXECD + * server to return error output on the data socket, else open a second + * socket to be used for error communications and signals. + */ + if (fd2p == 0) { + tcp_write (s, "", 1); + port = 0; + + } else { + char *num, *ku_itoc(); + int sin2len, len; + u_sock s2; + + s2 = tcp_socket (AF_INET, SOCK_STREAM, 0); + if (s2 < 0) { + tcp_close (s); + return (-1); + } + + tcp_listen (s2, 1); + + sin2len = sizeof (sin2); + if (tcp_gsockname (s2, (char *)&sin2, &sin2len) < 0 || + sin2len != sizeof (sin2)) { + + ku_error ("rexec: getsockname failed"); + tcp_close (s2); + goto bad; + } + + port = htons ((u_short)sin2.sin_port); + num = ku_itoc (port); + tcp_write (s, num, strlen(num)+1); + len = sizeof (from); + + s3 = tcp_accept (s2, &from, &len, 0); + + tcp_close (s2); + if (s3 < 0) { + ku_error ("rexec: accept failure"); + port = 0; + goto bad; + } + + *fd2p = s3; + } + + tcp_write (s, name, strlen (name) + 1); + tcp_write (s, pass, strlen (pass) + 1); + tcp_write (s, cmd, strlen (cmd) + 1); + + if (tcp_read (s, &c, 1) != 1) { + ku_error ("rexec: cannot read server"); + goto bad; + } + + /* Read error message from server process. + */ + if (c != 0) { + char lbuf[80]; + char *op; + + for (op=lbuf; (tcp_read (s, op, 1) == 1); op++) + if (*op == '\n') + break; + *op = '\0'; + ku_error (lbuf); + goto bad; + } + + return (s); +bad: + if (port) + tcp_close (*fd2p); + tcp_close (s); + + return (-1); +} diff --git a/unix/os/net/socket.c b/unix/os/net/socket.c new file mode 100644 index 00000000..c5872fee --- /dev/null +++ b/unix/os/net/socket.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +extern int tcperrno; + +/* TCP_SOCKET -- Create an endpoint for communications (a socket) and bind the + * socket to an i/o descriptor, returning the descriptor as the function value. + */ +u_sock +tcp_socket (af, type, protocol) +int af; /* address format, e.g, AF_INET */ +int type; /* socket type, e.g., SOCK_STREAM */ +int protocol; /* communications protocol, if used */ +{ + u_sock s; + + /* MACHDEP */ +eprintf ("socket\n"); + s = socket (af, type, protocol); + tcperrno = errno; + return (s); +} diff --git a/unix/os/net/socket.h b/unix/os/net/socket.h new file mode 100644 index 00000000..ed399681 --- /dev/null +++ b/unix/os/net/socket.h @@ -0,0 +1,109 @@ +/* socket.h 6.1 83/07/29 */ + +/* + * Definitions related to sockets: types, address families, options. + */ + +/* + * Types + */ +#define SOCK_STREAM 1 /* stream socket */ +#define SOCK_DGRAM 2 /* datagram socket */ +#define SOCK_RAW 3 /* raw-protocol interface */ +#define SOCK_RDM 4 /* reliably-delivered message */ +#define SOCK_SEQPACKET 5 /* sequenced packet stream */ + +/* + * Option flags per-socket. + */ +#define SO_DEBUG 0x01 /* turn on debugging info recording */ +#define SO_ACCEPTCONN 0x02 /* socket has had listen() */ +#define SO_REUSEADDR 0x04 /* allow local address reuse */ +#define SO_KEEPALIVE 0x08 /* keep connections alive */ +#define SO_DONTROUTE 0x10 /* just use interface addresses */ + /* 0x20 was SO_NEWFDONCONN */ +#define SO_USELOOPBACK 0x40 /* bypass hardware when possible */ +#define SO_LINGER 0x80 /* linger on close if data present */ +#define SO_DONTLINGER (~SO_LINGER) /* ~SO_LINGER */ + +/* + * Address families. + */ +#define AF_UNSPEC 0 /* unspecified */ +#define AF_UNIX 1 /* local to host (pipes, portals) */ +#define AF_INET 2 /* internetwork: UDP, TCP, etc. */ +#define AF_IMPLINK 3 /* arpanet imp addresses */ +#define AF_PUP 4 /* pup protocols: e.g. BSP */ +#define AF_CHAOS 5 /* mit CHAOS protocols */ +#define AF_NS 6 /* XEROX NS protocols */ +#define AF_NBS 7 /* nbs protocols */ +#define AF_ECMA 8 /* european computer manufacturers */ +#define AF_DATAKIT 9 /* datakit protocols */ +#define AF_CCITT 10 /* CCITT protocols, X.25 etc */ +#define AF_SNA 11 /* IBM SNA */ + +#define AF_MAX 12 + +/* + * Structure used by kernel to store most + * addresses. + */ +struct sockaddr { + u_short sa_family; /* address family */ + char sa_data[14]; /* up to 14 bytes of direct address */ +}; + +/* + * Structure used by kernel to pass protocol + * information in raw sockets. + */ +struct sockproto { + u_short sp_family; /* address family */ + u_short sp_protocol; /* protocol */ +}; + +/* + * Protocol families, same as address families for now. + */ +#define PF_UNSPEC AF_UNSPEC +#define PF_UNIX AF_UNIX +#define PF_INET AF_INET +#define PF_IMPLINK AF_IMPLINK +#define PF_PUP AF_PUP +#define PF_CHAOS AF_CHAOS +#define PF_NS AF_NS +#define PF_NBS AF_NBS +#define PF_ECMA AF_ECMA +#define PF_DATAKIT AF_DATAKIT +#define PF_CCITT AF_CCITT +#define PF_SNA AF_SNA + +#define PF_MAX 12 + +/* + * Level number for (get/set)sockopt() to apply to socket itself. + */ +#define SOL_SOCKET 0xffff /* options for socket level */ + +/* + * Maximum queue length specifiable by listen. + */ +#define SOMAXCONN 5 + +/* + * Message header for recvmsg and sendmsg calls. + */ +struct msghdr { + caddr_t msg_name; /* optional address */ + int msg_namelen; /* size of address */ + struct iovec *msg_iov; /* scatter/gather array */ + int msg_iovlen; /* # elements in msg_iov */ + caddr_t msg_accrights; /* access rights sent/received */ + int msg_accrightslen; +}; + +#define MSG_OOB 0x1 /* process out-of-band data */ +#define MSG_PEEK 0x2 /* peek at incoming message */ +#define MSG_DONTROUTE 0x4 /* send without using routing tables */ + +#define MSG_MAXIOVLEN 16 diff --git a/unix/os/net/tcpclose.c b/unix/os/net/tcpclose.c new file mode 100644 index 00000000..0da1cc73 --- /dev/null +++ b/unix/os/net/tcpclose.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +extern int tcperrno; + +/* TCP_CLOSE -- Close a socket. + */ +tcp_close (s) +u_sock s; /* the socket */ +{ + /* MACHDEP */ + return (close (s)); +} diff --git a/unix/os/net/tcpread.c b/unix/os/net/tcpread.c new file mode 100644 index 00000000..3a7162d3 --- /dev/null +++ b/unix/os/net/tcpread.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +extern int tcperrno; + +/* TCP_READ -- Read from a socket. + */ +tcp_read (s, buf, maxbytes) +u_sock s; /* input socket */ +char *buf; /* output buffer */ +int maxbytes; /* max bytes to read */ +{ + int nbytes; + + /* MACHDEP */ +eprintf ("read %d bytes\n", maxbytes); + + nbytes = read (s, buf, maxbytes); +eprintf ("\t%d bytes read\n", nbytes); + + tcperrno = errno; + return (nbytes); +} diff --git a/unix/os/net/tcpwrite.c b/unix/os/net/tcpwrite.c new file mode 100644 index 00000000..c0a946d3 --- /dev/null +++ b/unix/os/net/tcpwrite.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "types.h" + +extern int errno; +extern int tcperrno; + +/* TCP_WRITE -- Write to a socket. + */ +tcp_write (s, buf, nbytes) +u_sock s; /* output socket */ +char *buf; /* input buffer */ +int nbytes; /* num bytes to write */ +{ + /* MACHDEP */ +eprintf ("write %d bytes\n", nbytes); + nbytes = write (s, buf, nbytes); +eprintf ("%d bytes written\n", nbytes); + + tcperrno = errno; + return (nbytes); +} diff --git a/unix/os/net/types.h b/unix/os/net/types.h new file mode 100644 index 00000000..3110398c --- /dev/null +++ b/unix/os/net/types.h @@ -0,0 +1,39 @@ +/* types.h 6.1 83/07/29 */ + +/* + * Basic system types and major/minor device constructing/busting macros. + */ + +/* major part of a device */ +#define major(x) ((int)(((unsigned)(x)>>8)&0377)) + +/* minor part of a device */ +#define minor(x) ((int)((x)&0377)) + +/* make a device number */ +#define makedev(x,y) ((dev_t)(((x)<<8) | (y))) + +typedef unsigned char u_char; +typedef unsigned short u_short; +typedef unsigned int u_int; +typedef unsigned long u_long; +typedef unsigned short ushort; /* sys III compat */ +typedef unsigned int u_sock; /* TCP/IP */ + +#ifdef vax +typedef struct _physadr { int r[1]; } *physadr; +typedef struct label_t { + int val[14]; +} label_t; +#endif +typedef struct _quad { long val[2]; } quad; +typedef long daddr_t; +typedef char * caddr_t; +typedef u_long ino_t; +typedef long swblk_t; +typedef int size_t; +typedef int time_t; +typedef short dev_t; +typedef int off_t; + +typedef struct fd_set { int fds_bits[1]; } fd_set; diff --git a/unix/os/net/zfioks.c b/unix/os/net/zfioks.c new file mode 100644 index 00000000..1db9cc1e --- /dev/null +++ b/unix/os/net/zfioks.c @@ -0,0 +1,441 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#include "types.h" +#include "in.h" + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_spp +#include + +/* ZFIOKS -- File i/o to a remote kernel server. This driver is the network + * interface for the kernel interface package (sys$ki). The KS driver is + * normally called directly by the KI routines, but is patterned after the + * regular FIO drivers hence may be connected to FIO to provide a network + * interface to the high level code. + * + * zopcks open kernel server on remote node + * zclcks close kernel server + * zardks read from the remote kernel server + * zawrks write to the remote kernel server + * zawtks wait for i/o + * zsttks get channel/device status + * + * The network interface used is an emulation of the Berkeley UNIX function + * REXEC on top of a standard TCP/IP interface. + */ + +#define SZ_NAME 32 /* max size node, etc. name */ +#define SZ_CMD 128 /* max size rexec sh command */ +#define FNNODE_CHAR '!' /* node name delimiter */ +#define HOSTLOGIN "hostlogin" /* user host login file */ +#define IRAFHOSTS ".irafhosts" /* default host login file (dev$) */ +#define USER "" /* symbol for user's login name */ + +int ks_ionbytes[MAXOFILES]; /* nbytes read|written on channel */ +static jmp_buf jmpbuf; +static int recursion = 0; + + +/* ZOPNKS -- Open a connected subprocess on a remote node. Parse the "server" + * argument to obtain the node name and the command to be issued to connect the + * remote process. Call REXEC to exec the remote process and set up a socket + * to be used for CLIN, CLOUT to the remote process. The "server" string is + * implementation dependent and normally comes from the file "dev$hosts" on each + * node. This file is read by the high level code before we are called. + */ +ZOPNKS (server, mode, chan) +PKCHAR *server; /* node name ! command */ +XINT *mode; /* access mode (not used) */ +XINT *chan; /* receives channel code (socket) */ +{ + register char *ip; + char username[SZ_NAME+1], password[SZ_NAME+1]; + char *host, *cmd; + int ipport; + + /* Extract the host name and remote process spawn command from the + * server string, format "host!cmd", e.g., "2!/iraf/lib/irafks.e". + * If the server is "host", we are being called from a server process + * to set up communications with the host process. The UNIX rexec + * connects the host to the process standard input and output, hence + * if the server is "host" the channels are already active. + */ + if (strcmp ((char *)server, "host") == 0) { + *chan = 0; + return; + } + + host = (char *)server; + cmd = NULL; + + for (ip = (char *)server; *ip != EOS; ip++) + if (*ip == FNNODE_CHAR) { + *ip = EOS; + cmd = ip + 1; + break; + } + if (cmd == NULL) { + *chan = ERR; + return; + } + + /* Get login name and password and connect to the kernel server + * process. TCP_REXEC is a portable version of the Berkeley UNIX + * REXEC facility (see ./net). + */ + if (ks_getlogin (host, username, password) == ERR) + *chan = ERR; + else { + ipport = htons (IPPORT_EXECSERVER); + *chan = tcp_rexec (&host, ipport, username, password, cmd, 0); + } + + if (*chan > 0) + ks_ionbytes[*chan] = 0; +} + + +/* KS_GETLOGIN -- Get the user's login name and password, required for + * authentication on the remote machine. We could get these from the unix + * password file on the local machine, but there is no guarantee that the + * login name and password would be the same on a remote node as on the + * local machine. Instead we look in the user's unix login directory for + * the file ".irafhosts". If this file cannot be opened or if it does not + * contain an entry for the named node we use a default public login. The + * public login provides sufficient priviledge for most operations but will + * not provide write access to the user's files on the remote node. + */ +ks_getlogin (node, username, password) +char *node; /* node we wish a login for */ +char *username; /* receives the login name */ +char *password; /* receives the login password */ +{ + char fname[SZ_FNAME+1]; + char uname[SZ_FNAME+1]; + + /* Get the user login name on the local node, used as the default + * login for remote nodes. [MACHDEP - edit for local system] + */ + strcpy (uname, "USER"); + + /* Try to open the .irafhosts file in the user's login directory. + */ + if (ku_mkfname ("home", "", IRAFHOSTS, fname, SZ_FNAME) != ERR) + if (ks_scanlogin (fname, node, uname, username, password) == OK) + return (OK); + + /* Scan the dev$hostlogin file and return a default public login + * on the remote node. + */ + if (ku_mkfname ("iraf", "dev", HOSTLOGIN, fname, SZ_FNAME) != ERR) + return (ks_scanlogin (fname, node, uname, username, password)); + + return (ERR); +} + + +/* KS_SCANLOGIN -- Open and scan a host login file, returning the login + * name and password to be used on the named node. The format of the table + * is a series of lines of the form + * + * alias1 alias2 ... aliasN : loginname password + * + * If the same login name and password are used on several nodes, a single + * entry may be given for all. If the alias "*" is encountered scanning stops + * and the next login name and password are used. The table file should of + * course be protected from reading except by the owner. If even this is + * considered too dangerous, the password "?" may be given in the table and a + * runtime query will result - this will fail if one is no longer logged in. + */ +ks_scanlogin (fname, node, uname, username, password) +char *fname; /* table file */ +char *node; /* node name */ +char *uname; /* user login on local node */ +char *username; /* receives user login name */ +char *password; /* receives user password */ +{ + char *ip; + char lbuf[SZ_LINE+1]; + char wbuf[SZ_NAME+1]; + int fp; + int foundit; + char *ku_fgets(); + + foundit = 0; + if ((fp = ku_fopen (fname, "r")) == ERR) + return (ERR); + + /* Scan file for line containing node name. + */ + while (!foundit && ku_fgets (lbuf, SZ_LINE, fp) != NULL) { + /* Skip blank lines and comment lines */ + for (ip=lbuf; *ip == ' ' || *ip == '\t'; ip++) + ; + if (*ip == '#' || *ip == EOS) + continue; + + /* Scan list of aliases */ + while (ks_getword (&ip, wbuf) > 0) { + if (strcmp (wbuf, ":") == 0) { + break; + } else if (strcmp(wbuf,"*")==0 || strcmp(wbuf,node)==0) { + foundit++; + break; + } + } + } + + ku_fclose (fp); + if (!foundit) + return (ERR); + + /* Skip to end of alias list. */ + while (ks_getword (&ip, wbuf) > 0) { + if (strcmp (wbuf, ":") == 0) { + /* Return login name and password. + */ + + /* If the login name is given as the USER string, use the + * login name on the local node. If the login name is given + * as "?", query the user for the actual login name. + */ + if (ks_getword (&ip, username) <= 0) + return (ERR); + if (strcmp (username, USER) == 0) + strcpy (username, uname); + else if (strcmp (username, "?") == 0) { + char prompt[80]; + + sprintf (prompt, "Login name (%s@%s): ", username, node); + if (ku_gpasswd (prompt, username, SZ_NAME) == ERR) + return (ERR); + } + + /* If the password is given as "?", query the user for + * the actual password. + */ + if (ks_getword (&ip, password) <= 0) + return (ERR); + if (strcmp (password, "?") == 0) { + char prompt[80]; + + sprintf (prompt, "Password (%s@%s): ", username, node); + if (ku_gpasswd (prompt, password, SZ_NAME) == ERR) + return (ERR); + } + + return (OK); /* SUCCESS */ + } + } + + return (ERR); +} + + +/* KS_GETWORD -- Get the next whitespace or : delimited word from the + * input string. + */ +ks_getword (ip, obuf) +char **ip; /* pointer into input buffer */ +char *obuf; /* receives name */ +{ + register char *cp, *op; + register int n; + + for (cp = *ip; isspace(*cp); cp++) + ; + + op = obuf; + n = 0; + + if (*cp == ':' || *cp == '*' || *cp == '?') { + *op++ = *cp++; + n++; + } else { + while (*cp && !isspace(*cp) && !(*cp==':' || *cp=='*' || *cp=='?')) + if (n++ >= SZ_NAME) + return (ERR); + else + *op++ = *cp++; + } + + *op = EOS; + *ip = cp; + + return (n); +} + + +/* ZCLSKS -- Close a kernel server connection. + */ +ZCLSKS (chan, status) +XINT *chan; /* socket to kernel server */ +XINT *status; /* receives close status */ +{ + *status = tcp_close (*chan); +} + + +/* ZARDKS -- Read from the kernel server channel. No attempt is made to + * impose a record structure upon the channel, as is the case with IPC. + * In UNIX the channel is stream oriented and it is up to the caller to + * unblock records from the input stream. Data blocks are assumed to be + * preceded by headers telling how much data to read, hence we read from + * the channel until the specified number of bytes have been read or ERR + * or EOF is seen on the stream. + */ +ZARDKS (chan, buf, totbytes, loffset) +XINT *chan; /* kernel server channel (socket) */ +XCHAR *buf; /* output buffer */ +XINT *totbytes; /* total number of bytes to read */ +XLONG *loffset; /* not used */ +{ + register char *op; + register int fd, nbytes; + int (*sigint)(), (*sigterm)(); + int status; + extern pr_onsig(); + + fd = *chan; + op = (char *)buf; + ks_ionbytes[fd] = nbytes = *totbytes; + + /* Now read exactly nbytes of data from channel into user buffer. + * Return actual byte count if EOF is seen. If ERR is seen return + * ERR. If necessary multiple read requests are issued to read the + * entire record. Reads are interruptable but the interrupt is caught + * and returned as a read error on the server channel. + */ + sigint = signal (SIGINT, pr_onsig); + sigterm = signal (SIGTERM, pr_onsig); + + while (nbytes > 0) { + if (setjmp (jmpbuf) == 0) + status = tcp_read (fd, op, nbytes); + else + status = ERR; + + switch (status) { + case 0: + ks_ionbytes[fd] -= nbytes; + signal (SIGINT, sigint); + signal (SIGTERM, sigterm); + return; + case ERR: + ks_ionbytes[fd] = ERR; + signal (SIGINT, sigint); + signal (SIGTERM, sigterm); + return; + default: + nbytes -= status; + op += status; + break; + } + } + + signal (SIGINT, sigint); + signal (SIGTERM, sigterm); +} + + +/* ZAWRKS -- Write to a kernel server channel. + */ +ZAWRKS (chan, buf, totbytes, loffset) +XINT *chan; /* kernel server channel (socket) */ +XCHAR *buf; /* output buffer */ +XINT *totbytes; /* number of bytes to write */ +XLONG *loffset; /* not used */ +{ + register int fd, ofd, nbytes; + int (*sigint)(), (*sigterm)(), (*sigpipe)(); + extern pr_onsig(); + + /* If chan=0 (the process standard input) then we really want to + * write to channel 1, the standard output. + */ + if ((ofd = fd = *chan) == 0) + ofd = 1; + + ks_ionbytes[fd] = nbytes = *totbytes; + + /* Write exactly nbytes of data to the channel from user buffer to + * the channel. Block interrupt during the write to avoid corrupting + * the data stream protocol if the user interrupts the client task. + * Trap SIGPIPE and return it as a write error on the channel instead. + * Likewise, turn an interrupt into a write error on the channel. + */ + sigint = signal (SIGINT, pr_onsig); + sigterm = signal (SIGTERM, pr_onsig); + sigpipe = signal (SIGPIPE, pr_onsig); + recursion = 0; + + if (setjmp (jmpbuf) == 0) + ks_ionbytes[fd] = tcp_write (ofd, (char *)buf, nbytes); + else + ks_ionbytes[fd] = ERR; + + signal (SIGINT, sigint); + signal (SIGTERM, sigterm); + signal (SIGPIPE, sigpipe); +} + + +/* PR_ONSIG -- Catch a signal and make it look like a write error on the + * server i/o channel. + */ +pr_onsig (sig, code, scp) +int sig; /* signal which was trapped */ +int code; /* subsignal code (vax) */ +struct sigcontext *scp; /* not used */ +{ + if (sig == SIGPIPE && recursion++ == 0) + ku_error ("kernel server process has died"); + + longjmp (jmpbuf, sig); +} + + +/* ZAWTKS -- Wait for i/o to a KS channel. Since UNIX i/o is not asynchronous + * we do not really wait, rather we return the status value (byte count) from + * the last read or write to the channel. + */ +ZAWTKS (chan, status) +XINT *chan; +XINT *status; +{ + if ((*status = ks_ionbytes[*chan]) == ERR) + *status = XERR; +} + + +/* ZSTTKS -- Get binary file status for an KS channel. A KS channel is a + * streaming binary file. + */ +ZSTTKS (chan, param, lvalue) +XINT *chan; /* not used; all KS channels have same status */ +XINT *param; +XLONG *lvalue; +{ + switch (*param) { + case FSTT_BLKSIZE: + case FSTT_FILSIZE: + *lvalue = 0; + break; + case FSTT_OPTBUFSIZE: + *lvalue = KS_OPTBUFSIZE; + break; + case FSTT_MAXBUFSIZE: + *lvalue = KS_MAXBUFSIZE; + break; + default: + *lvalue = XERR; + } +} diff --git a/unix/os/net/zzdebug.x b/unix/os/net/zzdebug.x new file mode 100644 index 00000000..6d22d29d --- /dev/null +++ b/unix/os/net/zzdebug.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task rexec = t_rexec, + rtype = t_rtype, + rread = t_rread + +define SZ_BUF 4096 + + +# REXEC -- Execute a command on a remote node and print the resultant output on +# the standard output. Used to test the kernel server driver. + +procedure t_rexec() + +char server[SZ_LINE] +char buf[SZ_BUF] +int chan, nbytes, status + +begin + call clgstr ("server", server, SZ_LINE) + call strpak (server, server, SZ_LINE) + + call zopnks (server, READ_WRITE, chan) + if (chan == ERR) + call error (1, "cannot connect to remote server process") + + repeat { + call zardks (chan, buf, SZ_BUF, 0) + call zawtks (chan, nbytes) + + if (nbytes > 0) { + call chrupk (buf, 1, buf, 1, nbytes) + call write (STDOUT, buf, nbytes) + call flush (STDOUT) + } + } until (nbytes <= 0) + + call zclsks (chan, status) + if (status == ERR) + call error (1, "error disconnecting server process") +end + + +# RTYPE -- Type a text file possibly resident on a remote node. + +procedure t_rtype() + +char fname[SZ_FNAME] +char lbuf[SZ_LINE] +int fd +int open(), getline() + +begin + call clgstr ("file", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, TEXT_FILE) + + while (getline (fd, lbuf) != EOF) { + call putline (STDOUT, lbuf) + call flush (STDOUT) + } + + call close (fd) +end + + +# RREAD -- Read a binary file. + +procedure t_rread() + +char fname[SZ_FNAME] +char dbuf[SZ_BUF] +int fd +long nchars, totchars +int open(), read() + +begin + call clgstr ("file", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, BINARY_FILE) + + totchars = 0 + + repeat { + nchars = read (fd, dbuf, SZ_BUF) + if (nchars > 0) + totchars = totchars + nchars + } until (nchars == EOF) + + call close (fd) + + call printf ("read %d chars\n") + call pargi (totchars) +end diff --git a/unix/os/prwait.c b/unix/os/prwait.c new file mode 100644 index 00000000..381d87b1 --- /dev/null +++ b/unix/os/prwait.c @@ -0,0 +1,175 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +/* Process table code. The high level code assumes that it can open and close + * processes in any order. The UNIX "wait" primitive, called when a process is + * closed, returns the process status and pid of the first process to exit. + * Hence several calls to wait may be necessary to wait for a given process to + * exit. We hide all this behind the pr_wait call, which waits for a PARTICULAR + * process to exit and returns its exit status. + * + * NOT INTERFACE PROCEDURES. This code is only called internally by other + * kernel procedures. All primitives which execute subprocesses, i.e., ZOPCPR, + * ZOPDPR, ZOSCMD, etc. must call these routines. + */ + +struct proctable { + int pr_pid; /* process id */ + int pr_active; /* if YES, process is still active */ + int pr_inchan; /* input IPC channel */ + int pr_outchan; /* output IPC channel */ + int pr_exit_status; /* process exit_status */ +} prtable[MAXPROCS]; + +extern int errno; + +#ifdef MACOSX +#define POSIX +#endif + + +/* PR_ENTER -- Make a new entry in the process table. Something is very wrong + * if the table overflows. + */ +void +pr_enter (int pid, int inchan, int outchan) +{ + register struct proctable *pr; + struct proctable *pr_findpid(); + + extern int kernel_panic (char *msg); + + + if ((pr = pr_findpid (NULL)) == NULL) + kernel_panic ("iraf process table overflow"); + else { + pr->pr_pid = pid; + pr->pr_active = YES; + pr->pr_inchan = inchan; + pr->pr_outchan = outchan; + } +} + + +/* PR_WAIT -- Wait for the process associated with the given pid to terminate + * and return it's exit status. If there is no such process in the table + * return ERR. The table entry is cleared by this call. + */ +int +pr_wait (int pid) +{ + register struct proctable *pr; + int error_code; + pid_t waitpid; + struct proctable *pr_findpid(); +#ifdef POSIX + int exit_status; +#else + union wait exit_status; +#endif + + + /* Lookup process in table. Return ERR if there is no entry. + */ + if ((pr = pr_findpid (pid)) == NULL) + return (ERR); + + if (pr->pr_active == NO) { + /* Process has already terminated. Clear table entry and return + * exit status (set in a previous call). + */ + pr->pr_pid = (int) 0; + return (pr->pr_exit_status); + + } else { + /* Process is in table but has not yet terminated. Call wait until + * the process exits. If other processes exit in the meantime + * save their exit status in the table and mark them inactive. + * If an unknown process terminates ignore it; this will happen + * when a killed bkg process terminates after its process slot + * has been released. + */ + while ((waitpid = wait (&exit_status)) != ERR) { + if ((pr = pr_findpid (waitpid)) != NULL) { + pr->pr_active = NO; + + /* The integer argument to exit() is returned in the + * wait struct defined in . + */ +#ifdef POSIX + error_code = WEXITSTATUS(exit_status); +#else + error_code = exit_status.w_T.w_Retcode; +#endif + pr->pr_exit_status = error_code ? error_code : XOK; + + if (waitpid == pid) { + pr->pr_pid = (int) 0; + return (pr->pr_exit_status); + } + } + } + return (ERR); + } +} + + +/* PR_GETIPC -- Get the codes for the IPC channels assigned to a process. + */ +int +pr_getipc (int pid, int *inchan, int *outchan) +{ + register struct proctable *pr; + struct proctable *pr_findpid(); + + + /* Lookup process in table. Return ERR if there is no entry. + */ + if ((pr = pr_findpid (pid)) == NULL) + return (ERR); + else { + *inchan = pr->pr_inchan; + *outchan = pr->pr_outchan; + return (pid); + } +} + + +/* PR_FINDPID -- Search the process table for a process. NULL is returned if + * the process cannot be found, otherwise a pointer to the table entry is + * returned. + */ +struct proctable * +pr_findpid (int pid) +{ + register int pr; + + + for (pr=0; pr < MAXPROCS; pr++) { + if (prtable[pr].pr_pid == pid) + return (&prtable[pr]); + } + + return (NULL); +} + + +/* PR_RELEASE -- Release the table entry for the process. Used when a process + * is killed and we do not wish to wait for process termination. + */ +void +pr_release (int pid) +{ + register struct proctable *pr; + + if ((pr = pr_findpid (pid)) != NULL) + pr->pr_pid = (int) 0; +} diff --git a/unix/os/tape.c b/unix/os/tape.c new file mode 100644 index 00000000..d6677bcf --- /dev/null +++ b/unix/os/tape.c @@ -0,0 +1,508 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef sun +#include +#include +#include +#endif + + +/* + * TAPE.C -- Magtape test program (for most UNIX systems). + * + * Commands: + * + * open [device [r|w]] open device with given mode + * close close device + * rew[ind] rewind + * + * fsf [n] forward space N filemarks + * bsf [n] backspace N filemarks + * fsr [n] forward space N records + * bsr [n] backspace N records + * read [n [bufsize]] read N records + * write [n [bufsize]] write N records + * seek [offset[bkm]] seek (b=block#, k=x1024, m=x1024*1024) + * weof write end of file + * + * s[tatus] print tape status (device dependent) + * verbose toggle verbose status mode + * + * log [file] toggle logging to file (def:tape.out) + * run file execute commands in "file" + * ? or help print commands + * q[uit] exit command loop + * + * The drive to be opened is by default the most recently referenced drive, + * or the value of the variable TAPE, if defined in the user environment. + * + * Records are read into a default buffer size of 65535 bytes on reads if + * no buffer size is specified. The number of bytes read will be printed, + * along with the first 76 or so printable ascii characters at the head of + * the record, omitting all control codes. This is usually enough to identify + * the type of record. + * + * On writes, the data written is an ascii representation of the file and + * record number, i.e., "file M record N". If the buffer size is not given + * the last buffer size specified is used, initially 1024. + */ + +/* #define SUNOS41 */ + +#define SZ_COMMAND 512 +#define SZ_FNAME 256 +#define SZ_IOBUF 262144 +#define NREAD 64512 +#define NWRITE 1024 +#define EOS '\0' + +static char mtdev[SZ_FNAME]; +static char o_mtdev[SZ_FNAME]; +static char iobuf[SZ_IOBUF]; +static char cmdbuf[SZ_COMMAND]; +static char tokbuf[SZ_COMMAND]; +static char logfile[SZ_FNAME]; +static int rbufsz, wbufsz; +static int t_fileno; +static int t_blkno; +static int t_acmode; +static int verbose; +static int status; +extern int errno; +static FILE *stack[20]; +static FILE *logfp; +static char *tp; +static int tape; +static int sp; + +char *nextcmd(), *prompt(); +char *gettok(), *getenv(); + +void mtop (int op, int count); +char *nextcmd (FILE *in); +char *gettok (void); +char *prompt (void); +void pstatus (void); +void output (char *text); +void phelp (void); + + +/* TAPE program main. + */ +int +main (int argc, char *argv[]) +{ + char lbuf[256]; + int nrec, nbytes; + char *token; + FILE *in; + FILE *fp; + + + errno = 0; + t_blkno = 0; + t_fileno = 0; + rbufsz = NREAD; + wbufsz = NWRITE; + strcpy (logfile, "tape.out"); + + if (argc > 1) + strcpy (o_mtdev, argv[1]); + + for (in=stdin, sp=0; sp >= 0; ) { + /* Prompt if interactive. */ + if (in == stdin) { + fputs (prompt(), stdout); + fflush (stdout); + } + + /* Get command from current input stream. */ + if (nextcmd (in) == NULL) { +quit: if (in != stdin) + fclose (in); + if (--sp >= 0) + in = stack[sp]; + continue; + } else if (*tp == '!') { + system (tp+1); + continue; + } else if ((token = gettok()) == NULL) + continue; + + if (in == stdin) { + /* Log command if entered interactively. */ + if (logfp) + fputs (cmdbuf, logfp); + } else { + /* Echo command if noninteractive. */ + output (cmdbuf); + fflush (stdout); + } + + /* Check for program control commands. */ + if (!strncmp (token, "quit", 1)) { + goto quit; + } else if (!strcmp (token, "?") || !strcmp (token, "help")) { + phelp(); + continue; + } else if (!strncmp (token, "status", 2)) { + pstatus(); + continue; + } else if (!strncmp (token, "verbose", 3)) { + verbose = !verbose; + continue; + + } else if (!strncmp (token, "log", 3)) { + /* Ignore log commands not entered interactively. */ + if (in != stdin) + continue; + + /* Toggle logging. */ + if (logfp) { + printf ("logging disabled\n"); + fclose (logfp); + logfp = NULL; + } else { + if ( (token = gettok()) ) + strcpy (logfile, token); + if ((logfp = fopen (logfile, "a")) == NULL) + printf ("cannot open logfile %s\n", logfile); + else { + printf ("logging output to %s\n", logfile); + fprintf (logfp, "# --- BEGIN ---\n"); + } + } + continue; + + } else if (!strcmp (token, "run")) { + if (!(token = gettok()) || (fp=fopen(token,"r")) == NULL) + printf ("cannot run %s\n", token ? token : "?"); + else { + stack[sp++] = in; + in = fp; + } + continue; + } + + /* + * TAPE CONTROL commands. + */ + + if (!strncmp (token, "open", 1)) { + /* Get device name. */ + if (!(token=gettok()) || !strcmp (token, ".")) { + if (!o_mtdev[0] && (token = getenv ("TAPE"))) + strcpy (mtdev, token); + else + strcpy (mtdev, o_mtdev); + } else if (token[0]) + strcpy (mtdev, token); + + if (!mtdev[0]) { + output ("no tape device specified\n"); + continue; + } + + /* Open device. */ + if ((tape = open (mtdev, t_acmode = + ((token=gettok()) && *token == 'w') ? 2 : 0)) == -1) { + sprintf (lbuf, "cannot open device %s\n", mtdev); + output (lbuf); + mtdev[0] = EOS; + continue; + } + sprintf (lbuf, + "device %s open on descriptor %d\n", mtdev, tape); + output (lbuf); + strcpy (o_mtdev, mtdev); + } else if (!strncmp (token, "close", 1)) { + close (tape); + if (t_acmode) { + t_fileno++; + t_blkno = 0; + } + mtdev[0] = EOS; + errno = 0; + } else if (!strncmp (token, "rew", 3)) { + mtop (MTREW, 1); + t_fileno = 0; + t_blkno = 0; + errno = 0; + } else if (!strcmp (token, "weof")) { + mtop (MTWEOF, 1); + t_fileno++; + t_blkno = 0; + + } else if (!strcmp (token, "fsf")) { + mtop (MTFSF, (token = gettok()) ? atoi(token) : 1); + } else if (!strcmp (token, "fsr")) { + mtop (MTFSR, (token = gettok()) ? atoi(token) : 1); + } else if (!strcmp (token, "bsf")) { + mtop (MTBSF, (token = gettok()) ? atoi(token) : 1); + } else if (!strcmp (token, "bsr")) { + mtop (MTBSR, (token = gettok()) ? atoi(token) : 1); + + } else if (!strncmp (token, "read", 1)) { + register int i, j; + + nrec = (token = gettok()) ? atoi(token) : 1; + nbytes = rbufsz = (token = gettok()) ? atoi(token) : rbufsz; + + for (j=0; j < nrec; j++) { + for (i=0; i < nbytes; i++) + iobuf[i] = 0; + status = read (tape, iobuf, nbytes); + pstatus(); + + if (status < 0) { + output (" ERR\n"); + } else if (status == 0) { + output (" EOF\n"); + } else if (status > 0) { + char obuf[512]; + char *op, *ip, ch; + + op = obuf; *op++ = ' '; *op++ = ' '; + for (i=0, ip=iobuf; i < status && op-obuf < 78; i++) + if ((ch = ip[i]) > 040 && ch < 0177) + *op++ = ip[i]; + *op++ = '\n'; + *op++ = EOS; + output (obuf); + } + } + + continue; + + } else if (!strncmp (token, "write", 1)) { + register int i; + + nrec = (token = gettok()) ? atoi(token) : 1; + nbytes = wbufsz = (token = gettok()) ? atoi(token) : wbufsz; + if (nbytes > SZ_IOBUF) + nbytes = SZ_IOBUF; + + for (i=0; i < nbytes; i++) + iobuf[i] = 0; + + for (i=0; i < nrec; i++) { + sprintf (iobuf, "file %d, record %d\n", + t_fileno, t_blkno); + status = write (tape, iobuf, nbytes); + t_blkno++; + pstatus(); + } + + continue; + + } else if (!strncmp (token, "seek", 2)) { + char *ip; + int fwd, bak, i; + + if ( (token = gettok()) ) { + ip = token; + fwd = bak = 0; + if (*ip == '-') { + bak++; + ip++; + } else if (*ip == '+') { + fwd++; + ip++; + } + + for (i=0; isdigit(*ip); ip++) + i = i * 10 + (*ip - '0'); + + switch (*ip) { + case 'b': + i *= rbufsz; + break; + case 'k': + i *= 1024; + break; + case 'm': + i *= (1024*1024); + break; + } + + if (fwd) + status = lseek (tape, (off_t)i, 1); + else if (bak) + status = lseek (tape, -(off_t)i, 1); + else + status = lseek (tape, (off_t)i, 0); + pstatus(); + + } else { + status = lseek (tape, 0, 1); + pstatus(); + } + + } else + output ("unrecognized command\n"); + + if (verbose) + pstatus(); + fflush (stdout); + } + + return (0); +} + + +/* MTOP -- Execute a magtape operation. + */ +void +mtop ( + int op, /* operation code */ + int count /* count argument */ +) +{ + struct mtop mt; + + mt.mt_op = op; + mt.mt_count = count; + status = ioctl (tape, MTIOCTOP, &mt); + if (!verbose && status < 0) + pstatus(); +} + + +/* NEXTCMD -- Get next command. + */ +char * +nextcmd (FILE *in) +{ + fflush (stdout); + if (fgets (cmdbuf, SZ_COMMAND, in) == NULL) + return (NULL); + else + return (tp = cmdbuf); +} + + +/* GETTOK -- Get next token from the input stream. + */ +char * +gettok (void) +{ + register char *op; + register int ch; + + while (*tp && isspace(*tp)) + tp++; + if (*tp == EOS || *tp == '#') + return (NULL); + + for (op=tokbuf; (ch = *tp) && !isspace(ch); tp++, op++) + *op = ch; + + *op = EOS; + return (tokbuf); +} + + +/* PROMPT -- Return a pointer to the prompt string. + */ +char * +prompt (void) +{ + static char prompt[32]; + static char defp[] = "% "; + register char *ip, *dev; + + for (ip=dev=mtdev; *ip; ip++) + if (*ip == '/') + dev = ip + 1; + + if (*dev) { + sprintf (prompt, "(%s) ", dev); + return (prompt); + } else + return (defp); +} + + +/* PSTATUS -- Print status of tape and last operation. + */ +void +pstatus (void) +{ + char obuf[512]; + + +#ifdef sun + static struct mt_tape_info info[] = MT_TAPE_INFO; + struct mt_tape_info *tp; + struct mtget mt; + char *tn; + + if (verbose) { + if (ioctl (tape, MTIOCGET, &mt) != 0) + sprintf (obuf, "MTIOCGET ioctl fails\n"); + else { + for (tn="unknown", tp=info; tp->t_type; tp++) + if (tp->t_type == mt.mt_type) { + tn = tp->t_name; + break; + } + + sprintf (obuf, + "status %d (%d) file=%d block=%d resid=%d [ds=0x%x er=0x%x] %s\n", + status, errno, mt.mt_fileno, mt.mt_blkno, + mt.mt_resid, mt.mt_dsreg, mt.mt_erreg, tn); + } + } else + sprintf (obuf, "status %d (%d)\n", status, errno); +#else + sprintf (obuf, "status %d (%d)\n", status, errno); +#endif + + output (obuf); + fflush (stdout); +} + + +/* OUTPUT -- Write text to the standard output, and to the logfile output + * if enabled. + */ +void +output (char *text) +{ + fputs (text, stdout); + if (logfp) { + fputs ("# ", logfp); + fputs (text, logfp); + } +} + + +char *helptxt[] = { + "Usage: tape [device]. The following commands are provided:\n", + "\n", + " open [device [r|w]] rewind fsf [n]\n", + " close read [nrec [bufsz]] fsr [n]\n", + " log [file] write [nrec [bufsz]] bsf [n]\n", + " run weof bsr [n]\n", + " verbose status quit\n", + 0 }; + +/* PHELP -- Print list of commands. + */ +void +phelp (void) +{ + register int i; + + for (i=0; helptxt[i]; i++) + output (helptxt[i]); +} diff --git a/unix/os/zalloc.c b/unix/os/zalloc.c new file mode 100644 index 00000000..4cc19765 --- /dev/null +++ b/unix/os/zalloc.c @@ -0,0 +1,206 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_spp +#define import_alloc +#define import_kernel +#define import_knames +#include + +/* + * ZALLOC.C -- Device allocation interface. Requires the dev$devices table, + * which is read by the high level code before we are called. + * + * zdvall (device, allflg, status) allocate/deallocate device + * zdvown (device, owner, maxch, status) query device allocation + * + * Status returns (import_alloc): + * + * OK operation successful + * ERR cannot allocate device + * DV_DEVALLOC device is already allocated + * DV_DEVINUSE device is in use by someone else + * DV_DEVFREE device is free and can be allocated + * + * The DEVICE name is a list of aliases for the physical device. On UNIX there + * can be multiple elements in the list (e.g., for a tape drive), but on other + * systems there may never be more than one device name. The elements of the + * list are delimited by whitespace. On host systems that do not support + * multiple device aliases, the kernel may assume that DEVICE is a scalar. + */ + +#define ALLOCEXE "alloc.e" + +static int u_allocstat (char *aliases); + + + +/* ZDVALL -- Allocate or deallocate a device. UNIX does not explicitly support + * device allocation, so we fake it by setting the device owner and removing + * group and other permissions. This requires superuser privilege, hence a + * separate process HLIB$ALLOC.E is used to set/remove device allocation. + */ +int +ZDVALL ( + PKCHAR *aliases, /* list of aliases for device */ + XINT *allflg, /* allocate or deallocate device? */ + XINT *status /* receives status word */ +) +{ + PKCHAR cmd[SZ_LINE+1], nullstr[1]; + + extern int ZOSCMD (); + + + /* Syntax: $host/hlib/alloc.e -[ad] aliases + */ + strcpy ((char *)cmd, irafpath(ALLOCEXE)); + strcat ((char *)cmd, *allflg ? " -a " : " -d "); + strcat ((char *)cmd, (char *)aliases); + + *nullstr = XEOS; + (void) ZOSCMD (cmd, nullstr, nullstr, nullstr, status); + if (*status == DV_ERROR) + *status = XERR; + + return (*status); +} + + +/* ZDVOWN -- Query device allocation. Tells whether or not the named device + * is allocated, and if so returns the "name" of the owner in the owner + * string. Just what the "name" string is is not precisely defined, it is + * merely printed for the user to tell them the status of the device. + * Note that the device is not considered to be allocated if the owner + * is not currently logged in. + * + * Device files may be specified by a full pathname, as a user directory + * relative pathname, or by the device name in /dev or /dev/rmt. + */ +int +ZDVOWN ( + PKCHAR *device, /* device name (not a list) */ + PKCHAR *owner, /* receives owner string */ + XINT *maxch, /* max chars out */ + XINT *status /* receives allocation status */ +) +{ + register int uid; + char *dev, devname[SZ_FNAME+1]; + struct passwd *pw, *getpwuid(); + struct stat fi; + + + /* Get device pathname. */ + dev = (char *)device; + if (dev[0] == '/') { + strcpy (devname, dev); + + } else if (dev[0] == '~' && dev[1] == '/') { + /* User home directory relative pathname. */ + struct passwd *pwd; + pwd = getpwuid (getuid()); + if (pwd != NULL) { + strcpy (devname, pwd->pw_dir); + strcat (devname, &dev[1]); + endpwent(); + } + } else { + sprintf (devname, "/dev/%s", dev); + if (access (devname, 0) == ERR) + sprintf (devname, "/dev/rmt/%s", dev); + } + + if (stat (devname, &fi) == ERR) { + *status = XERR; + return (XERR); + } + + uid = fi.st_uid; + *owner = XEOS; + + if (uid == 0) + *status = DV_DEVFREE; + else if (uid == getuid()) + *status = DV_DEVALLOC; + /* else if (!loggedin (uid)) */ + else if (u_allocstat ((char *)device) == DV_DEVFREE) + *status = DV_DEVFREE; + else { + if ((pw = getpwuid (uid)) == NULL) + sprintf ((char *)owner, "%d", uid); + else + strncpy ((char *)owner, pw->pw_name, *maxch); + *status = DV_DEVINUSE; + } + + return (*status); +} + + +/* LOGGEDIN -- Return 1 if uid is logged in, else 0. + */ +int +loggedin (int uid) +{ + struct utmpx ubuf; + struct passwd *pw, *getpwuid(); + FILE *ufp; + + if ((ufp = fopen ("/var/run/utmp", "r")) == NULL) { + printf ("zdvown: cannot open /var/run/utmp\n"); + return (1); + } + + if ((pw = getpwuid (uid)) == NULL) { + fclose (ufp); + return (0); + } + + do { + if (fread (&ubuf, sizeof (struct utmpx), 1, ufp) == (size_t) 0) { + fclose (ufp); + return (0); + } + } while (strncmp (ubuf.ut_user, pw->pw_name, 8) != 0); + + fclose (ufp); + + return (1); +} + + +/* U_ALLOCSTAT -- Call alloc.e to get the device status. Currently, this has + * to be done by a priviledged process as the process table is used in some + * cases. + */ +static int +u_allocstat ( + char *aliases /* list of aliases for device */ +) +{ + PKCHAR cmd[SZ_LINE+1], nullstr[1]; + XINT x_status; + + extern int ZOSCMD(); + + + /* Syntax: $host/hlib/alloc.e -s aliases + */ + strcpy ((char *)cmd, irafpath(ALLOCEXE)); + strcat ((char *)cmd, " -s "); + strcat ((char *)cmd, aliases); + + *nullstr = XEOS; + (void) ZOSCMD (cmd, nullstr, nullstr, nullstr, &x_status); + if (x_status == DV_ERROR) + x_status = XERR; + + return (x_status); +} diff --git a/unix/os/zawset.c b/unix/os/zawset.c new file mode 100644 index 00000000..62b0ef6b --- /dev/null +++ b/unix/os/zawset.c @@ -0,0 +1,154 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#ifdef SYSV +#define NORLIMIT +#endif + +#ifndef CYGWIN +#ifdef LINUX +#undef NORLIMIT +#endif +#endif + +#ifdef SOLARIS +#define RLIMIT_RSS RLIMIT_VMEM +#undef NORLIMIT +#endif + +#include +#include +#ifndef NORLIMIT +#include +#include +#endif + +#define import_kernel +#define import_knames +#define import_spp +#include + +#define PCT_RESERVE 10 /* percent */ +#define MIN_RESERVE 50 /* megabytes */ +#define MIN_WORKSET 32 /* megabytes */ + +#define ENV_DEBUG "ZAWSET_DEBUG" +#define MB (1024*1024) +#define KB 1024 + +/* Kernel default working set values in bytes. */ +unsigned int defworkset = SZ_DEFWORKSET; +unsigned int maxworkset = SZ_MAXWORKSET; +static unsigned int max_wss = 0; +extern char *getenv(); + + +/* ZAWSET -- Adjust or query the "working set", i.e., the maximum amount of + * physical memory allocated to the process. + */ +int +ZAWSET ( + XINT *best_size, /* requested working set size, bytes. */ + XINT *new_size, + XINT *old_size, /* actual new and old sizes, bytes. */ + XINT *max_size /* max working set size, bytes */ +) +{ + int physmem=0, kb_page; + int debug = (getenv(ENV_DEBUG) != NULL); + char *s, *getenv(); + +#ifndef NORLIMIT + unsigned int working_set_size; + struct rlimit rlp; +#endif + + + /* Get the page size in kilobytes. */ + kb_page = getpagesize() / KB; + +#ifdef _SC_PHYS_PAGES + /* On recent POSIX systems (including Solaris, Linux, and maybe + * others) we can use sysconf to get the actual system memory size. + * The computation is done in KB to avoid integer overflow. + */ + physmem = sysconf(_SC_PHYS_PAGES) * kb_page; + if (physmem > 0) { + maxworkset = min (MAX_LONG / KB, physmem); + + /* Don't try to use all of physical memory. */ + if (maxworkset == physmem) { + maxworkset -= (max ((MIN_RESERVE*MB)/KB, + physmem * PCT_RESERVE / 100)); + if (maxworkset <= 0) + maxworkset = (MIN_WORKSET * MB) / KB; + } + + /* Now convert back to bytes. */ + maxworkset *= 1024; + } +#endif + + /* The hard upper limit on memory utilization defined by the unix + * kernel can be limited either by the value compiled into the IRAF + * kernel, or by the value set in the user environment variable + * MAXWORKSET, given in units of Mb. + */ + if (!max_wss) { + if ( (s = getenv ("MAXWORKSET")) ) { + max_wss = atoi(s) * 1024*1024; + if (max_wss < 1024*1024) + max_wss = maxworkset; + } else + max_wss = maxworkset; + } + + if (debug) + fprintf(stderr,"zawset: physmem=%dm, maxworkset=%dm max_wss=%dm\n", + physmem / KB, maxworkset / MB, max_wss / MB); + +#ifdef NORLIMIT + if (*best_size == 0) + *old_size = *new_size = defworkset; + else + *new_size = *old_size = min (max_wss, *best_size); + *max_size = max_wss; +#else + getrlimit (RLIMIT_RSS, &rlp); + if (debug) + fprintf (stderr, "zawset: starting rlimit cur=%ldm, max=%ldm\n", + (long)(rlp.rlim_cur == RLIM_INFINITY ? 0 : rlp.rlim_cur) / MB, + (long)(rlp.rlim_max == RLIM_INFINITY ? 0 : rlp.rlim_max) / MB); + + working_set_size = min (max_wss, + rlp.rlim_cur == RLIM_INFINITY ? max_wss : rlp.rlim_cur); + + /* Now try to set the size requested by our caller. If bestsize was + * given as zero, merely return the status values. + */ + (*max_size) = min (max_wss, + rlp.rlim_max == RLIM_INFINITY ? max_wss : rlp.rlim_max); + + if (*best_size <= 0) + *new_size = *old_size = working_set_size; + else { + rlp.rlim_cur = min (*best_size, *max_size); + if (rlp.rlim_cur > working_set_size) + setrlimit (RLIMIT_RSS, &rlp); + getrlimit (RLIMIT_RSS, &rlp); + *old_size = working_set_size; + *new_size = min(*best_size, min(max_wss, + rlp.rlim_cur == RLIM_INFINITY ? max_wss : rlp.rlim_cur)); + } + if (debug) + fprintf (stderr, "zawset: adjusted rlimit cur=%ldm, max=%ldm\n", + (long)(rlp.rlim_cur == RLIM_INFINITY ? 0 : rlp.rlim_cur) / MB, + (long)(rlp.rlim_max == RLIM_INFINITY ? 0 : rlp.rlim_max) / MB); +#endif + if (debug) + fprintf (stderr, "zawset: best=%ldm old=%ldm new=%ldm max=%ldm\n", + (long)*best_size/MB, (long)*old_size/MB, + (long)*new_size/MB, (long)*max_size/MB); + + return (XOK); +} diff --git a/unix/os/zcall.c b/unix/os/zcall.c new file mode 100644 index 00000000..18d28ee4 --- /dev/null +++ b/unix/os/zcall.c @@ -0,0 +1,91 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZCALL[0-10] -- Call the procedure whose entry point address is pointed to + * by the first argument, which is the integer valued entry point address of + * the procedure as returned by ZLOCPR. Up to ten arguments are passed by + * reference to the called subprocedure. + */ + + + + +int ZCALL0 (XINT *proc) +{ + return (*(PFI)(*proc))(); +} + +int ZCALL1 (XINT *proc, void *arg1) +{ + return (*(PFI)(*proc)) (arg1); +} + + +int ZCALL2 (XINT *proc, void *arg1, void *arg2) +{ + return (*(PFI)(*proc)) (arg1, arg2); +} + + +int ZCALL3 (XINT *proc, void *arg1, void *arg2, void *arg3) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3); +} + + +int ZCALL4 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4); +} + + +int ZCALL5 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5); +} + + +int ZCALL6 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5, arg6); +} + + +int ZCALL7 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5, arg6, arg7); +} + + +int ZCALL8 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7, void *arg8) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +} + + +int ZCALL9 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7, void *arg8, void *arg9) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5, arg6, arg7, + arg8, arg9); +} + + +int ZCALLA (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, + void *arg10) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5, arg6, arg7, + arg8, arg9, arg10); +} diff --git a/unix/os/zdojmp.c b/unix/os/zdojmp.c new file mode 100644 index 00000000..2b825cde --- /dev/null +++ b/unix/os/zdojmp.c @@ -0,0 +1,38 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZDOJMP -- Restore the saved processor context (non-local goto). See also + * as$zsvjmp.s, where most of the work is done. + */ +void +ZDOJMP (XINT *jmpbuf, XINT *status) +{ +#ifdef DOJMP_ORIG + register int stat = *status ? *status : 1; + register long *jb = (long *)jmpbuf; + + *((int *)jb[0]) = stat; + longjmp (&jb[1], stat); + +#else + register int stat = *status ? *status : 1; + register XINT *status_ptr = ((XINT **)jmpbuf)[0]; + register void *jb = (XINT **)jmpbuf+1; + + *status_ptr = stat; +#if (defined(LINUX) || defined(CYGWIN)) + siglongjmp (jb, stat); +#else + longjmp (jb, stat); +#endif + +#endif +} diff --git a/unix/os/zfacss.c b/unix/os/zfacss.c new file mode 100644 index 00000000..f6624698 --- /dev/null +++ b/unix/os/zfacss.c @@ -0,0 +1,124 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +#define SZ_TESTBLOCK 1024 /* for TEXT/BINARY heuristic */ +#define MAX_LINELEN 256 /* when looking for newlines */ +#define R 04 /* UNIX access() codes */ +#define W 02 +#define ctrlcode(c) ((c) >= '\007' && (c) <= '\017') + + +/* ZFACSS -- Try to determine if FILE is accessible in the indicated MODE. + * If file is accessible for reading and TYPE is given as TEXT_FILE, + * look at the first block of data to see if it is legal text data. + * ACCESS(file,0,0) merely checks that the file exists. Any file is a + * legal binary file. + */ +int +ZFACSS ( + PKCHAR *fname, + XINT *mode, + XINT *type, + XINT *status +) +{ + static char modebits[] = { 0, R, R|W, W, R|W }; + register char *ip, ch; + register int n; + char buf[SZ_TESTBLOCK]; + int fd, acmode, accessible, nchars, newline_seen; + struct stat fi; + + /* Null filename? */ + if (*(char *)fname == EOS) { + *status = NO; + return (NO); + } + + /* Map IRAF access mode into UNIX access mode. + */ + if (*mode >= READ_ONLY && *mode <= APPEND) + acmode = modebits[*mode]; + else if (*mode == 0 && *type != 0) + acmode = R; + else + acmode = 0; + + /* Is file accessible with the given mode. + */ + accessible = (access ((char *)fname, acmode) == 0); + + if (accessible && *type == DIRECTORY_FILE) { + stat ((char *)fname, &fi); + if (fi.st_mode & S_IFDIR) + *status = YES; + else + *status = NO; + return (*status); + + } else if (!accessible && *type == SYMLINK_FILE) { + lstat ((char *)fname, &fi); + if (fi.st_mode & S_IFLNK) + *status = YES; + else + *status = NO; + + return (*status); + } + + /* If we have to check the file type (text or binary), then we must + * actually look at some file data since UNIX does not discriminate + * between text and binary files. NOTE that this heuristic is not + * completely reliable and can fail, although in practice it does + * very well. + */ + if (accessible && (acmode & R) && *type != 0) { + stat ((char *)fname, &fi); + + /* Do NOT read from a special device (may block) */ + if ((fi.st_mode & S_IFMT) & S_IFREG) { + /* If we are testing for a text file the portion of the file + * tested must consist of only printable ascii characters or + * whitespace, with occasional newline line delimiters. + * Control characters embedded in the text will cause the + * heuristic to fail. We require newlines to be present in + * the text to disinguish the case of a binary file containing + * only ascii data, e.g., a cardimage file. + */ + fd = open ((char *)fname, 0); + if (fd >= 0 && (nchars = read (fd, buf, SZ_TESTBLOCK)) > 0) { + ip = buf; + for (n=nchars, newline_seen=0; --n >= 0; ) { + ch = *ip++; + if (ch == '\n') + newline_seen++; + else if (!isprint(ch) && !isspace(ch) && !ctrlcode(ch)) + break; + } + + if (*type == TEXT_FILE) { + if (n >= 0 || (nchars > MAX_LINELEN && !newline_seen)) + accessible = NO; + } else if (*type == BINARY_FILE && n < 0) + accessible = NO; + close (fd); + } + } else if (fi.st_mode & S_IFCHR && *type != TEXT_FILE) + accessible = NO; + } + + (*status) = accessible; + + return (*status); +} diff --git a/unix/os/zfaloc.c b/unix/os/zfaloc.c new file mode 100644 index 00000000..c0eb09cd --- /dev/null +++ b/unix/os/zfaloc.c @@ -0,0 +1,104 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZFALOC -- Preallocate space for a large file of known size, without having + * to physically write zero blocks. In UNIX this is done by seeking to the + * desired end of file and writing some data. Standard UNIX does not provide + * any way to allocate a contiguous or near-contiguous file. + */ +int +ZFALOC ( + PKCHAR *fname, + XLONG *nbytes, + XINT *status +) +{ + char data = 0; + char *s; + int fd; + off_t lseek(); + extern char *getenv(); + extern int _u_fmode(); + + + if ((fd = creat ((char *)fname, _u_fmode(FILE_MODEBITS))) == ERR) { + *status = XERR; + return (XERR); + } + + /* Fix size of file by seeking to the end of file minus one byte, + * and writing one byte of data. UNIX will not allocate the remaining + * fileblocks until they are written into at run time; when referenced + * the blocks will be zero-fill on demand. + */ + if (*nbytes > 0) { + if (lseek (fd, (off_t)(*nbytes - 1), 0) == ERR) { + close (fd); + *status = XERR; + return (XERR); + } + if (write (fd, &data, 1) == ERR) { + close (fd); + *status = XERR; + return (XERR); + } + lseek (fd, (off_t)0, 0); + } + + /* For efficiency reasons the above is all we normally do. However, + * if ZFALOC is set in the environment we touch each file block at + * least once in order to preallocate all the space at zfaloc time. + * ZFALOC may optionally have a string value. If no value is given + * all files are match (zfaloc is fully allocate all files). + * Otherwise, the string value is a comma delimited list of simple + * pattern strings. A file is matched, and space preallocated, if + * the given substring appears anywhere in the file name. + */ + if ( (s = getenv ("ZFALOC")) ) { + register char *ip, *op; + char patstr[SZ_PATHNAME]; + int match = (*s == '\0'); + int patlen, i; + + while (!match && *s) { + for (op=patstr; *s && *s != ','; ) + *op++ = *s++; + *op = '\0'; + patlen = strlen (patstr); + if (*s == ',') + s++; + + for (ip=(char *)fname; *ip; ip++) + if (*ip == patstr[0] && !strncmp(ip,patstr,patlen)) { + match++; + break; + } + } + + if (match) + for (i=0; i < *nbytes; i += 512) { + lseek (fd, (off_t)i, 0); + if (write (fd, &data, 1) < 0) { + *status = XERR; + close (fd); + return (XERR); + } + } + } + + close (fd); + *status = XOK; + + return (XOK); +} diff --git a/unix/os/zfchdr.c b/unix/os/zfchdr.c new file mode 100644 index 00000000..3beae679 --- /dev/null +++ b/unix/os/zfchdr.c @@ -0,0 +1,57 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +extern char oscwd[]; + + +/* ZFCHDR -- Change the current working directory. Save directory name, + * excluding the trailing "/", in oscwd so that a subsequent call to ZFGCWD + * will be able to return directory name without a big hassle. + */ +int +ZFCHDR ( + PKCHAR *newdir, + XINT *status +) +{ + register char *ip, *op; + char dirname[SZ_PATHNAME]; + + + /* Change pathnames like "a/b/c/" to "a/b/c". + */ + for (ip=(char *)newdir, op=dirname; (*op = *ip++) != EOS; op++) + ; + if ((*(op-1) == '/') && (op - dirname > 1)) + *(op-1) = EOS; + + /* Ask UNIX to change the cwd to newdir. + */ + if (chdir (dirname) == ERR) { + *status = XERR; + + } else if (dirname[0] == '/') { + /* Save pathname of directory. + */ + strcpy (oscwd, dirname); + *status = XOK; + + } else { + /* Concatenate subdir name to current directory pathname. + */ + for (op=oscwd; *op; op++) + ; + if (*(op-1) != '/') + *op++ = '/'; + for (ip=dirname; (*op++ = *ip++); ) + ; + } + + return (*status); +} diff --git a/unix/os/zfdele.c b/unix/os/zfdele.c new file mode 100644 index 00000000..1e973040 --- /dev/null +++ b/unix/os/zfdele.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZFDELE -- Delete a file. + */ +int +ZFDELE ( + PKCHAR *fname, + XINT *status +) +{ + extern int vm_delete(); + + vm_delete ((char *)fname, 0); + if (unlink ((char *)fname) == ERR) + *status = XERR; + else + *status = XOK; + + return (*status); +} diff --git a/unix/os/zfgcwd.c b/unix/os/zfgcwd.c new file mode 100644 index 00000000..29b476c0 --- /dev/null +++ b/unix/os/zfgcwd.c @@ -0,0 +1,65 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#define import_spp +#define import_kernel +#define import_knames +#include + +extern char oscwd[]; + + +/* ZFGCWD -- Get working (current) UNIX directory. The current working + * directory, once set, is saved in oscwd. + */ +int +ZFGCWD ( + PKCHAR *outstr, + XINT *maxch, + XINT *status +) +{ + register char *ip, *op; + register int n; + char dirname[1025]; +#ifdef POSIX + char *getcwd(); +#else + char *getwd(); +#endif + + /* If cwd is already known, just return the name. Reconstructing + * the pathname of the cwd is expensive on some systems. + */ + if (oscwd[0] != EOS) + ip = oscwd; + else { +#ifdef POSIX + ip = getcwd (dirname, 1024); +#else + ip = getwd (dirname); +#endif + if (ip == NULL) { + *status = XERR; + return (XERR); + } else + strcpy (oscwd, dirname); + } + + op = (char *)outstr; + for (n = *maxch; --n >= 0 && (*op = *ip++) != EOS; ) + op++; + + /* Make sure a concatenatable directory prefix is returned. + */ + if (*(op-1) != '/') { + *op++ = '/'; + *op = EOS; + } + + *status = op - (char *)outstr; + + return (*status); +} diff --git a/unix/os/zfinfo.c b/unix/os/zfinfo.c new file mode 100644 index 00000000..db5803fb --- /dev/null +++ b/unix/os/zfinfo.c @@ -0,0 +1,99 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_spp +#define import_finfo +#include + +/* ZFINFO -- Get information describing the named file. Access times + * are returned in units of seconds since 00:00:00 01-Jan-80, local time. + */ +int +ZFINFO ( + PKCHAR *fname, + XLONG *finfo_struct, + XINT *status +) +{ + struct stat osfile; + struct _finfo *fs; + struct passwd *getpwuid(); + time_t gmt_to_lst(); + int stat(); + + /* Get UNIX file info. + */ + fs = (struct _finfo *)finfo_struct; + if (stat ((char *)fname, &osfile) == ERR) { + *status = XERR; + return (XERR); + } + + /* Determine file type. + */ + if (osfile.st_mode & S_IFDIR) + fs->fi_type = FI_DIRECTORY; + else if (osfile.st_mode & S_IEXEC) + fs->fi_type = FI_EXECUTABLE; + else if (osfile.st_mode & S_IFREG) + fs->fi_type = FI_REGULAR; + else + fs->fi_type = FI_SPECIAL; + + /* Set file size (in bytes), access times, and file permission bits. + * Times must be converted from GMT epoch 1970 to local standard time, + * epoch 1980. + */ + fs->fi_size = osfile.st_size; + fs->fi_atime = gmt_to_lst (osfile.st_atime); + fs->fi_mtime = gmt_to_lst (osfile.st_mtime); + fs->fi_ctime = gmt_to_lst (osfile.st_ctime); + + /* Encode file access permission bits. + */ + { + static int osbits[] = { 0400, 0200, 040, 020, 04, 02 }; + int bit; + + for (bit=0, fs->fi_perm=0; bit < 6; bit++) + fs->fi_perm |= (osfile.st_mode & osbits[bit]) ? 1<fi_owner, owner, SZ_OWNERSTR); + else { + setpwent(); + pw = getpwuid (osfile.st_uid); + endpwent(); + + if (pw == NULL) + sprintf ((char *)fs->fi_owner, "%d", osfile.st_uid); + else { + strncpy (owner, pw->pw_name, SZ_OWNERSTR); + strncpy ((char *)fs->fi_owner, owner, SZ_OWNERSTR); + uid = osfile.st_uid; + } + } + ((char *)fs->fi_owner)[SZ_OWNERSTR] = EOS; + } + + *status = XOK; + + return (*status); +} diff --git a/unix/os/zfiobf.c b/unix/os/zfiobf.c new file mode 100644 index 00000000..d3fd18ff --- /dev/null +++ b/unix/os/zfiobf.c @@ -0,0 +1,888 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +# ifndef O_NDELAY +#include +# endif + +#include +#include + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_spp +#include + +/* + * ZFIOBF -- FIO interface to UNIX 4.1BSD binary files. + * This is the interface to general, random access disk resident binary + * files (as opposed to text files). The basic strategy is very simple. + * FIO will request an asynchronous read or write of N device blocks at + * a given offset. The offset (one-indexed) is guaranteed by FIO to be + * aligned on a device block boundary, and to be in bounds. The size of + * a device block and of a file are determined at open time by FIO, which + * calls the zsttbf status routine. + * + * FIO ASSUMES that it can extend a file by writing at EOF in an ordinary + * zawrbf call with the appropriate one-indexed byte offset. If the last + * block in the file is a partial block, FIO will write at some device + * block offset within the file, after first reading the partial block + * into the FIO buffer. FIO will never write a partial block within + * a file, but assumes it can do so at the end of the file. If the OS + * does not support irregular length files, the interface routines should + * simulate it somehow. The FIO buffer is an integral number of SPP chars + * in size, and read requests (in units of bytes) will always be for an integral + * number of chars. + * + * In UNIX 4.1BSD, there is no such thing as asynchronous i/o, so we have + * to fake it. Also, the UNIX i/o interface is sequential/seek, while the + * FIO interface is absolute offset, so we have to keep track of the file + * position to avoid a seek on every i/o access. + */ + +int _u_fmode (int mode); +int vm_access (char *fname, int mode); +int vm_reservespace (long nbytes); +int vm_largefile (long nbytes); +int vm_directio (int fd, int flag); + + +/* ZOPNBF -- Open a binary file. The file must exist for modes RO, WO, RW. + * A new file will always be created for mode NF, and a file will be created + * if it does not exist for mode AP. Append mode is write-only at EOF. + * It is also legal to open RW and append by seeking to EOF and writing, + * if more generality is required. + */ +int +ZOPNBF ( + PKCHAR *osfn, /* UNIX name of file */ + XINT *mode, /* file access mode */ + XINT *chan /* file number (output) */ +) +{ + register int fd; + struct stat filstat; + + /* Open or create file with given access mode. + */ + switch (*mode) { + case READ_ONLY: + /* The O_NDELAY is necessary for some types of special devices, + * e.g., a FIFO, and should be harmless for other file types. + */ + if ((fd = open ((char *)osfn, O_RDONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_RDONLY); + break; + case WRITE_ONLY: + if ((fd = open ((char *)osfn, O_WRONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_WRONLY); + break; + + case READ_WRITE: + fd = open ((char *)osfn, O_RDWR); + break; + + case NEW_FILE: + /* Create file and then reopen for read-write access. + */ + if ((fd = creat ((char *)osfn, _u_fmode(FILE_MODEBITS))) != ERR) { + close (fd); + fd = open ((char *)osfn, 2); + } + break; + + case APPEND: + /* It is legal to append to a nonexistent file. We merely create + * a new, zero length file and append to it. Read access is + * required on a binary file opened for appending, since FIO has + * to read the partial block at the end of the file before it can + * append to it. + */ + if (access ((char *)osfn, 0) == ERR) + close (creat ((char *)osfn, _u_fmode(FILE_MODEBITS))); + fd = open ((char *)osfn, 2); + break; + + default: + fd = ERR; + } + + /* Initialize the kernel file descriptor. Seeks are illegal if the + * device is a character special device; the device is a "streaming" + * file (blksize=1) if it can only be accessed sequentially. + */ + if (fd != ERR && stat ((char *)osfn, &filstat) == ERR) { + close (fd); + fd = ERR; + } + + /* Don't set *chan until we have successfully finished opening the + * file, otherwise any error occuring during the open will try to + * close the partially opened file. + */ + if (fd == ERR) { + *chan = XERR; + } else if (fd >= MAXOFILES) { + close (fd); + if (*mode == NEW_FILE) + unlink ((char *)osfn); + *chan = XERR; + } else { + zfd[fd].fp = NULL; + zfd[fd].fpos = 0L; + zfd[fd].nbytes = 0; + zfd[fd].flags = (filstat.st_mode & S_IFCHR) ? KF_NOSEEK : 0; + zfd[fd].filesize = filstat.st_size; + if (!vm_access ((char *)osfn, *mode)) + zfd[fd].flags |= KF_DIRECTIO; + *chan = fd; + } + + return (*chan); +} + + +/* ZCLSBF -- Close a binary file. + */ +int +ZCLSBF (XINT *fd, XINT *status) +{ + extern int errno; + + /* This is a bit of a kludge, but closing a FIFO pipe opened for + * reading (probably attempting the close before the writer has + * closed the connection) causes an EPERM error on the close. + * This is harmless and only causes the VOS task to report an + * error, so ignore the error. + */ + if ((*status = (close (*fd) == ERR) ? XERR : XOK) == XERR) + if (errno == EPERM) + *status = XOK; + + return (*status); +} + + +/* ZARDBF -- "Asynchronous" binary block read. Initiate a read of at most + * maxbytes bytes from the file FD into the buffer BUF. Status is returned + * in a subsequent call to ZAWTBF. + */ +int +ZARDBF ( + XINT *chan, /* UNIX file number */ + XCHAR *buf, /* output buffer */ + XINT *maxbytes, /* max bytes to read */ + XLONG *offset /* 1-indexed file offset to read at */ +) +{ + register struct fiodes *kfp; + register int fd; + off_t fileoffset; + int aligned; + off_t lseek(); + + fd = *chan; + kfp = &zfd[fd]; + fileoffset = *offset - 1L; + + /* If reading from a device on which seeks are illegal, offset should + * be zero (as when called by ZARDCL). Otherwise, we must seek to + * the desired position. + */ + if (*offset > 0 && kfp->fpos != fileoffset) { + if ((kfp->fpos = lseek(fd,fileoffset,0)) == ERR) { + kfp->nbytes = ERR; + return (XERR); + } + } + + /* Disable direct i/o if transfers are not block aligned. */ + aligned = (!(fileoffset % SZ_DISKBLOCK) && !(*maxbytes % SZ_DISKBLOCK)); + if ((kfp->flags & KF_DIRECTIO) && !aligned) + kfp->flags &= ~KF_DIRECTIO; + + if (kfp->flags & KF_DIRECTIO) + vm_directio (fd, 1); + + if ((kfp->nbytes = read (fd, (char *)buf, *maxbytes)) > 0) + kfp->fpos += kfp->nbytes; + + if (kfp->flags & KF_DIRECTIO && aligned) + vm_directio (fd, 0); + + return (XOK); +} + + +/* ZAWRBF -- "Asynchronous" binary block write. Initiate a write of exactly + * nbytes bytes from the buffer BUF to the file FD. Status is returned in a + * subsequent call to ZAWTBF. + */ +int +ZAWRBF ( + XINT *chan, /* UNIX file number */ + XCHAR *buf, /* buffer containing data */ + XINT *nbytes, /* nbytes to be written */ + XLONG *offset /* 1-indexed file offset */ +) +{ + register int fd; + register struct fiodes *kfp; + off_t fileoffset; + off_t lseek(); + int aligned; + + fd = *chan; + kfp = &zfd[fd]; + fileoffset = *offset - 1L; + + /* If writing to a device on which seeks are illegal, offset should + * be zero (as when called by ZAWRCL). Otherwise, we must seek to + * the desired position. + */ + if (*offset > 0 && kfp->fpos != fileoffset) + if ((kfp->fpos = lseek(fd,fileoffset,0)) == ERR) { + kfp->nbytes = ERR; + return (XERR); + } + + /* Disable direct i/o if transfers are not block aligned. */ + aligned = (!(fileoffset % SZ_DISKBLOCK) && !(*nbytes % SZ_DISKBLOCK)); + if ((kfp->flags & KF_DIRECTIO) && !aligned) + kfp->flags &= ~KF_DIRECTIO; + + if (kfp->flags & KF_DIRECTIO) { + vm_directio (fd, 1); + } else if (vm_largefile((long)offset) || vm_largefile((long)*nbytes)) { + /* Reserve VM space if writing at EOF. */ + struct stat st; + if (!fstat(fd,&st) && fileoffset >= st.st_size) + vm_reservespace (fileoffset + *nbytes - st.st_size); + } + + if ((kfp->nbytes = write (fd, (char *)buf, *nbytes)) > 0) + kfp->fpos += kfp->nbytes; + + if (kfp->flags & KF_DIRECTIO) + vm_directio (fd, 0); + + /* Invalidate cached file size, forcing a UNIX system call to determine + * the file size the next time ZSTTBF is called. + */ + kfp->filesize = -1; + + return (XOK); +} + + +/* ZAWTBF -- "Wait" for an "asynchronous" read or write to complete, and + * return the number of bytes read or written, or ERR. + */ +int +ZAWTBF (XINT *fd, XINT *status) +{ + if ((*status = zfd[*fd].nbytes) == ERR) + *status = XERR; + + return (*status); +} + + +/* ZSTTBF -- Return status on a binary file. The same status routine is used + * for both blocked (random access) and streaming (sequential) binary files. + * All character special devices are considered to be streaming files, although + * such is not necessarily the case. Seeks are illegal on character special + * devices. The test for file type is made when the file is opened. + */ +int +ZSTTBF (XINT *fd, XINT *param, XLONG *lvalue) +{ + register struct fiodes *kfp = &zfd[*fd]; + struct stat filstat; + + switch (*param) { + case FSTT_BLKSIZE: + /* If all disk devices do not have the same block size then + * device dependent code should be substituted for the reference + * to SZ_DISKBLOCK below. + */ + if (kfp->flags & KF_NOSEEK) + (*lvalue) = 1L; + else + (*lvalue) = SZ_DISKBLOCK; + break; + + case FSTT_FILSIZE: + /* The file size is undefined if the file is a streaming file. + * For blocked files the file size is determined at open time + * and cached in the kernel file descriptor. The cached value + * is updated when we are called and invalidated whenever the file + * is written to. It is not worthwhile trying to keep track of + * the file size in the kernel because FIO only calls us to + * determine the filesize once, at open time. Caching the size + * saves us one FSTAT system call at open time. + */ + if (kfp->flags & KF_NOSEEK) + (*lvalue) = 0L; + else if ((*lvalue = kfp->filesize) < 0) { + if (fstat ((int)*fd, &filstat) == ERR) + (*lvalue) = XERR; + else + (*lvalue) = kfp->filesize = filstat.st_size; + } + break; + + case FSTT_OPTBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = BF_OPTBUFSIZE; + break; + + case FSTT_MAXBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = BF_MAXBUFSIZE; + break; + + default: + (*lvalue) = XERR; + break; + } + + return (XOK); +} + + +/* _U_FMODE -- Compute the effective file mode, taking into account the + * current process umask. (A no-op at present). + */ +int _u_fmode (int mode) +{ + return (mode); +} + + +/* + * VMcache client interface + * + * vm_access (fname, mode) + * vm_reservespace (nbytes) + * vm_directio (fd, flag) + * + * This small interface implements a subset of the client commands provided + * by the VMcache daemon (virtual memory cache controller). The client + * interface handles connection to the VMcache daemon (if any) transparently + * within the interface. + */ +#include + +#ifdef LINUX +#define USE_SIGACTION +#endif + +#define DEF_ACCESSVAL 1 +#define ENV_VMPORT "VMPORT" +#define ENV_VMCLIENT "VMCLIENT" +#define DEF_VMTHRESH (1024*1024*8) +#define DEF_DIOTHRESH (1024*1024*8) +#define DEF_VMPORT 8677 +#define SZ_CMDBUF 2048 +#define SZ_CNAME 32 + +#ifdef MACOSX +static int vm_enabled = 0; +static int vm_dioenabled = 1; +#else +static int vm_enabled = 1; +static int vm_dioenabled = 0; +#endif + +static int vm_debug = 0; +static int vm_server = 0; +static int vm_initialized = 0; +static int vm_threshold = DEF_VMTHRESH; +static int dio_threshold = DEF_DIOTHRESH; +static int vm_port = DEF_VMPORT; +static char vm_client[SZ_CNAME+1]; + +extern char *getenv(); +extern char *realpath(); +static void vm_initialize(); +static void vm_shutdown(); +static void vm_identify(); +static int vm_write(); +static int vm_connect(); +static int getstr(); + + + +/* VM_ACCESS -- Access a file via the VM subsystem. A return value of 1 + * indicates that the file is (or will be) "cached" in virtual memory, i.e., + * that normal virtual memory file system (normal file i/o) should be used + * to access the file. A return value of 0 indicates that direct i/o should + * be used to access the file, bypassing the virtual memory file system. + */ +int +vm_access (char *fname, int mode) +{ + struct stat st; + char *modestr = NULL, buf[SZ_COMMAND]; + char pathname[SZ_PATHNAME]; + int status; + + + /* One-time process initialization. */ + if (!vm_initialized) + vm_initialize(); + + if (stat (fname, &st) < 0) { + status = DEF_ACCESSVAL; + goto done; + } + + /* If directio is enabled and the file exceeds the directio threshold + * use directio to access the file (access=0). If vmcache is + * disabled use normal VM-based i/o to access the file (access=1). + * If VMcache is enabled we still only use it if the file size + * exceeds vm_threshold. + */ + if (vm_dioenabled) { + status = (st.st_size >= dio_threshold) ? 0 : 1; + goto done; + } else if (!vm_enabled || st.st_size < vm_threshold) { + status = DEF_ACCESSVAL; + goto done; + } + + /* Use of VMcache is enabled and the file equals or exceeds the + * minimum size threshold. Initialization has already been performed. + * Open a VMcache daemon server connection if we don't already have + * one. If the server connection fails we are done, but we will try + * to open a connection again in the next file access. + */ + if (!vm_server) + if (vm_connect() < 0) { + status = DEF_ACCESSVAL; + goto done; + } + + /* Compute the mode string for the server request. */ + switch (mode) { + case READ_ONLY: + modestr = "ro"; + break; + case NEW_FILE: + case READ_WRITE: + case APPEND: + modestr = "rw"; + break; + } + + /* Format and send the file access directive to the VMcache daemon. + * The status from the server is returned as an ascii integer value + * on the same socket. + */ + sprintf (buf, "access %s %s\n", realpath(fname,pathname), modestr); + if (vm_write (vm_server, buf, strlen(buf)) < 0) { + vm_shutdown(); + status = DEF_ACCESSVAL; + goto done; + } + if (read (vm_server, buf, SZ_CMDBUF) <= 0) { + if (vm_debug) + fprintf (stderr, + "vmclient (%s): server not responding\n", vm_client); + vm_shutdown(); + status = DEF_ACCESSVAL; + goto done; + } + + status = atoi (buf); +done: + if (vm_debug) + fprintf (stderr, "vmclient (%s): access `%s' -> %d\n", + vm_client, fname, status); + + return (status < 0 ? DEF_ACCESSVAL : status); +} + + +/* VM_DELETE -- Delete any VM space used by a file, e.g., because the file + * is being physically deleted. This should be called before the file is + * actually deleted so that the cache can determine its device and inode + * values. + */ +int +vm_delete (char *fname, int force) +{ + struct stat st; + char buf[SZ_COMMAND]; + char pathname[SZ_PATHNAME]; + int status = 0; + + /* One-time process initialization. */ + if (!vm_initialized) + vm_initialize(); + + if (stat (fname, &st) < 0) { + status = -1; + goto done; + } + + /* If VMcache is not being used we are done. */ + if (vm_dioenabled && (st.st_size >= dio_threshold)) + goto done; + else if (!vm_enabled || st.st_size < vm_threshold) + goto done; + + /* Don't delete the VM space used by the file if it has hard links + * and only a link is being deleted (force flag will override). + */ + if (st.st_nlink > 1 && !force) + goto done; + + /* Connect to the VMcache server if not already connected. */ + if (!vm_server) + if (vm_connect() < 0) { + status = -1; + goto done; + } + + /* Format and send the delete directive to the VMcache daemon. + * The status from the server is returned as an ascii integer value + * on the same socket. + */ + sprintf (buf, "delete %s\n", realpath(fname,pathname)); + if (vm_write (vm_server, buf, strlen(buf)) < 0) { + vm_shutdown(); + status = -1; + goto done; + } + if (read (vm_server, buf, SZ_CMDBUF) <= 0) { + if (vm_debug) + fprintf (stderr, + "vmclient (%s): server not responding\n", vm_client); + vm_shutdown(); + status = -1; + goto done; + } + + status = atoi (buf); +done: + if (vm_debug) + fprintf (stderr, "vmclient (%s): delete `%s' -> %d\n", + vm_client, fname, status); + + return (status < 0 ? -1 : status); +} + + +/* VM_RESERVESPACE -- Reserve VM space for file data. This directive is + * useful if VM is being used but the VM space could not be preallocated + * at file access time, e.g., when opening a new file. + */ +int +vm_reservespace (long nbytes) +{ + char buf[SZ_CMDBUF]; + int status; + + if (!vm_initialized) + vm_initialize(); + if (!vm_enabled || vm_dioenabled) + return (-1); + if (vm_connect() < 0) + return (-1); + + /* Format and send the file access directive to the VMcache daemon. + * The status from the server is returned as an ascii integer value + * on the same socket. + */ + sprintf (buf, "reservespace %ld\n", nbytes); + if (vm_debug) + fprintf (stderr, "vmclient (%s): %s", vm_client, buf); + + if (vm_write (vm_server, buf, strlen(buf)) < 0) { + vm_shutdown(); + return (-1); + } + if (read (vm_server, buf, SZ_CMDBUF) <= 0) { + if (vm_debug) + fprintf (stderr, + "vmclient (%s): server not responding\n", vm_client); + vm_shutdown(); + return (-1); + } + + status = atoi (buf); + return (status); +} + + +/* VM_IDENTIFY -- Identify the current process to the VM cache server when + * opening a new client connection. + */ +static void +vm_identify (void) +{ + char buf[SZ_CMDBUF]; + + if (vm_write (vm_server, vm_client, strlen(vm_client)) < 0) + vm_shutdown(); + + if (read (vm_server, buf, SZ_CMDBUF) <= 0) { + if (vm_debug) + fprintf (stderr, + "vmclient (%s): server not responding\n", vm_client); + vm_shutdown(); + } +} + + +/* VM_LARGEFILE -- Test if the given offset or file size exceeds the VMcache + * threshold. Zero (false) is returned if the offset is below the threshold + * or if VMcache is disabled. + */ +int +vm_largefile (long nbytes) +{ + return (vm_enabled && nbytes >= vm_threshold); +} + + +/* VM_DIRECTIO -- Turn direct i/o on or off for a file. Direct i/o is raw + * i/o from the device to process memory, bypassing system virtual memory. + */ +int +vm_directio (int fd, int flag) +{ +#ifdef SOLARIS + /* Currently direct i/o is implemented only for Solaris. */ + if (vm_debug > 1) + fprintf (stderr, "vmclient (%s): directio=%d\n", vm_client, flag); + return (directio (fd, flag)); +#else + return (-1); +#endif +} + + +/* VM_INITIALIZE -- Called once per process to open a connection to the + * vmcache daemon. The connection is kept open and is used for all + * subsequent vmcache requests by the process. + */ +static void +vm_initialize (void) +{ + register int ch; + register char *ip, *op; + char token[SZ_FNAME], value[SZ_FNAME]; + extern char os_process_name[]; + char *argp, buf[SZ_FNAME]; + + + /* Extract the process name minus the file path. */ + for (ip=os_process_name, op=vm_client; (*op++ = (ch = *ip)); ip++) { + if (ch == '/') + op = vm_client; + } + + /* Get the server socket port if set in the user environment. */ + if ((argp = getenv (ENV_VMPORT))) + vm_port = atoi (argp); + + /* Get the VM client parameters if an initialization string is + * defined in the user environment. + */ + if ((argp = getenv (ENV_VMCLIENT))) { + while (getstr (&argp, buf, SZ_FNAME, ',') > 0) { + char *modchar, *cp = buf; + int haveval; + + /* Parse "token[=value]" */ + if (getstr (&cp, token, SZ_FNAME, '=') <= 0) + continue; + haveval = (getstr (&cp, value, SZ_FNAME, ',') > 0); + + if (strcmp (token, "enable") == 0) { + vm_enabled = 1; + } else if (strcmp (token, "disable") == 0) { + vm_enabled = 0; + + } else if (strcmp (token, "debug") == 0) { + vm_debug = 1; + if (haveval) + vm_debug = strtol (value, &modchar, 10); + + } else if (strcmp (token, "threshold") == 0 && haveval) { + vm_threshold = strtol (value, &modchar, 10); + if (*modchar == 'k' || *modchar == 'K') + vm_threshold *= 1024; + else if (*modchar == 'm' || *modchar == 'M') + vm_threshold *= (1024 * 1024); + + } else if (strcmp (token, "directio") == 0) { + vm_dioenabled = 1; + if (haveval) { + dio_threshold = strtol (value, &modchar, 10); + if (*modchar == 'k' || *modchar == 'K') + dio_threshold *= 1024; + else if (*modchar == 'm' || *modchar == 'M') + dio_threshold *= (1024 * 1024); + } + } + } + } + + if (vm_debug) { + fprintf (stderr, "vmclient (%s): vm=%d dio=%d ", + vm_client, vm_enabled, vm_dioenabled); + fprintf (stderr, "vmth=%d dioth=%d port=%d\n", + vm_threshold, dio_threshold, vm_port); + } + + /* Attempt to open a connection to the VMcache server. */ + if (vm_enabled && !vm_dioenabled) + vm_connect(); + +#ifdef SUNOS + on_exit (vm_shutdown, NULL); +#else + atexit (vm_shutdown); +#endif + vm_initialized++; +} + + +/* VM_CONNECT -- Connect to the VMcache server. + */ +static int +vm_connect (void) +{ + XINT acmode = READ_WRITE; + char osfn[SZ_FNAME]; + int fd, status = 0; + + extern int ZOPNND(); + + + /* Already connected? */ + if (vm_server) + return (0); + + sprintf (osfn, "inet:%d::", vm_port); + if (vm_debug) + fprintf (stderr, + "vmclient (%s): open server connection `%s' -> ", + vm_client, osfn); + + ZOPNND (osfn, &acmode, &fd); + if (fd == XERR) { + if (vm_debug) + fprintf (stderr, "failed\n"); + status = -1; + } else { + vm_server = fd; + if (vm_debug) + fprintf (stderr, "fd=%d\n", fd); + vm_identify(); + } + + return (status); +} + + +/* VM_SHUTDOWN -- Called at process exit to shutdown the VMcached server + * connection. + */ +static void +vm_shutdown (void) +{ + int status; + extern int ZCLSND(); + + if (vm_server) { + if (vm_debug) + fprintf (stderr, + "vmclient (%s): shutdown server connection\n", vm_client); + vm_write (vm_server, "bye\n", 4); + ZCLSND (&vm_server, &status); + } + vm_server = 0; +} + + +/* VM_WRITE -- Write to the server. We need to encapsulate write so that + * SIGPIPE can be disabled for the duration of the write. We don't want the + * calling process to abort if the VMcache server goes away. + */ +static int +vm_write (int fd, char *buf, int nbytes) +{ + int status; +#ifdef USE_SIGACTION + struct sigaction oldact; +#else + SIGFUNC oldact; +#endif + + if (vm_debug > 1) { + fprintf (stderr, "vmclient (%s):: %s", vm_client, buf); + if (buf[nbytes-1] != '\n') + fprintf (stderr, "\n"); + } + +#ifdef USE_SIGACTION + sigaction (SIGPIPE, NULL, &oldact); + status = write (fd, buf, nbytes); + sigaction (SIGPIPE, &oldact, NULL); +#else + oldact = (SIGFUNC) signal (SIGPIPE, SIG_IGN); + status = write (fd, buf, nbytes); + signal (SIGPIPE, oldact); +#endif + + if (vm_debug && status < 0) + fprintf (stderr, + "vmclient (%s): server not responding\n", vm_client); + + return (status); +} + + +/* GETSTR -- Internal routine to extract a metacharacter delimited substring + * from a formatted string. The metacharacter to be taken as the delimiter + * is passed as an argument. Any embedded whitespace between the tokens is + * stripped. The number of characters in the output token is returned as + * the function value, or zero if EOS or the delimiter is reached. + */ +static int +getstr (char **ipp, char *obuf, int maxch, int delim) +{ + register char *op, *ip = *ipp; + register char *otop = obuf + maxch; + + while (*ip && isspace(*ip)) + ip++; + for (op=obuf; *ip; ip++) { + if (*ip == delim) { + ip++; + break; + } else if (op < otop && !isspace(*ip)) + *op++ = *ip; + } + + *op = '\0'; + *ipp = ip; + + return (op - obuf); +} diff --git a/unix/os/zfioks.c b/unix/os/zfioks.c new file mode 100644 index 00000000..5302dff0 --- /dev/null +++ b/unix/os/zfioks.c @@ -0,0 +1,2101 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef SYSV +#include +#else +#include +#endif + +#ifdef MACOSX +#define USE_RCMD 1 +#include +#endif + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_prtype +#define import_spp +#include + + +/* ZFIOKS -- File i/o to a remote kernel server. This driver is the network + * interface for the kernel interface package (sys$ki). The KS driver is + * normally called directly by the KI routines, but is patterned after the + * regular FIO drivers hence may be connected to FIO to provide a network + * interface to the high level code. + * + * zopcks open kernel server on remote node + * zclcks close kernel server + * zardks read from the remote kernel server + * zawrks write to the remote kernel server + * zawtks wait for i/o + * zsttks get channel/device status + * + * In the Berkeley UNIX environment the network interface is TCP/IP. The + * kernel server process irafks.e, running on the remote node, communicates + * directly with the zfioks driver in the iraf client process via a socket. + * Two protocols are supported for connecting to the irafks.e server. The + * default protocol uses RSH (or REMSH) as a bootstrap to start a daemon + * irafks.e process (known as in.irafksd) on the remote node. There is one + * such daemon process per node per user. Login authentication is performed + * when the daemon process is started. Once the daemon is running, each + * instance of the irafks.e server is started by a simple request to the daemon + * without repeating full login authentication, although an authorization code + * is required. The second, or alternate protocol uses REXEC to start the + * irafks.e server directly, and requires that a password be supplied, either + * in the irafhosts file or by an interactive query. + * + * The advantage of the default protocol is efficiency: starting a new server + * is fast once the in.irafksd daemon is up and running on the server node. + * All that is required is a connnect, an irafks.e fork, and another connect. + * There are however some drawbacks (which result from the desire to make all + * this work by boostrapping off of RSH so that no suid root processes are + * needed). First, for things to work correctly it must be possible to assign + * each user a unique port number for the in.irafksd daemon. This is done via + * a uid based scheme. There is however no guarantee that the port will not + * already be in use, preventing the daemon from being bound to the port; if + * this happens, a port is dynamically assigned by the daemon for temporary + * use to set up the server. If this happens a rsh request will be required + * to spawn each server (this involves a total of half a dozen or so forks + * and execs) but it should still work. + * + * The other complication has to do with security. There is a potentially + * serious security problem if the in.irafksd daemon simply responds to + * every request to spawn a kernel server, because any user could issue such + * a request (there is no way to check the uid of the client process over a + * socket connection). In an "open" environment this might be acceptable + * since some effort is required to take advantage of this loophole, but to + * avoid the loophole a simple authentication scheme is used. This involves + * a unique authentication integer which is set by the client when the daemon + * is spawned - spawning the daemon via rsh is "secure" if rsh is secure. + * Subsequent client requests must supply the same authentication number or + * the request will be denied. The authentication number may be specified + * either in the user environment or in the .irafhosts file. The driver will + * automatically set protection 0600 (read-only) on the .irafhosts file when + * accessed. + * + * The driver has a fall-back mode wherein a separate rsh call is used for + * every server connection. This is enabled by setting the in.irafksd port + * number to zero in the irafhosts file. In this mode, all port numbers are + * dynamically assigned, eliminating the chance of collisions with reserved + * or active ports. + */ + +/* + * PORTING NOTE -- A "SysV" system may use rsh instead of remsh. This should + * be checked when doing a port. Also, on at least one system it was necessary + * to change MAXCONN to 1 (maybe that is what it should be anyway). + */ + +extern int errno; +extern int save_prtype; + +#define SZ_NAME 32 /* max size node, etc. name */ +#define SZ_CMD 256 /* max size rexec sh command */ +#define MAXCONN 1 /* for listen */ +#define MAX_UNAUTH 32 /* max unauthorized requests */ +#define ONEHOUR (60*60) /* number of seconds in one hour */ +#define DEF_TIMEOUT (1*ONEHOUR) /* default in.irafksd idle timo */ +#define MIN_TIMEOUT 60 /* minimum timeout (seconds) */ +#define PRO_TIMEOUT 45 /* protocol (ks_geti) timeout */ +#define DEF_HIPORT 47000 /* default in.irafksd port region */ +#define MAX_HIPORT 65535 /* top of port number range */ +#define MIN_HIPORT 15000 /* bottom of port number range */ +#define REXEC_PORT 512 /* port for rexecd daemon */ +#define FNNODE_CHAR '!' /* node name delimiter */ +#define IRAFHOSTS ".irafhosts" /* user host login file */ +#define HOSTLOGIN "dev/irafhosts" /* system host login file */ +#define USER "" /* symbol for user account info */ +#define UNAUTH 99 /* means auth did not match */ + +#ifdef BSD +#define IPPORT_USERRESERVED 5000 +#endif + +#ifdef POSIX +#define SELWIDTH FD_SETSIZE /* number of bits for select */ +#else +#define SELWIDTH 32 /* number of bits for select */ +#endif + +#define KS_RETRY "KS_RETRY" /* number of connection attempts */ +#define KS_NO_RETRY "KS_NO_RETRY" /* env to override rexec retry */ + +#define KSRSH "KSRSH" /* set in env to override RSH cmd */ +#if (defined(BSD) | defined(LINUX)) +#define RSH "rsh" /* typical names are rsh, remsh */ +#else +#ifdef SYSV +#define RSH "remsh" /* typical names are rsh, remsh */ +#else +#define RSH "rsh" /* typical names are rsh, remsh */ +#endif +#endif + +#define IRAFKS_DIRECT 0 /* direct connection (via rexec) */ +#define IRAFKS_CALLBACK 1 /* callback to client socket */ +#define IRAFKS_DAEMON 2 /* in.irafksd daemon process */ +#define IRAFKS_SERVER 3 /* irafks server process */ +#define IRAFKS_CLIENT 4 /* zfioks client process */ + +#define C_RSH 1 /* rsh connect protocol */ +#define C_REXEC 2 /* rexec connect protocol */ +#define C_REXEC_CALLBACK 3 /* rexec-callback protocol */ + +struct ksparam { + int auth; /* user authorization code */ + int port; /* in.irafksd port */ + int hiport; /* in.irafksd port region */ + int timeout; /* in.irafksd idle timeout, sec */ + int protocol; /* connect protocol */ +}; + +int debug_ks = 0; /* print debug info on stderr */ +char debug_file[64] = ""; /* debug output file if nonnull */ +FILE *debug_fp = NULL; /* debugging output */ + +extern uid_t getuid(); +extern char *getenv(); +extern char *strerror(); +static jmp_buf jmpbuf; +static int jmpset = 0; +static int recursion = 0; +static int parent = -1; +static SIGFUNC old_sigcld; +static int ks_pchan[MAXOFILES]; +static int ks_achan[MAXOFILES]; +static int ks_getresvport(), ks_rexecport(); +static int ks_socket(), ks_geti(), ks_puti(), ks_getlogin(); +static void dbgsp(), dbgmsg(), dbgmsgs(); +static void dbgmsg1(), dbgmsg2(), dbgmsg3(), dbgmsg4(); +static char *ks_getpass(); +static void ks_onsig(), ks_reaper(); + +static int ks_getlogin (char *hostname, char *loginname, char *password, + struct ksparam *ks); +static char *ks_username (char *filename, char *pathname, char *username); +static char *ks_sysname (char *filename, char *pathname); +static struct irafhosts *ks_rhosts (char *filename); +static int ks_getword (char **ipp, char *obuf); +static void ks_whosts (struct irafhosts *hp, char *filename); +static char *ks_getpass (char *user, char *host); + +void pr_mask (char *str); + +/* ZOPNKS -- Open a connected subprocess on a remote node. Parse the "server" + * argument to obtain the node name and the command to be issued to connect the + * remote process. Set up a socket to be used for communications with the + * remote irafks kernel server. The "server" string is implementation + * dependent and normally comes from the file dev$hosts. This file is read + * by the high level VOS code before we are called. + */ +int +ZOPNKS ( + PKCHAR *x_server, /* type of connection */ + XINT *mode, /* access mode (not used) */ + XINT *chan /* receives channel code (socket) */ +) +{ + register char *ip, *op; + char *server = (char *)x_server; + char host[SZ_NAME+1], username[SZ_NAME+1], password[SZ_NAME+1]; + int proctype=0, port=0, auth=0, s_port=0, pid=0, s=0, i=0; + struct sockaddr_in from; + char *hostp=NULL, *cmd=NULL; + char obuf[SZ_LINE]; + struct ksparam ks; + + + + /* Initialize local arrays */ + host[0] = username[0] = password[0] = (char) 0; + + /* Parse the server specification. We can be called to set up either + * the irafks daemon or to open a client connection. + * + * (null) direct via rexec + * callback port@host callback client + * in.irafksd [port auth [timeout]] start daemon + * [-prot] [-log file] host!command client connection + * + * where -prot is -rsh, -rex, or -rcb denoting the client connect + * protocols rsh, rexec, and rexec-callback. + */ + + /* Eat any protocol specification strings. The default connect + * protocol is rsh. + */ + for (ip = server; isspace(*ip); ip++) + ; + ks.protocol = C_RSH; + if (strncmp (ip, "-rsh", 4) == 0) { + ks.protocol = C_RSH; + ip += 4; + } else if (strncmp (ip, "-rex", 4) == 0) { + ks.protocol = C_REXEC; + ip += 4; + } else if (strncmp (ip, "-rcb", 4) == 0) { + ks.protocol = C_REXEC_CALLBACK; + ip += 4; + } + + /* Check for the debug log flag. */ + for ( ; isspace(*ip); ip++) + ; + if (strncmp (ip, "-log", 4) == 0) { + debug_ks++; + for (ip += 4; isspace(*ip); ip++) + ; + for (op=debug_file; *ip && !isspace(*ip); ) + *op++ = *ip++; + *op = EOS; + } + + /* Determine connection type. */ + for ( ; isspace(*ip); ip++) + ; + if (!*ip) { + proctype = IRAFKS_DIRECT; + } else if (strncmp (ip, "callback ", 9) == 0) { + proctype = IRAFKS_CALLBACK; + ip += 9; + } else if (strncmp (ip, "in.irafksd", 10) == 0) { + proctype = IRAFKS_DAEMON; + ip += 10; + } else { + proctype = IRAFKS_CLIENT; + cmd = NULL; + for (op=host; *ip != EOS; ip++) + if (*ip == FNNODE_CHAR) { + *op = EOS; + cmd = ++ip; + break; + } else + *op++ = *ip; + if (cmd == NULL) { + *chan = ERR; + goto done; + } + } + + + /* Debug output. If debug_ks is set (e.g. with adb) but no filename + * is given, debug output goes to stderr. + */ + if (debug_ks && !debug_fp) { + if (debug_file[0] != EOS) { + if ((debug_fp = fopen (debug_file, "a")) == NULL) + debug_fp = stderr; + } else + debug_fp = stderr; + } + + + /* Begin debug message log. */ + dbgmsg ("---------------------------------------------------------\n"); + dbgmsg1 ("zopnks (`%s')\n", server); + dbgmsg4 ("kstype=%d, prot=%d, host=`%s', cmd=`%s')\n", + proctype, ks.protocol, host, ip); + parent = getpid(); + + /* + * SERVER side code. + * --------------------- + */ + + if (proctype == IRAFKS_DIRECT) { + /* Kernel server was called by rexec and is already set up to + * communicate on the standard streams. + */ + *chan = 0; + goto done; + + } else if (proctype == IRAFKS_CALLBACK) { + /* The kernel server was called by rexec using the rexec-callback + * protocol. Connect to the client specified socket. + */ + char *client_host; + int port, s; + + /* Parse "port@client_host". */ + for (port=0; isdigit(*ip); ip++) + port = port * 10 + (*ip - '0'); + client_host = ip + 1; + + dbgmsg2 ("S:callback client %s on port %d\n", client_host, port); + if ((s = ks_socket (client_host, NULL, port, "connect")) < 0) + *chan = ERR; + else + *chan = s; + goto done; + + } else if (proctype == IRAFKS_DAEMON) { + /* Handle the special case of spawning the in.irafksd daemon. This + * happens when the zfioks driver is called by the irafks.e process + * which is started up on a remote server node by the networking + * system. (via either rsh or rexec). To start the in.irafksd + * daemon we fork the irafks.e and exit the parent so that the + * rsh|remsh or rexec completes. The daemon will run indefinitely + * or until the specified timeout interval passes without receiving + * any requests. The daemon listens for connections on a global + * (per-user) socket; when a connection is made, the client passes + * in a socket address and authentication code, and provided the + * request is authenticated an irafks server is forked and + * connected to the client socket. The irafks server then runs + * indefinitely, receiving and processing iraf kernel RPCs from the + * client until commanded to shutdown, the connection is broken, or + * an i/o error occurs. + */ + struct timeval timeout; + int check, fromlen, req_port; + int nsec, fd, sig; +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + fd_set rfd; +#else + int rfd; +#endif + int once_only = 0; + int detached = 0; + int unauth = 0; + int status = 0; + + /* Get the server parameters. These may be passed either via + * the client in the datastream, or on the command line. The + * latter mode allows the daemon to be run standalone on a server + * node, without the need for a rsh call from a client to start + * the daemon. + */ + while (*ip && isspace (*ip)) + ip++; + if (isdigit (*ip)) { + /* Server parameters were passed on the command line. */ + char *np; + + detached++; + port = req_port = strtol (ip, &np, 10); + if (np == NULL) { + status = 1; + goto d_err; + } else + ip = np; + auth = strtol (ip, &np, 10); + if (np == NULL) { + status = 2; + goto d_err; + } else + ip = np; + nsec = strtol (ip, &np, 10); + if (np == NULL) { + nsec = 0; /* no timeout */ + } else + ip = np; + dbgmsg3 ("S:detached in.irafksd, port=%d, auth=%d, timeout=%d\n", + port, auth, nsec); + + } else { + /* Get client data from the client datastream. */ + if ((req_port = port = ks_geti(0)) < 0) + { status = 1; goto d_err; } + if ((auth = ks_geti(0)) < 0) + { status = 2; goto d_err; } + if ((nsec = ks_geti(0)) < 0) + { status = 3; goto d_err; } + dbgmsg2 ("S:client spawned in.irafksd, port=%d, timeout=%d\n", + port, nsec); + } + + /* Attempt to bind the in.irafksd server socket to the client + * specified port. If this fails a free socket is dynamically + * allocated. If no port is specified (e.g. port=0) the port + * will always be dynamically allocated and a rsh call will be + * employed for every server connection. + */ + if (port <= IPPORT_RESERVED) + port = IPPORT_USERRESERVED - 1; + s = ks_getresvport (&port); + if (s < 0 || listen(s,MAXCONN) < 0) { + status = 4; + goto d_err; + } else if (port != req_port) { + if (detached) { + status = 4; + goto d_err; + } + once_only++; + } + + /* Fork daemon process and return if parent, exiting rsh. */ + dbgmsg2 ("S:fork in.irafksd, port=%d, timeout=%d\n", port, nsec); + pid = fork(); + if (pid < 0) { + status = 4; + goto d_err; + } + + if (pid) { +d_err: dbgmsg1 ("S:in.irafksd parent exit, status=%d\n", status); + if (!detached) { + ks_puti (1, status); + ks_puti (1, port); + } + exit(0); + } + + /* + * What follows is the code for the daemon process. Close the + * stdio streams, which we won't need any more. Create a socket + * and bind it to the given port. Sit in a loop until timeout, + * listening for client connection requests and forking the irafks + * server in response to each such request. + */ + + dbgmsg3 ("S:in.irafksd started, pid=%d ppid=%d\n", + getpid(), getppid()); + old_sigcld = (SIGFUNC) signal (SIGCHLD, (SIGFUNC)ks_reaper); + + /* Reset standard streams to console to record error messages. */ + fd = open ("/dev/null", 0); close(0); dup(fd); close(fd); + fd = open ("/dev/console", 1); close(1); dup(fd); close(fd); + fd = open ("/dev/console", 2); close(2); dup(fd); close(fd); + + /* Loop forever or until the idle timeout expires, waiting for a + * client connection. + */ + for (;;) { + timeout.tv_sec = nsec; + timeout.tv_usec = 0; +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + FD_ZERO(&rfd); + FD_SET(s,&rfd); +#else + rfd = (1 << s); +#endif + status = 0; + + /* Wait until either we get a connection, or a previously + * started server exits. + */ + jmpset++; + if ((sig = setjmp(jmpbuf))) { + if (sig == SIGCHLD) { + dbgmsg ("S:in.irafksd sigchld return\n"); + while (waitpid ((pid_t)0, (int *)0, WNOHANG) > 0) + ; + } else + exit (0); + } + if (select (SELWIDTH,&rfd,NULL,NULL, nsec ? &timeout : 0) <= 0) + exit (0); + + /* Accept the connection. */ + if ((fd = accept (s, (struct sockaddr *)0, + (socklen_t *)0)) < 0) { + fprintf (stderr, + "S:in.irafksd: accept on port %d failed\n", port); + exit (2); + } else + dbgmsg ("S:in.irafksd: connection established\n"); + + /* Find out where the connection is coming from. */ + fromlen = sizeof (from); +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + if (getpeername (fd, (struct sockaddr *)&from, + (socklen_t *)&fromlen) < 0) { +#else + if (getpeername (fd, &from, (socklen_t *)&fromlen) < 0) { +#endif + fprintf (stderr, "in.irafksd: getpeername failed\n"); + exit (3); + } + + /* Connection established. Get client data. */ + if ((s_port = ks_geti(fd)) < 0 || (check = ks_geti(fd)) < 0) { + fprintf (stderr, "in.irafksd: protocol error\n"); + status = 1; + goto s_err; + } + + /* Verify authorization. Shutdown if repeated unauthorized + * requests occur. + */ + if (auth && check != auth) { + if (unauth++ > MAX_UNAUTH) { + fprintf (stderr, + "in.irafksd: unauthorized connection attempt\n"); + exit (4); + } + status = UNAUTH; + goto s_err; + } + + /* Connection authorized if this message is output. */ + dbgmsg1 ("S:in.irafksd: client port = %d\n", s_port); + + /* Fork the iraf kernel server. */ + pid = fork(); + if (pid < 0) { + fprintf (stderr, "in.irafksd: process creation failed\n"); + status = 3; + goto s_err; + } + + if (pid) { /** parent **/ +s_err: dbgmsg1 ("S:in.irafksd fork complete, status=%d\n", + status); + ks_puti (fd, status); + close (fd); + if (once_only) + exit (0); + /* otherwise loop indefinitely */ + + } else { /** child **/ + /* Set up iraf kernel server. */ + u_long n_addr, addr; + unsigned char *ap = (unsigned char *)&n_addr; + + dbgmsg2 ("S:irafks server started, pid=%d ppid=%d\n", + getpid(), getppid()); + signal (SIGCHLD, old_sigcld); + /* + old_sigcld = (SIGFUNC) signal (SIGCHLD, (SIGFUNC)ks_reaper); + */ + close (fd); close (s); + + n_addr = from.sin_addr.s_addr; + addr = ntohl(n_addr); + sprintf (obuf, "%d.%d.%d.%d", ap[0],ap[1],ap[2],ap[3]); + dbgmsg2 ("S:client address=%s port=%d\n", obuf, s_port); + + if ((s = ks_socket (NULL, addr, s_port, "connect")) < 0) { + dbgmsg1 ("S:irafks connect to port %d failed\n", s_port); + fprintf (stderr, "irafks: cannot connect to client\n"); + exit (1); + } else + dbgmsg1 ("S:irafks connected on port %d\n", s_port); + + *chan = s; + goto done; + } + } + } /* else fall through to DAEMON_CLIENT code */ + + /* + * CLIENT side code. + * --------------------- + */ + + /* Attempt to fire up the kernel server process. Get login name + * and password for the named host. If a password is given attempt + * to connect via the rexec protocol, otherwise attempt the connection + * via the rsh/in.irafksd protocol. + */ + if (ks_getlogin (host, username, password, &ks) == ERR) { + *chan = ERR; + + } else if (ks.protocol == C_REXEC) { + /* Use rexec protocol. We start the remote kernel server with + * rexec and communicate via the socket returned by rexec. + */ + hostp = host; + dbgmsg2 ("C:rexec for host=%s, user=%s\n", host, username); +#ifdef USE_RCMD + *chan = rcmd (&hostp, ks_rexecport(), + getlogin(), username, cmd, 0); +#else + *chan = rexec (&hostp, ks_rexecport(), username, password, cmd, 0); +#endif + + } else if (ks.protocol == C_REXEC_CALLBACK) { + /* Use rexec-callback protocol. In this case the remote kernel + * server is started with rexec, but we have the remote server + * call us back on a private socket. This guarantees a direct + * socket connection for use in cases where the standard i/o + * streams set up for rexec do not provide a direct connection. + */ + char localhost[SZ_FNAME]; + char callback_cmd[SZ_LINE]; + struct hostent *hp; + int tfd=0, fd=0, ss=0; + + /* Get reserved port for direct communications link. */ + s_port = IPPORT_USERRESERVED - 1; + s = ks_getresvport (&s_port); + if (s < 0) + goto r_err; + + /* Ready to receive callback from server. */ + if (listen (s, MAXCONN) < 0) + goto r_err; + + /* Compose rexec-callback command: "cmd port@client-host". */ + if (gethostname (localhost, SZ_FNAME) < 0) + goto r_err; + if ((hp = gethostbyname (localhost)) == NULL) + goto r_err; + sprintf (callback_cmd, "%s callback %d@%s", + cmd, s_port, hp->h_name); + dbgmsg2 ("rexec to host %s: %s\n", host, callback_cmd); + + hostp = host; + dbgmsg3 ("rexec for host=%s, user=%s, using client port %d\n", + host, username, s_port); +#ifdef USE_RCMD + ss = rcmd (&hostp, ks_rexecport(), + getlogin(), username, callback_cmd, 0); +#else + ss = rexec (&hostp, + ks_rexecport(), username, password, callback_cmd, 0); +#endif + + /* Wait for the server to call us back. */ + dbgmsg1 ("waiting for connection on port %d\n", s_port); + if ((tfd = accept (s, (struct sockaddr *)0, (socklen_t *)0)) < 0) { +r_err: dbgmsg ("rexec-callback connect failed\n"); + close(s); close(ss); + *chan = ERR; + } else { + close(s); fd = dup(tfd); close(tfd); + dbgmsg1 ("connected to irafks server on fd=%d\n", fd); + *chan = fd; + + /* Mark the rexec channel for deletion at close time when + * the i/o socket is closed. + */ + for (i=0; i < MAXOFILES; i++) + if (!ks_pchan[i]) { + ks_pchan[i] = fd; + ks_achan[i] = ss; + break; + } + } + + } else { + /* Use the default protocol, which avoids passwords. This uses + * rsh to start up (once) the iraf networking daemon in.irafksd + * on the remote node, and thereafter merely places requests to + * in.irafksd to spawn each instance of the irafks.e server. + */ + char command[SZ_LINE], *nretryp; + int pin[2], pout[2]; + int status = 0; + int ntries = 0, nretries = 0; + char *password; + int fd, tfd; + int t=0, s=0; + + /* Get reserved port for client. */ + s_port = IPPORT_USERRESERVED - 1; + s = ks_getresvport (&s_port); + if (s < 0) { + status |= 01; + goto c_err; + } + dbgmsg2 ("C:connect to in.irafksd host=%s client port=%d\n", + host, s_port); + + /* Ready to receive callback from server. */ + if (listen (s, MAXCONN) < 0) { + status |= 02; + goto c_err; + } + + /* Check for the number of connection attempts. */ + if ((nretryp = getenv(KS_RETRY))) + nretries = atoi(nretryp); + + /* in.irafkd port. */ + port = ks.port; +again: + /* Connect to in.irafksd daemon on server system and send request + * to start up a new irafks daemon on the port just created. If + * the connection fails, fork an rsh and start up the in.irafksd. + */ + if (!port || (t = ks_socket (host, NULL, port, "connect")) < 0) { + dbgmsg ("C:no server, fork rsh to start in.irafksd\n"); + + if (pipe(pin) < 0 || pipe(pout) < 0) { + status |= 04; + goto c_err; + } + pid = fork(); + if (pid < 0) { + status |= 010; + goto c_err; + } + + if (pid) { + /* Pass target port and authorization code to in.irafksd. + * Server returns the actual port assigned. + */ + close (pin[1]); + close (pout[0]); +retry: + dbgmsg2 ("C:send port=%d, timeout=%d to irafks.e\n", + ks.port, ks.timeout); + if (ks_puti (pout[1], port) <= 0) + status |= 0020; + if (ks_puti (pout[1], ks.auth) <= 0) + status |= 0040; + if (ks_puti (pout[1], ks.timeout) <= 0) + status |= 0100; + if (ks_geti(pin[0])) + status |= 0200; + + port = ks_geti (pin[0]); + dbgmsg1 ("C:irafks.e returns port=%d\n", port); + + /* Wait for the rsh connection to shut down. */ + while (read (pin[0], obuf, SZ_LINE) > 0) + ; + wait (NULL); + close (pin[0]); + if (pout[1] != pin[0]) + close (pout[1]); + + /* If the rsh succeeded the in.irafksd daemon should be + * running now. Attempt again to connect. If this fails, + * most likely the rsh failed. Try to use rexecd to start + * the daemon. + */ + if (status || + (t = ks_socket (host, NULL, port, "connect")) < 0) { + + /* The KS_RETRY environment variable may be set to + * the number of times we wish to try to reconnect. + * We'll sleep for 1-second between attempts before + * giving up. + */ + if (getenv (KS_RETRY) && nretries--) { + sleep (1); + goto again; + } + + /* If KS_NO_RETRY is set then we won't try at all + * with an rexec. These two variables give us a + * chance to retry using the rsh/KSRSH protocol some + * number of times before failing, and optionally + * trying with a different (rexec) before quitting + * entirely. On most recent systems the rexec port + * isn't enabled anyway. + */ + if (getenv (KS_NO_RETRY) || ntries++) { + status |= 0400; + goto c_err; + } + + dbgmsg ("C:rsh failed - try rexec\n"); + if (!(password = ks_getpass (username, host))) + { status |= 01000; goto c_err; } + + sprintf (command, "%s in.irafksd", cmd); + dbgmsg3 ("C:rexec %s@%s: %s\n", username, host, command); + + hostp = host; +#ifdef USE_RCMD + fd = rcmd (&hostp, ks_rexecport(), + getlogin(), username, command, 0); +#else + fd = rexec (&hostp, ks_rexecport(), + username, password, command, NULL); +#endif + + if (fd < 0) { + status |= 02000; + goto c_err; + } else { + status = 0; + port = ks.port; + pin[0] = pout[1] = fd; + goto retry; + } + } + + } else { + /* Call rsh to start up in.irafksd on server node. + */ + char *s, *rshcmd; + + close (pin[0]); close (pout[1]); + close (0); dup (pout[0]); close (pout[0]); + close (1); dup (pin[1]); close (pin[1]); + + rshcmd = (s = getenv(KSRSH)) ? s : RSH; + + dbgmsg3 ("C:exec rsh %s -l %s `%s' in.irafksd\n", + host, username, cmd); + execlp (rshcmd, rshcmd, + host, "-l", username, cmd, "in.irafksd", NULL); + exit (1); + } + } + + /* Send command to start up irafks server. This consists of the + * reserved port for the server connection followed by the + * authorization code. The in.irafksd daemon returns a status + * byte which will be zero if the operation is successful. + */ + dbgmsg1 ("C:request irafks server for client port %d\n", s_port); + + if (ks_puti (t, s_port) <= 0) + { status |= 004000; goto c_err; } + if (ks_puti (t, ks.auth) <= 0) + { status |= 010000; goto c_err; } + + /* Check for an authorization failure and connect on a dynamically + * allocated port if this happens (in.irafksd will allocate the + * port). An authorization failure does not necessarily indicate + * an unauthorized connection attempt; it may mean instead that + * the user has not set up the same authorization code on two + * different nodes and iraf clients on both nodes, with different + * authorization codes, are trying to access the same server. + * If this happens the first client will get the in.irafksd daemon + * and the other client will have to do an rsh connect each time. + */ + if ((status = ks_geti(t))) { + if (port && status == UNAUTH) { + close(t); + port = 0; + dbgmsg ("C:authorization failed, retry with port=0\n"); + status = 0; + goto again; + } else { + status |= 020000; + goto c_err; + } + } + + /* Wait for the server to call us back. */ + if ((tfd = accept (s, (struct sockaddr *)0, (socklen_t *)0)) < 0) { +c_err: dbgmsg1 ("C:zfioks client status=%o\n", status); + close(t); close(s); + kill (pid, SIGTERM); + *chan = ERR; + } else { + close(t); close(s); fd = dup(tfd); close(tfd); + dbgmsg1 ("C:connected to irafks server on fd=%d\n", fd); + *chan = fd; + } + } + +done: + jmpset = 0; + if (*chan > 0) { + if (*chan < MAXOFILES) + zfd[*chan].nbytes = 0; + else { + close (*chan); + *chan = ERR; + } + } + + dbgmsg1 ("zopnks returns status=%d\n", *chan); + + return (*chan); +} + + +/* ZCLSKS -- Close a kernel server connection. + */ +int +ZCLSKS ( + XINT *chan, /* socket to kernel server */ + XINT *status /* receives close status */ +) +{ + int i; + + /* Close the primary channel. */ + *status = close (*chan); + + /* Close any alternate channels associated with the primary. */ + for (i=0; i < MAXOFILES; i++) { + if (ks_pchan[i] == *chan) { + close (ks_achan[i]); + ks_pchan[i] = 0; + } + } + + dbgmsg2 ("server [%d] terminated, status = %d\n", *chan, *status); + + return (*status); +} + + +/* ZARDKS -- Read from the kernel server channel. No attempt is made to + * impose a record structure upon the channel, as is the case with IPC. + * In UNIX the channel is stream oriented and it is up to the caller to + * unblock records from the input stream. Data blocks are assumed to be + * preceded by headers telling how much data to read, hence we read from + * the channel until the specified number of bytes have been read or ERR + * or EOF is seen on the stream. + */ +int +ZARDKS ( + XINT *chan, /* kernel server channel (socket) */ + XCHAR *buf, /* output buffer */ + XINT *totbytes, /* total number of bytes to read */ + XLONG *loffset /* not used */ +) +{ +#ifdef ANSI + volatile char *op; + volatile int fd, nbytes; +#else + char *op; + int fd, nbytes; +#endif + SIGFUNC sigint, sigterm; + int status = ERR; + + fd = *chan; + op = (char *)buf; + zfd[fd].nbytes = nbytes = *totbytes; + if (debug_ks > 1) + dbgmsg2 ("initiate read of %d bytes from KS channel %d\n", + nbytes, fd); + + /* Now read exactly nbytes of data from channel into user buffer. + * Return actual byte count if EOF is seen. If ERR is seen return + * ERR. If necessary multiple read requests are issued to read the + * entire record. Reads are interruptable but the interrupt is caught + * and returned as a read error on the server channel. + */ + sigint = (SIGFUNC) signal (SIGINT, (SIGFUNC)ks_onsig); + sigterm = (SIGFUNC) signal (SIGTERM, (SIGFUNC)ks_onsig); + + while (nbytes > 0) { + jmpset++; + if (setjmp (jmpbuf) == 0) + status = read (fd, op, nbytes); + else + status = ERR; + + switch (status) { + case 0: + zfd[fd].nbytes -= nbytes; + return (XERR); + case ERR: + zfd[fd].nbytes = ERR; + return (XERR); + default: + nbytes -= status; + op += status; + break; + } + } + + jmpset = 0; + signal (SIGINT, sigint); + signal (SIGTERM, sigterm); + if (debug_ks > 1) + dbgmsg2 ("read %d bytes from KS channel %d:\n", op-(char *)buf, fd); + + return (status); +} + + +/* ZAWRKS -- Write to a kernel server channel. + */ +int +ZAWRKS ( + XINT *chan, /* kernel server channel (socket) */ + XCHAR *buf, /* output buffer */ + XINT *totbytes, /* number of bytes to write */ + XLONG *loffset /* not used */ +) +{ + SIGFUNC sigint, sigterm, sigpipe; +#ifdef ANSI + volatile int fd, nbytes; + volatile int ofd; +#else + int fd, nbytes; + int ofd; +#endif + + /* If chan=0 (the process standard input) then we really want to + * write to channel 1, the standard output. + */ + if ((ofd = fd = *chan) == 0) + ofd = 1; + + zfd[fd].nbytes = nbytes = *totbytes; + if (debug_ks > 1) + dbgmsg2 ("initiate write of %d bytes to KS channel %d\n", + nbytes, ofd); + + /* Write exactly nbytes of data to the channel from user buffer to + * the channel. Block interrupt during the write to avoid corrupting + * the data stream protocol if the user interrupts the client task. + * Trap SIGPIPE and return it as a write error on the channel instead. + * Likewise, turn an interrupt into a write error on the channel. + */ + sigint = (SIGFUNC) signal (SIGINT, (SIGFUNC)ks_onsig); + sigterm = (SIGFUNC) signal (SIGTERM, (SIGFUNC)ks_onsig); + sigpipe = (SIGFUNC) signal (SIGPIPE, (SIGFUNC)ks_onsig); + recursion = 0; + + jmpset++; + if (setjmp (jmpbuf) == 0) + zfd[fd].nbytes = write (ofd, (char *)buf, nbytes); + else + zfd[fd].nbytes = ERR; + + jmpset = 0; + signal (SIGINT, sigint); + signal (SIGTERM, sigterm); + signal (SIGPIPE, sigpipe); + if (debug_ks > 1) + dbgmsg2 ("wrote %d bytes to KS channel %d:\n", zfd[fd].nbytes, ofd); + + return (XOK); +} + + +/* KS_ONSIG -- Catch a signal. + */ +static void +ks_onsig ( + int sig, /* signal which was trapped */ + int *arg1, /* not used */ + int *arg2 /* not used */ +) +{ + /* If we get a SIGPIPE writing to a server the server has probably + * died. Make it look like there was an i/o error on the channel. + */ + if (sig == SIGPIPE && recursion++ == 0) + fputs ("kernel server process has died\n", stderr); + + if (jmpset) + longjmp (jmpbuf, sig); +} + + +/* KS_REAPER -- Catch a SIGCHLD signal and reap all children. + */ +static void +ks_reaper ( + int sig, /* signal which was trapped */ + int *arg1, /* not used */ + int *arg2 /* not used */ +) +{ + int status=0, pid=0; + + while ((pid = waitpid ((pid_t)0, (int *) &status, WNOHANG)) > 0) + dbgmsg2 ("ks_reaper -- pid=%d, status=%d\n", pid, status); + + if (jmpset) + longjmp (jmpbuf, sig); +} + + +/* ZAWTKS -- Wait for i/o to a KS channel. Since UNIX i/o is not asynchronous + * we do not really wait, rather we return the status value (byte count) from + * the last read or write to the channel. + */ +int +ZAWTKS (XINT *chan, XINT *status) +{ + if ((*status = zfd[*chan].nbytes) == ERR) + *status = XERR; + + return (*status); +} + + +/* ZSTTKS -- Get binary file status for an KS channel. A KS channel is a + * streaming binary file. + */ +int +ZSTTKS ( + XINT *chan, /* not used; all KS channels have same status */ + XINT *param, + XLONG *lvalue +) +{ + switch (*param) { + case FSTT_BLKSIZE: + case FSTT_FILSIZE: + *lvalue = 0; + break; + case FSTT_OPTBUFSIZE: + *lvalue = KS_OPTBUFSIZE; + break; + case FSTT_MAXBUFSIZE: + *lvalue = KS_MAXBUFSIZE; + break; + default: + *lvalue = XERR; + } + + return (XOK); +} + + +/* + * Internal routines. + * ------------------- + */ + +/* KS_SOCKET -- Get a socket configured for the given host and port. Either + * bind the socket to the port and make it ready for connections, or connect + * to the remote socket at the given address. + */ +static int +ks_socket (host, addr, port, mode) +char *host; +u_long addr; +int port; +char *mode; +{ + struct sockaddr_in sockaddr; + struct hostent *hp; + int s; + + /* Create socket. */ + if ((s = socket (AF_INET, SOCK_STREAM, 0)) < 0) + return (ERR); + + /* Set socket address. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = htons((short)port); + + /* Get address of server host. */ + if (addr) { + sockaddr.sin_addr.s_addr = htonl((long)addr); + } else if (*host) { + if ((hp = gethostbyname (host)) == NULL) + goto failed; + bcopy((char *)hp->h_addr,(char *)&sockaddr.sin_addr, hp->h_length); + } else + sockaddr.sin_addr.s_addr = INADDR_ANY; + + /* Either bind and listen for connnections, or connect to a remote + * socket. + */ + if (strncmp (mode, "listen", 1) == 0) { + if (bind (s, (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) + goto failed; + if (listen (s, MAXCONN) < 0) + goto failed; + } else if (strncmp (mode, "connect", 1) == 0) { + if (connect(s,(struct sockaddr *)&sockaddr,sizeof(sockaddr)) < 0) + goto failed; + } else + goto failed; + + return (s); + +failed: + dbgmsg2 ("ks_socket: errno=%d (%s)\n", errno, strerror(errno)); + close (s); + return (ERR); +} + + +/* KS_GETRESVPORT -- Open a socket and attempt to bind it to the given port. + * Locate a usable port if this fails. The actual port is returned in the + * output argument. + */ +static int +ks_getresvport (alport) +int *alport; +{ + struct sockaddr_in sin; + int s; + + sin.sin_family = AF_INET; + sin.sin_addr.s_addr = INADDR_ANY; + s = socket (AF_INET, SOCK_STREAM, 0); + if (s < 0) + return (-1); + + for (;;) { + sin.sin_port = htons((u_short)*alport); +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + if (bind(s, (struct sockaddr *)&sin, sizeof(sin)) >= 0) { +#else + if (bind(s, (caddr_t)&sin, sizeof (sin)) >= 0) { +#endif + return (s); + } + if (errno != EADDRINUSE) { + (void) close(s); + return (-1); + } + dbgmsg4 ("ks_getresvport: decr errno=%d (%s) alport=%d -> %d\n", + errno, strerror(errno), *alport, *alport - 1); + (*alport)--; + if (*alport == IPPORT_RESERVED) { + (void) close(s); + errno = EAGAIN; /* close */ + return (-1); + } + } +} + + +/* KS_REXECPORT -- Return the port for the rexec system service. + */ +static int +ks_rexecport() +{ + register struct servent *sv; + static int port = 0; + + if (port) + return (port); + + if ((sv = getservbyname ("exec", "tcp"))) + return (port = sv->s_port); + else + return (port = REXEC_PORT); +} + + +/* KS_PUTI -- Write an integer value to the output stream as a null terminated + * ascii string. + */ +static int +ks_puti (fd, ival) +int fd; +int ival; +{ + char obuf[SZ_FNAME]; + + sprintf (obuf, "%d", ival); + return (write (fd, obuf, strlen(obuf)+1)); +} + + +/* KS_GETI -- Read a positive integer value, passed as a null terminated ascii + * string, base decimal, from the given stream. + */ +static int +ks_geti (fd) +int fd; +{ + register int value = 0; + struct timeval timeout; + int stat, sig; +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + fd_set rfd; +#else + int rfd; +#endif + char ch; + + jmpset++; + if ((sig = setjmp(jmpbuf))) + if (sig == SIGCHLD) + waitpid ((pid_t)0, (int *)0, WNOHANG); + + timeout.tv_sec = PRO_TIMEOUT; + timeout.tv_usec = 0; +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + FD_ZERO(&rfd); + FD_SET(fd,&rfd); +#else + rfd = (1 << fd); +#endif + + /* Read and accumulate a decimal integer. Timeout if the client + * does not respond within a reasonable period. + */ + do { + if (select (SELWIDTH, &rfd, NULL, NULL, &timeout) <= 0) { + dbgmsg ("ks_geti: timeout on read\n"); + jmpset = 0; + return (ERR); + } + + if ((stat = read (fd, &ch, 1)) <= 0) { + dbgmsg3 ("ks_geti: read status=%d, errno=%d (%s)\n", + stat, errno, strerror(errno)); + jmpset = 0; + return (ERR); + } + + if (ch) { + if (isdigit(ch)) + value = value * 10 + (ch - '0'); + else { + dbgmsg1 ("ks_geti: read char=%o\n", ch); + jmpset = 0; + return (ERR); + } + } + } while (ch); + + jmpset = 0; + return (value); +} + + +/* KS_GETS -- Read a null terminated ascii string. +static int +ks_gets (fd, outstr) +int fd; +char *outstr; +{ + register char *op = outstr; + int stat; + + do { + if ((stat = read (fd, op, 1)) <= 0) { + dbgmsg3 ("ks_gets: read status=%d, errno=%d (%s)\n", + stat, errno, strerror(errno)); + return (ERR); + } + } while (*op++); + + return (op - outstr - 1); +} + */ + + +/* KS_MSG -- Print debugging messages. + */ +static void dbgsp (pid) +int pid; +{ + int i, nsp = ((parent > 0) ? (pid - parent) : 0); + for (i=0; i < nsp; i++) + fprintf (debug_fp, " "); +} + +static void +dbgmsg (msg) +char *msg; +{ + int pid; + if (debug_ks) { + fprintf (debug_fp, "[%5d] ", (pid = getpid())); dbgsp(pid); + fprintf (debug_fp, "%s", msg); + } +} +static void +dbgmsgs (fmt, arg) +char *fmt; +char *arg; +{ + int pid; + if (debug_ks) { + fprintf (debug_fp, "[%5d] ", (pid = getpid())); dbgsp(pid); + fprintf (debug_fp, fmt, arg); + fflush (debug_fp); + } +} +static void +dbgmsg1 (fmt, arg) +char *fmt; +int arg; +{ + int pid; + if (debug_ks) { + fprintf (debug_fp, "[%5d] ", (pid = getpid())); dbgsp(pid); + fprintf (debug_fp, fmt, arg); + fflush (debug_fp); + } +} +static void +dbgmsg2 (fmt, arg1, arg2) +char *fmt; +int arg1, arg2; +{ + int pid; + if (debug_ks) { + fprintf (debug_fp, "[%5d] ", (pid = getpid())); dbgsp(pid); + fprintf (debug_fp, fmt, arg1, arg2); + fflush (debug_fp); + } +} +static void +dbgmsg3 (fmt, arg1, arg2, arg3) +char *fmt; +int arg1, arg2, arg3; +{ + int pid; + if (debug_ks) { + fprintf (debug_fp, "[%5d] ", (pid = getpid())); dbgsp(pid); + fprintf (debug_fp, fmt, arg1, arg2, arg3); + fflush (debug_fp); + } +} +static void +dbgmsg4 (fmt, arg1, arg2, arg3, arg4) +char *fmt; +int arg1, arg2, arg3, arg4; +{ + int pid; + if (debug_ks) { + fprintf (debug_fp, "[%5d] ", (pid = getpid())); dbgsp(pid); + fprintf (debug_fp, fmt, arg1, arg2, arg3, arg4); + fflush (debug_fp); + } +} + + +/* + * Stuff for processing the irafhosts file. + * ---------------------------------------- + */ + +#define MAX_HEADERLINES 128 +#define MAX_NODES 256 +#define SZ_SBUF 4096 +#define DEFAULT (-1) +#define KSAUTH "KSAUTH" + +struct irafhosts { + int port; + int auth; + int hiport; + int timeout; + int nheaderlines; + int nparams; + int mode; + char *header[MAX_HEADERLINES]; + int nnodes; + struct nodelist { + char *name; + char *login; + char *password; + int port; + int auth; + int hiport; + int timeout; + int protocol; + } node[MAX_NODES]; + int sbuflen; + char sbuf[SZ_SBUF]; +}; + + +/* KS_GETLOGIN -- Read the irafhosts file to determine how to connect to + * the indicated host. If the user has a .irafhosts file read that, otherwise + * read the system default irafhosts file in iraf$dev. Fill in or correct + * any networking parameters as necessary. If the rsh protocol is enabled + * and the user does not have a .irafhosts file, create one for them. If + * the user has a .irafhosts file but a unique authorization code has not + * yet been assigned, assign one and write a new file. Ensure that the + * file has read-only access privileges. + */ +static int +ks_getlogin ( + char *hostname, /* node we wish a login for */ + char *loginname, /* receives the login name */ + char *password, /* receives the login password */ + struct ksparam *ks /* networking parameters */ +) +{ + register struct irafhosts *hp; + register int i; + char userfile[SZ_PATHNAME]; + char sysfile[SZ_PATHNAME]; + char fname[SZ_PATHNAME]; + char username[SZ_NAME]; + char *namep, *authp; + struct nodelist *np; + int update = 0; + int auth; + + /* Get path to user irafhosts file. */ + if (ks_username (IRAFHOSTS, userfile, username) == NULL) + return (ERR); + + /* Read user irafhosts file if there is one. Check for an old-style + * irafhosts file, and read the system file instead if the user file + * is the old obsolete version. + */ + if ((hp = ks_rhosts (userfile))) { + /* Old style irafhosts file? */ + if (hp->nparams == 0) { + /* Attempt to preserve old file with .OLD extension. */ + strcpy (fname, username); + strcat (fname, ".OLD"); + unlink (fname); + rename (username, fname); + + /* Read system file instead. */ + free ((char *)hp); + if (ks_sysname (HOSTLOGIN, sysfile) == NULL) + return (ERR); + if ((hp = ks_rhosts (sysfile)) == NULL) + return (ERR); + update++; + } + } else { + /* Use system default irafhosts. */ + if (ks_sysname (HOSTLOGIN, sysfile) == NULL) + return (ERR); + if ((hp = ks_rhosts (sysfile)) == NULL) + return (ERR); + update++; + } + + /* Search the node list for an entry for the named host. + */ + for (i=0, np=NULL; i < hp->nnodes; i++) { + namep = hp->node[i].name; + if (strcmp (hostname, namep) == 0 || strcmp (namep, "*") == 0) { + np = &hp->node[i]; + break; + } + } + + /* Get the login name. If this is "disable" networking is disabled + * for the given node entry. + */ + if (np->login[0] && strcmp(np->login,"disable") == 0) { + free ((char *)hp); + return (ERR); + } else if (np->login[0] && strcmp(np->login,USER) != 0) { + strcpy (loginname, np->login); + } else + strcpy (loginname, username); + + /* Get the password. */ + if (np->password[0]) { + if (strcmp (np->password, USER) == 0) { + if (ks->protocol == C_RSH) + password[0] = EOS; + else + goto query; /* need a valid password for rexec */ + } else if (strcmp (np->password, "?") == 0) { +query: if ((namep = ks_getpass (loginname, hostname))) + strcpy (password, namep); + else + password[0] = EOS; + } else + strcpy (password, np->password); + } else + password[0] = EOS; + + /* + * Set up ksparam structure. Check to see if any of the irafhosts + * parameter values are out of range; if so, set the default values, + * and mark the file for updating. + * + * NOTE -- If possible, the user should have the same port number and + * authorization code (e.g., same .irafhosts file) on all local nodes. + * All we can do here is manage the file on the local node. It is up + * to the user to make all the files the same. + */ + + /* The port number for the in.irafksd daemon should be unique for + * every user, as well as unique in the sense that no other network + * service uses the port. This is impossible to guarantee, but we + * can come close by choosing port numbers in the high range for a + * short integer, using the user's UID to attempt to give each user + * a unique port. + */ + if (hp->hiport == DEFAULT) { + ks->hiport = DEF_HIPORT; + } else if (hp->hiport > MAX_HIPORT || hp->hiport < MIN_HIPORT) { + ks->hiport = DEF_HIPORT; + hp->hiport = DEFAULT; + update++; + } else + ks->hiport = hp->hiport; + + if (hp->port == 0) + ks->port = 0; + else if (hp->port > MAX_HIPORT || hp->port < IPPORT_RESERVED) + ks->port = ks->hiport - (getuid() % 10000); + else + ks->port = hp->port; + + /* Every user should also have a unique authorization code. It should + * be next to impossible to predict apriori, so that user A cannot + * predict user B's authorization code. The number is arbitary, + * and can be changed by the user by editing the irafhosts file. + * Any heuristic which produces a reasonable unique and unpredictable + * number will do. We use the system clock time and a snapshot of + * the machine registers as saved in a setjmp. Given that any iraf + * program can cause a network request which results in generation + * of an authorization code, and the point at which this request + * occurs during the execution of a task is arbtrary, the register + * set should be pretty unpredictable. + */ + if (hp->auth == DEFAULT) { + jmp_buf jmpbuf; + int value; + + setjmp (jmpbuf); + value = time(NULL); + for (i=0; i < sizeof(jmpbuf)/sizeof(int); i++) + value ^= ((int *)jmpbuf)[i]; + value = (value << 13) / 1000 * 1000; + if (value < 0) + value = -value; + value += (getuid() % 1000); + ks->auth = hp->auth = value; + update++; + } else + ks->auth = hp->auth; + + /* If KSAUTH is defined in the user environment this overrides the + * value given in the .irafhosts file. This allows authorization + * codes to be dynamically allocated at login time if someone doesn't + * want to take the risk of having their authorization code in the + * irafhosts file. + */ + if ((authp = getenv(KSAUTH)) && (auth = atoi(authp))) + ks->auth = auth; + + /* The timeout value is the time in seconds after which the in.irafksd + * daemon will shutdown if idle. + */ + if (hp->timeout == DEFAULT) { + ks->timeout = DEF_TIMEOUT; + } else if (hp->timeout < MIN_TIMEOUT) { + ks->timeout = DEF_TIMEOUT; + hp->timeout = DEFAULT; + update++; + } else + ks->timeout = hp->timeout; + + /* Check for any node specific KS parameter overrides. */ + if (np->port) + ks->port = np->port; + if (np->auth) + ks->auth = np->auth; + if (np->hiport) + ks->hiport = np->hiport; + if (np->timeout) + ks->timeout = np->timeout; + if (np->protocol) + ks->protocol = np->protocol; + + dbgmsg1 ("ks.port = %d\n", ks->port); + dbgmsg1 ("ks.hiport = %d\n", ks->hiport); + dbgmsg1 ("ks.timeout = %d\n", ks->timeout); + + /* Update irafhosts if necessary. */ + if (update || (hp->mode & 077)) + ks_whosts (hp, userfile); + + free ((char *)hp); + return (0); +} + + +/* KS_USERNAME -- Convert the given filename into a user home directory + * relative pathname. A pointer to a buffer containing the pathname is + * returned as the function value. If the pointer "username" is nonnull + * the user's name is returned as well. + */ +static char * +ks_username (char *filename, char *pathname, char *username) +{ + register struct passwd *pwd; + + pwd = getpwuid (getuid()); + if (pwd == NULL) + return (NULL); + + strcpy (pathname, pwd->pw_dir); + strcat (pathname, "/"); + strcat (pathname, IRAFHOSTS); + if (username) + strcpy (username, pwd->pw_name); + + endpwent(); + return (pathname); +} + + +/* KS_SYSNAME -- Convert the given filename into an iraf$dev pathname. + * A pointer to a buffer containing the pathname is returned as the + * function value. + */ +static char * +ks_sysname (char *filename, char *pathname) +{ + XCHAR irafdir[SZ_PATHNAME+1]; + XINT x_maxch=SZ_PATHNAME, x_nchars; + extern int ZGTENV(); + + + ZGTENV ("iraf", irafdir, &x_maxch, &x_nchars); + if (x_nchars <= 0) + return (NULL); + + strcpy (pathname, (char *)irafdir); + strcat (pathname, HOSTLOGIN); + + return (pathname); +} + + +/* KS_RHOSTS -- Read the named irafhosts file into a descriptor, returning + * the descriptor as the function value. + */ +static struct irafhosts * +ks_rhosts (char *filename) +{ + char lbuf[SZ_LINE]; + char word[SZ_LINE]; + struct irafhosts *hp; + struct nodelist *np; + struct stat st; + char *ip, *op; + int value; + FILE *fp; + + dbgmsgs ("read %s\n", filename); + + /* Open irafhosts file. */ + if ((fp = fopen (filename, "r")) == NULL) + return (NULL); + + /* Get descriptor. */ + hp = (struct irafhosts *) malloc (sizeof(struct irafhosts)); + if (hp == NULL) { + fclose (fp); + return (NULL); + } + + hp->port = DEFAULT; + hp->auth = DEFAULT; + hp->hiport = DEF_HIPORT; + hp->timeout = DEF_TIMEOUT; + hp->nheaderlines = 0; + hp->nparams = 0; + hp->nnodes = 0; + hp->mode = 0; + op = hp->sbuf; + + if (fstat (fileno(fp), &st) == 0) + hp->mode = st.st_mode; + + /* Get file header. */ + while (fgets (op, SZ_LINE, fp)) + if (op[0] == '#' || isspace(op[0])) { + hp->header[hp->nheaderlines++] = op; + op += strlen(op) + 1; + } else { + strcpy (lbuf, op); + break; + } + + /* Everything else is a parameter assignment (param =), a node + * entry (node :), or ignored. + */ + do { + ip = lbuf; + if (*ip == '#' || isspace(*ip)) + continue; + + ks_getword (&ip, word); + while (*ip && isspace(*ip)) + ip++; + + if (*ip == '=') { + for (ip++; *ip && isspace(*ip); ip++) + ; + if (strncmp (ip, "default", 7) == 0) + value = DEFAULT; + else if (isdigit (*ip)) + value = atoi (ip); + else + value = 0; + + if (strcmp (word, "port") == 0) + hp->port = value; + else if (strcmp (word, "auth") == 0) + hp->auth = value; + else if (strcmp (word, "hiport") == 0) + hp->hiport = value; + else if (strcmp (word, "timeout") == 0) + hp->timeout = value; + /* else disregard */ + + hp->nparams++; + + } else if (*ip == ':') { + /* Node entry. + */ + np = &hp->node[hp->nnodes++]; /* nodename */ + strcpy (op, word); + np->name = op; + op += strlen(op) + 1; + + ip++; + ks_getword (&ip, word); /* loginname */ + strcpy (op, word); + np->login = op; + op += strlen(op) + 1; + + ks_getword (&ip, word); /* password */ + strcpy (op, word); + np->password = op; + op += strlen(op) + 1; + + /* Process any optional networking paramaeter overrides. + * These are in the form param=value where param is port, + * auth, etc. + */ + np->port = 0; + np->auth = 0; + np->hiport = 0; + np->timeout = 0; + np->protocol = 0; + + while (ks_getword (&ip, word)) { + if (strncmp (word, "port=", 5) == 0) { + np->port = atoi (word + 5); + } else if (strncmp (word, "auth=", 5) == 0) { + np->auth = atoi (word + 5); + } else if (strncmp (word, "hiport=", 7) == 0) { + np->hiport = atoi (word + 7); + } else if (strncmp (word, "timeout=", 8) == 0) { + np->timeout = atoi (word + 8); + } else if (strncmp (word, "protocol=", 9) == 0) { + if (strcmp (word + 9, "rsh") == 0) + np->protocol = C_RSH; + else if (strcmp (word + 9, "rex") == 0) + np->protocol = C_REXEC; + else if (strcmp (word + 9, "rcb") == 0) + np->protocol = C_REXEC_CALLBACK; + } + } + } + + hp->sbuflen = op - hp->sbuf; + if (hp->sbuflen + SZ_LINE > SZ_SBUF) + break; + + } while (fgets (lbuf, SZ_LINE, fp)); + + fclose (fp); + return (hp); +} + + +/* KS_GETWORD -- Get a quoted or whitespace delimited word. + */ +static int +ks_getword (char **ipp, char *obuf) +{ + register char *ip = *ipp, *op = obuf; + + while (*ip && isspace(*ip)) + ip++; + + if (*ip == '"') { + for (ip++; *ip && *ip != '"'; ) + *op++ = *ip++; + } else { + while (*ip && !isspace(*ip)) + *op++ = *ip++; + } + + *op = EOS; + *ipp = ip; + return (op - obuf); +} + + +/* KS_WHOSTS -- Write out a hosts file from the internal descriptor to disk. + */ +static void +ks_whosts ( + struct irafhosts *hp, + char *filename +) +{ + register char *ip; + struct nodelist *np; + int fd, q, i; + FILE *fp; + + dbgmsgs ("update %s\n", filename); + + /* Open new irafhosts file. */ + unlink (filename); + if ((fd = creat (filename, 0600)) < 0) + return; + if ((fp = fdopen(fd,"w")) == NULL) { + close (fd); + unlink (filename); + return; + } + + /* Output any header comments. */ + for (i=0; i < hp->nheaderlines; i++) + fputs (hp->header[i], fp); + + /* Output the networking parameters. */ + if (hp->port == DEFAULT) + fprintf (fp, "port = default\n"); + else + fprintf (fp, "port = %d\n", hp->port); + fprintf (fp, "auth = %d\n", hp->auth); + if (hp->hiport == DEFAULT) + fprintf (fp, "hiport = default\n"); + else + fprintf (fp, "hiport = %d\n", hp->hiport); + if (hp->timeout == DEFAULT) + fprintf (fp, "timeout = default\n"); + else + fprintf (fp, "timeout = %d\n", hp->timeout); + fprintf (fp, "\n"); + + /* Output each "node : login password" sequence, quoting the login + * and password strings if they contain any whitespace. + */ + for (i=0; i < hp->nnodes; i++) { + np = &hp->node[i]; + + /* Output username. */ + fprintf (fp, "%s\t:", np->name); + for (q=0, ip=np->login; *ip && !(q = isspace(*ip)); ip++) + ; + fprintf (fp, q ? " \"%s\"" : " %s", np->login); + + /* Output password field. */ + for (q=0, ip=np->password; *ip && !(q = isspace(*ip)); ip++) + ; + fprintf (fp, q ? " \"%s\"" : " %s", np->password); + + /* Add any optional parameter overrides given in the file when + * originally read. + */ + if (np->port) + fprintf (fp, " port=%d", np->port); + if (np->auth) + fprintf (fp, " auth=%d", np->auth); + if (np->hiport) + fprintf (fp, " hiport=%d", np->hiport); + if (np->timeout) + fprintf (fp, " timeout=%d", np->timeout); + if (np->protocol) { + fprintf (fp, " protocol="); + switch (np->protocol) { + case C_REXEC: + fprintf (fp, "rex"); + break; + case C_REXEC_CALLBACK: + fprintf (fp, "rcb"); + break; + default: + fprintf (fp, "rsh"); + break; + } + } + + fprintf (fp, "\n"); + } + + fclose (fp); +} + + +/* KS_GETPASS -- Access the terminal in raw mode to get the user's + * password. + */ +static char *ks_getpass (char *user, char *host) +{ + static char password[SZ_NAME]; + char prompt[80]; + int tty, n; +#ifdef SYSV + struct termios tc, tc_save; +#else + struct sgttyb ttystat; + int sg_flags; +#endif + + if ((tty = open ("/dev/tty", 2)) == ERR) + return (NULL); + + sprintf (prompt, "Password (%s@%s): ", user, host); + write (tty, prompt, strlen(prompt)); + +#ifdef SYSV + tcgetattr (tty, &tc); + tc_save = tc; + + tc.c_lflag &= + ~(0 | ECHO | ECHOE | ECHOK | ECHONL); + tc.c_oflag |= + (0 | TAB3 | OPOST | ONLCR); + tc.c_oflag &= + ~(0 | OCRNL | ONOCR | ONLRET); + + tc.c_cc[VMIN] = 1; + tc.c_cc[VTIME] = 0; + tc.c_cc[VLNEXT] = 0; + + tcsetattr (tty, TCSADRAIN, &tc); +#else + ioctl (tty, TIOCGETP, &ttystat); + sg_flags = ttystat.sg_flags; + ttystat.sg_flags &= ~ECHO; + ioctl (tty, TIOCSETP, &ttystat); +#endif + + n = read (tty, password, SZ_NAME); + write (tty, "\n", 1); + +#ifdef SYSV + tcsetattr (tty, TCSADRAIN, &tc_save); +#else + ttystat.sg_flags = sg_flags; + ioctl (tty, TIOCSETP, &ttystat); +#endif + + close (tty); + + if (n <= 0) + return (NULL); + else + password[n-1] = EOS; + + return (password); +} + + +/* PR_MASK -- Debug routine to print the current SIGCHLD mask. + */ +void pr_mask (char *str) +{ + sigset_t sigset, pending; + + if (sigprocmask (0, NULL, &sigset) < 0) + dbgmsg ("sigprocmask error"); + + dbgmsg (str); + if (sigismember (&sigset, SIGCHLD)) + dbgmsg ("pr_mask: SIGCHLD set\n"); + + if (sigpending (&pending) < 0) + dbgmsg ("sigpending error"); + if (sigismember (&pending, SIGCHLD)) + dbgmsg ("\tpr_mask: SIGCHLD pending\n"); +} diff --git a/unix/os/zfiolp.c b/unix/os/zfiolp.c new file mode 100644 index 00000000..e07571a2 --- /dev/null +++ b/unix/os/zfiolp.c @@ -0,0 +1,239 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_prtype +#define import_spp +#include + +/* + * ZFIOLP -- IRAF FIO interface to the line printer device. The line printer + * is opened as a streaming type (no seeks) write-only binary device. + * On systems like UNIX in which the line printer is just another file, + * the interface is trivial; we just call the FIOBF routines. On other + * systems it might be necessary to spool the output to a binary file + * and dispose of the file to a queue when the printer file is closed, + * or some such thing. + * + * Currently, the CL-callable LPRINT program is the only thing in IRAF which + * writes to the printer. Most programs are intended to write to their + * standard output or a file, which is subsequently copied to the printer + * by the user or by a CL level script. LPRINT uses "dev$*.tty" descriptors + * and the TTY interface to learn the characteristics of the printer (eject + * is considered equivalent to a tty clear, for example). + * + * The system and device dependent information necessary to perform these + * functions is contained in three strings passed as the "printer" parameter + * to ZOPNLP. The strings come from the TERMCAP entry for the device. + * The format of such a string is + * + * device D spoolfile D dispose_cmd EOS + * + * where DEVICE is the logical device name (not used herein), D is the field + * delimiter character (the first nonalphnumeric character encountered after + * the device field), SPOOLFILE is a UNIX pathname to be passed to MKTEMP + * to create the spoolfile pathname, and DISPOSE_CMD is a fill-in-the-blanks + * template for a UNIX shell command which will dispose of the spoolfile to + * the printer device. + */ + +extern int save_prtype; + +#define SZ_OSCMD 512 /* buffer for dispose cmd */ +#define SZ_LPSTR 256 /* zopnlp plotter argument */ + +struct lprinter { + char *name; /* logical gdevice name */ + char *spoolfile; /* spoolfile string */ + char *dispose; /* dispose format string */ +}; + +struct oprinter { + struct lprinter *lp; /* device code as above */ + long wbytes; /* nbytes written to device */ + char spoolfile[SZ_PATHNAME+1]; +}; + +struct lprinter dpr; /* device table */ +struct oprinter lpr; /* printer descriptor */ +int lpr_inuse = NO; /* set if printer is open */ +char lpstr[SZ_LPSTR+1]; /* save zopnlp argument */ + + +extern int ZOPNBF (), ZCLSBF (), ZOSCMD (), ZFDELE (), ZARDBF (); +extern int ZAWRBF (), ZAWTBF (), ZSTTBF (); + + +/* ZOPNLP -- Open a printer device for binary file i/o. If we can talk + * directly to the printer, do so, otherwise open a spoolfile which is + * to be sent to the printer when ZCLSLP is later called. + */ +int +ZOPNLP ( + PKCHAR *printer, /* logical name of printer device */ + XINT *mode, /* file access mode */ + XINT *chan /* UNIX file number (output) */ +) +{ + register char *ip; + static char delim; + int fd; + + + /* We do not see a need to have more than one printer open at + * a time, and it makes things simpler. We can easily generalize + * to multiple open printer devices in the future if justified. + */ + if (lpr_inuse == YES) { + *chan = XERR; + return (XERR); + } else + lpr_inuse = YES; + + /* Parse the printer string into the name, spoolfile, and dispose + * strings. + */ + strncpy (lpstr, (char *)printer, SZ_LPSTR); + lpstr[SZ_LPSTR] = EOS; + + /* Locate NAME field. */ + dpr.name = lpstr; + for (ip=lpstr; isalnum(*ip); ip++) + ; + delim = *ip; + *ip++ = EOS; + + /* Locate SPOOLFILE field. */ + for (dpr.spoolfile=ip; *ip && *ip != delim; ip++) + ; + *ip++ = EOS; + + /* Locate DISPOSE field. */ + for (dpr.dispose=ip; *ip && *ip != delim; ip++) + ; + *ip++ = EOS; + + /* Initialize the open printer descriptor. + */ + lpr.wbytes = 0L; + lpr.lp = &dpr; + strcpy (lpr.spoolfile, dpr.spoolfile); + if (dpr.dispose[0] != EOS) + if ((fd = mkstemp (lpr.spoolfile)) >= 0) { + fchmod (fd, 0644); + close (fd); + } + + return ZOPNBF ((PKCHAR *)lpr.spoolfile, mode, chan); +} + + +/* ZCLSLP -- To close a printer we merely close the "spoolfile", and then + * dispose of the spoolfile to the OS if so indicated. + */ +int +ZCLSLP (XINT *chan, XINT *status) +{ + static PKCHAR xnullstr[1] = { XEOS }; + register char *ip, *op, *f; + PKCHAR cmd[(SZ_LINE+1) / sizeof(PKCHAR)]; + XINT junk; + + ZCLSBF (chan, status); + lpr_inuse = NO; + + /* Dispose of the output file if so indicated. Do not bother to + * check the status return, since we cannot return status to FIO + * from here anyhow. Do not dispose of the file if it is empty. + * If the file is disposed of by the OS, we assume that it is also + * deleted after printing. If file is not disposed to the OS, we + * delete it ourselves. + */ + if (*(lpr.lp->dispose) != EOS) { + if (lpr.wbytes > 0) { + PKCHAR out[SZ_FNAME+1]; + + /* Build up command line by substituting the spoolfile name + * everywhere the macro "$F" appears in the "dispose" text. + */ + op = (char *)cmd; + for (ip=lpr.lp->dispose; (*op = *ip++) != EOS; op++) + if (*op == '$' && *ip == 'F') { + for (f=lpr.spoolfile; (*op = *f++) != EOS; op++) + ; + /* Overwrite EOS, skip over 'F' */ + --op, ip++; + } + strcpy ((char *)out, + save_prtype == PR_CONNECTED ? "/dev/tty" : ""); + ZOSCMD (cmd, xnullstr, out, out, &junk); + } else + ZFDELE ((PKCHAR *)lpr.spoolfile, &junk); + } + + return (*status); +} + + +/* ZARDLP -- Initiate a read from the line printer device. For UNIX, the read + * and write routines are just the binary file i/o routines. Note that packing + * of chars into bytes, mapping of escape sequences, etc. is done by the high + * level code; our function is merely to move the data to the device. The read + * primitive is not likely to be needed for a printer, but you never know... + */ +int +ZARDLP (XINT *chan, XCHAR *buf, XINT *maxbytes, XLONG *offset) +{ + XLONG dummy_offset = 0; + + return ZARDBF (chan, buf, maxbytes, &dummy_offset); +} + + +/* ZAWRLP -- Initiate a write to the line printer. Keep track of the number + * of bytes written so we know whether or not to dispose of the spoolfile + * at close time. + */ +int +ZAWRLP (XINT *chan, XCHAR *buf, XINT *nbytes, XLONG *offset) +{ + XLONG dummy_offset = 0; + + lpr.wbytes += *nbytes; + return ZAWRBF (chan, buf, nbytes, &dummy_offset); +} + + +/* ZAWTLP -- Wait for i/o and return the status of the channel, i.e., the + * number of bytes read or written or XERR. + */ +int +ZAWTLP (XINT *chan, XINT *status) +{ + return ZAWTBF (chan, status); +} + + +/* ZSTTLP -- Get status for the line printer output file. We call ZSTTBF since + * the output file was opened by ZOPNBF. The actual output file may be either + * a blocked or streaming file depending on whether the output is spooled. + */ +int +ZSTTLP (XINT *chan, XINT *param, XLONG *lvalue) +{ + switch (*param) { + case FSTT_BLKSIZE: + *lvalue = 0L; /* streaming device */ + break; + default: + return ZSTTBF (chan, param, lvalue); + } + return (*lvalue); +} diff --git a/unix/os/zfiomt.c b/unix/os/zfiomt.c new file mode 100644 index 00000000..e3c3a890 --- /dev/null +++ b/unix/os/zfiomt.c @@ -0,0 +1,1911 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef _AIX +#include +#define MTIOCTOP STIOCTOP +#define MTBSF STRSF +#define MTBSR STRSR +#define MTFSF STFSF +#define MTFSR STFSR +#define MTREW STREW +#define MTWEOF STWEOF +#define mtop stop +#define mt_op st_op +#define mt_count st_count +#else +#ifndef MACOSX +#include +#endif +#endif + +/* Define if status logging to sockets is desired. */ +#define TCPIP + +#ifdef TCPIP +#include +#include +#include +#include +#define DEFPORT 5138 +#endif + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_stdarg +#define import_spp +#include + +/* + * ZFIOMT.C -- Programmable magtape kernel interface for UNIX/IRAF systems. + * This file contains only the lowest level i/o routines. Most of the + * functionality of the iraf magtape i/o system is provided by the routines + * in the VOS interfaces MTIO and ETC. The dev$tapecap file is used to + * describe the magtape devices present on the local host system, and to + * characterize the behavior of each device. + * + * The behavior of this driver is controlled by parameters given in the + * entry for a magtape device in the tapecap file. The following parameters + * are defined (not all of which are necessarily used by the driver). + * + * CODE TYPE DEFAULT DESCRIPTION + * + * bs i 0 device block size (0 if variable) + * dn s 0 density + * dt s generic drive type + * fb i 1 default FITS blocking factor (recsize=fb*2880) + * fe i 0 time to FSF equivalent in file Kb + * fs i 0 approximate filemark size (bytes) + * mr i 65535 maximum record size + * or i 63360 optimum record size + * rs i 0 approximate record gap size (bytes) + * ts i 0 tape capacity (Mb) + * tt s unknown tape type + * + * al s none device allocation info + * dv s required i/o (no-rewind) device file + * lk s required lock file root name (uparm$mt.lok) + * rd s none rewind device file + * so s none status output device file or socket + * + * bo b no BSF positions to BOF + * ce b no ignore close status on CLRO + * eo b no do not write double EOT on CLWO (VMS) + * fc b no device does a FSF on CLRO + * ir b no treat all read errors as EOF + * mf b no enable multifile FSF for forward positioning + * nb b no device cannot backspace + * nf b/i no/0 rewind and space forward to backspace file + * np b no disable all positioning ioctls + * ow b no backspace and overwrite EOT at append + * re b no read at EOT returns ERR + * rf b no use BSR,FSR to space over filemarks + * ro b no rewind on every open to define position + * rr b no rewind at close-readonly to define position + * se b no device will position past EOT in a read + * sk b no skip record forward after a read error + * ue b no force update of EOT (search for EOT) + * wc b no OPWR-CLWR at EOF writes null file + * + * ct i builtin MTIOCTOP code + * bf i builtin BSF ioctl code + * br i builtin BSR ioctl code + * ff i builtin FSF ioctl code + * fr i builtin FSR ioctl code + * ri i builtin REW ioctl code + * + * + * Many of these parameters are optional. Some are used by the high level MTIO + * code rather than the host level driver. + * + * The externally callable driver routines are the following. + * + * ZZOPMT (device, acmode, devcap, devpos, newfile, chan) + * ZZRDMT (chan, buf, maxbytes, offset) + * ZZWRMT (chan, buf, nbytes, offset) + * ZZWTMT (chan, devpos, status) + * ZZSTMT (chan, param, value) + * ZZCLMT (chan, devpos, status) + * ZZRWMT (device, devcap, status) + * + * Here, "device" is the name by which the device is known to the driver, + * acmode is the access mode, devcap is the tapecap device entry, devpos is a + * structure giving the current tape position, amount of tape used, etc, and + * newfile is the requested file. The driver will position to the indicated + * file at open time. The devpos structure is passed in to the driver at open + * time and returned to the client at close time. While i/o is in progress + * the driver is responsible for keeping track of the device position. The + * client is responsible for maintaining the position information while the + * device is closed. If the position is uncertain devpos should be passed in + * with a negative file number and the driver will rewind to reestablish a + * known position. + * + * The devpos structure (struct _mtpos) has the following fields: + * + * int filno file number + * int recno record number + * int nfiles number of files on tape + * int tapeused total amount of storage used (Kb) + * int pflags bitflags describing last i/o operation + * + * FILNO and RECNO are negative if the position is undefined (unknown). File + * number 1 is the first file. NFILES is the total number of files on the + * tape. NFILES less than or equal to zero indicates that the number of files + * is unknown; the driver will set nfiles when EOT is seen. The tape can be + * positioned to EOT by opening the device at file NFILES+1. TAPEUSED refers + * to the total amount of tape used at EOT, regardless of the current tape + * position. The driver will keep track of tape usage using the device + * attributes specified in the tapecap entry. TAPEUSED less than or equal to + * zero indicates that the amount of tape used is unknown. Both the tape + * capacity and TAPEUSED are given in Kb (1024 byte blocks). + * + * + * The following bitflags are defined: + * + * MF_ERR i/o error occurred in last operation + * MF_EOF a tape mark was seen in the last operation + * MF_EOT end of tape seen in the last operation + * MF_EOR a record advance occurred in the last operation + * + * The PFLAGS field is output only, and is cleared at the beginning of each + * i/o request. + */ + +extern int errno; +typedef unsigned int U_int; + +#define CONSOLE "/dev/console" +#define MAX_ERRIGNORE 10 /* max errs before skiprec */ +#define MAX_ERRCNT 20 /* max errs before EOF */ +#define MAXDEV 8 /* max open magtape devices */ +#define MAXREC 64512 /* default maximum record size */ +#define OPTREC 64512 /* default optimum record size */ +#define SHORTREC 20 /* short record for dummy files */ +#define RDONLY 0 /* read only */ +#define WRONLY 1 /* write only */ + +/* Tape position information (must agree with client struct). This is input + * by the client at open time and is only modified locally by the driver. + */ +struct _mtpos { + int filno; /* current file (1=first) */ + int recno; /* current record (1=first) */ + int nfiles; /* number of files on tape */ + int tapeused; /* total tape used (Kb) */ + int pflags; /* i/o status bitflags (output) */ +}; + +/* MTPOS bitflags. */ +#define MF_ERR 0001 /* i/o error occurred in last operation */ +#define MF_EOF 0002 /* a tape mark was seen in the last operation */ +#define MF_EOT 0004 /* end of tape seen in the last operation */ +#define MF_EOR 0010 /* a record advance occurred in the last operation */ + +/* General magtape device information, for status output. */ +struct mtdev { + FILE *statusout; /* status out or NULL */ + int blksize; /* device block size */ + int recsize; /* last record size */ + int maxrec; /* maximum record size */ + int optrec; /* optimum record size */ + int tapesize; /* tape capacity (Kb) */ + int eofsize; /* filemark size, bytes */ + int gapsize; /* interrecord gap size, bytes */ + int maxbsf; /* BSF vs rewind-FSF threshold */ + char density[SZ_FNAME]; /* tape density, bpi */ + char devtype[SZ_FNAME]; /* drive type */ + char tapetype[SZ_FNAME]; /* tape type */ + char statusdev[SZ_FNAME]; /* status output device */ +}; + +/* Magtape device descriptor. */ +#define get_mtdesc(fd) ((struct mtdesc *)zfd[fd].fp) +#define set_mtdesc(fd,mp) zfd[fd].fp = (FILE *)mp +#define ateot(pp) (pp->nfiles>0 && pp->filno==pp->nfiles+1 && pp->recno==1) +#define spaceused(pp) ((pp->nfiles==0 || pp->filno>pp->nfiles) && !ateot(pp)) + +struct mtdesc { + XINT *chan; /* file descriptor open device */ + int flags; /* device characteristics */ + int acmode; /* access mode */ + int errcnt; /* i/o error count */ + int nbytes; /* status of last i/o transfer */ + int tbytes; /* byte portion of tapeused */ + int mtrew; /* REW ioctl code */ + int mtbsr, mtfsr; /* BSR,FSR ioctl codes */ + int mtbsf, mtfsf; /* BSF,FSF ioctl codes */ + U_int mtioctop; /* MTIOCTOP code */ + struct _mtpos mtpos; /* position information */ + struct mtdev mtdev; /* drive type information */ + char iodev[SZ_FNAME]; /* i/o device */ + char nr_device[SZ_FNAME]; /* no-rewind-on-close device */ + char rw_device[SZ_FNAME]; /* rewind-on-close device */ +}; + +/* Parameter codes. */ +#define P_AL 1 /* allocation stuff */ +#define P_BF 2 /* MTBSF */ +#define P_BO 3 /* BSF positions to BOF */ +#define P_BR 4 /* MTBSR */ +#define P_BS 5 /* block size */ +#define P_CE 6 /* ignore close status on CLRO */ +#define P_CT 7 /* MTIOCTOP */ +#define P_DN 8 /* density */ +#define P_DT 9 /* drive type id string */ +#define P_DV 10 /* no rewind device */ +#define P_EO 11 /* do not write double EOT on CLWO (VMS) */ +#define P_FC 12 /* device does FSF on close readonly */ +#define P_FF 13 /* MTFSF */ +#define P_FR 14 /* MTFSR */ +#define P_FS 15 /* filemark size, Kb */ +#define P_IR 16 /* map read errors to EOF */ +#define P_MF 17 /* enable multifile FSF for fwd positioning */ +#define P_MR 18 /* max record (i/o transfer) size */ +#define P_NB 19 /* backspace not allowed */ +#define P_NF 20 /* rewind and space forward to posn back */ +#define P_NP 21 /* disable file positioning */ +#define P_OR 22 /* optimum record size */ +#define P_OW 23 /* optimize EOT (9tk drives) */ +#define P_RD 24 /* rewind device */ +#define P_RE 25 /* read at EOT returns ERR */ +#define P_RF 26 /* use record skip ioctls to skip filemarks */ +#define P_RI 27 /* MTREW */ +#define P_RO 28 /* rewind on every open to define position */ +#define P_RR 29 /* rewind after close-readonly */ +#define P_RS 30 /* interrecord gap size, bytes */ +#define P_SE 31 /* BSF needed after read at EOT */ +#define P_SK 32 /* skip record forward after read error */ +#define P_SO 33 /* status output device or socket */ +#define P_TS 34 /* tape size, Mb */ +#define P_TT 35 /* tape type id string */ +#define P_UE 36 /* force update of EOT (search for EOT) */ +#define P_WC 37 /* open-write/close creates dummy EOT */ + +/* Tapecap device characteristic bitflags. */ +#define BO 00000001 /* BSF positions to BOF */ +#define CE 00000002 /* ignore close status on CLRO */ +#define EO 00000004 /* do not write double EOT on CLWO (VMS) */ +#define FC 00000010 /* defines does a FSF on CLRO */ +#define IR 00000020 /* treat all read errors as EOF */ +#define MF 00000040 /* enable multifile FSF for fwd positioning */ +#define NB 00000100 /* device cannot backspace */ +#define NF 00000200 /* rewind and space forward to position back */ +#define NP 00000400 /* disable file positioning */ +#define OW 00001000 /* backspace and overwrite at append */ +#define RD 00002000 /* rewind-on-close device specified */ +#define RE 00004000 /* read at EOT can signal error */ +#define RF 00010000 /* use BSR,FSR to space over filemarks */ +#define RO 00020000 /* rewind on every open to define position */ +#define RR 00040000 /* rewind after close-readonly */ +#define SE 00100000 /* read at EOT leaves past tape mark */ +#define SK 00200000 /* skip record forward after a read error */ +#define UE 00400000 /* force update of EOT (search for EOT) */ +#define WC 01000000 /* CLWR at EOF writes null file */ + +/* Device characteristic codes. */ +#define PNAME(a,b) ((((int)(a))<<8)+(int)(b)) + +/* Tape drives aren't supported on Mac systems currently. +*/ +#ifndef MACOSX + +/* Device flag table. */ +static struct mtchar { + int pname; /* 2 byte parameter name code */ + int pcode; /* parameter number */ + int bitflag; /* flag bit */ + int valset; /* value has been set */ +} devpar[] = { + { PNAME('a','l'), P_AL, 0, 0 }, + { PNAME('b','f'), P_BF, 0, 0 }, + { PNAME('b','o'), P_BO, BO, 0 }, + { PNAME('b','r'), P_BR, 0, 0 }, + { PNAME('b','s'), P_BS, 0, 0 }, + { PNAME('c','e'), P_CE, CE, 0 }, + { PNAME('c','t'), P_CT, 0, 0 }, + { PNAME('d','n'), P_DN, 0, 0 }, + { PNAME('d','t'), P_DT, 0, 0 }, + { PNAME('d','v'), P_DV, 0, 0 }, + { PNAME('e','o'), P_EO, EO, 0 }, + { PNAME('f','c'), P_FC, FC, 0 }, + { PNAME('f','f'), P_FF, 0, 0 }, + { PNAME('f','r'), P_FR, 0, 0 }, + { PNAME('f','s'), P_FS, 0, 0 }, + { PNAME('i','r'), P_IR, IR, 0 }, + { PNAME('m','f'), P_MF, MF, 0 }, + { PNAME('m','r'), P_MR, 0, 0 }, + { PNAME('n','b'), P_NB, NB, 0 }, + { PNAME('n','f'), P_NF, NF, 0 }, + { PNAME('n','p'), P_NP, NP, 0 }, + { PNAME('o','r'), P_OR, 0, 0 }, + { PNAME('o','w'), P_OW, OW, 0 }, + { PNAME('r','d'), P_RD, 0, 0 }, + { PNAME('r','e'), P_RE, RE, 0 }, + { PNAME('r','f'), P_RF, RF, 0 }, + { PNAME('r','i'), P_RI, 0, 0 }, + { PNAME('r','o'), P_RO, RO, 0 }, + { PNAME('r','r'), P_RR, RR, 0 }, + { PNAME('r','s'), P_RS, 0, 0 }, + { PNAME('s','e'), P_SE, SE, 0 }, + { PNAME('s','k'), P_SK, SK, 0 }, + { PNAME('s','o'), P_SO, 0, 0 }, + { PNAME('t','s'), P_TS, 0, 0 }, + { PNAME('t','t'), P_TT, 0, 0 }, + { PNAME('u','e'), P_UE, UE, 0 }, + { PNAME('w','c'), P_WC, WC, 0 }, + { 0, 0, 0, 0 }, +}; + + +static int zmtgetfd(); +static int zmtbsr(), zmtbsf(), zmtfsr(), zmtfsf(); +static int zmtclose(), zmtfpos(), zmtrew(); + +static int zmtopen (char *dev, int u_acmode); +static int zmtclose (int fd); +static struct mtdesc *zmtdesc (char *device, int acmode, char *devcap, + struct _mtpos *devpos); +static int zmtfpos (struct mtdesc *mp, int newfile); +static int zmtrew (int fd); +static void zmtfls (struct mtdesc *mp); +static void zmtfree (struct mtdesc *mp); +static int zmtfsf (int fd, int nfiles); +static int zmtbsf (int fd, int nfiles); +static int zmtfsr (int fd, int nrecords); +static int zmtbsr (int fd, int nrecords); + +static void zmtdbgn (struct mtdesc *mp, const char *argsformat, ... ); +static void zmtdbg (struct mtdesc *mp, char *msg); +static void zmtdbgopen (struct mtdesc *mp); +static void zmtdbgclose (struct mtdesc *mp); + + + + +/* ZZOPMT -- Open the named magtape device and position to the given file. + * On output, "newfile" contains the number of the file actually opened, + * which may be less than what was requested if EOT is reached. + */ +int +ZZOPMT ( + PKCHAR *device, /* device name */ + XINT *acmode, /* access mode: read_only or write_only for tapes */ + PKCHAR *devcap, /* tapecap entry for device */ + XINT *devpos, /* pointer to tape position info struct */ + XINT *newfile, /* file to be opened or EOT */ + XINT *chan /* OS channel of opened file */ +) +{ + register int fd; + register struct mtdesc *mp; + struct _mtpos *pp; + + /* Open the main device descriptor. */ + mp = zmtdesc ((char *)device, *acmode, (char *)devcap, + (struct _mtpos *)devpos); + if (mp == NULL) { + *chan = XERR; + return (XERR); + } + + zmtdbgn (mp, "open device %s\n", (char *)device); + + /* Save the channel pointer for the delayed open used for file + * positioning. If file positioning is needed the device will + * be opened read-only, so that an interrupt occurring while seeking + * to EOT for writing will not result in truncation of the tape! + * BE SURE TO RETURN OSCHAN as soon as the device is physically + * opened, so that the error recovery code can close the file if + * we are interrupted. + */ + mp->chan = chan; + *chan = 0; + + /* Initialize the descriptor. */ + mp->errcnt = 0; + mp->tbytes = 0; + pp = &mp->mtpos; + + /* Zero counters if position is undefined. */ + if (pp->filno < 1 || pp->recno < 1) { + pp->nfiles = 0; + pp->tapeused = 0; + } + + /* Zero counters if new tape? */ + if (mp->acmode == WRITE_ONLY && (*newfile == 0 || *newfile == 1)) { + pp->nfiles = 0; + pp->tapeused = 0; + } + + /* Zero tapeused counter if rewinding and nfiles is still unknown. */ + if (pp->nfiles == 0 && *newfile == 1) + pp->tapeused = 0; + + /* Status output. */ + zmtdbgn (mp, "devtype = %s", mp->mtdev.devtype); + zmtdbgn (mp, "tapetype = %s", mp->mtdev.tapetype); + zmtdbgn (mp, "tapesize = %d", mp->mtdev.tapesize); + zmtdbgn (mp, "density = %s", + mp->mtdev.density[0] ? mp->mtdev.density : "na"); + zmtdbgn (mp, "blksize = %d", mp->mtdev.blksize); + zmtdbgn (mp, "acmode = %s", mp->acmode == READ_ONLY ? "read" : + ((*newfile < 0) ? "append" : "write")); + zmtdbgn (mp, "file = %d%s", pp->filno, ateot(pp) ? " (EOT)" : ""); + zmtdbgn (mp, "record = %d", pp->recno); + zmtdbgn (mp, "nfiles = %d", pp->nfiles); + zmtdbgn (mp, "tapeused = %d", pp->tapeused); + zmtfls (mp); + + /* Position to the desired file. Do not move the tape if newfile=0 + * or if NP (no-position) is specified for the device. Rewind the tape + * to get to a known position if current tape position is undefined. + */ + if (*newfile == 0 || (mp->flags & NP)) { + zmtdbg (mp, "file positioning is disabled\n"); + zmtfls (mp); + } + if (*newfile) { + /* Rewind if current position uncertain. */ + if ((mp->flags & RO) || pp->filno < 1 || pp->recno < 1) { + if (!(mp->flags & NP)) + if ((fd = zmtgetfd (mp)) == ERR || zmtrew(fd) == ERR) + goto err; + pp->filno = pp->recno = 1; + } + + /* Position to the desired file. NP disables file positioning, + * in which case we assume the user knows what they are doing + * and we are already there. + */ + if (mp->flags & NP) + *newfile = (*newfile < 0) ? pp->filno : *newfile; + else if ((*newfile = zmtfpos (mp, *newfile)) == XERR) + goto err; + } + + /* Reopen file with write permission if necessary. */ + if (mp->acmode == WRITE_ONLY) { + if (*chan) { + zmtclose (*chan); + zmtdbg (mp, "reopen for writing\n"); + } + (*chan) = fd = zmtopen (mp->iodev, WRONLY); + if (fd != ERR) + zmtdbgn (mp, + "device %s opened on descriptor %d\n", mp->iodev, fd); + } else + fd = zmtgetfd (mp); + + if (fd == ERR) + goto err; + set_mtdesc(fd,mp); + mp->errcnt = 0; + + zmtdbgn (mp, "file = %d%s", pp->filno, ateot(pp) ? " (EOT)" : ""); + zmtdbgn (mp, "record = %d", mp->mtpos.recno); + zmtfls (mp); + + if (mp->acmode == WRITE_ONLY) + zmtdbg (mp, "writing...\n"); + else + zmtdbg (mp, "reading...\n"); + + return (XOK); +err: + /* Error exit. */ + zmtfree (mp); + *chan = XERR; + + return (*chan); +} + + +/* ZZCLMT -- Close magtape. Write a new EOT mark at the current position + * if tape is open for writing, leaving tape positioned ready to write the + * next file. + */ +int +ZZCLMT (XINT *chan, XINT *devpos, XINT *o_status) +{ + register int fd; + register struct mtdesc *mp; + register struct _mtpos *pp; + int status, eof_seen, eor_seen, eot_seen; + + /* Since open files are closed during error recovery and an interrupt + * can occur while closing a magtape file, it is possible that ZZCLMT + * twice, after the host file has been closed and the MP descriptor + * freed. Watch out for a bad channel number or mp=NULL. + */ + *o_status = XERR; + if ((fd = *chan) <= 0) + return (XERR); + if ((mp = get_mtdesc(fd)) == NULL) + return (XERR); + pp = &mp->mtpos; + + eof_seen = 0; + eor_seen = 0; + eot_seen = 0; + status = OK; + + /* Close file and update tape position. + */ + if (mp->acmode == READ_ONLY) { + /* Rewind if the rewind-after-read flag is set. This is used on + * devices that can leave the tape in an undefined position after + * a file read. + */ + if (mp->flags & RR) { + if (zmtrew(fd) == ERR) + status = ERR; + else { + pp->filno = pp->recno = 1; + zmtdbgn (mp, "file = %d", pp->filno); + zmtdbgn (mp, "record = %d", pp->recno); + } + } + + /* Close device. */ + status = zmtclose (fd); + if (mp->flags & CE) + status = 0; + + /* On some SysV systems closing a tape opened RO causes a skip + * forward to BOF of the next file on the tape. This does not + * occur though when the device is closed after reading EOF on + * a file. + */ + if ((mp->flags & FC) && pp->recno > 1) + eof_seen = 1; + + } else if (pp->recno > 1) { + /* Close WRONLY other than at BOF always writes EOT, advancing + * the file position by one file. + */ + status = zmtclose (fd); + eof_seen = 1; + eot_seen = 1; + + } else if (mp->flags & WC) { + /* If a tape is opened for writing and then closed without any + * data being written, a tape mark is written resulting in a + * dummy EOT in the middle of the tape if writing continues. + * Backspace over the the extra tape mark if possible, otherwise + * write a short record. This will result in an extra dummy + * file being written to the tape but the only alternative is to + * rewind and space forward, or abort on an error. + */ + register int flags = mp->flags; + int blksize = mp->mtdev.blksize; + int bufsize; + char *bufp; + + if ((flags & NB) || ((flags & BO) && !(flags & RF))) { + bufsize = blksize ? blksize : SHORTREC; + bufsize = max (bufsize, SHORTREC); + if ((bufp = malloc(bufsize)) == NULL) { + zmtclose (fd); + status = ERR; + } else { + zmtdbg (mp, "no data - null file written\n"); + zmtfls (mp); + strcpy (bufp, "[NULLFILE]"); + write (fd, bufp, bufsize); + free (bufp); + status = zmtclose (fd); + eof_seen = 1; + } + } else { + /* Close and write EOT, reopen RDONLY and backspace over it. */ + status = (zmtclose(fd) == ERR); + if (status || (fd = zmtopen (mp->iodev, RDONLY)) == ERR) + status = ERR; + else { + status = ((flags & RF) ? zmtbsr : zmtbsf)(fd, 1); + status = (zmtclose(fd) == ERR) ? ERR : status; + } + eof_seen = 1; + } + eot_seen = 1; + } else { + status = zmtclose (fd); + eof_seen = 0; + eot_seen = 1; + } + + /* Update position information and write status output. */ + pp->pflags = status ? MF_ERR : 0; + if (eot_seen) { + pp->pflags |= MF_EOT; + } + if (eof_seen) { + pp->pflags |= MF_EOF; + pp->filno++; + pp->recno = 1; + if (mp->acmode == WRITE_ONLY) { + pp->nfiles = pp->filno - 1; + zmtdbgn (mp, "nfiles = %d", pp->nfiles); + } + if (mp->acmode == WRITE_ONLY || spaceused(pp)) + mp->tbytes += mp->mtdev.eofsize; + zmtdbgn (mp, "record = %d", pp->recno); + zmtdbgn (mp, "file = %d%s", pp->filno, ateot(pp) ? " (EOT)" : ""); + } + if (eor_seen) { + pp->pflags |= MF_EOR; + pp->recno++; + if (mp->acmode == WRITE_ONLY || spaceused(pp)) + mp->tbytes += mp->mtdev.gapsize; + zmtdbgn (mp, "record = %d", pp->recno); + } + + pp->tapeused += ((mp->tbytes + 512) / 1024); + zmtdbgn (mp, "tapeused = %d", pp->tapeused); + zmtfls (mp); + + *((struct _mtpos *)devpos) = *pp; + *o_status = status ? XERR : XOK; + zmtfree (mp); + + return (status); +} + + +/* ZZRDMT -- Read next tape record. We are supposed to be asynchronous, + * so save read status for return by next call to ZZWTMT. Read returns + * zero byte count if EOF is seen, as required by the specs, so we need + * do nothing special in that case. Tape is left positioned just past the + * tape mark. + */ +int +ZZRDMT ( + XINT *chan, + XCHAR *buf, + XINT *maxbytes, + XLONG *offset /* fixed block devices only */ +) +{ + register int fd = *chan, mb = (int)*maxbytes; + register struct mtdesc *mp = get_mtdesc(fd); + register struct _mtpos *pp = &mp->mtpos; + int status; + + if (mp->mtdev.blksize && (mb % mp->mtdev.blksize)) { + zmtdbgn (mp, + "read request %d not a multiple of device block size\n", mb); + zmtfls (mp); + } + + /* Position to the desired record (fixed block devices only). */ +/* + if (mp->mtdev.blksize && *offset > 0) { + int blkno, oldblk; + blkno = *offset / mp->mtdev.blksize + 1; + oldblk = mp->mtpos.recno; + if (blkno != oldblk) { + zmtdbgn (mp, "position to block %d\n", blkno); + if (blkno > oldblk) { + if (zmtfsr (fd, blkno - oldblk) == ERR) { + status = ERR; + goto done; + } + } else { + if ((mp->flags & NB) || zmtbsr(fd,oldblk-blkno) == ERR) { + status = ERR; + goto done; + } + } + mp->mtpos.recno = blkno; + } + } + */ + + /* Map read error to EOF if RE is set and we are reading the first + * record of a file (i.e. are positioned to EOT) or if IR is set. + */ + status = read (fd, (char *)buf, mb); + if (status == ERR) { + if ((mp->flags & RE) && pp->recno == 1) { + status = 0; + } else if (mp->flags & IR) { + zmtdbg (mp, "read error converted to zero read (EOF)\n"); + zmtfls (mp); + status = 0; + } + } + + /* If an error occurs on the read we assume that the tape has advanced + * beyond the bad record, and that the next read will return the next + * record on the tape. If this is not true and a read error loop + * occurs, we try skipping a record forward. If we continue to get + * read errors, we give up and return a premature EOF on the file. + */ + if (status == ERR) { + zmtdbgn (mp, "read error, errno = %d\n", errno); + zmtfls (mp); + if ((mp->errcnt)++ >= MAX_ERRCNT) + status = 0; /* give up; return EOF */ + else if ((mp->flags & SK) || mp->errcnt >= MAX_ERRIGNORE) + zmtfsr (fd, 1); + } + + mp->nbytes = status; + if (status >= 0 && mp->mtdev.recsize != status) + zmtdbgn (mp, "recsize = %d", mp->mtdev.recsize = status); + zmtfls (mp); + + return (status); +} + + +/* ZZWRMT -- Write next tape record. We are supposed to be asynchronous, + * so save write status for return by next call to ZZWTMT. + */ +int +ZZWRMT ( + XINT *chan, + XCHAR *buf, + XINT *nbytes, + XLONG *offset /* ignored on a write */ +) +{ + register int fd = *chan, nb = *nbytes; + register struct mtdesc *mp = get_mtdesc(fd); + int blksize = mp->mtdev.blksize; + + /* If writing to a blocked device, promote partial blocks to a + * full device block. + */ + if (blksize > 0 && (nb % blksize)) { + nb += blksize - (nb % blksize); + zmtdbgn (mp, "partial record promoted from %d to %d bytes\n", + *nbytes, nb); + } + + if (mp->mtdev.recsize != nb) + zmtdbgn (mp, "recsize = %d", mp->mtdev.recsize = nb); + if ((mp->nbytes = write (fd, (char *)buf, nb)) != nb) { + zmtdbgn (mp, "write error, status=%d, errno=%d\n", + mp->nbytes, errno); + mp->nbytes = ERR; + } + zmtfls (mp); + + return (XOK); +} + + +/* ZZWTMT -- "Wait" for i/o transfer to complete, and return the number of + * bytes transferred or XERR. A read at EOF returns a byte count of zero. + */ +int +ZZWTMT ( + XINT *chan, + XINT *devpos, + XINT *o_status +) +{ + register int fd = *chan; + register struct mtdesc *mp = get_mtdesc(fd); + register struct _mtpos *pp = &mp->mtpos; + register int flags = mp->flags; + int status, eof_seen, eor_seen, eot_seen; + + eof_seen = 0; + eor_seen = 0; + eot_seen = 0; + status = OK; + + if ((status = mp->nbytes) == ERR) { /* i/o error */ + status = ERR; + } else if (status == 0) { /* saw EOF */ + if (pp->recno <= 1) { + /* A read of zero (EOF) at the beginning of a file signals + * EOT. The file number does not change. + */ + pp->nfiles = pp->filno - 1; + zmtdbgn (mp, "nfiles = %d", pp->nfiles); + zmtdbgn (mp, "file = %d%s", + pp->filno, ateot(pp) ? " (EOT)" : ""); + zmtfls (mp); + eot_seen = 1; + + /* If the device allows us to read past the second filemark + * (SE) we must backspace over the filemark or any further + * reads could result in tape runaway. + */ + if (flags & SE) { + if ((flags & NB) || ((flags & FC) && !(flags & RF))) { + /* Cannot backspace; must rewind and space forward. */ + if (zmtrew(fd) == ERR) + status = ERR; + else if (zmtfsf(fd,pp->filno-1) == ERR) + status = ERR; + } else { + /* BSR is preferable if we can use it. */ + if ((((flags & RF) ? zmtbsr : zmtbsf)(fd, 1)) < 0) + status = ERR; + } + } + } else + eof_seen = 1; + } else + eor_seen = 1; + + /* Update position records and output status info. */ + pp->pflags = (status < 0) ? MF_ERR : 0; + if (eot_seen) + pp->pflags |= MF_EOT; + if (eof_seen) { + pp->filno++; + pp->recno = 1; + pp->pflags |= MF_EOF; + zmtdbg (mp, "record = 1"); + if (spaceused(pp)) + mp->tbytes += mp->mtdev.eofsize; + zmtdbgn (mp, "file = %d%s", pp->filno, ateot(pp) ? " (EOT)" : ""); + } + if (eor_seen) { + pp->pflags |= MF_EOR; + if (mp->mtdev.blksize > 0) + pp->recno += (status / mp->mtdev.blksize); + else + pp->recno++; + if (spaceused(pp)) + mp->tbytes += mp->mtdev.gapsize; + zmtdbgn (mp, "record = %d", pp->recno); + } + + if (status >= 0 && spaceused(pp)) { + mp->tbytes += status; + pp->tapeused += mp->tbytes / 1024; + mp->tbytes %= 1024; + zmtdbgn (mp, "tapeused = %d", pp->tapeused); + } + + *((struct _mtpos *)devpos) = *pp; + *o_status = (status < 0) ? XERR : status; + zmtfls (mp); + + return (status); +} + + +/* ZZSTMT -- Query a device or device driver parameter. + */ +int +ZZSTMT (XINT *chan, XINT *param, XLONG *lvalue) +{ + register int fd = *chan; + register struct mtdesc *mp = get_mtdesc(fd); + /* register struct _mtpos *pp = &mp->mtpos; */ + + + switch (*param) { + case FSTT_BLKSIZE: + /* Zero for variable size record devices, nonzero for fixed + * block size devices. + */ + (*lvalue) = mp->mtdev.blksize; + break; + case FSTT_FILSIZE: + /* When reading there is no way to know the file size, so set + * it to the largest possible value to make all reads in bounds. + * When appending a file the file starts out zero length, so + * set the file size to zero for a write access. + */ + if (mp->acmode == READ_ONLY) + (*lvalue) = MAX_LONG; + else + (*lvalue) = 0; + break; + case FSTT_OPTBUFSIZE: + (*lvalue) = mp->mtdev.optrec; + break; + case FSTT_MAXBUFSIZE: + (*lvalue) = mp->mtdev.maxrec; + break; + default: + (*lvalue) = XERR; + } + + return (*lvalue); +} + + +/* ZZRWMT -- Rewind the tape. This routine is in principle asynchronous but + * this is not the case for most unix systems (unless the host driver does + * asynchronous rewind with synchronization internally). + * + * This routine is not part of the normal binary file driver. + */ +int +ZZRWMT ( + PKCHAR *device, /* device name */ + PKCHAR *devcap, /* tapecap entry for device */ + XINT *o_status +) +{ + register struct mtdesc *mp; + register int fd; + int status; + + /* Open the main device descriptor. */ + mp = zmtdesc ((char *)device, READ_ONLY, (char *)devcap, NULL); + if (mp == NULL) { + *o_status = ERR; + return (XERR); + } + + /* If a rewind-on-close device is defined for this device use that + * to do the rewind, otherwise open the no-rewind device RDONLY and do + * an explicit rewind. The RD device can also be used to avoid an + * error condition if the device does not support the MTREW ioctl. + */ + if (mp->flags & RD) { + if ((fd = zmtopen (mp->rw_device, RDONLY)) == ERR) + status = ERR; + else + status = zmtclose (fd); + } else { + if ((fd = zmtopen (mp->iodev, RDONLY)) == ERR) { + status = ERR; + } else if (mp->flags & FC) { + /* Device does a FSF when closed read-only, making it + * impossible to leave the tape rewound after the close. + * Return ERR to cause MTIO to mark the position undefined, + * forcing a rewind the next time the tape is opened for i/o. + */ + static FILE *tty = NULL; + if (!tty && (tty = fopen (CONSOLE, "a")) != NULL) { + fprintf (tty, "cannot rewind device %s: ", (char *)device); + fprintf (tty, "add RD capability to dev$devices entry\n"); + fclose (tty); + } + status = ERR; + } else { + /* Normal rewind. */ + status = zmtrew (fd); + status = zmtclose(fd) ? ERR : status; + } + } + + zmtdbg (mp, "file = 1"); + zmtdbg (mp, "record = 1"); + zmtfls (mp); + *o_status = status ? XERR : XOK; + zmtfree (mp); + + return (status); +} + + + +/* + * INTERNAL INTERFACE ROUTINES. + * ---------------------------- + */ + +/* ZMTGETFD -- Open tape read-only, if not already open, and return the + * file descriptor as the function value. If the tape is already open + * the only action is to return the file descriptor. This routine is used + * to delay the device open during file positioning operations, so that + * it can be skipped if it is not necessary to move the tape. + */ +static int +zmtgetfd (mp) +register struct mtdesc *mp; +{ + register int fd; + + if (*mp->chan > 0) + return (*mp->chan); + + *mp->chan = fd = zmtopen (mp->iodev, RDONLY); + if (fd >= MAXOFILES) { + zmtclose (fd); + fd = ERR; + } + + if (fd == ERR) + zmtdbgn (mp, "failed to open device %s\n", mp->iodev); + else { + zmtdbgn (mp, "device %s opened on descriptor %d\n", mp->iodev, fd); + set_mtdesc (fd, mp); + mp->errcnt = 0; + mp->tbytes = 0; + } + + return (fd); +} + + +/* ZMTOPEN -- Convert the magtape device name into a unix pathname and open + * the drive. Do not move the tape. + * + * Devices can be specified as + * + * devname system device name in /dev or /dev/rmt + * /devpath full pathname of device + * ~/devpath user home directory relative pathname + * + * Returns the unix file descriptor or ERR. + */ +static int +zmtopen ( + char *dev, /* device name or pathname */ + int u_acmode /* read only or write only for tapes */ +) +{ + char path[SZ_PATHNAME+1]; + int fd = ERR; + + /* If the device name is already a pathname leave it alone, else + * prepend the /dev/ or /dev/rmt prefix. The device file can be + * in the user's home directory if ~/dev is specified. + */ + if (dev[0] == '/') { + /* Full pathname. */ + fd = open (dev, u_acmode); + + } else if (dev[0] == '~' && dev[1] == '/') { + /* User home directory relative pathname. */ + struct passwd *pwd; + pwd = getpwuid (getuid()); + if (pwd != NULL) { + strcpy (path, pwd->pw_dir); + strcat (path, &dev[1]); + endpwent(); + fd = open (path, u_acmode); + } + } else { + /* System device. */ + strcpy (path, "/dev/"); + strcat (path, dev); + if ((fd = open (path, u_acmode)) == ERR) { + /* If that fails take a look in /dev/rmt too, since this + * is where some SysV systems like to hide raw magtape device + * files. + */ + strcpy (path, "/dev/rmt/"); + strcat (path, dev); + fd = open (path, u_acmode); + } + } + + return (fd); +} + + +/* ZMTCLOSE -- Close a magtape device. + */ +static int zmtclose (int fd) +{ + register struct mtdesc *mp = get_mtdesc(fd); + zmtdbg (get_mtdesc(fd), "close device\n"); + zmtfls (mp); + return (close (fd)); +} + + +/* ZMTDESC -- Allocate and initialize the main magtape device descriptor. + */ +static struct mtdesc * +zmtdesc ( + char *device, /* host device to be used for i/o */ + int acmode, /* iraf file access mode code */ + char *devcap, /* tapecap entry for device */ + struct _mtpos *devpos /* device position info (or NULL ptr) */ +) +{ + register struct mtdesc *mp; + register struct mtdev *dp; + register struct mtchar *pp; + register char *ip, *op; + int pname; + + /* Allocate and initialize the device descriptor. */ + if ((mp = (struct mtdesc *) calloc (1, sizeof(*mp))) == NULL) + return (NULL); + + dp = &mp->mtdev; + dp->maxrec = MAXREC; + dp->optrec = OPTREC; + strcpy (dp->devtype, "generic"); + strcpy (dp->tapetype, "unknown"); + + mp->acmode = acmode; + strcpy (mp->iodev, device); + mp->mtioctop = MTIOCTOP; + mp->mtbsr = MTBSR; + mp->mtbsf = MTBSF; + mp->mtfsr = MTFSR; + mp->mtfsf = MTFSF; + mp->mtrew = MTREW; + + if (devpos) { + mp->mtpos = *devpos; + mp->mtpos.pflags = 0; + } + + /* Prepare to scan tapecap entry. */ + for (pp=devpar; pp->pname; pp++) + pp->valset = 0; + + /* Process the tapecap entry. This is a sequence of entries of the + * form "nn=value", where the NN is a two character name, the "=" is + * actually either `=' or `#', and where successive entries are + * delimited by colons. For example, ":dv=nrst0:rd=rst0:bs#0:...". + */ + for (ip=devcap; *ip; ) { + while (*ip && *ip != ':') + ip++; + if (*ip == ':') + ip++; + else + break; + pname = PNAME(ip[0],ip[1]); + + ip += 2; + if (*ip == '=' || *ip == '#') + ip++; + + for (pp=devpar; pp->pname; pp++) { + if (pp->pname == pname) { + /* If multiple entries are given for the parameter ignore + * all but the first. + */ + if (pp->valset) + continue; + else + mp->flags |= pp->bitflag; + + /* Check for a negated entry (e.g., ":ir@:"). */ + if (*ip == '@') { + mp->flags &= ~pp->bitflag; + pp->valset++; + continue; + } + + /* Check for a string valued parameter. */ + switch (pp->pcode) { + case P_DV: op = mp->nr_device; break; + case P_RD: op = mp->rw_device; break; + case P_DN: op = mp->mtdev.density; break; + case P_DT: op = mp->mtdev.devtype; break; + case P_TT: op = mp->mtdev.tapetype; break; + case P_SO: op = mp->mtdev.statusdev; break; + default: op = NULL; + } + + if (op != NULL) { + int nchars; + + /* String valued parameters. */ + for (nchars=0; *ip && *ip != ':'; ip++, nchars++) { + if (*ip == '\\' && isdigit(*(ip+1))) { + int n, i; + for (n=i=0; i < 3; i++) + n = n * 10 + (*(++ip) - '0'); + *op++ = n; + } else + *op++ = *ip; + } + *op = EOS; + pp->valset++; + + /* Default if no string value given but entry was + * found, e.g., ":so:". + */ + if (!nchars) + if (pp->pcode == P_SO) + strcpy (mp->mtdev.statusdev, ","); + break; + + } else if (*ip != ':') { + /* Numeric parameters. */ + int n = 0; + + while (*ip && *ip != ':') { + if (isdigit (*ip)) + n = n * 10 + (*ip - '0'); + ip++; + } + + switch (pp->pcode) { + case P_CT: mp->mtioctop = n; break; + case P_BF: mp->mtbsf = n; break; + case P_BR: mp->mtbsr = n; break; + case P_FF: mp->mtfsf = n; break; + case P_FR: mp->mtfsr = n; break; + case P_RI: mp->mtrew = n; break; + + case P_BS: dp->blksize = n; break; + case P_FS: dp->eofsize = n; break; + case P_MR: dp->maxrec = n; break; + case P_NF: dp->maxbsf = n; break; + case P_OR: dp->optrec = n; break; + case P_RS: dp->gapsize = n; break; + case P_TS: dp->tapesize = n; break; + default: /* ignore (bitflags) */ + ; + } + + pp->valset++; + break; + } + } + } + } + + /* Apply some obvious constraints. */ + if (dp->blksize) { + dp->maxrec = dp->maxrec / dp->blksize * dp->blksize; + dp->optrec = dp->optrec / dp->blksize * dp->blksize; + } + if (dp->maxrec > 0 && dp->optrec > dp->maxrec) + dp->optrec = dp->maxrec; + + zmtdbgopen (mp); + return (mp); +} + + +/* ZMTFREE -- Free the magtape device descriptor. + */ +static void +zmtfree (struct mtdesc *mp) +{ + zmtdbgclose (mp); + free (mp); +} + + +/* ZMTFPOS -- Position to the indicated file. The first file is #1. + * A negative newfile number signifies EOT. + */ +static int +zmtfpos ( + register struct mtdesc *mp, + int newfile /* file we want to position to */ +) +{ + register struct _mtpos *pp = &mp->mtpos; + register int flags = mp->flags; + int oldfile, oldrec, maxrec; + char *buf = NULL; + int fd, status, n; + + oldfile = pp->filno; + oldrec = pp->recno; + + if (newfile > 0) + zmtdbgn (mp, "position to file %d\n", newfile); + else if (newfile < 0) + zmtdbg (mp, "position to end of tape\n"); + else + return (oldfile); + + /* If we are positioning to EOT and UE is not set to force a search + * for EOT, use the nfiles information in the position descriptor to + * position to just before the EOT marker. + */ + if (newfile < 0 && !(flags&UE) && pp->nfiles > 0) { + newfile = pp->nfiles + 1; + zmtdbgn (mp, "end of tape is file %d\n", newfile); + } + zmtfls (mp); + + /* Don't do anything if already positioned to desired file and no + * further positioning is necessary. + */ + if (newfile == oldfile && oldrec == 1 && (!(flags & OW) || + newfile < pp->nfiles + 1 || mp->acmode == READ_ONLY)) + return (newfile); + + /* It is necessary to move the tape. Open the device if it has + * not already been opened. + */ + if ((fd = zmtgetfd(mp)) < 0) + return (ERR); + + /* Move the tape. */ + if (newfile == 1) { + if (zmtrew(fd) < 0) + return (ERR); + + } else if (newfile <= oldfile && newfile > 0) { + /* Backspace to the desired file. */ + if ((flags & NB) || + ((flags & NF) && oldfile - newfile > mp->mtdev.maxbsf)) { + + /* Device cannot backspace or is slow to backspace; must + * rewind and space forward. + */ + if (zmtrew(fd) < 0) + return (ERR); + oldfile = oldrec = 1; + zmtdbgn (mp, "file = %d", oldfile); + zmtfls (mp); + goto fwd; + } else if (flags & BO) { + /* BSF positions to BOF. */ + if (zmtbsf (fd, oldfile - newfile) < 0) + return (ERR); + } else { + /* BSF positions to BOT side of filemark. */ + if (zmtbsf (fd, oldfile - newfile + 1) < 0) + return (ERR); + else if (zmtfsf (fd, 1) < 0) + return (ERR); + } + + } else if (newfile < 0 && !(flags & UE) && + (pp->nfiles > 0 && oldfile == pp->nfiles+1)) { + + /* Already at EOT. */ + newfile = oldfile; + if ((flags & OW) && mp->acmode == WRITE_ONLY) + goto oweot; + + } else { + /* Space forward to desired file or EOT. + */ +fwd: + /* Fast file skip forward to numbered file. Used only when + * positioning to a numbered file, as opposed to positioning + * to EOT and the number of files on the tape is unknown. + * A multifile FSF is much faster on some devices than skipping + * a file at a time. It is also an atomic, uninterruptable + * operation so may be undesirable on devices where file + * positioning takes a long time, and could result in tape + * runaway in an attempt to position beyond EOT (if the host + * device driver cannot detect this). Fast skip is enabled if + * the MF (multifile-file) flag is set. + */ + if (newfile > oldfile && (flags & MF)) { + if (zmtfsf (fd, newfile - oldfile) < 0) + return (ERR); + + oldfile = newfile; + if ((flags & OW) && mp->acmode == WRITE_ONLY) + goto oweot; + else + goto done; + } + + /* Get a read buffer as large as the largest possible record, + * for variable record size devices, or the size of a device + * block for fixed block devices. + */ + if (mp->mtdev.blksize) + maxrec = mp->mtdev.blksize; + else { + maxrec = mp->mtdev.maxrec; + if (maxrec <= 0) + maxrec = MAXREC; + } + if (buf == NULL && !(buf = malloc(maxrec))) + return (ERR); + + /* Skip file forward one file at a time. This is tricky as we + * must be able to detect EOT when spacing forward or we risk + * tape runaway. Detecting EOT portably requires looking for + * a double EOT. We FSF to the next file and then read the + * first record; a read of zero (or ERR on some devices) signals + * a tape mark and hence double EOF or EOT. + */ + while (oldfile < newfile || newfile < 0) { + /* Test if the next record is a data record or filemark. */ + n = read (fd, buf, maxrec); + + /* Check for EOT, signified by two consecutive logical + * filemarks, or equivalently, a zero length file. On + * some systems a read at EOT might be an error, so treat + * a read error the same as EOF if the RE capability is set. + * (the IR flag causes all read errors to be treated as EOF + * and is intended only to try to workaround host driver bugs). + */ + if (n < 0 && !(flags & (RE|IR))) { + goto err; + } else if (n <= 0 && oldrec == 1) { + /* At EOT. Leave the tape between the filemarks if such + * a concept applies to the current device. If SE is + * not specified for the device, we are already there. + */ + + pp->nfiles = (newfile=oldfile) - 1; + zmtdbgn (mp, "nfiles = %d", pp->nfiles); + zmtdbg (mp, "at end of tape\n"); + zmtfls (mp); + + if (flags & SE) { + /* Cannot backspace? */ + if (flags & NB) { + newfile = oldfile; + if (zmtrew (fd) < 0) + goto err; + if (zmtfsf (fd, newfile - 1) < 0) + goto err; + oldrec = 1; + break; + } else { + if ((((flags & RF) ? zmtbsr:zmtbsf)(fd, 1)) < 0) + goto err; + } + } +oweot: + /* On some devices, e.g., 1/2 inch reel tape, the space + * between the two filemarks marking EOT can be large and + * we can get more data on the tape if we back up over the + * first filemark and then space forward over it, leaving + * the tape just after the first filemark rather than just + * before the second one. The OW (overwrite) capability + * enables this. + */ + if ((flags & OW) && !(flags & NB) && + mp->acmode == WRITE_ONLY) { + + if (flags & RF) { + status = zmtbsr (fd, 1); + status = (zmtfsr (fd, 1) < 0) ? ERR : status; + } else if (flags & BO) { + /* This may not actually do anything, depending + * upon the host driver... */ + status = zmtbsf (fd, 0); + } else { + status = zmtbsf (fd, 1); + status = (zmtfsf (fd, 1) < 0) ? ERR : status; + } + if (status < 0) + goto err; + } + + break; + + } else if (n > 0) { + if (zmtfsf (fd, 1) < 0) { +err: free (buf); + return (ERR); + } + } + + oldfile++; + oldrec = 1; + zmtdbgn (mp, "file = %d", oldfile); + zmtfls (mp); + } + + /* Set newfile to the file we actually ended up positioned to. */ + newfile = oldfile; + free (buf); + } +done: + /* Update position descriptor */ + pp->filno = newfile; + pp->recno = 1; + + return (newfile); +} + + +/* ZMTREW -- Rewind the tape. + */ +static int +zmtrew (int fd) +{ + register struct mtdesc *mp = get_mtdesc(fd); + struct mtop mt_rewind; + int status; + + mt_rewind.mt_op = mp->mtrew; + mt_rewind.mt_count = 1; + + zmtdbg (mp, "rewinding..."); + zmtfls (mp); + status = ioctl (fd, mp->mtioctop, (char *)&mt_rewind); + zmtdbgn (mp, "%s\n", status < 0 ? "failed" : "done"); + zmtfls (mp); + + return (status); +} + + +/* ZMTFSF -- Skip file forward. + */ +static int +zmtfsf (int fd, int nfiles) +{ + register struct mtdesc *mp = get_mtdesc(fd); + struct mtop mt_fwdskipfile; + int status; + + mt_fwdskipfile.mt_op = mp->mtfsf; + mt_fwdskipfile.mt_count = nfiles; + + zmtdbgn (mp, "skip %d file%s forward...", nfiles, + nfiles > 1 ? "s" : ""); + zmtfls (mp); + status = ioctl (fd, mp->mtioctop, (char *)&mt_fwdskipfile); + zmtdbgn (mp, "%s\n", status < 0 ? "failed" : "done"); + zmtfls (mp); + + return (status); +} + + +/* ZMTBSF -- Skip file backward. + */ +static int +zmtbsf (int fd, int nfiles) +{ + register struct mtdesc *mp = get_mtdesc(fd); + struct mtop mt_backskipfile; + int status; + + mt_backskipfile.mt_op = mp->mtbsf; + mt_backskipfile.mt_count = nfiles; + + zmtdbgn (mp, "skip %d file%s backward...", nfiles, + nfiles > 1 ? "s" : ""); + zmtfls (mp); + status = ioctl (fd, mp->mtioctop, (char *)&mt_backskipfile); + zmtdbgn (mp, "%s\n", status < 0 ? "failed" : "done"); + zmtfls (mp); + + return (status); +} + + +/* ZMTFSR -- Skip record forward. + */ +static int +zmtfsr (int fd, int nrecords) +{ + register struct mtdesc *mp = get_mtdesc(fd); + struct mtop mt_fwdskiprecord; + int status; + + mt_fwdskiprecord.mt_op = mp->mtfsr; + mt_fwdskiprecord.mt_count = nrecords; + + zmtdbgn (mp, "skip %d record%s forward...", nrecords, + nrecords > 1 ? "s" : ""); + zmtfls (mp); + status = ioctl (fd, mp->mtioctop, (char *)&mt_fwdskiprecord); + zmtdbgn (mp, "%s\n", status < 0 ? "failed" : "done"); + zmtfls (mp); + + return (status); +} + + +/* ZMTBSR -- Skip record backward. + */ +static int +zmtbsr (int fd, int nrecords) +{ + register struct mtdesc *mp = get_mtdesc(fd); + struct mtop mt_backskiprecord; + int status; + + mt_backskiprecord.mt_op = mp->mtbsr; + mt_backskiprecord.mt_count = nrecords; + + zmtdbgn (mp, "skip %d record%s backward...", nrecords, + nrecords > 1 ? "s" : ""); + zmtfls (mp); + status = ioctl (fd, mp->mtioctop, (char *)&mt_backskiprecord); + zmtdbgn (mp, "%s\n", status < 0 ? "failed" : "done"); + zmtfls (mp); + + return (status); +} + + +/* + * I/O logging routines. + * + * zmtdbgopen (mp) + * zmtdbg (mp, msg) + * zmtdbgn (mp, fmt, arg) + * zmtdbgn (mp, fmt, arg1, arg2) + * zmtdbg3 (mp, fmt, arg1, arg2, arg3) + * zmtfls (mp) + * zmtdbgclose (mp) + * + * Output may be written to either a file, if an absolute file pathname is + * given, or to a socket specified as "host[,port]". + */ + +#ifdef TCPIP +static SIGFUNC sigpipe = NULL; +static int nsockets = 0; +static int s_port[MAXDEV]; +static FILE *s_fp[MAXDEV]; +static int s_fd[MAXDEV]; +static int s_checksum[MAXDEV]; +#endif + +/* ZMTDBGOPEN -- Attempt to open a file or socket for status logging. + */ +static void zmtdbgopen (struct mtdesc *mp) +{ +#ifndef TCPIP + if (!mp->mtdev.statusdev[0] || mp->mtdev.statusout) + return; + if (mp->mtdev.statusdev[0] == '/') + mp->mtdev.statusout = fopen (mp->mtdev.statusdev, "a"); +#else + register char *ip, *op; + struct sockaddr_in sockaddr; + int port, isfile, sum, s, i; + char host[SZ_FNAME]; + struct hostent *hp; + FILE *fp = (FILE *) NULL; + + + /* Status logging disabled. */ + if (!mp->mtdev.statusdev[0]) + return; + + /* Status device already open. This is only possible in repeated + * calls to zmtdbgopen after a zzopmt. + */ + if (mp->mtdev.statusout) { + if (nsockets > 0 && !sigpipe) + sigpipe = (SIGFUNC) signal (SIGPIPE, SIG_IGN); + return; + } + + /* Compute statusdev checksum. */ + for (sum=0, ip = mp->mtdev.statusdev; *ip; ip++) + sum += (sum + *ip); + + /* Log status output to a file if a pathname is specified. + */ + for (isfile=0, ip=mp->mtdev.statusdev; *ip; ip++) + if ((isfile = (*ip == '/'))) + break; + if (isfile) { + mp->mtdev.statusout = fopen (mp->mtdev.statusdev, "a"); + if (mp->mtdev.statusout) { + for (i=0; i < MAXDEV; i++) + if (!s_fp[i]) { + s_fp[i] = mp->mtdev.statusout; + s_port[i] = s_fd[i] = 0; + s_checksum[i] = sum; + break; + } + } + return; + } + + /* If the entry is of the form "host" or "host,port" then status output + * is written to a socket connected to the specified host and port. + */ + for (ip=mp->mtdev.statusdev, op=host; *ip && *ip != ','; ) + *op++ = *ip++; + *op = EOS; + if (!host[0]) + strcpy (host, "localhost"); + if (*ip == ',') + ip++; + port = (isdigit(*ip)) ? atoi(ip) : DEFPORT; + + /* Is port already open in cache? */ + s = 0; + for (i=0; i < MAXDEV; i++) + if (s_port[i] == port) { + if (s_checksum[i] != sum) { + fclose (s_fp[i]); + s_fd[i] = s_port[i] = s_checksum[i] = 0; + s_fp[i] = NULL; + } else { + s = s_fd[i]; + fp = s_fp[i]; + } + break; + } + + if (!s) { + if ((hp = gethostbyname(host)) == NULL) + return; + if ((s = socket (AF_INET, SOCK_STREAM, 0)) < 0) + return; + + bzero ((char *)&sockaddr, sizeof(sockaddr)); + bcopy ((char *)hp->h_addr,(char *)&sockaddr.sin_addr, hp->h_length); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = htons((short)port); + if (connect (s,(struct sockaddr *)&sockaddr,sizeof(sockaddr)) < 0) { + close (s); + return; + } + + fp = fdopen (s, "w"); + for (i=0; i < MAXDEV; i++) + if (!s_fp[i]) { + s_port[i] = port; + s_fd[i] = s; + s_fp[i] = fp; + s_checksum[i] = sum; + break; + } + } + + /* Ignore signal generated if server goes away unexpectedly. */ + nsockets++; + if (!sigpipe) + sigpipe = signal (SIGPIPE, SIG_IGN); + + mp->mtdev.statusout = fp; + zmtdbgn (mp, "iodev = %s", mp->iodev); + if (gethostname (host, SZ_FNAME) == 0) + zmtdbgn (mp, "host = %s", host); +#endif +} + + +/* ZMTDBGCLOSE -- Close the status output. Called at ZZCLMT time. If the + * status output is a socket merely flush the output and restore the original + * sigpipe signal handler if the reference count for the process goes to zero. + * If the output is a file always close the file. If the debug output is + * changed from a socket to a file during the execution of a process this + * will leave a socket open, never to be closed, but this is not likely to + * be worth fixing since the status output device, if used, should change + * infrequently. + */ +static void zmtdbgclose (struct mtdesc *mp) +{ + register int i; + + if (mp->mtdev.statusout) { + fflush (mp->mtdev.statusout); + for (i=0; i < MAXDEV; i++) { + if (s_fp[i] == mp->mtdev.statusout) { + if (s_port[i]) + nsockets--; + else { + fclose (mp->mtdev.statusout); + s_checksum[i] = 0; + s_fp[i] = NULL; + } + break; + } + } + + if (sigpipe && nsockets <= 0) { +#ifdef AUX + signal (SIGPIPE, (sigfunc_t)sigpipe); +#else + signal (SIGPIPE, sigpipe); +#endif + sigpipe = (SIGFUNC) NULL; + nsockets = 0; + } + } +} + +static void zmtdbg (struct mtdesc *mp, char *msg) +{ + register FILE *out; + register char *ip; + + if ((out = mp->mtdev.statusout)) { + for (ip=msg; *ip; ip++) { + if (*ip == '\n') { + putc ('\\', out); + putc ('n', out); + } else + putc (*ip, out); + } + putc ('\n', out); + } +} + +static void zmtfls (struct mtdesc *mp) +{ + FILE *out; + if ((out = mp->mtdev.statusout)) + fflush (out); +} + +static void zmtdbgn ( struct mtdesc *mp, const char *argsformat, ... ) +{ + va_list ap; + char obuf[SZ_LINE]; + va_start (ap, argsformat); + vsnprintf (obuf, SZ_LINE, argsformat, ap); + va_end (ap); + obuf[SZ_LINE-1]='\0'; + zmtdbg (mp, obuf); +} + + + +#else + +int ZZOPMT ( + PKCHAR *device, /* device name */ + XINT *acmode, /* access mode: read_only or write_only for tapes */ + PKCHAR *devcap, /* tapecap entry for device */ + XINT *devpos, /* pointer to tape position info struct */ + XINT *newfile, /* file to be opened or EOT */ + XINT *chan /* OS channel of opened file */ +) +{ + return (XERR); +} + + +int ZZCLMT (XINT *chan, XINT *devpos, XINT *o_status) +{ + return (XERR); +} + + +int ZZRDMT ( + XINT *chan, + XCHAR *buf, + XINT *maxbytes, + XLONG *offset /* fixed block devices only */ +) +{ + return (XERR); +} + + +int ZZWRMT ( + XINT *chan, + XCHAR *buf, + XINT *nbytes, + XLONG *offset /* ignored on a write */ +) +{ + return (XERR); +} + + +int ZZWTMT ( + XINT *chan, + XINT *devpos, + XINT *o_status +) +{ + return (XERR); +} + + +int ZZSTMT (XINT *chan, XINT *param, XLONG *lvalue) +{ + return (XERR); +} + + +int ZZRWMT ( + PKCHAR *device, /* device name */ + PKCHAR *devcap, /* tapecap entry for device */ + XINT *o_status +) +{ + return (XERR); +} + + +#endif + + diff --git a/unix/os/zfiond.c b/unix/os/zfiond.c new file mode 100644 index 00000000..6f12413f --- /dev/null +++ b/unix/os/zfiond.c @@ -0,0 +1,918 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef LINUX +#include +#endif +#ifdef MACOSX +#include +#endif + +#include +#include + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_spp +#include + +/* + * ZFIOND -- This driver provides a FIO-compatible interface to network or + * IPC streaming devices such as Berkeley sockets, FIFOs, and the like. + * Any connection-oriented stream type network interface can be supported. + * + * The type of connection desired is determined at device open time by the + * "filename" and file access mode arguments. The syntax for the filename + * argument is as follows: + * + * :
[ : flag ] [ : flag...] + * + * where is one of "inet" (internet tcp/ip socket), "unix" (unix + * domain socket) or "fifo" (named pipe). The form of the address depends + * upon the domain, as illustrated in the examples below. + * + * inet:5187 Server connection to port 5187 on the local + * host. For a client, a connection to the + * given port on the local host. + * + * inet:5187:foo.bar.edu Client connection to port 5187 on internet + * host foo.bar.edu. The dotted form of address + * may also be used. + * + * unix:/tmp/.IMT212 Unix domain socket with the given pathname + * IPC method, local host only. + * + * fifo:/dev/imt1i:/dev/imt1o FIFO or named pipe with the given pathname. + * IPC method, local host only. Two pathnames + * are required, one for input and one for + * output, since FIFOs are not bidirectional. + * For a client the first fifo listed will be + * the client's input fifo; for a server the + * first fifo will be the server's output fifo. + * This allows the same address to be used for + * both the client and the server, as for the + * other domains. + * + * sock:5 Used by servers to accept a connection on + * a server socket opened in nonblocking mode + * on the given channel (5 in the example). + * The channel is returned in a previous call + * to open an INET or UNIX server port. + * + * The address field may contain up to two "%d" fields. If present, the + * user's UID will be substituted (e.g. "unix:/tmp/.IMT%d"). + * + * The protocol flags currently supported are "text", "binary", "nonblock", + * and "nodelay". If "text" is specified the datastream is assumed to + * consist only of byte packed ascii text and is automatically converted by + * the driver to and from SPP chars during i/o. The default is binary i/o + * (no conversions). The "nonblock" flag is used to specify nonblocking + * mode. The "nodelay" flag is used to return an error when opening a + * "sock" connection in "nonblock" mode and for read when there is no + * pending connection or data. + * + * + * Client connections normally use mode READ_WRITE, although READ_ONLY and + * WRITE_ONLY are permitted. APPEND is the same as WRITE_ONLY. A server + * connection is indicated by the mode NEW_FILE. The endpoints of the server + * connection will be created if necessary. A client connection will timeout + * if no server responds. + * + * By default a server connection will block until a client connects, and + * the channel returned will be the i/o channel for the client connection. + * If however a server connection is opened in nonblocking mode then a server + * socket will be opened which can be used for multiple client connections. + * When a client makes a connection attempt, opening the server socket as + * "sock:", where is the channel assigned to the socket, will + * accept the client connection and open a new channel to be used for + * bidirectional i/o to the client. The open will block until a client + * connects unless the socket is opened in nonblocking mode. If opening the + * channel under IRAF FIO and separate read and write streams are desired, + * this can be achieved by using REOPEN to open a second stream on the same + * channel). The server sees an EOF on the input stream when the client + * disconnects. + * + * The "nodelay" flag will poll for "sock" connections or for a pending + * read. This uses the SELECT call. If there is no pending connection + * then the open call will return an error through FIO. The application + * may trap the error and try again later. If there is no pending data in a + * read then the number of bytes read is set to XERR and FIO will return ERR. + * The exception to this is if asynchronous reads are used with AREADB + * and AWAITB. In this case the application will see the number of bytes + * read as zero for EOF (client disconnected) and ERR for no data. + * + * FIFO domain connection are slightly different. When the server opens a + * FIFO connection the open returns immediately. When the server reads from + * the input fifo the server will block until some data is written to the + * fifo by a client. The server connection will remain open over multiple + * client connections until it is closed by the server. This is done to + * avoid a race condition that could otherwise occur at open time, with both + * the client and the server blocked waiting for an open on the opposite stream. + */ + +#define SZ_NAME 256 +#define SZ_OBUF 4096 +#define MAXCONN 32 +#define MAXSEL 32 + +#define INET 1 +#define UNIX 2 +#define FIFO 3 +#define SOCK 4 + +#define F_SERVER 00001 +#define F_NONBLOCK 00002 +#define F_TEXT 00004 +#define F_DEL1 00010 +#define F_DEL2 00020 +#define F_NODELAY 00040 + +/* Network portal descriptor. */ +struct portal { + int channel; + int domain; + int flags; + int datain; + int dataout; + int keepalive; + char path1[SZ_NAME]; + char path2[SZ_NAME]; +}; + +#define get_desc(fd) ((struct portal *)zfd[fd].fp) +#define set_desc(fd,np) zfd[fd].fp = (FILE *)np +#define min(a,b) (((a)<(b))?(a):(b)) + +static jmp_buf jmpbuf; +static int jmpset = 0; +static int recursion = 0; +extern int errno; +static int getstr(); + +static void nd_onsig (int sig, int *arg1, int *arg2); + + + +/* ZOPNND -- Open a network device. + */ +int +ZOPNND ( + PKCHAR *pk_osfn, /* UNIX name of file */ + XINT *mode, /* file access mode */ + XINT *chan /* file number (output) */ +) +{ + register int fd; + register struct portal *np, *s_np = (struct portal *) NULL; + unsigned short host_port = 0; + unsigned long host_addr = 0; + char osfn[SZ_NAME*2]; + char flag[SZ_NAME]; + char *ip; + + /* Get network device descriptor. */ + if (!(np = (struct portal *) calloc (1, sizeof(struct portal)))) { + *chan = XERR; + return (XERR); + } + + /* Expand any %d fields in the network address to the UID. */ + sprintf (osfn, (char *)pk_osfn, getuid(), getuid()); + + /* Parse the network filename to determine the domain type and + * network address. + */ + if (strncmp (osfn, "inet:", 5) == 0) { + /* Internet connection. + */ + char port_str[SZ_NAME]; + char host_str[SZ_NAME]; + unsigned short port; + struct servent *sv; + struct hostent *hp; + + /* Get port number. This may be specified either as a service + * name or as a decimal port number. + */ + ip = osfn + 5; + if (getstr (&ip, port_str, SZ_NAME, ':') <= 0) + goto err; + if (isdigit (port_str[0])) { + port = atoi (port_str); + host_port = htons (port); + } else if ((sv = getservbyname(port_str,"tcp"))) { + host_port = sv->s_port; + } else + goto err; + + /* Get host address. This may be specified either has a host + * name or as an Internet address in dot notation. If no host + * name is specified default to the local host. + */ + if (getstr (&ip, host_str, SZ_NAME, ':') <= 0) + strcpy (host_str, "localhost"); + if (isdigit (host_str[0])) { + host_addr = inet_addr (host_str); + if ((int)host_addr == -1) + goto err; + } else if ((hp = gethostbyname(host_str))) { + bcopy (hp->h_addr, (char *)&host_addr, sizeof(host_addr)); + } else + goto err; + + np->domain = INET; + + } else if (strncmp (osfn, "unix:", 5) == 0) { + /* Unix domain socket connection. + */ + ip = osfn + 5; + if (!getstr (&ip, np->path1, SZ_NAME, ':')) + goto err; + np->domain = UNIX; + + } else if (strncmp (osfn, "sock:", 5) == 0) { + /* Open (accept) a client connection on an existing, open + * server socket. + */ + char chan_str[SZ_NAME]; + int channel; + + /* Get the channel of the server socket. */ + ip = osfn + 5; + if (getstr (&ip, chan_str, SZ_NAME, ':') <= 0) + goto err; + if (isdigit (chan_str[0])) + channel = atoi (chan_str); + else + goto err; + + /* Get the server portal descriptor. */ + s_np = get_desc(channel); + if (!(s_np->flags & F_SERVER)) + goto err; + + np->domain = SOCK; + + } else if (strncmp (osfn, "fifo:", 5) == 0) { + /* FIFO (named pipe) connection. + */ + ip = osfn + 5; + if (*mode == NEW_FILE) { + /* Server. */ + if (!getstr (&ip, np->path2, SZ_NAME, ':')) + goto err; + if (!getstr (&ip, np->path1, SZ_NAME, ':')) + goto err; + } else { + /* Client. */ + if (!getstr (&ip, np->path1, SZ_NAME, ':')) + goto err; + if (!getstr (&ip, np->path2, SZ_NAME, ':')) + goto err; + } + np->domain = FIFO; + + } else + goto err; + + /* Process any optional protocol flags. + */ + while (getstr (&ip, flag, SZ_NAME, ':') > 0) { + /* Get content type (text or binary). If the stream will be used + * only for byte-packed character data the content type can be + * specified as "text" and data will be automatically packed and + * unpacked during i/o. + */ + if (strcmp (flag, "text") == 0) + np->flags |= F_TEXT; + if (strcmp (flag, "binary") == 0) + np->flags &= ~F_TEXT; + + /* Check for nonblocking i/o or connections. */ + if (strcmp (flag, "nonblock") == 0) + np->flags |= F_NONBLOCK; + + /* Check for no delay flag. */ + if (strcmp (flag, "nodelay") == 0) + np->flags |= F_NODELAY; + } + + /* Open the network connection. + */ + switch (*mode) { + case READ_ONLY: + /* Client side read only FIFO connection. */ + if (np->domain == FIFO) { + if ((fd = open (np->path1, O_RDONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_RDONLY); + np->datain = fd; + np->dataout = -1; + break; + } + /* fall through */ + + case WRITE_ONLY: + case APPEND: + /* Client side write only FIFO connection. */ + if (np->domain == FIFO) { + if ((fd = open (np->path2, O_WRONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_WRONLY); + np->datain = -1; + np->dataout = fd; + break; + } + /* fall through */ + + case READ_WRITE: + if (np->domain == INET) { + /* Client side Internet domain connection. */ + struct sockaddr_in sockaddr; + + /* Get socket. */ + if ((fd = socket (AF_INET, SOCK_STREAM, 0)) < 0) + goto err; + + /* Compose network address. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = host_port; + bcopy ((char *)&host_addr, (char *)&sockaddr.sin_addr, + sizeof(host_addr)); + + /* Connect to server. */ + if (fd >= MAXOFILES || (connect (fd, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0)) { + close (fd); + fd = ERR; + } else { + np->datain = fd; + np->dataout = fd; + } + + } else if (np->domain == UNIX) { + /* Client side Unix domain socket connection. */ + struct sockaddr_un sockaddr; + + /* Get socket. */ + if ((fd = socket (AF_UNIX, SOCK_STREAM, 0)) < 0) + goto err; + + /* Compose network address. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sun_family = AF_UNIX; + strncpy (sockaddr.sun_path, + np->path1, sizeof(sockaddr.sun_path)); + + /* Connect to server. */ + if (fd >= MAXOFILES || (connect (fd, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0)) { + close (fd); + fd = ERR; + } else { + np->datain = fd; + np->dataout = fd; + } + + } else if (np->domain == FIFO) { + /* Client side FIFO connection. */ + int fd1, fd2; + + /* Open the fifos. */ + if ((fd1 = open (np->path1, O_RDONLY|O_NDELAY)) != ERR) + fcntl (fd1, F_SETFL, O_RDONLY); + if ((fd2 = open (np->path2, O_WRONLY|O_NDELAY)) != ERR) + fcntl (fd2, F_SETFL, O_WRONLY); + + /* Clean up if there is an error. */ + if (fd1 < 0 || fd1 > MAXOFILES || fd2 < 0 || fd2 > MAXOFILES) { + if (fd1 > 0) + close (fd1); + if (fd2 > 0) + close (fd2); + fd = ERR; + } else { + np->datain = fd1; + np->dataout = fd2; + fd = fd1; + } + } else + goto err; + break; + + case NEW_FILE: + /* Connect to a client. */ + np->flags |= F_SERVER; + + if (np->domain == INET) { + /* Server side Internet domain connection. */ + struct sockaddr_in sockaddr; + int s, reuse=1; + + /* Get socket. */ + if ((s = socket (AF_INET, SOCK_STREAM, 0)) < 0) + goto err; + + /* Bind server port to socket. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = host_port; + sockaddr.sin_addr.s_addr = htonl(INADDR_ANY); + + if (setsockopt(s, SOL_SOCKET, SO_REUSEADDR, (char *)&reuse, + sizeof(reuse)) < 0) { + close (s); + goto err; + } + + if (bind (s, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) { + close (s); + goto err; + } + + /* Enable queuing of client connections. */ + if (listen (s, MAXCONN) < 0) { + close (s); + goto err; + } + + /* If in blocking mode wait for a client connection, otherwise + * return the server socket on the channel. + */ + if (!(np->flags & F_NONBLOCK)) { + if ((fd = accept (s, (struct sockaddr *)0, + (socklen_t *)0)) < 0) { + close (s); + goto err; + } else + close (s); + } else + fd = s; + + np->datain = fd; + np->dataout = fd; + + } else if (np->domain == UNIX) { + /* Server side Unix domain connection. */ + struct sockaddr_un sockaddr; + int addrlen, s; + + /* Get socket. */ + if ((s = socket (AF_UNIX, SOCK_STREAM, 0)) < 0) + goto err; + + /* Bind server port to socket. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sun_family = AF_UNIX; + strncpy (sockaddr.sun_path,np->path1,sizeof(sockaddr.sun_path)); + addrlen = sizeof(sockaddr) - sizeof(sockaddr.sun_path) + + strlen(np->path1); + + unlink (np->path1); + if (bind (s, (struct sockaddr *)&sockaddr, addrlen) < 0) { + close (s); + goto err; + } + + /* Enable queuing of client connections. */ + if (listen (s, MAXCONN) < 0) { + close (s); + goto err; + } + + /* If in blocking mode wait for a client connection, otherwise + * return the server socket on the channel. + */ + if (!(np->flags & F_NONBLOCK)) { + if ((fd = accept (s, (struct sockaddr *)0, + (socklen_t *)0)) < 0) { + close (s); + goto err; + } else + close (s); + } else + fd = s; + + np->datain = fd; + np->dataout = fd; + np->flags |= F_DEL1; + + } else if (np->domain == SOCK) { + /* Open (accept) a client connection on a server socket. */ + int s = s_np->channel; + + if (s_np->flags & F_NODELAY) { + struct timeval timeout; +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + fd_set readfds; + FD_ZERO (&readfds); + FD_SET (s, &readfds); +#else + int readfds = (1 << s); +#endif + timeout.tv_sec = 0; + timeout.tv_usec = 0; + if (select (MAXSEL, &readfds, NULL, NULL, &timeout)) { + if ((fd = accept (s, (struct sockaddr *)0, + (socklen_t *)0))<0) + goto err; + } else { + goto err; + } + } else { + if ((fd = accept (s, (struct sockaddr *)0, + (socklen_t *)0)) < 0) + goto err; + } + + np->datain = fd; + np->dataout = fd; + np->flags = s_np->flags; + + } else if (np->domain == FIFO) { + /* Server side FIFO connection. */ + int fd1=0, fd2=0, keepalive=0; + + /* Create fifos if necessary. */ + if (access (np->path1, 0) < 0) { + if (mknod (np->path1, 010660, 0) < 0) + goto err; + else + np->flags |= F_DEL1; + } + if (access (np->path2, 0) < 0) { + if (mknod (np->path2, 010660, 0) < 0) { + unlink (np->path1); + goto err; + } else + np->flags |= F_DEL2; + } + + /* Open the output fifo (which is the client's input fifo). + * We have to open it ourselves first as a client to get + * around the fifo open-no-client error. + */ + if ((fd1 = open (np->path2, O_RDONLY|O_NDELAY)) != -1) { + if ((fd2 = open (np->path2, O_WRONLY|O_NDELAY)) != -1) + fcntl (fd2, F_SETFL, O_WRONLY); + close (fd1); + } + + /* Open the input fifo. */ + if ((fd1 = open (np->path1, O_RDONLY|O_NDELAY)) == -1) + fprintf (stderr, "Warning: cannot open %s\n", np->path1); + else { + /* Clear O_NDELAY for reading. */ + fcntl (fd1, F_SETFL, O_RDONLY); + + /* Open the client's output fifo as a pseudo-client to + * make it appear that a client is connected. + */ + keepalive = open (np->path1, O_WRONLY); + } + + /* Clean up if there is an error. */ + if (fd1 < 0 || fd1 > MAXOFILES || fd2 < 0 || fd2 > MAXOFILES) { + if (fd1 > 0) { + close (fd1); + close (keepalive); + } + if (fd2 > 0) + close (fd2); + fd = ERR; + } else { + np->datain = fd1; + np->dataout = fd2; + np->keepalive = keepalive; + fd = fd1; + } + + } else + goto err; + break; + + default: + fd = ERR; + } + + /* Initialize the kernel file descriptor. Seeks are illegal for a + * network device; network devices are "streaming" files (blksize=1) + * which can only be accessed sequentially. + */ + if ((*chan = fd) == ERR) { +err: free (np); + *chan = XERR; + } else if (fd >= MAXOFILES) { + free (np); + close (fd); + *chan = XERR; + } else { + zfd[fd].fp = NULL; + zfd[fd].fpos = 0L; + zfd[fd].nbytes = 0; + zfd[fd].flags = 0; + zfd[fd].filesize = 0; + set_desc(fd,np); + np->channel = fd; + } + + return (*chan); +} + + +/* ZCLSND -- Close a network device. + */ +int +ZCLSND (XINT *fd, XINT *status) +{ + register struct portal *np = get_desc(*fd); + register int flags; + + if (np) { + flags = np->flags; + + if (np->datain > 0) + close (np->datain); + if (np->dataout > 0 && np->dataout != np->datain) + close (np->dataout); + if (np->keepalive > 0) + close (np->keepalive); + + if (flags & F_DEL1) + unlink (np->path1); + if (flags & F_DEL2) + unlink (np->path2); + + free (np); + set_desc(*fd,NULL); + *status = XOK; + + } else + *status = XERR; + + return (*status); +} + + +/* ZARDND -- "Asynchronous" binary block read. Initiate a read of at most + * maxbytes bytes from the file FD into the buffer BUF. Status is returned + * in a subsequent call to ZAWTND. + */ +int +ZARDND ( + XINT *chan, /* UNIX file number */ + XCHAR *buf, /* output buffer */ + XINT *maxbytes, /* max bytes to read */ + XLONG *offset /* 1-indexed file offset to read at */ +) +{ + register int n; + int fd = *chan; + struct fiodes *kfp = &zfd[fd]; + register struct portal *np = get_desc (fd); + register char *ip; + register XCHAR *op; + int nbytes, maxread; + struct timeval timeout; +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + fd_set readfds; + FD_ZERO (&readfds); + FD_SET (np->datain, &readfds); +#else + int readfds; +#endif + + /* Determine maximum amount of data to be read. */ + maxread = (np->flags & F_TEXT) ? *maxbytes/sizeof(XCHAR) : *maxbytes; + + /* The following call to select shouldn't be necessary, but it + * appears that, due to the way we open a FIFO with O_NDELAY, read + * can return zero if read is called before the process on the other + * end writes any data. This happens even though fcntl is called to + * restore blocking i/o after the open. + */ +#if defined(POSIX) || defined(LINUX) || defined(MACOSX) + FD_ZERO (&readfds); + FD_SET (np->datain, &readfds); +#else + readfds = (1 << np->datain); +#endif + if ((np->flags & F_NODELAY) && np->datain < MAXSEL) { + timeout.tv_sec = 0; + timeout.tv_usec = 0; + if (select (MAXSEL, &readfds, NULL, NULL, &timeout)) + nbytes = read (np->datain, (char *)buf, maxread); + else + nbytes = XERR; + } else { + if (np->domain == FIFO && np->datain < MAXSEL) { + select (MAXSEL, &readfds, NULL, NULL, NULL); + nbytes = read (np->datain, (char *)buf, maxread); + } else { + nbytes = read (np->datain, (char *)buf, maxread); + } + } + + if ((n = nbytes) > 0 && (np->flags & F_TEXT)) { + op = (XCHAR *) buf; + op[n] = XEOS; + for (ip = (char *)buf; --n >= 0; ) + op[n] = ip[n]; + nbytes *= sizeof(XCHAR); + } + + kfp->nbytes = nbytes; + + return (nbytes); +} + + +/* ZAWRND -- "Asynchronous" binary block write. Initiate a write of exactly + * nbytes bytes from the buffer BUF to the file FD. Status is returned in a + * subsequent call to ZAWTND. + */ +int +ZAWRND ( + XINT *chan, /* UNIX file number */ + XCHAR *buf, /* buffer containing data */ + XINT *nbytes, /* nbytes to be written */ + XLONG *offset /* 1-indexed file offset */ +) +{ + register int fd = *chan; + register struct fiodes *kfp = &zfd[fd]; + register struct portal *np = get_desc (fd); + int nwritten, maxbytes, n; + char *text, *ip = (char *)buf; + char obuf[SZ_OBUF]; + SIGFUNC sigpipe; + + + /* Enable a signal mask to catch SIGPIPE when the server has died. + */ + sigpipe = (SIGFUNC) signal (SIGPIPE, (SIGFUNC)nd_onsig); + recursion = 0; + + maxbytes = (np->domain == FIFO || (np->flags & F_TEXT)) ? SZ_OBUF : 0; + for (nwritten=0; nwritten < *nbytes; nwritten += n, ip+=n) { + n = *nbytes - nwritten; + if (maxbytes) + n = min (maxbytes, n); + + if (np->flags & F_TEXT) { + register XCHAR *ipp = (XCHAR *)ip; + register char *op = (char *)obuf; + register int nbytes = n / sizeof(XCHAR); + + while (--nbytes >= 0) + *op++ = *ipp++; + text = obuf; + + jmpset++; + if (setjmp (jmpbuf) == 0) { + if ((n = write(np->dataout, text, n / sizeof(XCHAR))) < 0) { + nwritten = ERR; + break; + } + } else { + nwritten = ERR; + break; + } + + n *= sizeof(XCHAR); + + } else { + text = ip; + if ((n = write (np->dataout, text, n)) < 0) { + nwritten = ERR; + break; + } + } + } + + /* Restore the signal mask. */ + jmpset = 0; + signal (SIGPIPE, sigpipe); + + kfp->nbytes = nwritten; + + return (nwritten); +} + + +/* ND_ONSIG -- Catch a signal. + * */ +static void +nd_onsig ( + int sig, /* signal which was trapped */ + int *arg1, /* not used */ + int *arg2 /* not used */ +) +{ + /* If we get a SIGPIPE writing to a server the server has probably + * died. Make it look like there was an i/o error on the channel. + */ + if (sig == SIGPIPE && recursion++ == 0) + ; + + if (jmpset) + longjmp (jmpbuf, sig); +} + + +/* ZAWTND -- "Wait" for an "asynchronous" read or write to complete, and + * return the number of bytes read or written, or ERR. + */ +int +ZAWTND (XINT *fd, XINT *status) +{ + if ((*status = zfd[*fd].nbytes) == ERR) + *status = XERR; + + return (*status); +} + + +/* ZSTTND -- Return file status information for a network device. + */ +int +ZSTTND (XINT *fd, XINT *param, XLONG *lvalue) +{ + switch (*param) { + case FSTT_BLKSIZE: + (*lvalue) = 0L; + break; + + case FSTT_FILSIZE: + (*lvalue) = 0L; + break; + + case FSTT_OPTBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = ND_OPTBUFSIZE; + break; + + case FSTT_MAXBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = ND_MAXBUFSIZE; + break; + + default: + (*lvalue) = XERR; + break; + } + + return (XOK); +} + + +/* + * Internal routines. + * ---------------------------- + */ + +/* GETSTR -- Internal routine to extract a metacharacter delimited substring + * from a formatted string. The metacharacter to be taken as the delimiter + * is passed as an argument. Any embedded whitespace between the tokens is + * stripped. The number of characters in the output token is returned as + * the function value, or zero if EOS or the delimiter is reached. + */ +static int +getstr (char **ipp, char *obuf, int maxch, int delim) +{ + register char *op, *ip = *ipp; + register char *otop = obuf + maxch; + + while (*ip && isspace(*ip)) + ip++; + for (op=obuf; *ip; ip++) { + if (*ip == delim) { + ip++; + break; + } else if (op < otop && !isspace(*ip)) + *op++ = *ip; + } + + *op = '\0'; + *ipp = ip; + + return (op - obuf); +} diff --git a/unix/os/zfiopl.c b/unix/os/zfiopl.c new file mode 100644 index 00000000..26468834 --- /dev/null +++ b/unix/os/zfiopl.c @@ -0,0 +1,279 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_prtype +#define import_spp +#include + +/* + * ZFIOPL -- IRAF FIO interface to plotter devices. A plotter + * is opened as a streaming type (no seeks) write-only binary device. + * FIO writes NCAR metacode to the plotter. This metacode is spooled + * in a temporary file and then disposed of to the plotter by calling + * an OS metacode translator to process the file. The spoolfile is then + * deleted. + * + * The system and device dependent information necessary to perform these + * functions is contained in three strings passed as the "device" parameter + * to ZOPNPL. The strings come from the GRAPHCAP entry for the device. + * The format of such a string is + * + * device D spoolfile D dispose_cmd EOS + * + * where DEVICE is the logical device name (not used herein), D is the field + * delimiter character (the first nonalphnumeric character encountered after + * the device field), SPOOLFILE is a UNIX pathname to be passed to MKTEMP + * to create the spoolfile pathname, and DISPOSE_CMD is a fill-in-the-blanks + * template for a UNIX shell command which will dispose of the spoolfile to + * the plotter device. + */ + +extern int save_prtype; + +#define SZ_OSCMD 512 /* buffer for dispose cmd */ +#define SZ_PLSTR 256 /* zopnpl plotter argument */ + +struct dplotter { + char *name; /* logical gdevice name */ + char *spoolfile; /* spoolfile string */ + char *dispose; /* dispose format string */ +}; + +struct oplotter { + long wbytes; /* nbytes written to device */ + struct dplotter *pl; /* device code as above */ + int status; /* status of last write */ + char spoolfile[SZ_PATHNAME+1]; +}; + +struct dplotter dpltr; /* machdep plotter info */ +struct oplotter pltr; /* open plotter descriptor */ +char plstr[SZ_PLSTR+1]; /* save zopnpl argument */ +int pltr_inuse = NO; /* set if plotter is open */ + + +extern int ZOPNBF (), ZCLSBF (), ZOSCMD (), ZFDELE (), ZARDBF (); +extern int ZAWRBF (), ZAWTBF (), ZSTTBF (); + + + +/* ZOPNPL -- Open a plotter device for binary file i/o. If we can talk + * directly to the plotter, do so, otherwise open a spoolfile which is + * to be sent to the plotter when ZCLSPL is later called. + */ +int +ZOPNPL ( + PKCHAR *plotter, /* plotter device descriptor */ + XINT *mode, /* file access mode */ + XINT *chan /* UNIX file number (output) */ +) +{ + register char *ip; + static char delim; + int fd; + + /* We do not see a need to have more than one plotter open at + * a time, and it makes things simpler. We can easily generalize + * to multiple open plotter devices in the future if justified. + */ + if (pltr_inuse == YES) { + *chan = XERR; + return (XERR); + } else + pltr_inuse = YES; + + /* Parse the plotter string into the name, spoolfile, and dispose + * strings. + */ + strncpy (plstr, (char *)plotter, SZ_PLSTR); + + /* Locate NAME field. */ + dpltr.name = plstr; + for (ip=plstr; isalnum(*ip); ip++) + ; + delim = *ip; + *ip++ = EOS; + + /* Locate SPOOLFILE field. */ + for (dpltr.spoolfile=ip; *ip && *ip != delim; ip++) + ; + *ip++ = EOS; + + /* Locate DISPOSE field. */ + for (dpltr.dispose=ip; *ip && *ip != delim; ip++) + ; + *ip++ = EOS; + + /* Initialize the open plotter descriptor. + */ + pltr.wbytes = 0L; + pltr.pl = &dpltr; + strcpy (pltr.spoolfile, dpltr.spoolfile); + if (dpltr.dispose[0] != EOS) + if ((fd = mkstemp (pltr.spoolfile)) >= 0) { + fchmod (fd, 0644); + close (fd); + } + + return ZOPNBF ((PKCHAR *)pltr.spoolfile, mode, chan); +} + + +/* ZCLSPL -- To close a plotter we merely close the "spoolfile", and then + * dispose of the spoolfile to the OS if so indicated. + */ +int +ZCLSPL (XINT *chan, XINT *status) +{ + static PKCHAR xnullstr[1] = { EOS }; + register char *ip, *op, *f; + PKCHAR cmd[(SZ_OSCMD+1) / sizeof(PKCHAR)]; + XINT junk; + + ZCLSBF (chan, status); + pltr_inuse = NO; + + /* Dispose of the output file if so indicated. Do not bother to + * check the status return, since we cannot return status to FIO + * from here anyhow. Do not dispose of the file if it is empty. + * If the file is disposed of by the OS, we assume that it is also + * deleted after printing. If file is not disposed to the OS, we + * delete it ourselves. + */ + if (*(pltr.pl->dispose) != EOS) { + if (pltr.wbytes > 0) { + PKCHAR out[SZ_FNAME+1]; + + /* Build up command line by substituting the spoolfile name + * everywhere the macro "$F" appears in the "dispose" text. + */ + op = (char *)cmd; + for (ip=pltr.pl->dispose; (*op = *ip++) != EOS; op++) + if (*op == '$' && *ip == 'F') { + for (f=pltr.spoolfile; (*op = *f++) != EOS; op++) + ; + /* Overwrite EOS, skip over 'F' */ + --op, ip++; + } + strcpy ((char *)out, + save_prtype == PR_CONNECTED ? "/dev/tty" : ""); + ZOSCMD (cmd, xnullstr, out, out, &junk); + } else + ZFDELE ((PKCHAR *)pltr.spoolfile, &junk); + } + + return (*status); +} + + +/* ZARDPL -- For UNIX, the read and write routines are just the binary file + * i/o routines. Note that packing of chars into bytes, mapping of escape + * sequences, etc. is done by the high level code; our function is merely to + * move the data to the device. The read primitive is not likely to be needed + * for a plotter, but you never know... + */ +int +ZARDPL ( + XINT *chan, + XCHAR *buf, + XINT *maxbytes, + XLONG *offset +) +{ + return ZARDBF (chan, buf, maxbytes, offset); +} + + +/* ZAWRPL -- Write a metafile record to the plotter spoolfile. We are always + * called to write metacode; zfiopl is not used to send device codes to the + * plotter. Our job is to make the NSPP metacode record passed on to us by + * WRITEB look like whatever the system metacode translators expect. On the + * KPNO system, the metacode translators are Fortran programs, expecting an + * unformatted binary metacode file as input. We simulate this file by + * adding the integer byte count of the record to the beginning and end of + * each record. + * + * N.B.: We ASSUME that the FIO buffer has been set to the size of a metafile + * record, i.e., 1440 bytes or 720 chars on the VAX. + */ +int +ZAWRPL ( + XINT *chan, + XCHAR *buf, + XINT *nbytes, + XLONG *offset /* not used */ +) +{ + static XINT hdrlen=sizeof(int); + static XLONG noffset=0L; + XINT status; + int reclen; + + /* Write out the integer record header. Set the file offset to zero + * since the file is sequential, and the offsets do not include the + * record headers anyhow so are wrong. + */ + reclen = *nbytes; + ZAWRBF (chan, (XCHAR *)&reclen, &hdrlen, &noffset); + ZAWTBF (chan, &status); + + /* Write the metacode data. + */ + pltr.wbytes += *nbytes; + ZAWRBF (chan, buf, nbytes, &noffset); + ZAWTBF (chan, &pltr.status); + + /* Write out the integer record trailer. Set the file offset to zero + * since the file is sequential, and the offsets do not include the + * record headers anyhow so are wrong. + */ + reclen = *nbytes; + ZAWRBF (chan, (XCHAR *)&reclen, &hdrlen, &noffset); + ZAWTBF (chan, &status); + + return (status); +} + + +/* ZAWTPL -- Return the status of the write (we do not read metafiles with + * the plotter interface). The status byte count does not include the + * record header, since that was written with a separate write unbeknownst + * to FIO, so the status value returned refers only to the metacode data. + */ +int +ZAWTPL (XINT *chan, XINT *status) +{ + ZAWTBF (chan, status); + if (*status > 0) + *status = pltr.status; + + return (*status); +} + + +/* ZSTTPL -- Get status for the plotter output file. Plotter output is + * strictly sequential due to the way metacode records are packaged in + * ZAWRPL. Hence we must always return blksize=0 to indicate that the + * device is a streaming file, regardless of whether or not the output + * is spooled. + */ +int +ZSTTPL (XINT *chan, XINT *param, XLONG *lvalue) +{ + switch (*param) { + case FSTT_BLKSIZE: + *lvalue = 0L; + break; + default: + return ZSTTBF (chan, param, lvalue); + } + return (XOK); +} diff --git a/unix/os/zfiopr.c b/unix/os/zfiopr.c new file mode 100644 index 00000000..9bf2dfed --- /dev/null +++ b/unix/os/zfiopr.c @@ -0,0 +1,499 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_prtype +#define import_zfstat +#define import_spp +#include + +extern int errno; /* error code returned by the kernel */ +#ifdef SYSV +#define vfork fork +#else +# ifdef sun +# include +# endif +#endif + +extern void pr_enter (int pid, int inchan, int outchan); + + + +/* ZFIOPR -- File i/o to a subprocess. A "connected" subprocess is connected + * to the parent via two IPC channels (read and write), and is analogous to a + * streaming binary file: + * + * zopcpr open process + * zclcpr close process + * zardpr read from process + * zawrpr write to process + * zawtpr wait for i/o + * zsttpr get channel/device status + * also + * zintpr interrupt process + * + * See also the zopdpr, zcldpr primitives, used to spawn "detached" processes + * which do not communicate with the parent. + */ + +#define IPC_MAGIC 01120 /* First 2 bytes of IPC block */ +#define SZ_TTYIBUF 512 /* buffer size if reading TTY */ +#define SZ_TTYOBUF 2048 /* buffer size if writing TTY */ +#define MAX_TRYS 2 /* max interupted reads */ + +#define mask(s) (1 << ((s) - 1)) + +int pr_ionbytes[MAXOFILES]; /* nbytes read|written on channel */ +int debug_ipc = 0; /* print debug info on stderr */ +int ipc_in = 0; /* logfile for IPC input */ +int ipc_out = 0; /* logfile for IPC output */ +int ipc_isatty = 0; /* set when debugging IPC at TTY */ + + +/* ZOPCPR -- Open a connected subprocess. Spawn process and open bidirectional + * IPC channels, implemented with pipes for this version of Berkeley UNIX. + */ +int +ZOPCPR ( + PKCHAR *osfn, /* name of executable file */ + XINT *inchan, + XINT *outchan, /* IPC channels (parent reads inchan) */ + XINT *pid +) +{ + int pin[2], pout[2]; + int maxforks = 3, fd; + + if (debug_ipc) + fprintf (stderr, "zopcpr (`%s')", (char *)osfn); + + + /* Check that the process file exists and is executable. + */ + if (access ((char *)osfn, 1) == ERR) { + *pid = XERR; + return (XERR); + } + + /* Open binary IPC channels. Clear byte counts. + */ + pin[0] = pin[1] = -1; + pout[0] = pout[1] = -1; + + if (pipe(pin) == ERR || pipe(pout) == ERR) + goto err; + else if (pin[0] >= MAXOFILES || pin[1] >= MAXOFILES || + pout[0] >= MAXOFILES || pout[1] >= MAXOFILES) { +err: close (pin[0]); close (pin[1]); + close (pout[0]); close (pout[1]); + *pid = XERR; + return (XERR); + } + + pr_ionbytes[pin[0]] = 0; + pr_ionbytes[pin[1]] = 0; + pr_ionbytes[pout[0]] = 0; + pr_ionbytes[pout[1]] = 0; + + /* Create child process. Vfork is used to avoid necessity to copy + * the full address space of the parent, since we are going to overlay + * a new process immediately with Execl anyhow. The child inherits + * the open stdio files. The fork can fail if swap space is full or + * if we have too many processes. + */ + while ((*pid = vfork()) == ERR) { + if (--maxforks == 0) { + close (pin[0]); close (pin[1]); + close (pout[0]); close (pout[1]); + *pid = XERR; + return (XERR); + } + sleep (2); + } + + if (*pid == 0) { + /* New, child process. Make child think the pipe is its stdin/out. + */ + struct rlimit rlim; + int maxfd; + + if (getrlimit (RLIMIT_NOFILE, &rlim)) + maxfd = MAXOFILES; + else + maxfd = rlim.rlim_cur; + + close (pin[0]); + close (pout[1]); + close (0); dup (pout[0]); close (pout[0]); + close (1); dup (pin[1]); close (pin[1]); + + /* Disable SIGINT so that child process does not die when the + * parent process is interrupted. Parent sends SIGTERM to + * interrupt a child process. + */ + signal (SIGINT, SIG_IGN); + + /* Arrange for the local file descriptors of the parent to be + * closed in the child if the exec succeeds. IRAF subprocesses + * do not expect to inherit any file descriptors other than + * stdin, stdout, and stderr. + */ + for (fd=3; fd < maxfd; fd++) + fcntl (fd, F_SETFD, 1); + + /* Exec the new process. Will not return if successful. + * The "-c" flag tells the subprocess that it is a connected + * subprocess. + */ + execl ((char *)osfn, (char *)osfn, "-c", (char *) 0); + + /* If we get here the new process could not be executed for some + * reason. Shutdown, calling _exit to avoid flushing parent's + * io buffers. Parent will receive the X_IPC exception when it + * subsequently tries to write to the child. + */ + _exit (1); + + } else { + + /* Existing, parent process. */ + close (pin[1]); + close (pout[0]); + *inchan = pin[0]; + *outchan = pout[1]; + + /* Save pid in parent's process table. Entry cleared when + * pr_wait is called to wait for process to terminate. Also save + * channel numbers in process table since only the pid is passed + * when the process is closed. + */ + pr_enter (*pid, pin[0], pout[1]); + + if (debug_ipc) + fprintf (stderr, " [%ld]\n", (long) *pid); + } + + return (XOK); +} + + +/* ZCLCPR -- Close a connected subprocess. Wait for subprocess to terminate, + * close the IPC channels, and return the exit status. + */ +int +ZCLCPR (XINT *pid, XINT *exit_status) +{ + int inchan, outchan; + extern int pr_getipc(), pr_wait(); + + + if (pr_getipc ((int)*pid, &inchan, &outchan) == ERR) + *exit_status = XERR; + else { + close (outchan); + close (inchan); + *exit_status = pr_wait ((int)*pid); + } + + if (debug_ipc) + fprintf (stderr, "[%ld] terminated, exit code %ld\n", + (long)*pid, (long)*exit_status); + + return (*exit_status); +} + + +/* ZARDPR -- Read next record from an IPC channel. Since UNIX pipes are byte + * streams we must take special measures to transmit data through a pipe in + * records. Each block of data is preceded by a 4-byte header consisting + * of a 2-byte magic number (used to verify that the correct protocol is in + * use on the channel) and a 2-byte count of the number of bytes in the block. + * To read a block we must read the count and then issue successive read + * requests until the entire block has been read. The byte count (excluding the + * 4-byte header) is saved in a static table for return to the high level code + * in a subsequent call to ZAWTPR. Disaster occurs if the actual block length + * does not agree with the header, but that cannot happen since only ZAWRPR + * writes to an IPC channel. + */ +int +ZARDPR ( + XINT *chan, + XCHAR *buf, + XINT *maxbytes, + XLONG *loffset /* not used */ +) +{ + register char *op; + register int fd, nbytes; + int record_length, status; + short temp; +#ifdef POSIX + sigset_t sigmask_save, set; +#else + int sigmask_save; +#endif + + fd = *chan; + op = (char *)buf; + + if (debug_ipc) + fprintf (stderr, + "[%d] initiate read for %ld bytes from IPC channel %d\n", + getpid(), (long)*maxbytes, fd); + + /* In TTY debug mode we simulate IPC i/o but are actually talking to + * a terminal. Omit the packet headers and unpack input into XCHAR. + * If a interrupt ocurrs while the read is pending and control returns + * to the do-while, try to complete the read successfully. + */ + if (ipc_isatty) { + char ibuf[SZ_TTYIBUF], *ip; + XCHAR *xop; + int maxch = min (SZ_TTYIBUF, *maxbytes / sizeof(XCHAR)); + int ntrys = MAX_TRYS; + + do { + errno = 0; + if ((pr_ionbytes[fd] = nbytes = read (fd, ibuf, maxch)) > 0) { + for (ip=ibuf, xop=buf; --nbytes >= 0; ) + *xop++ = *ip++; + pr_ionbytes[fd] *= sizeof (XCHAR); + } + } while (nbytes <= 0 && errno == EINTR && --ntrys >= 0); + + return (XOK); + } + + /* Read 2-byte magic number to verify that the channel was written to + * by ZAWRPR and that we are at the start of a record. + */ + switch (status = read (fd, &temp, 2)) { + case 0: + pr_ionbytes[fd] = 0; + return (0); + case ERR: + pr_ionbytes[fd] = ERR; + return (XERR); + default: + if (status != 2 || temp != IPC_MAGIC) { + pr_ionbytes[fd] = ERR; + return (XERR); + } + } + + if (ipc_in > 0) + write (ipc_in, (char *)&temp, 2); + + /* Get byte count of record. + */ + if (read (fd, &temp, 2) != 2) { + pr_ionbytes[fd] = ERR; + return (XERR); + } + record_length = temp; + nbytes = min (record_length, *maxbytes); + pr_ionbytes[fd] = nbytes; + if (ipc_in > 0) + write (ipc_in, (char *)&temp, 2); + + /* Now read exactly nbytes of data from channel into user buffer. + * Return actual byte count if EOF is seen. If ERR is seen return + * ERR. If necessary multiple read requests are issued to read the + * entire record. This is implemented as a critical section to + * prevent corruption of the IPC protocol when an interrupt occurs. + */ +#ifdef POSIX + sigemptyset (&set); + sigaddset (&set, SIGINT); + sigaddset (&set, SIGTERM); + sigprocmask (SIG_BLOCK, &set, &sigmask_save); +#else + sigmask_save = sigblock (mask(SIGINT) | mask(SIGTERM)); +#endif + + while (nbytes > 0) { + switch (status = read (fd, op, nbytes)) { + case 0: + pr_ionbytes[fd] -= nbytes; + goto reenab_; + case ERR: + pr_ionbytes[fd] = ERR; + goto reenab_; + default: + nbytes -= status; + op += status; + } + } + + if (debug_ipc) { +/* +char ch, *bp = buf, nc=0; +for (nc=0; nc < 30; nc++) { + ch = (char)(*(buf + nc)); + fprintf (stderr, "rd ipc_in=%d [%d] '%c' %d \n", ipc_in, nc, ch, ch); +} +*/ + fprintf (stderr, "[%d] read %ld bytes from IPC channel %d:\n", + getpid(), (long) (op - (char *)buf), fd); + write (2, (char *)buf, op - (char *)buf); + } + + if (ipc_in > 0) + write (ipc_in, (char *)buf, op - (char *)buf); + + /* If the record is larger than maxbytes, we must read and discard + * the additional bytes. The method used is inefficient but it is + * unlikely that we will be called to read less than a full record. + */ + for (nbytes = *maxbytes; nbytes < record_length; nbytes++) + if (read (fd, &temp, 1) <= 0) + break; +reenab_: +#ifdef POSIX + sigprocmask (SIG_SETMASK, &sigmask_save, NULL); +#else + sigsetmask (sigmask_save); +#endif + + return (XOK); +} + + +/* ZAWRPR -- Write to an IPC channel. Write the IPC block header followed by + * the data block. + */ +int +ZAWRPR ( + XINT *chan, + XCHAR *buf, + XINT *nbytes, + XLONG *loffset +) +{ + register int fd; + short temp; +#ifdef POSIX + sigset_t sigmask_save, set; +#else + int sigmask_save; +#endif + + fd = *chan; + + /* In TTY debug mode we simulate IPC i/o but are actually talking to + * a terminal. Omit the packet headers and pack XCHAR output into + * bytes. + */ + if (ipc_isatty) { + char obuf[SZ_TTYOBUF], *op; + XCHAR *ip; + int nchars, n; + + n = nchars = min (SZ_TTYOBUF, *nbytes / sizeof(XCHAR)); + for (ip=buf, op=obuf; --n >= 0; ) + *op++ = *ip++; + if ((pr_ionbytes[fd] = write (fd, obuf, nchars)) > 0) + pr_ionbytes[fd] *= sizeof (XCHAR); + return (XOK); + } + + /* Write IPC block header. + */ +#ifdef POSIX + sigemptyset (&set); + sigaddset (&set, SIGINT); + sigaddset (&set, SIGTERM); + sigprocmask (SIG_BLOCK, &set, &sigmask_save); +#else + sigmask_save = sigblock (mask(SIGINT) | mask(SIGTERM)); +#endif + + temp = IPC_MAGIC; + write (fd, &temp, 2); + if (ipc_out > 0) + write (ipc_out, &temp, 2); + temp = *nbytes; + write (fd, &temp, 2); + if (ipc_out > 0) + write (ipc_out, &temp, 2); + + /* Write data block. + */ + pr_ionbytes[fd] = write (fd, (char *)buf, (int)*nbytes); + if (ipc_out > 0) + write (ipc_out, (char *)buf, (int)*nbytes); + +#ifdef POSIX + sigprocmask (SIG_SETMASK, &sigmask_save, NULL); +#else + sigsetmask (sigmask_save); +#endif + + if (debug_ipc) { +/* +char ch, *bp = buf, nc=0; +for (nc=0; nc < 30; nc++) { + ch = (char)(*(buf + nc)); + fprintf (stderr, "wr ipc_out=%d [%d] '%c' %d pr_io=%d\n", + ipc_out, nc, ch, ch, pr_ionbytes[fd]); +} +*/ + fprintf (stderr, "[%d] wrote %d bytes to IPC channel %d:\n", + getpid(), (int)*nbytes, fd); + write (2, (char *)buf, (int)*nbytes); + } + + return (XOK); +} + + +/* ZAWTPR -- Wait for i/o to an IPC channel. Since UNIX pipes are not + * asynchronous we do not really wait, rather we return the status value + * (byte count) from the last read or write to the channel. + */ +int +ZAWTPR (XINT *chan, XINT *status) +{ + if ((*status = pr_ionbytes[*chan]) == ERR) + *status = XERR; + + return (*status); +} + + +/* ZSTTPR -- Get binary file status for an IPC channel. An IPC channel is a + * streaming binary file. + */ +int +ZSTTPR ( + XINT *chan, /* not used; all IPC channels have same status */ + XINT *param, + XLONG *lvalue +) +{ + switch (*param) { + case FSTT_BLKSIZE: + case FSTT_FILSIZE: + *lvalue = 0; + break; + case FSTT_OPTBUFSIZE: + *lvalue = PR_OPTBUFSIZE; + break; + case FSTT_MAXBUFSIZE: + *lvalue = PR_MAXBUFSIZE; + break; + default: + *lvalue = XERR; + } + + return (*lvalue); +} diff --git a/unix/os/zfiosf.c b/unix/os/zfiosf.c new file mode 100644 index 00000000..a6efe7ed --- /dev/null +++ b/unix/os/zfiosf.c @@ -0,0 +1,126 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +/* + * ZFIOSF -- Static file device driver. In the 4.1BSD UNIX kernel the ordinary + * binary file driver is used for static files (files that do not change in + * size once created by ZFALOC), hence all we need do to implement a SF routine + * is call the corresponding BF routine. A great gain in i/o efficiency could + * probably be gained by replacing this driver by one using raw i/o, but we do + * not want to bother with that for 4.1BSD UNIX because the time would be + * better spent doing it for 4.2BSD. + * + * If anyone is stuck with 4.1BSD for some reason and wants fast static file + * i/o, the strategy is to try to allocate contiguous files with ZFALOC, either + * in a raw partition using a special file manager or within an ordinary + * partition adding a new system call to allocate contiguous storage for a file. + * The latter scheme has the advantage that files thus created are ordinary + * UNIX files and can be accessed normally as well as by the static file driver. + * Given a contiguous or near-contiguous file on disk, all the static file + * driver needs for direct access with large transfers is the physical block + * offset of the file. The raw device is then accessed via physio calls to + * transfer data directly to or from the user's buffer, bypassing the system + * buffer cache. Write perm is required on the raw device for the target + * filesystem; this opens up the possibility of trashing the files system. + * Static file access should be restricted to one or more large temporary files + * systems. If one gets really ambitious a special UNIX driver can be added to + * permit asynchronous i/o, bypassing the UNIX files system entirely except + * during file creation and deletion. + */ + +extern int ZOPNBF(), ZCLSBF (), ZARDBF (), ZAWRBF (), ZAWTBF (), ZSTTBF (); + + +/* ZOPNSF -- Open a static file. Only RO, WO, and RW modes are permitted + * for static files, since allocation is via ZFALOC and appending is not + * permitted. + */ +int +ZOPNSF ( + PKCHAR *osfn, /* UNIX name of file */ + XINT *mode, /* file access mode */ + XINT *chan /* file number (output) */ +) +{ + switch (*mode) { + case READ_ONLY: + case WRITE_ONLY: + case READ_WRITE: + return ZOPNBF (osfn, mode, chan); + break; + default: + *chan = XERR; + return (*chan); + } +} + + +/* ZCLSSF -- Close a static file. + */ +int +ZCLSSF (XINT *fd, XINT *status) +{ + return ZCLSBF (fd, status); +} + + +/* ZARDSF -- "Asynchronous" static block read. Initiate a read of at most + * maxbytes bytes from the file FD into the buffer BUF. Status is returned + * in a subsequent call to ZAWTSF. + */ +int +ZARDSF ( + XINT *chan, /* UNIX file number */ + XCHAR *buf, /* output buffer */ + XINT *maxbytes, /* max bytes to read */ + XLONG *offset /* 1-indexed file offset to read at */ +) +{ + return ZARDBF (chan, buf, maxbytes, offset); +} + + +/* ZAWRSF -- "Asynchronous" static block write. Initiate a write of exactly + * nbytes bytes from the buffer BUF to the file FD. Status is returned in a + * subsequent call to ZAWTSF. + */ +int +ZAWRSF ( + XINT *chan, /* UNIX file number */ + XCHAR *buf, /* buffer containing data */ + XINT *nbytes, /* nbytes to be written */ + XLONG *offset /* 1-indexed file offset */ +) +{ + return ZAWRBF (chan, buf, nbytes, offset); +} + + +/* ZAWTSF -- "Wait" for an "asynchronous" read or write to complete, and + * return the number of bytes read or written, or ERR. + */ +int +ZAWTSF (XINT *fd, XINT *status) +{ + return ZAWTBF (fd, status); +} + + +/* ZSTTSF -- Return status on a static file. + */ +int +ZSTTSF ( + XINT *fd, + XINT *param, + XLONG *lvalue +) +{ + return ZSTTBF (fd, param, lvalue); +} diff --git a/unix/os/zfiotx.c b/unix/os/zfiotx.c new file mode 100644 index 00000000..e387dfaa --- /dev/null +++ b/unix/os/zfiotx.c @@ -0,0 +1,991 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include + +#ifdef LINUX +#define USE_SIGACTION +#endif + +#ifdef SYSV +#include +#else +#include +#endif + +#ifndef O_NDELAY +#include +#endif + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_spp +#include + +/* + * ZFIOTX -- File i/o to textfiles, for UNIX 4.1BSD. This driver is used for + * both terminals and ordinary disk text files. I/O is via the C library + * stdio routines, which provide buffering. + * + * On input, we must check for newline and terminate when it has been read, + * including the newline character in the return buffer and in the character + * count. If the buffer limit is reached before newline is found, we return + * the line without a newline, and return the rest of the line in the next + * read request. If a single character is requested character mode is + * asserted, i.e., if the device is a terminal RAW is enabled and ECHO and + * CRMOD (CR to LF mapping) are disabled. A subsequent request to read or + * write more than one character restores line mode. + * + * On output, we transmit the specified number of characters, period. + * No checking for newline or EOS is performed. Text may contain null + * characters (note that EOS == NUL). There is no guarantee that the + * output line will contain a newline. When flushing partial lines to a + * terminal, this is often not the case. When FIO writes a very long + * line and the FIO buffer overflows, it will flush a partial line, + * passing the rest of the line (with newline delimiter) in the next + * write request. The newline should be included in the data as stored + * on disk, if possible. It is not necessary to map newlines upon output + * because UNIX does this already. + * + * N.B.: An SPP char is usually not a byte, so these routines usually + * perform type conversion. The actual SPP datatype is defined in language.h + * An SPP char is a signed integer, but only values in the range 0-127 may + * be written to a text file. We assume that character set conversion (e.g., + * ASCII to EBCDIC) is not necessary since all 4.1BSD hosts we are aware of + * are ASCII machines. + */ + +#define MAXOTTYS 20 /* max simultaneous open ttys */ +#define MAX_TRYS 2 /* max interrupted trys to read */ +#define NEWLINE '\n' + +/* The ttyport descriptor is used by the tty driver (zfiotx). */ +struct ttyport { + int inuse; /* port in use */ + int chan; /* host channel (file descrip.) */ + unsigned device; /* tty device number */ + int flags; /* port flags */ + char redraw; /* redraw char, sent after susp */ +#ifdef SYSV + struct termios tc; /* normal tty state */ + struct termios save_tc; /* saved rawmode tty state */ +#else + struct sgttyb tc; /* normal tty state */ + struct sgttyb save_tc; /* saved rawmode tty state */ +#endif +}; + + + +#define CTRLC 3 +extern int errno; +static jmp_buf jmpbuf; +static int tty_getraw = 0; /* raw getc in progress */ +#ifdef USE_SIGACTION +static struct sigaction sigint, sigterm; +static struct sigaction sigtstp, sigcont; +static struct sigaction oldact; +#else +static SIGFUNC sigint, sigterm; +static SIGFUNC sigtstp, sigcont; +#endif +static void tty_rawon(), tty_reset(), uio_bwrite(); +static void tty_onsig(), tty_stop(), tty_continue(); + +/* The ttyports array describes up to MAXOTTYS open terminal i/o ports. + * Very few processes will ever have more than one or two ports open at + * one time. ttyport descriptors are allocated one per tty device, using + * the minor device number to identify the device. This serves to + * uniquely identify each tty device regardless of the file descriptor + * used to access it. Multiple file descriptors (e.g. stdin, stdout, + * stderr) used to access a single device must use description of the + * device state. + */ +struct ttyport ttyports[MAXOTTYS]; +struct ttyport *lastdev = NULL; + +/* Omit this for now; it was put in for an old Linux libc bug, and since libc + * is completely different now the need for it has probably gone away. + * + * #ifdef LINUX + * #define FCANCEL + * #endif + */ +#ifdef FCANCEL +/* The following definition has intimate knowledge of the STDIO structures. */ +#define fcancel(fp) ( \ + (fp)->_IO_read_ptr = (fp)->_IO_read_end = (fp)->_IO_read_base,\ + (fp)->_IO_write_ptr = (fp)->_IO_write_end = (fp)->_IO_write_base) +#endif + + +/* ZOPNTX -- Open or create a text file. The pseudo-files "unix-stdin", + * "unix-stdout", and "unix-stderr" are treated specially. These denote the + * UNIX stdio streams of the process. These streams are not really opened + * by this driver, but ZOPNTX should be called on these streams to + * properly initialize the file descriptor. + */ +int +ZOPNTX ( + PKCHAR *osfn, /* UNIX filename */ + XINT *mode, /* file access mode */ + XINT *chan /* UNIX channel of file (output) */ +) +{ + register int fd; + register FILE *fp; + struct stat filestat; + int newmode, maskval; + FILE *fopen(); + char *fmode; + + /* Map FIO access mode into UNIX/stdio access mode. + */ + switch (*mode) { + case READ_ONLY: + fmode = "r"; + break; + case READ_WRITE: + fmode = "r+"; /* might not work on old systems */ + break; + case APPEND: + fmode = "a"; + break; + case WRITE_ONLY: + fmode = "w"; + break; + case NEW_FILE: /* create for appending */ + fmode = "w"; + break; + default: + goto error; + } + + /* Open or create file. If a new file is created it is necessary + * to explicitly set the file access permissions as indicated by + * FILE_MODEBITS in kernel.h. This is done in such a way that the + * user's UMASK bits are preserved. + */ + if (strcmp ((char *)osfn, U_STDIN) == 0) { + fp = stdin; + } else if (strcmp ((char *)osfn, U_STDOUT) == 0) { + fp = stdout; + } else if (strcmp ((char *)osfn, U_STDERR) == 0) { + fp = stderr; + } else if ((fp = fopen ((char *)osfn, fmode)) == NULL) + goto error; + + fd = fileno (fp); + if (fstat (fd, &filestat) == ERR) { + if (fd > 2) + fclose (fp); + goto error; + } else if (fd >= MAXOFILES) { + if (fd > 2) + fclose (fp); + goto error; + } + + /* If regular file apply the umask. */ + if (fd > 2 && S_ISREG(filestat.st_mode) && + (*mode == WRITE_ONLY || *mode == NEW_FILE)) { + umask (maskval = umask (022)); + newmode = ((filestat.st_mode | 066) & ~maskval); + (void) chmod ((char *)osfn, newmode); + } + + /* Set up kernel file descriptor. + */ + zfd[fd].fp = fp; + zfd[fd].fpos = 0; + zfd[fd].nbytes = 0; + zfd[fd].io_flags = 0; + zfd[fd].port = (char *) NULL; + + zfd[fd].flags = (KF_NOSEEK | KF_NOSTTY); + if (S_ISREG (filestat.st_mode)) + zfd[fd].flags &= ~KF_NOSEEK; + if (S_ISCHR (filestat.st_mode)) + zfd[fd].flags &= ~KF_NOSTTY; + + /* If we are opening a terminal device set up ttyport descriptor. */ + if (!(zfd[fd].flags & KF_NOSTTY)) { + register struct ttyport *port; + register unsigned device; + register int i; + + /* Check if we already have a descriptor for this device. */ + device = (filestat.st_dev << 16) + filestat.st_rdev; + for (i=0, port = &ttyports[0]; i < MAXOTTYS; i++, port++) + if (port->inuse && port->device == device) { + zfd[fd].port = (char *) port; + port->inuse++; + goto done; + } + + /* Fill in a fresh descriptor. */ + port = &ttyports[0]; + for (i=MAXOTTYS; --i >= 0 && port->inuse; port++) + ; + if (i >= MAXOTTYS) + goto error; + + port->chan = fd; + port->device = device; + port->flags = 0; + port->redraw = 0; + port->inuse = 1; + + zfd[fd].port = (char *) port; + } + +done: + *chan = fd; + return (*chan); + +error: + *chan = XERR; + return (*chan); +} + + +/* ZCLSTX -- Close a text file. + */ +int +ZCLSTX (XINT *fd, XINT *status) +{ + register struct fiodes *kfp = &zfd[*fd]; + register struct ttyport *port = (struct ttyport *) kfp->port; + + /* Disable character mode if still in effect. If this is necessary + * then we have already saved the old tty status flags in sg_flags. + */ + if (port && (port->flags & KF_CHARMODE)) + tty_reset (port); + + /* Close the file. Set file pointer field of kernel file descriptor + * to null to indicate that the file is closed. + * + * [NOTE] -- fclose errors are ignored if we are closing a terminal + * device. This was necessary on the Suns and it was not clear why + * a close error was occuring (errno was EPERM - not owner). + */ + *status = (fclose(kfp->fp) == EOF && kfp->flags&KF_NOSTTY) ? XERR : XOK; + + kfp->fp = NULL; + if (port) { + kfp->port = NULL; + if (--port->inuse < 0) + port->inuse = 0; + if (lastdev == port) + lastdev = NULL; + } + + return (*status); +} + + +/* ZFLSTX -- Flush any buffered textual output. + */ +int +ZFLSTX (XINT *fd, XINT *status) +{ + *status = (fflush (zfd[*fd].fp) == EOF) ? XERR : XOK; + return ((int) *status); +} + + +/* ZGETTX -- Get a line of text from a text file. Unpack machine chars + * into type XCHAR. If output buffer is filled before newline is encountered, + * the remainder of the line will be returned in the next call, and the + * current line will NOT be newline terminated. If maxchar==1 assert + * character mode, otherwise assert line mode. + */ +int +ZGETTX (XINT *fd, XCHAR *buf, XINT *maxchars, XINT *status) +{ + register FILE *fp; + register XCHAR *op; + register int ch, maxch = *maxchars; + register struct fiodes *kfp; + struct ttyport *port; + int nbytes, ntrys; + + if (maxch <= 0) { + *status = 0; + return (*status); + } + + kfp = &zfd[*fd]; + port = (struct ttyport *) kfp->port; + fp = kfp->fp; + + /* If maxch=1 assert char mode if legal on device, otherwise clear + * char mode if set. Ignore ioctl errors if ioctl is illegal on + * device. + */ + if (port) { + if (maxch == 1 && !(port->flags & KF_CHARMODE)) + tty_rawon (port, 0); + else if (maxch > 1 && (port->flags & KF_CHARMODE)) { + /* Disable character mode. If this is necessary then we have + * already saved the old tty status flags in sg_flags. + */ + tty_reset (port); + } + } + + /* Copy the next line of text into the user buffer. Keep track of + * file offsets of current line and next line for ZNOTTX. A call to + * ZNOTTX will return the value of kfp->fpos, the file offset of the + * next line to be read (unless newline has not yet been seen on the + * current line due to a partial read). The following while loop is + * the inner loop of text file input, hence is heavily optimized at + * the expense of some clarity. If the host is non-ASCII add a lookup + * table reference to this loop to map chars from the host character + * set to ASCII. + * + * N.B.: If an interrupt occurs during the read and the output buffer + * is still empty, try to complete the read. This can happen when + * an interrupt occurs while waiting for input from the terminal, in + * which case recovery is probably safe. + */ + if (!port || !(port->flags & KF_CHARMODE)) { + /* Read in line mode. + */ + ntrys = MAX_TRYS; + do { + clearerr (fp); + op = buf; + errno = 0; + while (*op++ = ch = getc(fp), ch != EOF) { + if (--maxch <= 0 || ch == NEWLINE) + break; + } +#ifdef FCANCEL + if (errno == EINTR) + fcancel (fp); +#endif + } while (errno == EINTR && op-1 == buf && --ntrys >= 0); + + *op = XEOS; + nbytes = *maxchars - maxch; + + } else if (kfp->flags & KF_NDELAY) { + /* Read a single character in nonblocking raw mode. Zero + * bytes are returned if there is no data to be read. + */ + struct timeval timeout; + int chan = fileno(fp); + fd_set rfds; + char data[1]; + + FD_ZERO (&rfds); + FD_SET (chan, &rfds); + timeout.tv_sec = 0; + timeout.tv_usec = 0; + clearerr (fp); + + if (select (chan+1, &rfds, NULL, NULL, &timeout)) { + if (read (chan, data, 1) != 1) { + *status = XERR; + return (XERR); + } + ch = *data; + goto outch; + } else { + *buf = XEOS; + *status = 0; + return (*status); + } + + } else { + /* Read a single character in raw mode. Catch interrupts and + * return the interrupt character as an ordinary character. + * We map interrupts in this way, rather than use raw mode + * (which disables interrupts and all other input processing) + * because ctrl/s ctrl/q is disabled in raw mode, and that can + * cause sporadic protocol failures. + */ +#ifdef USE_SIGACTION + sigint.sa_handler = (SIGFUNC) tty_onsig; + sigemptyset (&sigint.sa_mask); + sigint.sa_flags = SA_NODEFER; + sigaction (SIGINT, &sigint, &oldact); + + sigterm.sa_handler = (SIGFUNC) tty_onsig; + sigemptyset (&sigterm.sa_mask); + sigterm.sa_flags = SA_NODEFER; + sigaction (SIGTERM, &sigterm, &oldact); +#else + sigint = (SIGFUNC) signal (SIGINT, (SIGFUNC)tty_onsig); + sigterm = (SIGFUNC) signal (SIGTERM, (SIGFUNC)tty_onsig); +#endif + tty_getraw = 1; + + /* Async mode can be cleared by other processes (e.g. wall), + * so reset it on every nonblocking read. This code should + * never be executed as KF_NDELAY is handled specially above, + * but it does no harm to leave it in here anyway. + */ + if (kfp->flags & KF_NDELAY) + fcntl (*fd, F_SETFL, kfp->io_flags | O_NDELAY); + + if ((ch = setjmp (jmpbuf)) == 0) { + clearerr (fp); + ch = getc (fp); + } +#ifdef FCANCEL + if (ch == CTRLC) + fcancel (fp); +#endif + +#ifdef USE_SIGACTION + sigaction (SIGINT, &oldact, NULL); + sigaction (SIGTERM, &oldact, NULL); +#else + signal (SIGINT, sigint); + signal (SIGTERM, sigterm); +#endif + tty_getraw = 0; + + /* Clear parity bit just in case raw mode is used. + */ +outch: op = buf; + if (ch == EOF) { + *op++ = ch; + nbytes = 0; + } else { + *op++ = (ch & 0177); + nbytes = 1; + } + *op = XEOS; + } + + /* Check for errors and update offsets. If the last char copied + * was EOF step on it with an EOS. In nonblocking raw mode EOF is + * indistinguishable from a no-data read, but it doesn't matter + * especially since a ctrl/d, ctrl/z, etc. typed by the user is + * passed through as data. + */ + if (ferror (fp)) { + clearerr (fp); + *op = XEOS; + nbytes = (kfp->flags&KF_NDELAY && errno==EWOULDBLOCK) ? 0 : XERR; + } else { + kfp->nbytes += nbytes; + switch (*--op) { + case NEWLINE: + kfp->fpos += kfp->nbytes; + kfp->nbytes = 0; + break; + case EOF: + *op = XEOS; + break; + } + } + + *status = nbytes; + + return (*status); +} + + +/* ZNOTTX -- Return the seek offset of the beginning of the current line + * of text (file offset of char following last newline seen). + */ +int +ZNOTTX (XINT *fd, XLONG *offset) +{ + *offset = zfd[*fd].fpos; + return ((int) *offset); +} + + +/* ZPUTTX -- Put "nchars" characters into the text file "fd". The final + * character will always be a newline, unless the FIO line buffer overflowed, + * in which case the correct thing to do is to write out the line without + * artificially adding a newline. We do not check for newlines in the text, + * hence ZNOTTX will return the offset of the next write, which will be the + * offset of the beginning of a line of text only if we are called to write + * full lines of text. + */ +int +ZPUTTX ( + XINT *fd, /* file to be written to */ + XCHAR *buf, /* data to be output */ + XINT *nchars, /* nchars to write to file */ + XINT *status /* return status */ +) +{ + register FILE *fp; + register int nbytes; + register struct fiodes *kfp = &zfd[*fd]; + struct ttyport *port; + int count, ch; + XCHAR *ip; + char *cp; + + count = nbytes = *nchars; + port = (struct ttyport *) kfp->port; + fp = kfp->fp; + + /* Clear raw mode if raw mode is set, the output file is a tty, and + * more than one character is being written. We must get an exact + * match to the RAWOFF string for the string to be recognized. + * The string is recognized and removed whether or not raw mode is + * in effect. The RAWON sequence may also be issued to turn raw + * mode on. The SETREDRAW sequence is used to permit an automatic + * screen redraw when a suspended process receives SIGCONT. + */ + if ((*buf == '\033' && count == LEN_RAWCMD) || count == LEN_SETREDRAW) { + /* Note that we cannot use strcmp since buf is XCHAR. */ + + /* The disable rawmode sequence. */ + for (ip=buf, cp=RAWOFF; *cp && (*ip == *cp); ip++, cp++) + ; + if (*cp == EOS) { + tty_reset (port); + *status = XOK; + return (XOK); + } + + /* The enable rawmode sequence. The control sequence is followed + * by a single modifier character, `D' denoting a normal blocking + * character read, and `N' nonblocking character reads. + */ + for (ip=buf, cp=RAWON; *cp && (*ip == *cp); ip++, cp++) + ; + if (*cp == EOS) { + tty_rawon (port, (*ip++ == 'N') ? KF_NDELAY : 0); + *status = XOK; + return (XOK); + } + + /* The set-redraw control sequence. If the redraw code is + * set to a nonnull value, that value will be returned to the + * reader in the next GETC call following a process + * suspend/continue, as if the code had been typed by the user. + */ + for (ip=buf, cp=SETREDRAW; *cp && (*ip == *cp); ip++, cp++) + ; + if (*cp == EOS) { + if (port) + port->redraw = *ip; + *status = XOK; + return (XOK); + } + } + + /* Do not check for EOS; merely output the number of characters + * requested. Checking for EOS prevents output of nulls, used for + * padding to create delays on terminals. We must pass all legal + * ASCII chars, i.e., all chars in the range 0-127. The results of + * storing non-ASCII chars in a text file are system dependent. + * If the host is not ASCII then a lookup table reference should be + * added to this loop to map ASCII chars to the host character set. + * + * The uio_bwrite function moves the characters in a block and is + * more efficient than character at a time output with putc, if the + * amount of text to be moved is large. + */ + if (nbytes < 10) { + for (ip=buf; --nbytes >= 0; ) { + ch = *ip++; + putc (ch, fp); + } + } else + uio_bwrite (fp, buf, nbytes); + + kfp->fpos += count; + + /* If an error occurred while writing to the file, clear the error + * on the host stream and report a file write error to the caller. + * Ignore the special case of an EBADF occuring while writing to the + * terminal, which occurs when a background job writes to the terminal + * after the user has logged out. + */ + if (ferror (fp)) { + clearerr (fp); + if (errno == EBADF && (fp == stdout || fp == stderr)) + *status = count; + else + *status = XERR; + } else + *status = count; + + return (*status); +} + + +/* ZSEKTX -- Seek on a text file to the character offset given by a prior + * call to ZNOTTX. This offset should always refer to the beginning of a line. + */ +int +ZSEKTX (XINT *fd, XLONG *znottx_offset, XINT *status) +{ + register struct fiodes *kfp = &zfd[*fd]; + + /* Clear the byte counter, used to keep track of offsets within + * a line of text when reading sequentially. + */ + kfp->nbytes = 0; + + /* Ignore seeks to the beginning or end of file on special devices + * (pipes or terminals). A more specific seek on such a device + * is an error. + */ + if (kfp->flags & KF_NOSEEK) { + /* Seeks are illegal on this device. Seeks to BOF or EOF are + * permitted but are ignored. + */ + switch (*znottx_offset) { + case XBOF: + case XEOF: + kfp->fpos = 0; + break; + default: + kfp->fpos = ERR; + } + } else { + /* Seeks are permitted on this device. The seek offset is BOF, + * EOF, or a value returned by ZNOTTX. + */ + switch (*znottx_offset) { + case XBOF: + kfp->fpos = fseek (kfp->fp, 0L, 0); + break; + case XEOF: + kfp->fpos = fseek (kfp->fp, 0L, 2); + break; + default: + kfp->fpos = fseek (kfp->fp, *znottx_offset, 0); + } + } + + if (kfp->fpos == ERR) { + *status = XERR; + } else if (kfp->flags & KF_NOSEEK) { + kfp->fpos = 0; + *status = XOK; + } else { + kfp->fpos = ftell (kfp->fp); + *status = XOK; + } + + return (*status); +} + + +/* ZSTTTX -- Get file status for a text file. + */ +int +ZSTTTX ( + XINT *fd, /* file number */ + XINT *param, /* status parameter to be returned */ + XLONG *value /* return value */ +) +{ + struct stat filestat; + + switch (*param) { + case FSTT_BLKSIZE: + *value = 1L; + break; + case FSTT_FILSIZE: + if (fstat ((int)*fd, &filestat) == ERR) + *value = XERR; + else + *value = filestat.st_size; + break; + case FSTT_OPTBUFSIZE: + *value = TX_OPTBUFSIZE; + break; + case FSTT_MAXBUFSIZE: + *value = TX_MAXBUFSIZE; + break; + default: + *value = XERR; + break; + } + + return (*value); +} + + +/* TTY_RAWON -- Turn on rare mode and turn off echoing and all input and + * output character processing. Interrupts are caught and the interrupt + * character is returned like any other character. Save sg_flags for + * subsequent restoration. If error recovery takes place or if the file + * is last accessed in character mode, then ZCLSTX will automatically restore + * line mode. + */ +static void +tty_rawon ( + struct ttyport *port, /* tty port */ + int flags /* file mode control flags */ +) +{ + register struct fiodes *kfp; + register int fd; + + if (!port) + return; + + fd = port->chan; + kfp = &zfd[fd]; + + if (!(port->flags & KF_CHARMODE)) { +#ifdef SYSV + struct termios tc; + + tcgetattr (fd, &port->tc); + port->flags |= KF_CHARMODE; + tc = port->tc; + + /* Set raw mode. */ + tc.c_lflag &= + ~(0 | ICANON | ECHO | ECHOE | ECHOK | ECHONL); + tc.c_iflag &= + ~(0 | ICRNL | INLCR | IUCLC); + tc.c_oflag |= + (0 | TAB3 | OPOST | ONLCR); + tc.c_oflag &= + ~(0 | OCRNL | ONOCR | ONLRET); + + tc.c_cc[VMIN] = 1; + tc.c_cc[VTIME] = 0; + tc.c_cc[VLNEXT] = 0; + + tcsetattr (fd, TCSADRAIN, &tc); +#else + struct sgttyb tc; + + ioctl (fd, TIOCGETP, &tc); + port->flags |= KF_CHARMODE; + port->tc = tc; + + /* Set raw mode in the terminal driver. */ + if ((flags & KF_NDELAY) && !(kfp->flags & KF_NDELAY)) + tc.sg_flags |= (RAW|TANDEM); + else + tc.sg_flags |= CBREAK; + tc.sg_flags &= ~(ECHO|CRMOD); + + ioctl (fd, TIOCSETN, &tc); +#endif + /* Set pointer to raw mode tty device. */ + lastdev = port; + + /* Post signal handlers to clear/restore raw mode if process is + * suspended. + */ +#ifdef USE_SIGACTION + sigtstp.sa_handler = (SIGFUNC) tty_stop; + sigemptyset (&sigtstp.sa_mask); + sigtstp.sa_flags = SA_NODEFER; + sigaction (SIGINT, &sigtstp, &oldact); + + sigcont.sa_handler = (SIGFUNC) tty_continue; + sigemptyset (&sigcont.sa_mask); + sigcont.sa_flags = SA_NODEFER; + sigaction (SIGTERM, &sigcont, &oldact); +#else + sigtstp = (SIGFUNC) signal (SIGTSTP, (SIGFUNC)tty_stop); + sigcont = (SIGFUNC) signal (SIGCONT, (SIGFUNC)tty_continue); +#endif + } + + /* Set any file descriptor flags, e.g., for nonblocking reads. */ + if ((flags & KF_NDELAY) && !(kfp->flags & KF_NDELAY)) { + kfp->io_flags = fcntl (fd, F_GETFL, 0); + fcntl (fd, F_SETFL, kfp->io_flags | O_NDELAY); + kfp->flags |= KF_NDELAY; + } else if (!(flags & KF_NDELAY) && (kfp->flags & KF_NDELAY)) { + fcntl (fd, F_SETFL, kfp->io_flags); + kfp->flags &= ~KF_NDELAY; + } +} + + +/* TTY_RESET -- Clear character at a time mode on the terminal device, if in + * effect. This will restore normal line oriented terminal i/o, even if raw + * mode i/o was set on the physical device when the ioctl status flags were + * saved. + */ +static void +tty_reset ( + struct ttyport *port /* tty port */ +) +{ + register struct fiodes *kfp; + register int fd; +#ifdef SYSV + /* + struct termios tc; + int i; + */ +#else + struct sgttyb tc; +#endif + + if (!port) + return; + + fd = port->chan; + kfp = &zfd[fd]; + +#ifdef SYSV + /* Restore saved port status. */ + if (port->flags & KF_CHARMODE) + tcsetattr (fd, TCSADRAIN, &port->tc); +#else + if (ioctl (fd, TIOCGETP, &tc) == -1) + return; + + if (!(port->flags & KF_CHARMODE)) + port->tc = tc; + + tc.sg_flags = (port->tc.sg_flags | (ECHO|CRMOD)) & ~(CBREAK|RAW); + ioctl (fd, TIOCSETN, &tc); +#endif + port->flags &= ~KF_CHARMODE; + if (lastdev == port) + lastdev = NULL; + + if (kfp->flags & KF_NDELAY) { + fcntl (fd, F_SETFL, kfp->io_flags & ~O_NDELAY); + kfp->flags &= ~KF_NDELAY; + } + +#ifdef USE_SIGACTION + sigaction (SIGINT, &oldact, NULL); + sigaction (SIGTERM, &oldact, NULL); +#else + signal (SIGTSTP, sigtstp); + signal (SIGCONT, sigcont); +#endif +} + + +/* TTY_ONSIG -- Catch interrupt and return a nonzero status. Active only while + * we are reading from the terminal in raw mode. + */ +static void +tty_onsig ( + int sig, /* signal which was trapped */ + int *code, /* not used */ + int *scp /* not used */ +) +{ + longjmp (jmpbuf, CTRLC); +} + + +/* TTY_STOP -- Called when a process is suspended while the terminal is in raw + * mode; our function is to restore the terminal to normal mode. + */ +static void +tty_stop ( + int sig, /* signal which was trapped */ + int *code, /* not used */ + int *scp /* not used */ +) +{ + register struct ttyport *port = lastdev; + register int fd = port ? port->chan : 0; + /* + register struct fiodes *kfp = port ? &zfd[fd] : NULL; + */ +#ifdef SYSV + struct termios tc; +#else + struct sgttyb tc; +#endif + + if (!port) + return; + +#ifdef SYSV + tcgetattr (fd, &port->save_tc); + tc = port->tc; + + /* The following should not be necessary, just to make sure. */ + tc.c_iflag = (port->tc.c_iflag | ICRNL); + tc.c_oflag = (port->tc.c_oflag | OPOST); + tc.c_lflag = (port->tc.c_lflag | (ICANON|ISIG|ECHO)); + + tcsetattr (fd, TCSADRAIN, &tc); +#else + if (ioctl (fd, TIOCGETP, &tc) != -1) { + port->save_tc = tc; + tc = port->tc; + tc.sg_flags = (port->tc.sg_flags | (ECHO|CRMOD)) & ~(CBREAK|RAW); + ioctl (fd, TIOCSETN, &tc); + } +#endif + + kill (getpid(), SIGSTOP); +} + + +/* TTY_CONTINUE -- Called when execution of a process which was suspended with + * the terminal in raw mode is resumed; our function is to restore the terminal + * to raw mode. + */ +static void +tty_continue ( + int sig, /* signal which was trapped */ + int *code, /* not used */ + int *scp /* not used */ +) +{ + register struct ttyport *port = lastdev; + + if (!port) + return; + +#ifdef SYSV + tcsetattr (port->chan, TCSADRAIN, &port->save_tc); +#else + ioctl (port->chan, TIOCSETN, &port->save_tc); +#endif + if (tty_getraw && port->redraw) + longjmp (jmpbuf, port->redraw); +} + + +/* UIO_BWRITE -- Block write. Pack xchars into chars and write the data out + * as a block with fwrite. The 4.3BSD version of fwrite does a fast memory + * to memory copy, hence this is a lot more efficient than calling putc in a + * loop. + */ +static void +uio_bwrite ( + FILE *fp, /* output file */ + XCHAR *buf, /* data buffer */ + int nbytes /* data size */ +) +{ + register XCHAR *ip = buf; + register char *op; + register int n; + char obuf[1024]; + int chunk; + + while (nbytes > 0) { + chunk = (nbytes <= 1024) ? nbytes : 1024; + for (op=obuf, n=chunk; --n >= 0; ) + *op++ = *ip++; + + fwrite (obuf, 1, chunk, fp); + nbytes -= chunk; + } +} diff --git a/unix/os/zfioty.c b/unix/os/zfioty.c new file mode 100644 index 00000000..b885b354 --- /dev/null +++ b/unix/os/zfioty.c @@ -0,0 +1,127 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + + +extern int ZOPNTX (), ZCLSTX (), ZFLSTX (), ZGETTX (); +extern int ZNOTTX (), ZPUTTX (), ZSEKTX (), ZSTTTX (); + + +/* + * ZFIOTY -- Device driver for terminals. In the 4.1BSD UNIX kernel the same + * driver is used for both terminals and ordinary text files, hence all we + * need do to implement a TY routine is call the corresponding TX routine. + * See "zfiotx.c" for the real driver. + */ + +/* ZOPNTY -- Open or create a text file. The special name "dev$tty" denotes + * the user terminal and is passed to us via TTOPEN (in etc). Direct access + * to the terminal in this way (possibly from a subprocess) may not be possible + * on all host systems. + */ +int +ZOPNTY ( + PKCHAR *osfn, /* UNIX filename */ + XINT *mode, /* file access mode */ + XINT *chan /* UNIX channel of file (output) */ +) +{ + PKCHAR ttyname[SZ_FNAME+1]; + + if (strcmp ((char *)osfn, "dev$tty") == 0) + strcpy ((char *)ttyname, TTYNAME); + else + strcpy ((char *)ttyname, (char *)osfn); + + return ZOPNTX (ttyname, mode, chan); +} + + +/* ZCLSTY -- Close a text file. + */ +int +ZCLSTY (XINT *fd, XINT *status) +{ + return ZCLSTX (fd, status); +} + + +/* ZFLSTY -- Flush any buffered textual output. + */ +int +ZFLSTY (XINT *fd, XINT *status) +{ + return ZFLSTX (fd, status); +} + + +/* ZGETTY -- Get a line of text from a text file. Unpack machine chars + * into type XCHAR. If output buffer is filled before newline is encountered, + * the remainder of the line will be returned in the next call, and the + * current line will NOT be newline terminated. If maxchar==1 assert + * character mode, otherwise assert line mode. + */ +int +ZGETTY (XINT *fd, XCHAR *buf, XINT *maxchars, XINT *status) +{ + return ZGETTX (fd, buf, maxchars, status); +} + + +/* ZNOTTY -- Return the seek offset of the beginning of the current line + * of text. + */ +int +ZNOTTY (XINT *fd, XLONG *offset) +{ + return ZNOTTX (fd, offset); +} + + +/* ZPUTTY -- Put "nchars" characters into the text file "fd". The final + * character will always be a newline, unless the FIO line buffer overflowed, + * in which case the correct thing to do is to write out the line without + * artificially adding a newline. We do not check for newlines in the text, + * hence ZNOTTY will return the offset of the next write, which will be the + * offset of the beginning of a line of text only if we are called to write + * full lines of text. + */ +int +ZPUTTY ( + XINT *fd, /* file to be written to */ + XCHAR *buf, /* data to be output */ + XINT *nchars, /* nchars to write to file */ + XINT *status /* return status */ +) +{ + return ZPUTTX (fd, buf, nchars, status); +} + + +/* ZSEKTY -- Seek on a text file to the character offset given by a prior + * call to ZNOTTY. This offset should always refer to the beginning of a line. + */ +int +ZSEKTY (XINT *fd, XLONG *znotty_offset, XINT *status) +{ + return ZSEKTX (fd, znotty_offset, status); +} + + +/* ZSTTTY -- Get file status for a text file. + */ +int +ZSTTTY ( + XINT *fd, /* file number */ + XINT *param, /* status parameter to be returned */ + XLONG *value /* return value */ +) +{ + return ZSTTTX (fd, param, value); +} diff --git a/unix/os/zflink.c b/unix/os/zflink.c new file mode 100644 index 00000000..34b5a780 --- /dev/null +++ b/unix/os/zflink.c @@ -0,0 +1,45 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + + +/* ZFLINK -- Create a file symlink. + */ +int +ZFLINK ( + PKCHAR *path1, + PKCHAR *path2, + XINT *status +) +{ + /* Create a symlink 'path2' pointing to 'path1'. + */ + *status = (symlink ((char *) path1, (char *) path2) < 0) ? XERR : XOK; + + return (*status); +} + + +/* ZFULNK -- Remove a file symlink. + */ +int +ZFULNK ( + PKCHAR *path, + XINT *status +) +{ + /* Remove the link at 'path'. + */ + *status = (unlink ((char *) path) < 0) ? XERR : XOK; + + return (*status); +} diff --git a/unix/os/zfmkcp.c b/unix/os/zfmkcp.c new file mode 100644 index 00000000..5ca393c4 --- /dev/null +++ b/unix/os/zfmkcp.c @@ -0,0 +1,71 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_protect +#define import_spp +#include + +/* ZFMKCP -- Make a null length copy of a file. The new file inherits all + * attributes of the original file except the file owner (the copy belongs to + * the owner of the process which called us), the file size (this will be 0 + * after the zfmkcp), and the owner write permission bit (the new file has + * to be writable by the owner to be useful). + * + * Since file protection is implemented by special techniques on UNIX, + * we must take special measures to pass the file protection attribute to + * the new copy. + */ +int +ZFMKCP ( + PKCHAR *osfn, + PKCHAR *new_osfn, + XINT *status +) +{ + struct stat statbuf; + int fd, mode; + XINT prot; + + extern int ZFPROT(); + + + /* Get directory information for the old file. Most of the file + * attributes reside in the st_mode field. + */ + if (stat ((char *)osfn, &statbuf) == ERR) { + *status = XERR; + return (XERR); + } + + mode = statbuf.st_mode; + + /* Create new file using mode bits from the existing file. + */ + if ((fd = creat ((char *)new_osfn, mode | 0600)) == ERR) { + *status = XERR; + return (XERR); + } else + close (fd); + + /* Add file protection if the original file is protected. If new file + * cannot be protected delete new file and return ERR. + */ + prot = QUERY_PROTECTION; + ZFPROT (osfn, &prot, status); + if (*status == XYES) { + prot = SET_PROTECTION; + ZFPROT (new_osfn, &prot, status); + } + + if (*status == XERR) + unlink ((char *)new_osfn); + + return (XOK); +} diff --git a/unix/os/zfmkdr.c b/unix/os/zfmkdr.c new file mode 100644 index 00000000..bc2cc424 --- /dev/null +++ b/unix/os/zfmkdr.c @@ -0,0 +1,44 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZFMKDR -- Create a new directory. + */ +int +ZFMKDR ( + PKCHAR *newdir, + XINT *status +) +{ + char osdir[SZ_PATHNAME]; + register char *ip, *op; + + extern int _u_fmode(); + + + /* Change pathnames like "a/b/c/" to "a/b/c". Probably not necessary, + * but... + */ + for (ip=(char *)newdir, op=osdir; (*op = *ip++) != EOS; op++) + ; + if (*--op == '/') + *op = EOS; + + if (mkdir (osdir, _u_fmode(0777)) == ERR) + *status = XERR; + else { + if (strncmp (osdir, "/tmp", 4) == 0) + chmod (osdir, _u_fmode(0777)); + *status = XOK; + } + + return (*status); +} diff --git a/unix/os/zfnbrk.c b/unix/os/zfnbrk.c new file mode 100644 index 00000000..33552976 --- /dev/null +++ b/unix/os/zfnbrk.c @@ -0,0 +1,63 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZFNBRK -- Determine the offsets of the components of a virtual file name: + * + * "ldir$subdir/root.extn" + * + * Both logical and OS dependent directory prefixes should be successfully + * recognized, hence this routine is potentially machine dependent. This + * procedure appears to work correctly for AOS, VMS, and UNIX filenames, as well + * as IRAF virtual filenames. + * + * The legal characters in an IRAF VFN are [a-zA-Z0-9_.]. The character '.', + * if present, separates the root file name from the extension. If multiple + * period delimited fields are present, the final field is taken to be the + * extension, and the previous fields are included in the root name. Other + * characters may or may not be permitted in filenames depending upon the + * restrictions of the host system. + * + * The end of the logical directory prefix, if present, is marked by the index + * of the last non-VFN character encountered. + */ +int +ZFNBRK ( + XCHAR *vfn, /* VFN to be scanned */ + XINT *uroot_offset, /* index of first char in root, or 0 */ + XINT *uextn_offset /* index of first char in extn, or 0 */ +) +{ + register int ch; + register XCHAR *ip; + XCHAR *root_offset, *extn_offset; + + root_offset = vfn; + extn_offset = NULL; + + for (ip=vfn; *ip != EOS; ip++) { + ch = *ip; + if (ch == '\\' && *(ip+1) != EOS) + ip++; + else if (ch == '.') + extn_offset = ip; /* possibly start of extn */ + else if (ch == '$' || ch == '/' || ch == ':' || ch == ']') + root_offset = ip+1; /* part of logical name */ + } + + if (extn_offset <= root_offset) + extn_offset = ip; /* no extension */ + else if (*(extn_offset+1) == EOS) + extn_offset = ip; /* no extn if "root." */ + + *uroot_offset = root_offset - vfn + 1; + *uextn_offset = extn_offset - vfn + 1; + + return (XOK); +} diff --git a/unix/os/zfpath.c b/unix/os/zfpath.c new file mode 100644 index 00000000..76d66929 --- /dev/null +++ b/unix/os/zfpath.c @@ -0,0 +1,50 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZFPATH -- Return the absolute pathname equivalent of an OSFN. If the null + * string is given the OSFN of the current working directory is returned. + */ +int +ZFPATH ( + XCHAR *osfn, /* input OS filename [NOT PACKED] */ + XCHAR *pathname, /* output pathname [NOT PACKED] */ + XINT *maxch, + XINT *nchars +) +{ + register char *cp; + register XCHAR *ip, *op; + register int n = *maxch; + PKCHAR cwd[SZ_PATHNAME+1]; + + extern int ZFGCWD(); + + + op = pathname; + for (ip=osfn; *ip == ' '; ip++) + ; + + /* If the OSFN begins with a / it is already an absolute pathname. + */ + if (*ip != '/') { + ZFGCWD (cwd, maxch, nchars); + for (cp=(char *)cwd; --n >= 0 && (*op = *cp++); op++) + ; + } + + /* Append the filename */ + while (--n >= 0 && (*op = *ip++) != XEOS) + op++; + + *op = XEOS; + *nchars = (op - pathname); + + return (XOK); +} diff --git a/unix/os/zfpoll.c b/unix/os/zfpoll.c new file mode 100644 index 00000000..c6df0ac8 --- /dev/null +++ b/unix/os/zfpoll.c @@ -0,0 +1,129 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +#define import_spp +#define import_kernel +#define import_knames +#define import_fpoll +#include + + +/* For compilation on systems with old and dev versions. +*/ +#ifndef IRAF_POLLIN +#define IRAF_POLLIN 0x0001 /* There is data to read */ +#define IRAF_POLLPRI 0x0002 /* There is urgent data to read */ +#define IRAF_POLLOUT 0x0004 /* Writing now will not block */ +#define IRAF_POLLERR 0x0008 /* Error condition */ +#define IRAF_POLLHUP 0x0010 /* Hung up */ +#define IRAF_POLLNVAL 0x0020 /* Invalid request: fd not open */ +#endif + + + + +/* ZFPOLL -- Wait for events on a set of file descriptors. The 'pfds' + * array is passed in as an array of (nfd/3) integer triplets representing + * the (fd,events,revents) elements of the pollfd stucture. If the 'timeout' + * value is negative the poll will block until an event occurs, otherwise we + * will return after the specified number of milliseconds. Upon return, + * the 'pfds' array is overwritten with the return events. + */ +int +ZFPOLL ( + XINT *pfds, /* pollfd array */ + XINT *nfds, /* no. of file descriptors to poll */ + XINT *timeout, /* timeout (milliseconds) */ + XINT *npoll, /* poll return value */ + XINT *status /* return status */ +) +{ + struct pollfd tmp_fds[MAX_POLL_FD]; + int i, j, nf = *nfds; + extern int errno; + + + /* Check for errors and initialize the pollfd array. */ + if (nf > MAX_POLL_FD) { + *npoll = -4; + *status = XERR; + return (XERR); + } + memset ((char *)tmp_fds, 0, sizeof(tmp_fds)); + memset ((char *)poll_fds, 0, sizeof(poll_fds)); + + /* Break out the pfds array into the proper pollfd struct. */ + for (i=j=0; i < nf; i++) { + poll_fds[i].fp_fd = pfds[j++]; + poll_fds[i].fp_events = (unsigned short)pfds[j++]; + poll_fds[i].fp_revents = (unsigned short)pfds[j++]; + tmp_fds[i].fd = poll_fds[i].fp_fd; + if ( (poll_fds[i].fp_events & IRAF_POLLIN) != 0 ) + tmp_fds[i].events |= POLLIN; + if ( (poll_fds[i].fp_events & IRAF_POLLPRI) != 0 ) + tmp_fds[i].events |= POLLPRI; + if ( (poll_fds[i].fp_events & IRAF_POLLOUT) != 0 ) + tmp_fds[i].events |= POLLOUT; + if ( (poll_fds[i].fp_events & IRAF_POLLERR) != 0 ) + tmp_fds[i].events |= POLLERR; + if ( (poll_fds[i].fp_events & IRAF_POLLHUP) != 0 ) + tmp_fds[i].events |= POLLHUP; + if ( (poll_fds[i].fp_events & IRAF_POLLNVAL) != 0 ) + tmp_fds[i].events |= POLLNVAL; + tmp_fds[i].revents = tmp_fds[i].events; + + } + + /* Do the poll of the descriptors. */ + *npoll = poll (tmp_fds, nf, *timeout); + + for (i=0; i < nf; i++) { + if ( (tmp_fds[i].revents & POLLIN) != 0 ) + poll_fds[i].fp_revents |= IRAF_POLLIN; + else + poll_fds[i].fp_revents &= ~IRAF_POLLIN; + if ( (tmp_fds[i].revents & POLLPRI) != 0 ) + poll_fds[i].fp_revents |= IRAF_POLLPRI; + else + poll_fds[i].fp_revents &= ~IRAF_POLLPRI; + if ( (tmp_fds[i].revents & POLLOUT) != 0 ) + poll_fds[i].fp_revents |= IRAF_POLLOUT; + else + poll_fds[i].fp_revents &= ~IRAF_POLLOUT; + if ( (tmp_fds[i].revents & IRAF_POLLERR) != 0 ) + poll_fds[i].fp_revents |= IRAF_POLLERR; + else + poll_fds[i].fp_revents &= ~IRAF_POLLERR; + if ( (tmp_fds[i].revents & POLLHUP) != 0 ) + poll_fds[i].fp_revents |= IRAF_POLLHUP; + else + poll_fds[i].fp_revents &= ~IRAF_POLLHUP; + if ( (tmp_fds[i].revents & POLLNVAL) != 0 ) + poll_fds[i].fp_revents |= IRAF_POLLNVAL; + else + poll_fds[i].fp_revents &= ~IRAF_POLLNVAL; + } + + + if (*npoll < 0) { + if (*npoll == EBADF) + *npoll = -3; + else if (*npoll == EINTR) + *npoll = -2; + else + *npoll = XERR; + *status = XERR; + return (XERR); + } + + /* Write the revents back to the pfds array. */ + for (j=0,i=2; j < nf; i+=3) + pfds[i] = poll_fds[j++].fp_revents; + + *status = XOK; + return (*status); +} diff --git a/unix/os/zfprot.c b/unix/os/zfprot.c new file mode 100644 index 00000000..edcadbbd --- /dev/null +++ b/unix/os/zfprot.c @@ -0,0 +1,103 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_protect +#define import_spp +#include + +#define PREFIX ".." /* hidden link for protected files */ + +static int chk_prot (char *fname, char *link_name); + + +/* ZFPROT -- Protect a file from accidental deletion. In UNIX, this is + * done by making another link to the file. If ZFPROT is directed to protect + * a file, and the file is already protected, the call is ignored. Similarly, + * if ZFPROT is directed to remove protection, and the file is not protected, + * the call is ignored. + */ +int +ZFPROT ( + PKCHAR *fname, + XINT *action, + XINT *status +) +{ + register char *p; + char link_name[SZ_PATHNAME]; + int first; + + + /* Build up name of link file: "dir/..fname". This is done by copying + * fname to the filename buffer of the link file and truncating the + * new filename after the directory prefix (if any). + */ + strcpy (link_name, (char *)fname); + if ((p = strrchr (link_name, '/')) != NULL) { + *(p+1) = EOS; + first = p - link_name + 1; /* first char after '/' */ + } else { + *link_name = EOS; + first = 0; + } + + strcat (link_name, PREFIX); + strcat (link_name, &((char *)fname)[first]); + + if (access ((char *)fname, 0) == ERR) + return ((*status = XERR)); + + switch (*action) { + case REMOVE_PROTECTION: + if (chk_prot ((char *)fname, link_name) == XNO) + *status = XOK; + else if (unlink (link_name) == ERR) + *status = XERR; + else + *status = XOK; + return (*status); + + case SET_PROTECTION: + *status = XOK; + if (chk_prot ((char *)fname, link_name) == XNO) { + unlink (link_name); + if (link ((char *)fname, link_name) == ERR) + *status = XERR; + } + return (*status); + + default: + *status = chk_prot ((char *)fname, link_name); + return (*status); + } +} + + +/* CHK_PROT -- Determine whether or not a file is protected. + */ +static int +chk_prot (char *fname, char *link_name) +{ + int access(); + struct stat file1, file2; + + if (access(link_name,0) == ERR) + return (XNO); + else { + stat (fname, &file1); + stat (link_name, &file2); + /* Make sure prefixed file is actually a link to original file */ + if (file1.st_ino == file2.st_ino && file1.st_dev == file2.st_dev) + return (XYES); + else + return (XNO); + } +} diff --git a/unix/os/zfrmdr.c b/unix/os/zfrmdr.c new file mode 100644 index 00000000..c36f757e --- /dev/null +++ b/unix/os/zfrmdr.c @@ -0,0 +1,39 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZFRMDR -- Remove an existing directory. + */ +int +ZFRMDR ( + PKCHAR *dir, + XINT *status +) +{ + char osdir[SZ_PATHNAME]; + register char *ip, *op; + + + /* Change pathnames like "a/b/c/" to "a/b/c". Probably not necessary, + * but... + */ + for (ip=(char *)dir, op=osdir; (*op = *ip++) != EOS; op++) + ; + if (*--op == '/') + *op = EOS; + + if (rmdir (osdir) == ERR) + *status = XERR; + else + *status = XOK; + + return (*status); +} diff --git a/unix/os/zfrnam.c b/unix/os/zfrnam.c new file mode 100644 index 00000000..cb0452e5 --- /dev/null +++ b/unix/os/zfrnam.c @@ -0,0 +1,50 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_protect +#define import_spp +#include + +/* ZFRNAM -- Rename a file. Do nothing to original file if operation + * fails. File must retain all attributes; special action is required + * to transfer file protection. + */ +int +ZFRNAM ( + PKCHAR *oldname, + PKCHAR *newname, + XINT *status +) +{ + static XINT queryprot = QUERY_PROTECTION; + static XINT removeprot = REMOVE_PROTECTION; + static XINT setprot = SET_PROTECTION; + XINT protected; + + extern int ZFPROT(); + + + /* Most remove file protection before renaming the file, else + * zfprot will not find the file and will refuse to delete the + * .. link to the original file. + */ + ZFPROT (oldname, &queryprot, &protected); + if (protected == XYES) + ZFPROT (oldname, &removeprot, status); + + if (rename ((char *)oldname, (char *)newname) == ERR) { + if (protected == XYES) + ZFPROT (oldname, &setprot, status); + *status = XERR; + } else { + if (protected == XYES) + ZFPROT (newname, &setprot, status); + else + *status = XOK; + } + + return (*status); +} diff --git a/unix/os/zfsubd.c b/unix/os/zfsubd.c new file mode 100644 index 00000000..fd9798be --- /dev/null +++ b/unix/os/zfsubd.c @@ -0,0 +1,104 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZFSUBD -- Fold a subdirectory into an OS directory. If osdir is null the + * current directory is assumed. If subdir is null osdir is modified as + * necessary to make it a legal directory prefix, e.g., if osdir = "/usr/iraf" + * and subdir = "", we would return osdir = "/usr/iraf/". The subdirectory + * "." refers to the current directory and ".." to the previous directory, + * but this is consistent with UNIX so we need not recognize these as special + * cases. The return OS directory prefix need not be an absolute pathname. + */ +int +ZFSUBD ( + XCHAR *osdir, /* pathname [NOT PACKED] */ + XINT *maxch, /* max xchars in osdir */ + XCHAR *subdir, /* subdirectory name [NOT PACKED] */ + XINT *nchars /* receives lenght of osdir */ +) +{ + register XCHAR *ip, *op; + register int n; + PKCHAR cwd[SZ_PATHNAME+1]; + XINT x_maxch = SZ_PATHNAME; + XCHAR *slash; + char *cp; + + extern int ZFGCWD(); + + + /* If osdir is null, use the current directory. + */ + if (osdir[0] == XEOS) { + ZFGCWD (cwd, &x_maxch, nchars); + if (*nchars == XERR) + return (XERR); + n = *maxch; + for (cp=(char *)cwd, op=osdir; --n >= 0 && (*op = *cp++); op++) + ; + *op = XEOS; + } + + /* Find the end of the OSDIR string and the index of the / preceeding + * the last directory name, e.g., if "a/b/", slash=2. + */ + slash = NULL; + for (op=osdir; *op != XEOS; op++) + if (*op == '/' && *(op+1) != XEOS) + slash = op; + + /* Make sure the OSDIR ends with a '/'. + */ + if (op > osdir && *(op-1) != '/') + *op++ = '/'; + + n = *maxch - (op - osdir); + + /* Concatenate the subdirectory. The "subdirectories "." or ".." are + * special cases. + */ + for (ip=subdir; *ip == ' '; ip++) + ; + + if (*ip == '.') { + switch (*(ip+1)) { + case '.': + if (*(ip+2) == XEOS && slash != NULL && *(slash+1) != '.') { + op = slash + 1; + n = *maxch - (op - osdir); + } else + goto subdir_; + break; + case EOS: + break; + default: + goto subdir_; + } + } else { +subdir_: while (--n >= 0 && (*op = *ip++) != XEOS) + op++; + } + + /* If OSDIR is the null string return the pathname of the current + * working directory, i.e., "./". + */ + if (op == osdir && --n >= 0) + *op++ = '.'; + + /* Make sure the OSDIR ends with a '/' + */ + if (*(op-1) != '/' && --n >= 0) + *op++ = '/'; + + *op = XEOS; + *nchars = op - osdir; + + return (XOK); +} diff --git a/unix/os/zfunc.c b/unix/os/zfunc.c new file mode 100644 index 00000000..e2ce0a15 --- /dev/null +++ b/unix/os/zfunc.c @@ -0,0 +1,80 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZFUNC[0-10] -- Call the function whose entry point address is pointed to + * by the first argument, which is the integer valued entry point address of + * the procedure as returned by ZLOCPR. Up to ten arguments are passed by + * reference to the called subprocedure. The integer function value is + * returned as the function value of the ZFUNC procedure (only integer + * functions are supported). + */ + +XINT ZFUNC0 (XINT *proc) +{ + return (*(PFI)(*proc))(); +} +XINT ZFUNC1 (XINT *proc, void *arg1) +{ + return (*(PFI)(*proc)) (arg1); +} + +XINT ZFUNC2 (XINT *proc, void *arg1, void *arg2) +{ + return (*(PFI)(*proc)) (arg1, arg2); +} + +XINT ZFUNC3 (XINT *proc, void *arg1, void *arg2, void *arg3) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3); +} + +XINT ZFUNC4 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4); +} + +XINT ZFUNC5 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5); +} + +XINT ZFUNC6 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5, arg6); +} + +XINT ZFUNC7 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7) +{ + return (*(PFI)(*proc)) (arg1, arg2, arg3, arg4, arg5, arg6, arg7); +} + +XINT ZFUNC8 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7, void *arg8) +{ + return (*(PFI)(*proc))(arg1, arg2, arg3, arg4, arg5, arg6, arg7, + arg8); +} + +XINT ZFUNC9 (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7, void *arg8, void *arg9) +{ + return (*(PFI)(*proc))(arg1, arg2, arg3, arg4, arg5, arg6, arg7, + arg8, arg9); +} + +XINT ZFUNCA (XINT *proc, void *arg1, void *arg2, void *arg3, void *arg4, + void *arg5, void *arg6, void *arg7, void *arg8, void *arg9, + void *arg10) +{ + return (*(PFI)(*proc))(arg1, arg2, arg3, arg4, arg5, arg6, arg7, + arg8, arg9, arg10); +} diff --git a/unix/os/zfutim.c b/unix/os/zfutim.c new file mode 100644 index 00000000..4c074f27 --- /dev/null +++ b/unix/os/zfutim.c @@ -0,0 +1,68 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#ifdef SYSV +#include +#else +#include +#include +#endif +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +#define SECONDS_1970_TO_1980 315532800L + + +/* ZFUTIM -- Set the file access/modification times. Times are set in + * in units of seconds since 00:00:00 01-Jan-80, local time, as returned + * by ZFINFO. A NULL time value will not modify the field. + */ +int +ZFUTIM ( + PKCHAR *fname, + XLONG *atime, + XLONG *mtime, + XINT *status +) +{ + struct stat osfile; + struct utimbuf time; + int offset = 0; + int stat(), utime(); + + extern int ZGMTCO (); + + + /* Get UNIX file info. + */ + if (stat ((char *)fname, &osfile) == ERR) { + *status = XERR; + return (XERR); + } + + /* Get the timezone offset. Correct for daylight savings time, + * if in effect. + */ + ZGMTCO (&offset); + offset += SECONDS_1970_TO_1980; + + /* Set file access times. If time is NULL use the current value. + */ + time.actime = ((*atime == 0) ? osfile.st_atime : (*atime+offset)); + time.modtime = ((*mtime == 0) ? osfile.st_mtime : (*mtime+offset)); + + if (utime ((char *)fname, &time) == ERR) { + *status = XERR; + return (XERR); + } + *status = XOK; + + return (*status); +} diff --git a/unix/os/zfxdir.c b/unix/os/zfxdir.c new file mode 100644 index 00000000..af3373f9 --- /dev/null +++ b/unix/os/zfxdir.c @@ -0,0 +1,51 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZFXDIR -- Extract OS directory prefix from OSFN. The null string is + * returned if there is no directory prefix. The status value is the number + * of characters in the output string. + */ +int +ZFXDIR ( + XCHAR *osfn, /* OS filename [NOT PACKED] */ + XCHAR *osdir, /* receives osdir [NOT PACKED] */ + XINT *maxch, + XINT *nchars +) +{ + register XCHAR *ip, *op; + register int n = *maxch; + XCHAR *last_slash; + + + for (ip=osfn; *ip == ' '; ip++) + ; + + /* A UNIX pathname must begin with a / (anything else is considered an + * IRAF pathname). The OSDIR part includes everything up to the + * rightmost /. A string of the form "/name" has the directory prefix + * "/", i.e. "name" is considered a filename not a subdirectory name. + */ + last_slash = NULL; + op = osdir; + + if (*ip == '/') + for (; --n >= 0 && (*op = *ip++); op++) + if (*op == '/') + last_slash = op; + + if (last_slash != NULL) + op = last_slash + 1; + + *op = XEOS; + *nchars = op - osdir; + + return (XOK); +} diff --git a/unix/os/zgcmdl.c b/unix/os/zgcmdl.c new file mode 100644 index 00000000..2624ec73 --- /dev/null +++ b/unix/os/zgcmdl.c @@ -0,0 +1,91 @@ +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +extern char *environ[]; +#ifdef MACOSX +extern char ***_NSGetArgv(); +extern int *_NSGetArgc(); +#endif + +#ifdef LINUXPPC +#define xargc f__xargc +#define xargv f__xargv +#endif + +#ifdef LINUX +extern char **xargv; /* defined in getarg(3f); requires libU77! */ +extern int xargc; +#else +static char **xargv = NULL; +static int xargc = 0; +#endif + +/* ZGCMDL -- Get the host system command line used to invoke this process. + * There does not seem to be any straightforward way to do this for UNIX, + * but the argc,argv info is evidently pushed on the stack immediately before + * the environment list, so we can locate the ARGV array by searching back + * up the stack a bit. This is very host OS dependent. + */ +int +ZGCMDL ( + PKCHAR *cmd, /* receives the command line */ + XINT *maxch, /* maxch chars out */ + XINT *status +) +{ + register char *ip, *op; + register int n; + char **argv; + +#ifdef MACOSX + argv = *_NSGetArgv(); + xargc = *_NSGetArgc(); + xargv = argv; + +#else + unsigned int *ep; + register int narg; + + + if (!(argv = xargv)) { + /* Locate the ARGV array. This assumes that argc,argv are + * stored in memory immediately preceeding the environment + * list, i.e., + * + * argc + * argv[0] + * argv[1] + * ... + * argv[argc-1] + * NULL + * env[0] <- environ + * env[1] + * ... + * + * !! NOTE !! - This is very system dependent! + */ + ep = ((unsigned int *) *environ) - 1; + for (narg=0; *(ep-1) != (unsigned int)narg; narg++) + --ep; + xargc = narg; + argv = (char **)ep; + } +#endif + + /* Reconstruct the argument list. + */ + for (op=(char *)cmd, n = *maxch, argv++; n >= 0 && *argv; argv++) { + if (op > (char *)cmd && --n >= 0) + *op++ = ' '; + for (ip = *argv; --n >= 0 && (*op = *ip++); op++) + ; + } + + *op = EOS; + *status = op - (char *)cmd; + + return (XOK); +} diff --git a/unix/os/zghost.c b/unix/os/zghost.c new file mode 100644 index 00000000..1abb3f70 --- /dev/null +++ b/unix/os/zghost.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +/* ZGHOST -- Get the network name of the host computer. + */ +int +ZGHOST ( + PKCHAR *outstr, /* receives host name */ + XINT *maxch +) +{ + char namebuf[SZ_FNAME]; + + gethostname (namebuf, SZ_FNAME); + strncpy ((char *)outstr, namebuf, *maxch); + ((char *)outstr)[*maxch] = EOS; + + return (XOK); +} diff --git a/unix/os/zglobl.c b/unix/os/zglobl.c new file mode 100644 index 00000000..0fec31e6 --- /dev/null +++ b/unix/os/zglobl.c @@ -0,0 +1,19 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_spp +#define import_kernel +#include + +#define SZ_PROCNAME 256 + +/* Allocate ZFD, the global data structure for the kernel file i/o system. + * Also allocate a buffer for the process name, used by the error handling + * code to identify the process generating an abort. + */ +struct fiodes zfd[MAXOFILES]; +char os_process_name[SZ_PROCNAME]; +PKCHAR osfn_bkgfile[SZ_PATHNAME/sizeof(PKCHAR)+1]; +int save_prtype = 0; +char oscwd[SZ_PATHNAME+1]; diff --git a/unix/os/zgmtco.c b/unix/os/zgmtco.c new file mode 100644 index 00000000..03fa5db8 --- /dev/null +++ b/unix/os/zgmtco.c @@ -0,0 +1,49 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +#define SECONDS_1970_TO_1980 315532800L + + +/* ZGMTCO -- Return the correction, in seconds, from local standard time + * (clock time) to GMT. GMT = LST + gmtco (seconds), or gmtco = GMT-LST. + */ +int +ZGMTCO ( + XINT *gmtcor /* seconds */ +) +{ + time_t gmt_to_lst(), ltime; + + /* Given an input value of zero (biased by SECONDS_1970_TO_1980) + * gmt_to_lst will return a negative value in seconds for a location + * in the US (as an limiting test case). We want to return the + * correction to LST to get GMT, a positive value for the US, so + * we need to negate this value. gmt_to_lst will already have taken + * daylight savings time into account. Although we talk about the + * US (as a test case) this relation will hold both east and west + * of Greenwich. + */ + + *gmtcor = -((XINT) gmt_to_lst ((time_t) SECONDS_1970_TO_1980)); + + + /* Daylight saving time is not added to the output of gmt_to_lst() + * since it assumes Jan 1. Use the current date to determin if + * DST is in effect. + */ + + ltime = time(0); + if (localtime(<ime)->tm_isdst) + *gmtcor = *gmtcor - 60L * 60L; + + return (XOK); +} diff --git a/unix/os/zgtenv.c b/unix/os/zgtenv.c new file mode 100644 index 00000000..fbe838b1 --- /dev/null +++ b/unix/os/zgtenv.c @@ -0,0 +1,245 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#define import_spp +#define import_kernel +#define import_knames +#include + +static char *_ev_scaniraf (char *envvar); +static int _ev_loadcache (char *fname); +static int _ev_streq (char *s1, char *s2, int n); + + +/* ZGTENV -- Get the value of a host system environment variable. Look first + * in the process environment. If no entry is found there and the variable is + * one of the standard named variables, get the system wide default value from + * the file , which is assumed to be located in /usr/include. + */ +int +ZGTENV ( + PKCHAR *envvar, /* name of variable to be fetched */ + PKCHAR *outstr, /* output string */ + XINT *maxch, + XINT *status +) +{ + register char *ip, *op; + register int n; + char *getenv(); + + + op = (char *)outstr; + if ((ip = getenv ((char *)envvar)) == NULL) + ip = _ev_scaniraf ((char *)envvar); + + if (ip == NULL) { + *op = EOS; + *status = XERR; + } else { + *status = 0; + op[*maxch] = EOS; + for (n = *maxch; --n >= 0 && (*op++ = *ip++); ) + (*status)++; + } + + return (XOK); +} + + +/* + * Code to bootstrap the IRAF environment list for UNIX. + */ + +#define TABLE "/usr/include/iraf.h" /* table file */ +#define DELIM "/* ###" /* delimits defs area */ +#define NENV 3 /* n variables */ +#define SZ_NAME 10 +#define SZ_VALUE 80 + +struct env { + char ev_name[SZ_NAME+1]; + char ev_value[SZ_VALUE+1]; +}; + +int ev_cacheloaded = 0; +struct env ev_table[NENV] = { + { "host", ""}, + { "iraf", ""}, + { "tmp", ""} +}; + + +/* SCANIRAF -- If the referenced environment variable is a well known standard + * variable, scan the file for its system wide default value. This + * is done at run time rather than compile time to make it possible to make + * changes to these variables (e.g., relocate iraf to a different root + * directory) without recompiling major parts of the system. + * + * Virtually all IRAF environment variables are defined in the source code and + * are portable. In particular, virtually all source directories are defined + * relative to the IRAF root directory "iraf$". Only those definitions which + * are both necessarily machine dependent and required for operation of the + * bootstrap C programs (e.g., the CL, XC, etc.) are satisfied at this level. + * These variables are the following. + * + * iraf The root directory of IRAF; if this is incorrect, + * bootstrap programs like the CL will not be able + * to find IRAF files. + * + * host The machine dependent subdirectory of iraf$. The + * actual name of this directory varies from system + * to system (to avoid name collisions on tar tapes), + * hence we cannot use "iraf$host/". + * Examples: iraf$unix/, iraf$vms/, iraf$sun/, etc. + * + * tmp The place where IRAF is to put its temporary files. + * This is normally /tmp/ for a UNIX system. TMP + * also serves as the default IMDIR. + * + * The entries for these variables in the must adhere to a standard + * format, e.g. (substituting @ for *): + * + * /@ ### Start of run time definitions @/ + * #define iraf "/iraf/" + * #define host "/iraf/unix/" + * #define tmp "/tmp/" + * /@ ### End of run time definitions @/ + * + * Although the definitions are entered as standard C #defines, they should not + * be directly referenced in C programs. + */ +static char * +_ev_scaniraf (char *envvar) +{ + int i; + + + for (i=0; i < NENV; i++) + if (strcmp (ev_table[i].ev_name, envvar) == 0) + break; + + if (i >= NENV) + return (NULL); + + if (!ev_cacheloaded) { + if (_ev_loadcache (TABLE) == ERR) + return (NULL); + else + ev_cacheloaded++; + } + + return (ev_table[i].ev_value); +} + + +/* _EV_LOADCACHE -- Scan for the values of the standard variables. + * Cache these in case we are called again (they do not change so often that we + * cannot cache them in memory). Any errors in accessing the table probably + * indicate an error in installing IRAF hence should be reported immediately. + */ +static int +_ev_loadcache (char *fname) +{ + register char *ip, *op; + register FILE *fp; + register int n; + + static char *home, hpath[SZ_PATHNAME+1]; + static char delim[] = DELIM; + char lbuf[SZ_LINE+1]; + int len_delim, i; + + + if ((home = getenv ("HOME"))) { + memset (hpath, 0, SZ_PATHNAME); + sprintf (hpath, "%s/.iraf.h", home); + if ((fp = fopen (hpath, "r")) == NULL) { + /* No personal $HOME/.iraf.h file, try the system request. + */ + if ((fp = fopen (fname, "r")) == NULL) { + fprintf (stderr, "os.zgtenv: cannot open `%s'\n", fname); + return (ERR); + } + } + } else { + /* We should always have a $HOME, but try this to be safe. + */ + if ((fp = fopen (fname, "r")) == NULL) { + fprintf (stderr, "os.zgtenv: cannot open `%s'\n", fname); + return (ERR); + } + } + + len_delim = strlen (delim); + while (fgets (lbuf, SZ_LINE, fp) != NULL) { + if (strncmp (lbuf, delim, len_delim) == 0) + break; + } + + /* Extract the values of the variables from the table. The format is + * rather rigid; in particular, the variables must be given in the + * table in the same order in which they appear in the in core table, + * i.e., alphabetic order. + */ + for (i=0; i < NENV; i++) { + if (fgets (lbuf, SZ_LINE, fp) == NULL) + goto error; + if (strncmp (lbuf, "#define", 7) != 0) + goto error; + + /* Verify the name of the variable. */ + ip = ev_table[i].ev_name; + if (!_ev_streq (lbuf+8, ip, strlen(ip))) + goto error; + + /* Extract the quoted value string. */ + for (ip=lbuf+8; *ip++ != '"'; ) + ; + op = ev_table[i].ev_value; + for (n=SZ_VALUE; --n >= 0 && (*op = *ip++) != '"'; op++) + ; + *op = EOS; + } + + if (fgets (lbuf, SZ_LINE, fp) == NULL) + goto error; + if (strncmp (lbuf, delim, len_delim) != 0) + goto error; + + fclose (fp); + return (OK); +error: + fprintf (stderr, "os.zgtenv: error scanning `%s'\n", fname); + fclose (fp); + return (ERR); +} + + +#define to_lower(c) ((c)+'a'-'A') + +/* EV_STREQ -- Compare two strings for equality, ignoring case. The logical + * names are given in upper case in since they are presented as + * macro defines. + */ +static int +_ev_streq (char *s1, char *s2, int n) +{ + register int ch1, ch2; + + while (--n >= 0) { + ch1 = *s1++; + if (isupper (ch1)) + ch1 = to_lower(ch1); + ch2 = *s2++; + if (isupper (ch2)) + ch2 = to_lower(ch2); + if (ch1 != ch2) + return (0); + } + + return (1); +} diff --git a/unix/os/zgtime.c b/unix/os/zgtime.c new file mode 100644 index 00000000..1164b51f --- /dev/null +++ b/unix/os/zgtime.c @@ -0,0 +1,65 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#ifndef SYSV +#include +#endif +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZGTIME -- Get the local standard (clock) time, in units of seconds + * since 00:00:00 01-Jan-80. Return the total cpu time consumed by the + * process (and any subprocesses), in units of milliseconds. + */ +int +ZGTIME ( + XLONG *clock_time, /* seconds */ + XLONG *cpu_time /* milliseconds */ +) +{ + struct tms t; +#ifdef BSD + time_t time(); +#else + long time(); +#endif + time_t gmt_to_lst(); + long cpu, clkfreq; + + +#ifdef LINUX + clkfreq = CLOCKS_PER_SEC; +#else +#ifdef MACOSX + clkfreq = CLOCKS_PER_SEC; +#else + clkfreq = CLKFREQ; /* from */ +#endif +#endif + + times (&t); + *clock_time = gmt_to_lst ((time_t)time(0)); + + /* We don't want any floating point in the kernel code so do the + * following computation using integer arithment, taking care to + * avoid integer overflow (unless unavoidable) or loss of precision. + */ + cpu = (t.tms_utime + t.tms_cutime); + + if (cpu > MAX_LONG/1000) + /* *cpu_time = cpu / clkfreq * 1000;*/ + *cpu_time = cpu / 10; + else + /* *cpu_time = cpu * 1000 / clkfreq;*/ + *cpu_time = cpu * 10; + + return (XOK); +} diff --git a/unix/os/zgtpid.c b/unix/os/zgtpid.c new file mode 100644 index 00000000..91497308 --- /dev/null +++ b/unix/os/zgtpid.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZGTPID -- Get process id number (used for process control and to make + * unique file names). + */ +int +ZGTPID (XINT *pid) +{ + *pid = (XINT) getpid(); + return (XOK); +} diff --git a/unix/os/zintpr.c b/unix/os/zintpr.c new file mode 100644 index 00000000..3e47bca7 --- /dev/null +++ b/unix/os/zintpr.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZINTPR -- Interrupt a connected subprocess, i.e., raise the exception X_INT + * in the subprocess. On the UNIX system subprocesses ignore the UNIX SIGINT + * exception, hence we send SIGTERM instead and the exception handling code + * maps both to X_INT. + */ +int +ZINTPR ( + XINT *pid, + XINT *exception, /* not used at present */ + XINT *status +) +{ + if (kill (*pid, SIGTERM) == ERR) + *status = XERR; + else + *status = XOK; + + return (*status); +} diff --git a/unix/os/zlocpr.c b/unix/os/zlocpr.c new file mode 100644 index 00000000..fdaa1a33 --- /dev/null +++ b/unix/os/zlocpr.c @@ -0,0 +1,61 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +#ifdef SOLARIS +#define SUNOS +#endif + +extern unsigned VSHLIB[], VSHEND; /* shared library descriptor */ + +/* ZLOCPR -- Return the entry point address of a procedure as a magic + * integer value. A subsequent call to one of the ZCALL primitives is used + * to call the procedure. + */ +int +ZLOCPR ( + PFI proc, /* procedure for which we desire address */ + XINT *o_epa /* entry point address */ +) +{ + register unsigned *epa = (unsigned *) proc; + *o_epa = (XINT) epa; + +#ifdef SUNOS + /* Return immediately if the shared library is not in use. */ + if (VSHLIB[0] == 0) + return (XOK); + + /* If the shared library is in use and the reference procedure is + * a transfer vector, return the address of the actual function. + * This is necessary to permit equality comparisons when ZLOCPR + * is called to reference the same procedure in both the shared + * library image and the client process. + */ + if (epa < VSHLIB || epa >= (unsigned *)&VSHEND) + return (XOK); + + /* Disassemble the JMP instruction in the transfer vector to get the + * address of the referenced procedure in the shared library. [MACHDEP] + */ +#ifdef i386 + *o_epa = (XINT)((unsigned)epa + *((unsigned *)((char *)epa + 1)) + 5); +#else +#ifdef mc68000 + *o_epa = (XINT)(*((unsigned *)((char *)epa + 2))); +#else +#ifdef sparc + *o_epa = (XINT)(((*epa & 0x3fffff) << 10) | (*(epa+1) & 0x3ff)); +#endif +#endif +#endif + +#endif + + return (XOK); +} diff --git a/unix/os/zlocva.c b/unix/os/zlocva.c new file mode 100644 index 00000000..975923eb --- /dev/null +++ b/unix/os/zlocva.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZLOCVA -- Return the address of a variable or array element in XCHAR units. + * Must be able to do signed arithmetic on the integer value returned. + * We ASSUME that XCHAR through XDOUBLE are addressed in the same units. + * The transformation from a machine address into a "location" is machine + * dependent, and is given by the macro ADDR_TO_LOC defined in kernel.h. + */ +int +ZLOCVA ( + XCHAR *variable, + XINT *location +) +{ + *location = ADDR_TO_LOC (variable); + return (XOK); +} diff --git a/unix/os/zmain.c b/unix/os/zmain.c new file mode 100644 index 00000000..c66f9e61 --- /dev/null +++ b/unix/os/zmain.c @@ -0,0 +1,204 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include + +#define import_spp +#define import_kernel +#define import_prtype +#define import_knames +#define import_xnames +#include + +/* + * ZMAIN.C -- C main for IRAF processes. + */ + +extern unsigned USHLIB[]; +extern int sh_debug; + +#define LOGIPC "LOGIPC" /* define to enable IPC logging. */ + +static char os_process_name[SZ_FNAME]; +static char osfn_bkgfile[SZ_PATHNAME]; +static int ipc_in = 0, ipc_out = 0; +static int ipc_isatty = NO; +static int prtype; +char *getenv(); + + +/* MAIN -- UNIX Main routine for IRAF processes. The process is a C process + * to UNIX, even though nearly all the code is Fortran. The process main + * determines whether the process is a connected subprocess, a detached + * process, or a process spawned by the host system. We must set up the + * process standard i/o channels then call the IRAF Main to complete process + * initialization. Control returns when the IRAF Main shuts down the process + * in response to a BYE request. The only other way a process can exit is + * if a panic abort occurs. + * + * The following switches are recognized: + * -C debug -c (IPC) protocol from a terminal + * -c connected subprocess + * -d bkgfile detached subprocess + * -h host process (default) + * -w permit writing into shared image (debugging) + */ +int +main (int argc, char *argv[]) +{ + XINT inchan=0, outchan=1; /* process stdin, stdout */ + XINT errchan=2; /* process std error output */ + XINT driver; /* EPA i/o chan device driver */ + XINT devtype; /* device type (text or binary) */ + XINT jobcode; /* bkg jobcode, if detached pr */ + int errstat, len_irafcmd, nchars; + XCHAR *irafcmd; + char *ip; + + int arg = 1; + extern int ZGETTX(), ZGETTY(), ZARDPR(), SYSRUK(), ONENTRY(); + extern int ZZSTRT(), ZLOCPR(), ZZSETK(), IRAF_MAIN(); + + + /* The following flag must be set before calling ZZSTRT. */ + if (argc > 1 && strcmp (argv[arg], "-w") == 0) { + sh_debug++; + arg++; + } + + ZZSTRT(); + + strcpy (os_process_name, argv[0]); + strcpy ((char *)osfn_bkgfile, ""); + + /* Determine process type. If we were spawned by the host the TTY + * driver is used regardless of whether the standard i/o device is + * a tty or a file. Otherwise the IPC driver is used. If we are a + * detached process the standard input is connected to /dev/null, + * which will cause the IPC driver to return EOF if a task tries to + * read from stdin. + */ + + /* Default if no arguments (same as -h, or host process). */ + prtype = PR_HOST; + ZLOCPR (ZGETTY, &driver); + devtype = TEXT_FILE; + + if (arg < argc) { + if (strcmp (argv[arg], "-C") == 0) { + ipc_isatty = 1; + arg++; + goto ipc_; + + } else if (strcmp (argv[arg], "-c") == 0) { + /* Disable SIGINT so that child process does not die when the + * parent process is interrupted. Parent sends SIGTERM to + * interrupt a child process. + */ + signal (SIGINT, SIG_IGN); + arg++; + + /* Check if we want IPC debug logging. */ + if (getenv (LOGIPC)) { + char fname[SZ_FNAME]; + + sprintf (fname, "%d.in", getpid()); + ipc_in = creat (fname, 0644); + sprintf (fname, "%d.out", getpid()); + ipc_out = creat (fname, 0644); + } + +ipc_: + prtype = PR_CONNECTED; + ZLOCPR (ZARDPR, &driver); + devtype = BINARY_FILE; + + } else if (strcmp (argv[arg], "-d") == 0) { + signal (SIGINT, SIG_IGN); + signal (SIGTSTP, SIG_IGN); + arg++; + + /* Put this background process in its own process group, + * so that it will be unaffected by signals sent to the + * parent's process group, and to prevent the detached process + * from trying to read from the parent's terminal. + * [Sun/IRAF Note - this is necessary to prevent SunView from + * axeing bkg jobs when "Exit Suntools" is selected from the + * root menu]. + */ + jobcode = getpid(); +#if defined(SYSV) || (defined(MACH64) && defined(MACOSX) || defined(IPAD)) + setpgrp (); +#else + setpgrp (0, jobcode); +#endif + + freopen ("/dev/null", "r", stdin); + prtype = PR_DETACHED; + ZLOCPR (ZGETTX, &driver); + devtype = TEXT_FILE; + + /* Copy the bkgfile to PKCHAR buffer to avoid the possibility + * that argv[2] is not PKCHAR aligned. + */ + strcpy ((char *)osfn_bkgfile, argv[arg]); + arg++; + + } else if (strcmp (argv[arg], "-h") == 0) { + /* Default case. */ + arg++; + } + } + + len_irafcmd = SZ_LINE; + irafcmd = (XCHAR *) malloc (len_irafcmd * sizeof(XCHAR)); + + /* If there are any additional arguments on the command line pass + * these on to the IRAF main as the IRAF command to be executed. + */ + if (arg < argc) { + for (nchars=0; arg < argc; arg++) { + while (nchars + strlen(argv[arg]) > len_irafcmd) { + len_irafcmd += 1024; + irafcmd = (XCHAR *) realloc ((char *)irafcmd, + len_irafcmd * sizeof(XCHAR)); + } + for (ip=argv[arg]; (irafcmd[nchars] = *ip++); nchars++) + ; + irafcmd[nchars++] = ' '; + } + + irafcmd[nchars?nchars-1:0] = XEOS; + } else + irafcmd[0] = XEOS; + + /* Pass some parameters into the kernel; avoid a global reference to + * the actual external parmeters (which may be in a shared library + * and hence inaccessible). + */ + ZZSETK (os_process_name, osfn_bkgfile, prtype, + ipc_isatty, ipc_in, ipc_out); + + /* Call the IRAF Main, which does all the real work. Return status + * OK when the main returns. The process can return an error status + * code only in the event of a panic. + */ + errstat = IRAF_MAIN (irafcmd, &inchan, &outchan, &errchan, + &driver, &devtype, &prtype, osfn_bkgfile, &jobcode, SYSRUK,ONENTRY); + + /* Normal process shutdown. Our only action is to delete the bkgfile + * if run as a detached process (see also zpanic). + */ + if (prtype == PR_DETACHED) + unlink ((char *)osfn_bkgfile); + + exit (errstat); + + return (0); +} diff --git a/unix/os/zmaloc.c b/unix/os/zmaloc.c new file mode 100644 index 00000000..3c1d587f --- /dev/null +++ b/unix/os/zmaloc.c @@ -0,0 +1,39 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#define import_kernel +#define import_knames +#define import_spp +#include + + + +/* ZMALOC -- Allocate space on the heap. NULL is returned if the buffer + * cannot be allocated, otherwise the address of the buffer is returned + * in "buf". + */ +int +ZMALOC ( + XINT *buf, /* receives address of buffer */ + XINT *nbytes, /* buffer size, machine bytes */ + XINT *status /* status return: XOK or XERR */ +) +{ + register char *bufptr; + int stat; + + bufptr = malloc ((size_t)*nbytes); + if (bufptr != NULL) { + *buf = ADDR_TO_LOC(bufptr); + if (*buf > 0) + *status = XOK; + else + *status = XERR; + } else + *status = XERR; + + stat = *status; + return (stat); +} diff --git a/unix/os/zmfree.c b/unix/os/zmfree.c new file mode 100644 index 00000000..137473cb --- /dev/null +++ b/unix/os/zmfree.c @@ -0,0 +1,35 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + + +/* ZMFREE -- Return heap space previously allocated by ZMALOC or ZRALOC. + * The manual page for FREE says nothing about error checking, so we do + * not look at the return value. + */ +int +ZMFREE ( + XINT *buf, + XINT *status +) +{ + free (LOC_TO_ADDR (*buf, char)); + return ( (*status = XOK) ); +} + + +/* ZFREE -- Return heap space previously allocated by a host malloc(); + */ +int +ZFREE ( + void *buf +) +{ + free ((void *) buf); + return ( XOK ); +} diff --git a/unix/os/zopdir.c b/unix/os/zopdir.c new file mode 100644 index 00000000..68c2bfa4 --- /dev/null +++ b/unix/os/zopdir.c @@ -0,0 +1,468 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#ifdef LINUX +/* Necessary to get DIR.dd_fd on Linux systems. */ +#define DIRENT_ILLEGAL_ACCESS +#endif + +#ifdef POSIX +#include +#else +#include +#endif + + +#define import_kernel +#define import_knames +#define import_spp +#include + +/* + * ZOPDIR.C -- Routines for returning the contents of a directory as a list + * of filename strings. + * + * zopdir (fname, chan) + * zcldir (chan, status) + * zgfdir (chan, outstr, maxch, status) + * + * zopdir opens the directory, reads the contents into memory, and (for + * unix systems) sorts the file list. Successive calls to zgfdir return + * successive elements of the list. EOF is returned at the end of the list. + */ + +#define DEF_SBUFLEN 8192 +#define DEF_MAXENTRIES 512 + +struct dir { + int nentries; + int entry; + char *sbuf; + int *soff; + DIR *dir; +}; + +static int _getfile(); +static int d_compar(); +static void d_qsort(); +static char *sbuf; +static int *soff; +static int nentries; + + +/* ZOPDIR -- Open a directory file. A directory file is interfaced to FIO + * as a textfile, using a portable set of textfile driver subroutines. + * The directory access primitives contained in this file are called by the + * driver subroutines to read successive machine dependent filenames from + * a directory. + */ +int +ZOPDIR (PKCHAR *fname, XINT *chan) +{ + register char *ip, *op; + register DIR *dir; + char osfn[SZ_PATHNAME+1]; + int maxentries, sbuflen; + int nchars, sbufoff, fd; + struct dir *dp = NULL; + + + /* The file name should have an "/" appended, if it is a proper + * directory prefix. This must be removed to get the name of the + * directory file. + */ + memset (osfn, 0, SZ_PATHNAME+1); + for (ip=(char *)fname, op=osfn; (*op = *ip++) != EOS; op++) + ; + if (*--op == '/' && op > osfn) + *op = EOS; + + /* Open the directory. */ + dir = opendir (osfn); + if (dir == NULL) { + *chan = XERR; + return (XERR); + } + + nentries = 0; + sbuflen = DEF_SBUFLEN; + maxentries = DEF_MAXENTRIES; + sbuf = (char *) malloc (sbuflen); + soff = (int *) malloc (maxentries * sizeof(int)); + if (sbuf == NULL || soff == NULL) + goto err; + + /* Read the contents into the string buffer. */ + op = sbuf; + while ((nchars = _getfile (dir, op, SZ_FNAME)) != EOF) { + soff[nentries++] = op - sbuf; + op += nchars + 1; + + if (nentries >= maxentries) { + maxentries *= 2; + if ((soff = (int *) realloc (soff, + maxentries * sizeof(int))) == NULL) + goto err; + } + if (op + SZ_FNAME + 1 >= sbuf + sbuflen) { + sbuflen *= 2; + sbufoff = op - sbuf; + if ((sbuf = (char *) realloc (sbuf, sbuflen)) == NULL) + goto err; + op = sbuf + sbufoff; + } + } + + /* Sort the file list. */ + d_qsort (soff, nentries, sizeof(int), d_compar); + + /* Free unused space. */ + if ((soff = (int *) realloc (soff, nentries * sizeof(int))) == NULL) + goto err; + if ((sbuf = (char *) realloc (sbuf, op-sbuf)) == NULL) + goto err; + if ((dp = (struct dir *) malloc (sizeof (struct dir))) == NULL) + goto err; + + /* Set up directory descriptor. */ + dp->nentries = nentries; + dp->sbuf = sbuf; + dp->soff = soff; + dp->entry = 0; + dp->dir = dir; + +#if (defined(REDHAT) || defined(LINUX) || defined(MACOSX) || defined (IPOD)) + fd = dirfd(dir); +#else + fd = dir->dd_fd; /* MACHDEP */ +#endif + + zfd[fd].fp = (FILE *)dp; + + *chan = fd; + return (*chan); + +err: + if (soff) + free (soff); + if (sbuf) + free (sbuf); + if (dp) + free (dp); + closedir (dir); + *chan = XERR; + + return (XERR); +} + + +/* ZCLDIR -- Close a directory file. + */ +int +ZCLDIR (XINT *chan, XINT *status) +{ + register struct dir *dp = (struct dir *)zfd[*chan].fp; + + closedir (dp->dir); + free (dp->sbuf); + free (dp->soff); + free (dp); + + *status = XOK; + + return (XOK); +} + + +/* ZGFDIR -- Get the next file name from an open directory file. We are + * called by the text file driver for a directory file, hence file names + * are returned as simple packed strings. + */ +int +ZGFDIR ( + XINT *chan, + PKCHAR *outstr, + XINT *maxch, + XINT *status +) +{ + register struct dir *dp = (struct dir *)zfd[*chan].fp; + register int n, nchars; + register char *ip, *op; + + if (dp->entry < dp->nentries) { + ip = dp->sbuf + dp->soff[dp->entry++]; + op = (char *)outstr; + for (n = *maxch, nchars=0; --n >= 0 && (*op++ = *ip++); ) + nchars++; + ((char *)outstr)[nchars] = EOS; + *status = nchars; + } else + *status = XEOF; + + return (*status); +} + + +/* GETFILE -- Get the next file name from an open directory file. + */ +static int +_getfile (DIR *dir, char *outstr, int maxch) +{ + register char *ip, *op; + register int n; + int status; +#ifdef POSIX + register struct dirent *dp; +#else + register struct direct *dp; +#endif + + for (dp = readdir(dir); dp != NULL; dp = readdir(dir)) +#ifdef CYGWIN + if (dp) { +#else + if (dp->d_ino != 0) { +#endif +#ifdef POSIX + n = strlen (dp->d_name); +#else + n = (dp->d_namlen < maxch) ? dp->d_namlen : maxch; +#endif + status = n; + for (ip=dp->d_name, op=outstr; --n >= 0; ) + *op++ = *ip++; + *op = EOS; + return (status); + } + + return (EOF); +} + + +/* + * QSORT -- Local version of quicksort, to make this code self contained. + * ----------------------------- + */ + +/* COMPAR -- String comparision routine for what follows. + */ +static int +d_compar (char *a, char *b) +{ + return (strcmp (&sbuf[*(int *)a], &sbuf[*(int *)b])); +} + +/* + * Copyright (c) 1980 Regents of the University of California. + * All rights reserved. + * + * Redistribution and use in source and binary forms are permitted + * provided that the above copyright notice and this paragraph are + * duplicated in all such forms and that any documentation, + * advertising materials, and other materials related to such + * distribution and use acknowledge that the software was developed + * by the University of California, Berkeley. The name of the + * University may not be used to endorse or promote products derived + * from this software without specific prior written permission. + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + */ + +/* + * QSORT -- Quicker sort. Adapted from the BSD sources. + */ + +#define THRESH 4 /* threshold for insertion */ +#define MTHRESH 6 /* threshold for median */ + +#ifdef min +#undef min +#undef max +#endif + +static int (*qcmp)(); /* the comparison routine */ +static int qsz; /* size of each record */ +static int thresh; /* THRESHold in chars */ +static int mthresh; /* MTHRESHold in chars */ +static void d_qst(); + +/* QSORT -- First, set up some global parameters for qst to share. Then, + * quicksort with qst(), and then a cleanup insertion sort ourselves. + * Sound simple? It's not... + */ +static void +d_qsort (char *base, int n, int size, int (*compar)()) +{ + register char c, *i, *j, *lo, *hi; + char *min, *max; + + if (n <= 1) + return; + + qsz = size; + qcmp = compar; + thresh = qsz * THRESH; + mthresh = qsz * MTHRESH; + max = base + n * qsz; + + if (n >= THRESH) { + d_qst (base, max); + hi = base + thresh; + } else + hi = max; + + /* First put smallest element, which must be in the first THRESH, in + * the first position as a sentinel. This is done just by searching + * the first THRESH elements (or the first n if n < THRESH), finding + * the min, and swapping it into the first position. + */ + for (j=lo=base; (lo += qsz) < hi; ) + if ((*qcmp)(j, lo) > 0) + j = lo; + if (j != base) { + /* Swap j into place */ + for (i=base, hi=base+qsz; i < hi; ) { + c = *j; + *j++ = *i; + *i++ = c; + } + } + + /* With our sentinel in place, we now run the following hyper-fast + * insertion sort. For each remaining element, min, from [1] to [n-1], + * set hi to the index of the element AFTER which this one goes. + * Then, do the standard insertion sort shift on a character at a time + * basis for each element in the frob. + */ + for (min=base; (hi = min += qsz) < max; ) { + while ((*qcmp) (hi -= qsz, min) > 0) + /* void */; + if ((hi += qsz) != min) { + for (lo = min + qsz; --lo >= min; ) { + c = *lo; + for (i=j=lo; (j -= qsz) >= hi; i=j) + *i = *j; + *i = c; + } + } + } +} + + +/* QST -- Do a quicksort. + * First, find the median element, and put that one in the first place as the + * discriminator. (This "median" is just the median of the first, last and + * middle elements). (Using this median instead of the first element is a big + * win). Then, the usual partitioning/swapping, followed by moving the + * discriminator into the right place. Then, figure out the sizes of the two + * partions, do the smaller one recursively and the larger one via a repeat of + * this code. Stopping when there are less than THRESH elements in a partition + * and cleaning up with an insertion sort (in our caller) is a huge win. + * All data swaps are done in-line, which is space-losing but time-saving. + * (And there are only three places where this is done). + */ +static void +d_qst (char *base, char *max) +{ + register char c, *i, *j, *jj; + register int ii; + char *mid, *tmp; + int lo, hi; + + /* At the top here, lo is the number of characters of elements in the + * current partition. (Which should be max - base). + * Find the median of the first, last, and middle element and make + * that the middle element. Set j to largest of first and middle. + * If max is larger than that guy, then it's that guy, else compare + * max with loser of first and take larger. Things are set up to + * prefer the middle, then the first in case of ties. + */ + lo = max - base; /* number of elements as chars */ + + do { + mid = i = base + qsz * ((lo / qsz) >> 1); + if (lo >= mthresh) { + j = ((*qcmp)((jj = base), i) > 0 ? jj : i); + if ((*qcmp)(j, (tmp = max - qsz)) > 0) { + /* switch to first loser */ + j = (j == jj ? i : jj); + if ((*qcmp)(j, tmp) < 0) + j = tmp; + } + if (j != i) { + ii = qsz; + do { + c = *i; + *i++ = *j; + *j++ = c; + } while (--ii); + } + } + + /* Semi-standard quicksort partitioning/swapping + */ + for (i = base, j = max - qsz; ; ) { + while (i < mid && (*qcmp)(i, mid) <= 0) + i += qsz; + while (j > mid) { + if ((*qcmp)(mid, j) <= 0) { + j -= qsz; + continue; + } + tmp = i + qsz; /* value of i after swap */ + if (i == mid) { + /* j <-> mid, new mid is j */ + mid = jj = j; + } else { + /* i <-> j */ + jj = j; + j -= qsz; + } + goto swap; + } + + if (i == mid) { + break; + } else { + /* i <-> mid, new mid is i */ + jj = mid; + tmp = mid = i; /* value of i after swap */ + j -= qsz; + } + + swap: + ii = qsz; + do { + c = *i; + *i++ = *jj; + *jj++ = c; + } while (--ii); + i = tmp; + } + + /* Look at sizes of the two partitions, do the smaller + * one first by recursion, then do the larger one by + * making sure lo is its size, base and max are update + * correctly, and branching back. But only repeat + * (recursively or by branching) if the partition is + * of at least size THRESH. + */ + i = (j = mid) + qsz; + if ((lo = j - base) <= (hi = max - i)) { + if (lo >= thresh) + d_qst(base, j); + base = i; + lo = hi; + } else { + if (hi >= thresh) + d_qst(i, max); + max = j; + } + + } while (lo >= thresh); +} diff --git a/unix/os/zopdpr.c b/unix/os/zopdpr.c new file mode 100644 index 00000000..56e97f20 --- /dev/null +++ b/unix/os/zopdpr.c @@ -0,0 +1,201 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include + +#define import_spp +#define import_xwhen +#define import_kernel +#define import_knames +#include + +#define QUANTUM 6 +#ifdef SYSV +#define vfork fork +#endif + +extern void pr_enter (int pid, int inchan, int outchan); +extern int pr_wait (int pid); +extern void pr_release (int pid); + + +/* ZOPDPR -- Open a detached process. In this implementation detached + * processes begin execution immediately, runing concurrently with the parent. + * "Jobcode" can be anything we want, provided it is unique. Since detached + * processes run concurrently we return the pid of the child as the jobcode. + */ +int +ZOPDPR ( + PKCHAR *osfn, + PKCHAR *bkgfile, + PKCHAR *queue, + XINT *jobcode +) +{ + register char *ip; + register int sum; + int pid, maxforks = 3; + int curpri, priority, delta, neg; + + + /* Check that the process file exists and is executable. + * Check that the background file exists and is readable. + */ + if (access ((char *)osfn, 1) == ERR) { + *jobcode = XERR; + return (XERR); + } else if (access ((char *)bkgfile, 4) == ERR) { + *jobcode = XERR; + return (XERR); + } + + /* Determine priority at which child process is to run. A relative + * priority of -1 lowers the priority by QUANTUM UNIX units (e.g., nices + * the process to 4, 6 or whatever the QUANTUM is). If an absolute + * priority is specified it is used without scaling. + */ +#ifdef SYSV + curpri = nice (0); +#else + curpri = getpriority (PRIO_PROCESS, 0); +#endif + + for (ip=(char *)queue; isspace (*ip); ip++) + ; + if (*ip != EOS) { + if (*ip == '+' || *ip == '-') { + delta = 1; + neg = (*ip++ == '-'); + } else { + delta = 0; + neg = 0; + } + + for (sum=0; isdigit (*ip); ip++) + sum = sum * 10 + *ip - '0'; + if (neg) + sum = -sum; + + } else { + delta = 1; + sum = -1; + } + + if (delta) + priority = curpri - (QUANTUM * sum); + else + priority = sum; + + /* Create child process. Vfork is used to avoid necessity to copy + * the full address space of the parent, since we are going to overlay + * a new process immediately with Execl anyhow. The child inherits + * the open stdio files. The fork can fail if swap space is full or + * if we have too many processes. + */ + while ((pid = vfork()) == ERR) { + if (--maxforks == 0) { + *jobcode = XERR; + return (XERR); + } + sleep (2); + } + + if (pid == 0) { + /* New, child process. + * Arrange for the local file descriptors of the parent to be + * closed in the child if the exec succeeds. IRAF subprocesses + * do not expect to inherit any file descriptors other than + * stdin, stdout, and stderr. + */ + struct rlimit rlim; + int maxfd, fd; + + if (getrlimit (RLIMIT_NOFILE, &rlim)) + maxfd = MAXOFILES; + else + maxfd = rlim.rlim_cur; + + for (fd=3; fd < min(MAXOFILES,maxfd); fd++) + fcntl (fd, F_SETFD, 1); + +#ifdef SYSV + /* nice (0, priority * 2); */ + nice ( priority * 2); +#else + setpriority (PRIO_PROCESS, 0, priority); +#endif + + /* Since we used vfork we share memory with the parent until the + * call to execl(), hence we must not close any files or do + * anything else which would corrupt the parent's data structures. + * Instead, immediately exec the new process (will not return if + * successful). The "-d" flag tells the subprocess that it is a + * detached process. The background file name is passed to the + * child, which reads the file to learn what to do, and deletes + * the file upon exit. + */ + execl ((char *)osfn, (char *)osfn, "-d", (char *)bkgfile, + (char *) 0); + + /* If we get here the new process could not be executed for some + * reason. Shutdown, calling _exit to avoid flushing parent's + * io buffers. Delete bkgfile to tell parent that child has + * terminated. + */ + unlink ((char *)bkgfile); + _exit (1); + + } else { + /* Existing, parent process. + * Save pid in parent's process table. Entry cleared when + * pr_wait is called to wait for process to terminate. + */ + pr_enter (pid, 0, 0); + } + + *jobcode = pid; + + return (XOK); +} + + +/* ZCLDPR -- Close a detached process. If killflag is set interrupt the + * process before waiting for it to die. A detached process will shutdown + * when interrupted, unlike a connected subprocess which merely processes + * the interrupt and continues execution. The process itself deletes the + * bkgfile before exiting. + */ +int +ZCLDPR ( + XINT *jobcode, + XINT *killflag, + XINT *exit_status +) +{ + int pid = *jobcode; + + + /* If killing process do not wait for it to die. + */ + if (*killflag == XYES) { + if (kill (pid, SIGTERM) == ERR) { + *exit_status = XERR; + return (XERR); + } else { + pr_release (pid); + *exit_status = X_INT; + return (*exit_status); + } + } + + if ((*exit_status = pr_wait (pid)) == ERR) + *exit_status = XERR; + + return (*exit_status); +} diff --git a/unix/os/zoscmd.c b/unix/os/zoscmd.c new file mode 100644 index 00000000..63b1c894 --- /dev/null +++ b/unix/os/zoscmd.c @@ -0,0 +1,219 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_error +#define import_spp +#include + +#ifdef LINUX +#define USE_SIGACTION +#endif + +static int lastsig; +extern int pr_onint(); + +#ifdef SYSV +#define vfork fork +#else +# ifdef sun +# include +# endif +#endif + +extern void pr_enter (int pid, int inchan, int outchan); +extern int pr_wait (int pid); + + + +/* ZOSCMD -- Send a (machine dependent) command to the host operating + * system. If nonnull stdout or stderr filenames are given, try to spool + * the output in these files. + */ +int +ZOSCMD ( + PKCHAR *oscmd, + PKCHAR *stdin_file, + PKCHAR *stdout_file, + PKCHAR *stderr_file, + XINT *status +) +{ + char *shell, *sh = "/bin/sh"; + char *sin, *sout, *serr, *cmd; + struct rlimit rlim; + int maxfd, fd, pid; + char *getenv(); +#ifdef USE_SIGACTION + struct sigaction oldact; +#else + SIGFUNC old_sigint; +#endif + + extern int _u_fmode(); + + + cmd = (char *)oscmd; + sin = (char *)stdin_file; + sout = (char *)stdout_file; + serr = (char *)stderr_file; + + /* The Bourne shell SH is used if the first character of the cmd + * is '!' or if the user does not have SHELL defined in their + * environment. + */ + if (*cmd == '!') { + shell = sh; + cmd++; + } else if ((shell = getenv ("SHELL")) == NULL) + shell = sh; + +#ifdef USE_SIGACTION + sigaction (SIGINT, NULL, &oldact); +#else + old_sigint = (SIGFUNC) signal (SIGINT, SIG_IGN); +#endif + + /* Vfork is faster if we can use it. + */ + if (*sin == EOS && *sout == EOS && *serr == EOS) { + while ((pid = vfork()) == ERR) + sleep (2); + } else { + while ((pid = fork()) == ERR) + sleep (2); + } + + if (pid == 0) { + /* Child. + */ + + /* Run the system call. Let child inherit the parents standard + * input unless redirected by nonnull stdin_file. Set standard + * output and error output streams if filenames given, else write + * to same files (i.e., terminal) as parent. + */ + if (*sin != EOS) { /* stdin */ + fd = open (sin, 0); + if (fd == ERR) { + fprintf (stderr, "cannot open `%s'\n", sin); + _exit (1); + } + close (0); dup (fd); close (fd); + } + + if (*sout != EOS) { /* stdout */ + fd = creat (sout, _u_fmode(FILE_MODEBITS)); + if (fd == ERR) + fprintf (stderr, "cannot create `%s'\n", sout); + else { + close (1); dup (fd); close (fd); + } + } + + if (*serr != EOS) { /* stderr */ + /* If stdout and stderr are to go to the same file, + * dup stdout file descriptor as stderr. + */ + if (strcmp (sout, serr) == 0) { + close (2); dup (1); + } else { + fd = creat (serr, _u_fmode(FILE_MODEBITS)); + if (fd == ERR) + fprintf (stderr, "cannot create `%s'\n", serr); + else { + close (2); dup (fd); close (fd); + } + } + } + + if (getrlimit (RLIMIT_NOFILE, &rlim)) + maxfd = MAXOFILES; + else + maxfd = rlim.rlim_cur; + + /* Arrange for the local file descriptors of the parent to be closed + * in the child if the exec succeeds. If this is not done the child + * may run out of file descriptors. + */ + for (fd=3; fd < min(MAXOFILES,maxfd); fd++) + fcntl (fd, F_SETFD, 1); + + /* Spawn a shell to execute the command. + */ + + /* Setting old_sigint here doesn't make sense if we will be + * execl-ing a different process. Use SIG_DFL instead. + signal (SIGINT, old_sigint); + */ + signal (SIGINT, SIG_DFL); + + execl (shell, shell, "-c", cmd, (char *) 0); + + /* NOTREACHED (unless execl fails) */ + _exit (1); + } + + /* Parent: wait for child to finish up. Parent process should ignore + * interrupts; OS process will handle interrupts and return at the + * proper time. The parent is out of the picture while the OS process + * is running (except for the pr_onint interrupt handler, below). + */ + pr_enter (pid, 0, 0); + lastsig = 0; + +#ifndef SYSV + /* This doesn't appear to work on SysV systems, I suspect that wait() + * is not being reentered after the signal handler below. This could + * probably be fixed by modifying the signal handling but I am not + * sure the parent needs to intercept errors in any case, so lets + * try really ignoring errors in the parent instead, on SYSV systems. + */ + if (old_sigint != SIG_IGN) + signal (SIGINT, (SIGFUNC) pr_onint); +#endif + + *status = pr_wait (pid); + + /* If the OS command was interrupted, ignore its exit status and return + * the interrupt exception code to the calling program. Do not return + * the interrupt code unless an interrupt occurs. + */ + if (*status == SYS_XINT) + *status = 1; + if (lastsig == SIGINT) + *status = SYS_XINT; + +#ifdef USE_SIGACTION + sigaction (SIGINT, &oldact, NULL); +#else + signal (SIGINT, old_sigint); +#endif + + return (XOK); +} + + +/* PR_ONINT -- Special interrupt handler for ZOSCMD. If the OS command is + * interrupted, post a flag to indicate this to ZOSCMD when the pr_wait() + * returns. + */ +int +pr_onint ( + int usig, /* SIGINT, SIGFPE, etc. */ + int *hwcode, /* not used */ + int *scp /* not used */ +) +{ + lastsig = usig; + /* return to wait() */ + + return (XOK); +} diff --git a/unix/os/zpanic.c b/unix/os/zpanic.c new file mode 100644 index 00000000..d4f75109 --- /dev/null +++ b/unix/os/zpanic.c @@ -0,0 +1,103 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +#define import_kernel +#define import_knames +#define import_prtype +#define import_spp +#include + +extern char os_process_name[]; /* process name, set in zmain */ +extern PKCHAR osfn_bkgfile[]; /* bkgfile fname if detached */ +extern int save_prtype; /* process type saved by zmain */ +extern int debug_sig; + + +/* ZPANIC -- Unconditionally terminate process. Normal termination occurs + * when the IRAF Main returns to the zmain. We are called if a nasty error + * occurs in the kernel (a "can't happen" type error) or if an error occurs + * during error recovery, and error recursion would otherwise result. + */ +int +ZPANIC ( + XINT *errcode, /* integer error code at time of crash */ + PKCHAR *errmsg /* packed error message string */ +) +{ + char msg[512]; + int fd; + + + /* \nPANIC in `procname': error message\n + */ + strcpy (msg, "\n"); + strcat (msg, "PANIC in `"); + strcat (msg, os_process_name); + strcat (msg, "': "); + strcat (msg, (char *)errmsg); + strcat (msg, "\n"); + + write (2, msg, strlen(msg)); + + /* Echo the error message on the console if we are a bkg process, + * in case the user has logged off. + */ + if (save_prtype == PR_DETACHED) { + fd = open ("/dev/console", 1); + if (fd > 0) { + write (fd, &msg[1], strlen(&msg[1])); + close (fd); + } + } + + /* Delete the bkgfile if run as a detached process. Deletion of the + * bkgfile signals process termination. + */ + if (save_prtype == PR_DETACHED) + unlink ((char *)osfn_bkgfile); + + /* Terminate process with a core dump if the debug_sig flag is set. + */ + if (debug_sig) { +#ifdef LINUX + signal (SIGABRT, SIG_DFL); + kill (getpid(), SIGABRT); +#else + signal (SIGEMT, SIG_DFL); + kill (getpid(), SIGEMT); +#endif + } else + _exit ((int)*errcode); + + return (XOK); +} + + +/* KERNEL_PANIC -- Called by a kernel routine if a fatal error occurs in the + * kernel. + */ +int +kernel_panic (char *errmsg) +{ + XINT errcode = 0; + PKCHAR pkmsg[SZ_LINE]; + register char *ip, *op; + + extern int ZPANIC(); + + + /* It is necessary to copy the error message string to get a PKCHAR + * type string since misalignment is possible when coercing from char + * to PKCHAR. + */ + for (ip=errmsg, op=(char *)pkmsg; (*op++ = *ip++) != EOS; ) + ; + ZPANIC (&errcode, pkmsg); + + return (XOK); +} diff --git a/unix/os/zraloc.c b/unix/os/zraloc.c new file mode 100644 index 00000000..6021a359 --- /dev/null +++ b/unix/os/zraloc.c @@ -0,0 +1,37 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* ZRALOC -- Reallocate space on the heap (change the size of the area). + */ +int +ZRALOC ( + XINT *buf, /* receives address of buffer */ + XINT *nbytes, /* buffer size, machine bytes */ + XINT *status /* status return: XOK or XERR */ +) +{ + register char *bufptr; + char *ptr = (void *) NULL; + int zstat; + + ptr = LOC_TO_ADDR(*buf,char); + bufptr = realloc (ptr, (size_t)*nbytes); + + if (bufptr != NULL) { + *buf = ADDR_TO_LOC(bufptr); + if (*buf > 0) + *status = XOK; + else + *status = XERR; + } else + *status = XERR; + + zstat = *status; + return (zstat); +} diff --git a/unix/os/zshlib.c b/unix/os/zshlib.c new file mode 100644 index 00000000..74bef63a --- /dev/null +++ b/unix/os/zshlib.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_knames +#include + +/* + * ZSHLIB.C -- This file contains dummy shared library descriptors to be linked + * into executables which do not use the Sun/IRAF shared library. See zzstrt.c + * and the code in the directory unix/shlib for additional information on the + * shared library facility. + */ +int sh_debug = 0; +unsigned USHLIB[3] = { 0, 0, 0 }; /* actual length does not matter */ +unsigned VSHLIB[3] = { 0, 0, 0 }; +unsigned VSHEND; + +void VLIBINIT(){} diff --git a/unix/os/zwmsec.c b/unix/os/zwmsec.c new file mode 100644 index 00000000..617478b8 --- /dev/null +++ b/unix/os/zwmsec.c @@ -0,0 +1,109 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#define import_kernel +#define import_knames +#define import_spp +#include + +/* Comment out or ifdef the following if usleep is not available. */ +#define USE_USLEEP + +#ifdef USE_USLEEP +#define ONEHOUR (60 * 60 * 1000) + + +/* ZWMSEC -- Suspend task execution (sleep) for the specified number + * of milliseconds. + */ +int +ZWMSEC (XINT *msec) +{ + /* Usleep doesn't really appear to be a standard, but it is + * available on most platforms. + */ + if (*msec > ONEHOUR) + sleep (*msec / 1000); + else + (void) usleep ((unsigned int)(*msec) * 1000); + + return (XOK); +} + + +#else +#include +#include + +#define mask(s) (1<<((s)-1)) + +static int ringring; +static void napmsx(); + + +/* ZWMSEC -- Suspend task execution (sleep) for the specified number + * of milliseconds. + */ +int +ZWMSEC (XINT *msec) +{ + struct itimerval itv, oitv; + register struct itimerval *itp = &itv; + SIGFUNC sv_handler; + int omask; + + if (*msec == 0) + return (XOK); + + timerclear (&itp->it_interval); + timerclear (&itp->it_value); + if (setitimer (ITIMER_REAL, itp, &oitv) < 0) + return (XERR); + +#ifndef SOLARIS + omask = sigblock(0); +#endif + + itp->it_value.tv_usec = (*msec % 1000) * 1000; + itp->it_value.tv_sec = (*msec / 1000); + + if (timerisset (&oitv.it_value)) { + if (timercmp(&oitv.it_value, &itp->it_value, >)) + oitv.it_value.tv_sec -= itp->it_value.tv_sec; + else { + itp->it_value = oitv.it_value; + /* This is a hack, but we must have time to + * return from the setitimer after the alarm + * or else it'll be restarted. And, anyway, + * sleep never did anything more than this before. + */ + oitv.it_value.tv_sec = 1; + oitv.it_value.tv_usec = 0; + } + } + + ringring = 0; + sv_handler = signal (SIGALRM, (SIGFUNC)napmsx); + (void) setitimer (ITIMER_REAL, itp, (struct itimerval *)0); + + while (!ringring) +#ifdef SOLARIS + sigpause (SIGALRM); +#else + sigpause (omask &~ mask(SIGALRM)); +#endif + + signal (SIGALRM, sv_handler); + (void) setitimer (ITIMER_REAL, &oitv, (struct itimerval *)0); + + return (XOK); +} + + +static void +napmsx() +{ + ringring = 1; +} +#endif diff --git a/unix/os/zxwhen.c b/unix/os/zxwhen.c new file mode 100644 index 00000000..e0730f38 --- /dev/null +++ b/unix/os/zxwhen.c @@ -0,0 +1,499 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#ifdef CYGWIN +# include +#else +#ifdef LINUX +# include +#else +# ifdef BSD +# include +# endif +#endif +#endif + +#ifdef SOLARIS +# include +# include +# include +#endif + +#ifdef MACOSX +#include +#include +#endif + +#ifdef LINUXPPC +#define MACUNIX +#endif + +#ifdef MACOSX +#ifndef MACINTEL +#define MACUNIX +#endif + +/* The following are needed for OS X 10.1 for backward compatability. The + * signal sa_flags are set to use them to get signal handling working on + * 10.2 and later systems. + */ +#ifdef OLD_MACOSX +#ifndef SA_NODEFER +#define SA_NODEFER 0x0010 /* don't mask the signal we're delivering */ +#endif +#ifndef SA_NOCLDWAIT +#define SA_NOCLDWAIT 0x0020 /* don't keep zombies around */ +#endif +#ifndef SA_SIGINFO +#define SA_SIGINFO 0x0040 /* signal handler with SA_SIGINFO args */ +#endif +#endif + +#endif + +#define import_spp +#define import_kernel +#define import_knames +#define import_xwhen +#include + +/* ZXWHEN.C -- IRAF exception handling interface. This version has been + * customized for PC-IRAF, i.e., LINUX and FreeBSD. + * + * Rewritten Aug200 to use sigaction by default on all systems (done in + * connection with the LinuxPPC port). This got rid of a lot of old kludgy + * platform-dependent code used to workaround Linux signal handling problems. + */ + +/* Set the following nonzero to cause process termination with a core dump + * when the first signal occurs. + */ +int debug_sig = 0; + +#ifdef LINUX +# define fcancel(fp) +#else +# ifdef BSD +# define fcancel(fp) ((fp)->_r = (fp)->_w = 0) +#else +# ifdef MACOSX +# define fcancel(fp) ((fp)->_r = (fp)->_w = 0) +#else +# ifdef SOLARIS +# define fcancel(fp) ((fp)->_cnt=BUFSIZ,(fp)->_ptr=(fp)->_base) +#endif +#endif +#endif +#endif + + +#if (defined(MACOSX) && defined(OLD_MACOSX)) +void ex_handler ( int, int, struct sigcontext * ); +#else +void ex_handler ( int, siginfo_t *, void * ); +#endif + +static long setsig(); +static int ignore_sigint = 0; + + +/* Exception handling: ZXWHEN (exception, handler, old_handler) + * + * exception: X_INT, X_ARITH, X_ACV, or X_IPC + * + * handler: Either X_IGNORE or the entry point address + * of a user supplied exception handler which + * will gain control in the event of an exception. + * + * old_handler: On output, contains the value of the previous + * handler (either X_IGNORE or an EPA). Used to + * restore an old handler, or to chain handlers. + * + * An exception can be entirely disabled by calling ZXWHEN with the + * handler X_IGNORE. Otherwise, the user supplied exception handler + * gains control when the exception occurs. An exception handler is + * called with one argument, an integer code identifying the exception. + * The handler should return as its function value either X_IGNORE, + * causing normal processing to resume, or the EPA of the next handler + * to be called (normally the value of the parameter "old_handler"). + * The user handler should call FATAL if error restart is desired. + * + * If the SIGINT exeception has already been set to SIG_IGN, i.e., by the + * parent process which spawned us, then it will continue to be ignored. + * It is standard procedure in UNIX to spawn a background task with SIGINT + * disabled, so that interrupts sent to the parent process are ignored by + * the child. If this is the case then SIGTERM may still be sent to the + * child to raise the X_INT exception in the high level code. + */ + +#define EOMAP (-1) /* end of map array sentinel */ +#define mask(s) (1 << ((s) - 1)) + +int last_os_exception; /* save OS code of last exception */ +int last_os_hwcode; /* hardware exception code */ + +XINT handler_epa[] = { /* table of handler EPAs */ + 0, /* X_ACV */ + 0, /* X_ARITH */ + 0, /* X_INT */ + 0, /* X_IPC */ +}; + +struct osexc { + int x_vex; /* UNIX signal code */ + char *x_name; /* UNIX signal name string */ +}; + +struct osexc unix_exception[] = { + { 0, "" }, + { 0, "hangup" }, + { X_INT, "interrupt" }, + { 0, "quit" }, + { X_ACV, "illegal instruction" }, + { 0, "trace trap" }, + { X_ACV, "abort" }, + { X_ACV, "EMT exception" }, + { X_ARITH, "arithmetic exception" }, + { 0, "kill" }, + { X_ACV, "bus error" }, + { X_ACV, "segmentation violation" }, + { X_ACV, "bad arg to system call" }, + { X_IPC, "write to pipe with no reader" }, + { 0, "alarm clock" }, + { X_INT, "software terminate (interrupt)" }, + { X_ARITH, "STKFLT" }, + { EOMAP, "" } +}; + + +/* Hardware exceptions [MACHDEP]. To customize for a new machine, replace + * the symbol MYMACHINE by the machine name, #define the name in + * (i.e., hlib$libc/iraf.h), and edit the hardware exception list below. + */ +struct _hwx { + int v_code; /* Hardware exception code */ + char *v_msg; /* Descriptive error message */ +}; + +#ifdef MACOSX +#ifdef FPE_INTDIV +#undef FPE_INTDIV +#endif +#define FPE_INTDIV (-2) /* N/A */ +#ifdef FPE_INTOVF +#undef FPE_INTOVF +#endif +#define FPE_INTOVF (-2) /* N/A */ +#ifdef FPE_FLTRES +#undef FPE_FLTRES +#endif +#define FPE_FLTRES FE_INEXACT /* inexact */ +#ifdef FPE_FLTDIV +#undef FPE_FLTDIV +#endif +#define FPE_FLTDIV FE_DIVBYZERO /* divide-by-zero */ +#ifdef FPE_FLTUND +#undef FPE_FLTUND +#endif +#define FPE_FLTUND FE_UNDERFLOW /* underflow */ +#ifdef FPE_FLTOVF +#undef FPE_FLTOVF +#endif +#define FPE_FLTOVF FE_OVERFLOW /* overflow */ +#ifdef FPE_FLTINV +#undef FPE_FLTINV +#endif +#define FPE_FLTINV FE_INVALID /* invalid */ +#ifdef FPE_FLTSUB +#undef FPE_FLTSUB +#endif +#define FPE_FLTSUB (-2) /* N/A */ +#endif + +struct _hwx hwx_exception[] = { + { FPE_INTDIV, "integer divide by zero" }, + { FPE_INTOVF, "integer overflow" }, + { FPE_FLTDIV, "floating point divide by zero" }, + { FPE_FLTOVF, "floating point overflow" }, + { FPE_FLTUND, "floating point underflow" }, + { FPE_FLTRES, "floating point inexact result" }, + { FPE_FLTINV, "floating point invalid operation" }, + { FPE_FLTSUB, "subscript out of range" }, + { EOMAP, "" } +}; + + +/* ZXWHEN -- Post an exception handler or turn off interrupts. Return + * value of old handler, so that it may be restored by the user code if + * desired. The function EPA's are the type of value returned by ZLOCPR. + */ +int +ZXWHEN ( + XINT *sig_code, + XINT *epa, /* EPA of new exception handler */ + XINT *old_epa /* receives EPA of old handler */ +) +{ + static int first_call = 1; + int vex, uex; + SIGFUNC vvector; + + extern int kernel_panic (); + + + /* Convert code for virtual exception into an index into the table + * of exception handler EPA's. + */ + switch (*sig_code) { + case X_ACV: + case X_ARITH: + case X_INT: + case X_IPC: + vex = *sig_code - X_FIRST_EXCEPTION; + break; + default: + vex = (int) 0; + kernel_panic ("zxwhen: bad exception code"); + } + + *old_epa = handler_epa[vex]; + handler_epa[vex] = *epa; + vvector = (SIGFUNC) ex_handler; + + /* Check for attempt to post same handler twice. Do not return EPA + * of handler as old_epa as this could lead to recursion. + */ + if (*epa == (XINT) X_IGNORE) + vvector = (SIGFUNC) SIG_IGN; + else if (*epa == *old_epa) + *old_epa = (XINT) X_IGNORE; + + /* Set all hardware vectors in the indicated exception class. + * If interrupt (SIGINT) was disabled when we were spawned (i.e., + * when we were first called to set SIGINT) leave it that way, else + * we will get interrupted when the user interrupts the parent. + */ + for (uex=1; unix_exception[uex].x_vex != EOMAP; uex++) { + if (unix_exception[uex].x_vex == *sig_code) { + if (uex == SIGINT) { + if (first_call) { + if (setsig (uex, vvector) == (long) SIG_IGN) { + setsig (uex, SIG_IGN); + ignore_sigint++; + } + first_call = 0; + } else if (!ignore_sigint) { + if (debug_sig) + setsig (uex, SIG_DFL); + else + setsig (uex, vvector); + } + } else { + if (debug_sig) + setsig (uex, SIG_DFL); + else + setsig (uex, vvector); + } + } + } + + return (XOK); +} + + +/* SETSIG -- Post an exception handler for the given exception. + */ +static long +setsig (code, handler) +int code; +SIGFUNC handler; +{ + struct sigaction sig; + long status; + + sigemptyset (&sig.sa_mask); +#ifdef MACOSX + sig.sa_handler = (SIGFUNC) handler; +#else + sig.sa_sigaction = (SIGFUNC) handler; +#endif + sig.sa_flags = (SA_NODEFER|SA_SIGINFO); + status = (long) sigaction (code, &sig, NULL); + + return (status); +} + + +/* EX_HANDLER -- Called to handle an exception. Map OS exception into + * xwhen signal, call user exception handler. A default exception handler + * posted by the IRAF Main is called if the user has not posted another + * handler. If we get the software termination signal from the CL, + * stop process execution immediately (used to kill detached processes). + */ +#if (defined(MACOSX) && defined(OLD_MACOSX)) + +void +ex_handler (unix_signal, info, scp) +int unix_signal; +#ifdef OLD_MACOSX +void *info; +#else +siginfo_t *info; +#endif +#ifdef MACINTEL +ucontext_t *scp; +#else +struct sigcontext *scp; +#endif + +#else + +void +ex_handler ( + int unix_signal, + siginfo_t *info, + void *ucp +) +#endif +{ + XINT next_epa, epa, x_vex; + int vex; + +#ifndef LINUX64 + extern int sfpucw_(); +#endif + + last_os_exception = unix_signal; + last_os_hwcode = info ? info->si_code : 0; + + x_vex = unix_exception[unix_signal].x_vex; + vex = x_vex - X_FIRST_EXCEPTION; + epa = handler_epa[vex]; + + /* Reenable/initialize the exception handler. + */ + +#if defined(MACOSX) || defined(CYGWIN) + /* Clear the exception bits (ppc and x86). */ + feclearexcept (FE_ALL_EXCEPT); +#else +#ifdef LINUX + /* setfpucw (0x1372); */ + { +#ifdef MACUNIX + /* This is for Linux on a Mac, e.g., LinuxPPC (not MacOSX). */ + int fpucw = _FPU_IEEE; + + /* + if (unix_signal == SIGFPE) + kernel_panic ("unrecoverable floating exception"); + else + sfpucw_ (&fpucw); + if (unix_signal == SIGPIPE && !ignore_sigint) + sigset (SIGINT, (SIGFUNC) ex_handler); + */ + + sfpucw_ (&fpucw); +#else +#ifdef LINUX64 + /* + XINT fpucw = 0x336; + SFPUCW (&fpucw); + */ + fpu_control_t cw = + (_FPU_EXTENDED | _FPU_MASK_PM | _FPU_MASK_UM | _FPU_MASK_ZM | _FPU_MASK_DM); + _FPU_SETCW(cw); + +#else + int fpucw = 0x336; + sfpucw_ (&fpucw); +#endif +#endif + } +#endif +#endif + + +#ifdef SOLARIS + fpsetsticky (0x0); + fpsetmask (FP_X_INV | FP_X_OFL | FP_X_DZ); +#endif + + /* If signal was SIGINT, cancel any buffered standard output. */ + if (unix_signal == SIGINT) { + fcancel (stdout); + } + + /* Call user exception handler(s). Each handler returns with the + * "value" (epa) of the next handler, or X_IGNORE if exception handling + * is completed and processing is to continue normally. If the handler + * wishes to restart the process, i.e., initiate error recovery, then + * the handler procedure will not return. + */ + for (next_epa=epa; next_epa != (XINT) X_IGNORE; + ((SIGFUNC)epa)(&x_vex,&next_epa)) + epa = next_epa; +} + + +/* ZXGMES -- Get the machine dependent integer code and error message for the + * most recent exception. The integer code XOK is returned if no exception + * has occurred, or if we are called more than once. + */ +int +ZXGMES ( + XINT *os_exception, + PKCHAR *errmsg, + XINT *maxch +) +{ + register int v; + char *os_errmsg; + + *os_exception = last_os_exception; + + if (last_os_exception == XOK) + os_errmsg = ""; + else { + os_errmsg = unix_exception[last_os_exception].x_name; + if (last_os_exception == SIGFPE) { + for (v=0; hwx_exception[v].v_code != EOMAP; v++) + if (hwx_exception[v].v_code == last_os_hwcode) { + os_errmsg = hwx_exception[v].v_msg; + break; + } + } + } + + strncpy ((char *)errmsg, os_errmsg, (int)*maxch); + ((char *)errmsg)[*maxch] = EOS; + + last_os_exception = XOK; + + return (XOK); +} + + +#ifdef LINUX64 + +int +gfpucw_ (XINT *xcw) +{ + fpu_control_t cw; + _FPU_GETCW(cw); + *xcw = cw; + return cw; +} + +int +sfpucw_ (XINT *xcw) +{ + fpu_control_t cw = *xcw; + _FPU_SETCW(cw); + return cw; +} + +#endif diff --git a/unix/os/zzdbg.c b/unix/os/zzdbg.c new file mode 100644 index 00000000..eaffd8ad --- /dev/null +++ b/unix/os/zzdbg.c @@ -0,0 +1,158 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include + +#define import_spp +#define import_kernel +#define import_knames +#define import_xnames +#define import_prtype +#include + + + +void zzval_ (XINT *val) +{ + fprintf (stderr, "zzprnt: %ld 0x%lx\n", (long)*val, (long)*val); +} + + +void zzprnt_ (XINT *val, XINT *len) +{ + int i; + + + fprintf (stderr, "zzprnt:\n"); + for (i=0; i < *len; i++) + fprintf (stderr, "%ld\n", (long)*val); + fprintf (stderr, "\n"); +} + + +void zzmsg_ (XCHAR *buf, XINT *val) +{ + char i, *cp = (char *) buf; + + fprintf (stderr, "zzmsg: "); + for (i=0; i < 64; i++, cp++) { + if (*cp == '\n' || (*cp == '\0' && *(cp+1) == '\0')) + break; + fprintf (stderr, "%c", *cp); + } + fprintf (stderr, " %ld 0x%lx\n", (long)*val, (long)*val); + fflush (stderr); +} + + +void zzmfd_ (XCHAR *buf, XINT *fd, XINT *val) +{ + char i, *cp = (char *) buf; + + fprintf (stderr, "zzmfd[%2d]: ", (int) *fd); + for (i=0; i < 64; i++) { + if (*cp == '\n' || (*cp == '\0' && *(cp+1) == '\0')) + break; + fprintf (stderr, "%c", *cp++); + } + fprintf (stderr, " %ld 0x%lx\n", (long)*val, (long)*val); + fflush (stderr); +} + + +void zzmstr_ (XCHAR *s1, XCHAR *s2, XINT *val) { + + char i, *c1 = (char *) s1, *c2 = (char *) s2; + + fprintf (stderr, "zzmstr: "); + for (i=0; i < 64; i++) { + if (*c1 == '\n' || (*c1 == '\0' && *(c1+1) == '\0')) + break; + fprintf (stderr, "%c", *c1++); + } + fprintf (stderr, " "); + for (i=0; i < 64; i++) { + if (*c2 == '\n' || (*c2 == '\0' && *(c2+1) == '\0')) + break; + fprintf (stderr, "%c", *c2++); + } + fprintf (stderr, " %ld 0x%lx\n", (long)*val, (long)*val); + fflush (stderr); +} + + +void zzdmp_ (XCHAR *buf, XINT *len) { + int i; + char *cp = (char *) buf; + for (i=0; i < *len; i++, cp++) { + if (*cp == '\0' && *(cp+1) == '\0') + break; + else + fprintf (stderr, "%c'", *cp); + } + fprintf (stderr, "\n"); + fflush (stderr); +} + + +void mdump_ (XINT *buf, XINT *nbytes) +{ + register int i=0, j=0, nb=(*nbytes); + char ch, *p = LOC_TO_ADDR(*buf,char); + + /* + fprintf (stderr, "*buf = %d %d %d %d %d\n", + *buf, ((int)p)*2, (((int)p)*4-4), ((int)(*buf))*2, (((int)(*buf))*4-4) ); + p = ((*buf) * 4 - 4); + */ + + printf ("\n"); + while ( i < nb ) { + printf ("%4d %ld 0x%lx\t", i, (long)(p+i), (long)(p+i) ); + for (j=0; j < 8; j++) { + ch = *(p+i); + printf ("0x%02x ", (ch & 0xff)); + i++; + } + printf ("\n"); + } + printf ("\n"); +} + + +void +zzpeek_ (void *a, XINT *nelems, XINT *nl) +{ + XINT i; + char *c; + + for (i=0, c=(char *)a; i < *nelems; i++) + printf ("%2d ", *c++); + printf ("%s", (*nl ? " : " : "\n")); +} + + +void +zzpdat_ (XCHAR *msg, void *a, XINT *nelems, XINT *nl) +{ + XINT i; + char *c; + + for (i=0; i < 32; i++) { + if (msg[i]) + printf ("%c", (char )msg[i]); + else { + printf (": "); + break; + } + } + + for (i=0, c=(char *)a; i < *nelems; i++) + printf ("%2d ", *c++); + printf ("%s", (*nl ? " : " : "\n")); +} diff --git a/unix/os/zzepro.c b/unix/os/zzepro.c new file mode 100644 index 00000000..9f046716 --- /dev/null +++ b/unix/os/zzepro.c @@ -0,0 +1,84 @@ +#include +#include +#ifdef MACOSX +#include +#include +#endif +#ifdef CYGWIN +#include +#include +#endif + +#define import_spp +#define import_knames +#include + + + +#if (defined(MACOSX) && defined(OLD_MACOSX)) +void ex_handler ( int, int, struct sigcontext * ); +#else +void ex_handler ( int, siginfo_t *, void * ); +#endif + + +/* + * ZZEPRO.C -- Code which is executed at the end of every procedure. + */ + +/* NOTE: Following is also picked up by Mac/Intel. */ +#if ( (defined(MACOSX) || defined(CYGWIN)) && !defined(IPAD)) + +int macosx_sigmask = (FE_DIVBYZERO|FE_OVERFLOW|FE_INVALID); + +void mxmask_ (void); +void mxumsk_ (void); + + +/* ZZEPRO.C -- On MacOSX (which under 10.1.x can't raise a hardware + * exception) we check at the end of every procedure to see if a floating + * exception occurred. + */ +int +ZZEPRO (void) +{ + fexcept_t flagp; + + fegetexceptflag (&flagp, macosx_sigmask); + if (flagp & macosx_sigmask) { + siginfo_t info; + info.si_code = (flagp & macosx_sigmask); + ex_handler (SIGFPE, &info, NULL); + } + + /* Clear the exception. */ + flagp = (fexcept_t) 0; + feclearexcept (FE_ALL_EXCEPT); + + return (XOK); +} + +/* Mask or unmask the invalid operand exception. Invalid must be + * masked to be able to operate upon invalid operands, e.g., to filter + * out NaN/Inf in IEEE i/o code (see as$ieee.gx). + */ +void mxmask_ (void) +{ + macosx_sigmask &= ~FE_INVALID; +} + +void mxumsk_ (void) +{ + fexcept_t flagp; + + fegetexceptflag (&flagp, macosx_sigmask); + macosx_sigmask |= FE_INVALID; + flagp &= ~FE_INVALID; + + fesetexceptflag (&flagp, macosx_sigmask); +} + + +#else +int ZZEPRO ( void) { return (XOK); } +#endif diff --git a/unix/os/zzexit.c b/unix/os/zzexit.c new file mode 100644 index 00000000..a54cfc38 --- /dev/null +++ b/unix/os/zzexit.c @@ -0,0 +1,17 @@ +#include + +#define import_spp +#include + +/* + * ZZEXIT.C -- Fortran callable exit procedure. Some systems (e.g. libf2c) + * require this procedure. We implement it as a separate library procedure + * so that it can be replaced by a user exit procedure. + */ +int +exit_ (code) +XINT *code; +{ + exit (*code); + return (XOK); +} diff --git a/unix/os/zzpstr.c b/unix/os/zzpstr.c new file mode 100644 index 00000000..30648b65 --- /dev/null +++ b/unix/os/zzpstr.c @@ -0,0 +1,176 @@ +#include +#include +#include +#include + +#define import_spp +#include + +/* + * ZZPSTR.C -- Support for debugging SPP programs. + * + * zzpstr (s1, s2) # Write a debug message to the process stderr + * zzlstr (s1, s2) # Write a debug message to /tmp/k.log + * spp_printstr (s) # GDB support function + * spp_printmemc (memc_p) # GDB support function + * + * The procedures zzpstr and zzlstr are meant to be called from within + * compiled SPP code to write debug messages to either the process stderr + * or to a log file. This is different than writing to SPP STDERR since + * the latter is a pseudofile (it gets sent to the CL before being written + * out). In other words zzpstr/zzlstr are low level debug functions, + * comparable to a host fprintf. + * + * spp_printstr and spp_printmemc are called from a debugger (GDB) to + * print char strings. spp_printstr prints a char variable as an EOS + * terminated string. spp_printmemc does the same thing, but takes a Memc + * pointer variable as input. + * + * The following commands can be added to your .gdbinit file to make it + * easier to use these functions: + * + * define ps + * call spp_printstr ($arg0) + * end + * + * define pc + * call spp_printmemc ($arg0) + * end + * + * Then you can type e.g., "ps fname" to print char variable fname, + * or "pc ip" to print the string pointed to by SPP Memc pointer "ip". + * Both of these functions will print tabs and newlines as \t and \n, + * and other control codes as \ooo where ooo is the octal value of the + * character. + */ + +#define LOGFILE "/tmp/k.log" + +void spp_printmemc (long memc_ptr); +void spp_printstr (XCHAR *s); + + + +/* SPP_DEBUG -- Dummy function called to link the SPP debug functions into + * a program. + */ +int spp_debug (void) { return (0); } + + +/* ZZPSTR -- Write SPP text data directly to the host stderr. Up to two + * strings may be ouptut. Either may be the null pointer to disable. + * A newline is added at the end if not present in the last string. + */ +int +zzpstr_ (XCHAR *s1, XCHAR *s2) +{ + register XCHAR *s, *ip; + register char *op; + char buf[4096]; + int lastch = 0; + + + if ( (s = s1) ) { + for (ip=s, op=buf; (*op = *ip++); op++) + ; + lastch = *(op-1); + write (2, buf, op-buf); + } + + if ( (s = s2) ) { + for (ip=s, op=buf; (*op = *ip++); op++) + ; + lastch = *(op-1); + write (2, buf, op-buf); + } + + if (lastch != '\n') + write (2, "\n", 1); + + return (XOK); +} + + +/* ZZLSTR -- Write SPP text data to a log file. + */ +int +zzlstr_ (XCHAR *s1, XCHAR *s2) +{ + register XCHAR *s, *ip; + register char *op; + char buf[4096]; + int lastch = 0; + int status = 0, fd; + + if ((fd = open (LOGFILE, O_CREAT|O_WRONLY|O_APPEND, 0644)) < 0) + return (fd); + + if ( (s = s1) ) { + for (ip=s, op=buf; (*op = *ip++); op++) + ; + lastch = *(op-1); + status = write (fd, buf, op-buf); + } + + if ( (s = s2) ) { + for (ip=s, op=buf; (*op = *ip++); op++) + ; + lastch = *(op-1); + status = write (fd, buf, op-buf); + } + + if (lastch != '\n') + status = write (fd, "\n", 1); + + status = close (fd); + return (status); +} + + +/* SPP_PRINTSTR -- GDB callable debug function to print an EOS terminated SPP + * string passed as a char array. + */ +void +spp_printstr (XCHAR *s) +{ + register XCHAR *ip; + register char *op, *otop; + static char obuf[1024]; + int ch; + + for (ip=s+1, op=obuf, otop=obuf+1020; (ch = *ip); ip++) { + if (!isprint (ch)) { + if (ch == '\t') { + *op++ = '\\'; + *op++ = 't'; + } else if (ch == '\n') { + *op++ = '\\'; + *op++ = 'n'; + } else { + *op++ = '\\'; + *op++ = ((ch >> 6) & 07) + '0'; + *op++ = ((ch >> 3) & 07) + '0'; + *op++ = ( ch & 07) + '0'; + } + } else + *op++ = ch; + + if (op >= otop) + break; + } + + *op++ = '\0'; + printf ("%s\n", obuf); + fflush (stdout); +} + + +/* SPP_PRINTMEMC -- GDB callable debug function to print an EOS terminated SPP + * string passed as a pointer to char. + */ +void +spp_printmemc (long memc_ptr) +{ + XCHAR *str = (XCHAR *) ((memc_ptr - 1) * 2 - 2); + spp_printstr (str); +} diff --git a/unix/os/zzsetk.c b/unix/os/zzsetk.c new file mode 100644 index 00000000..d1b374cc --- /dev/null +++ b/unix/os/zzsetk.c @@ -0,0 +1,38 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +#define import_spp +#define import_knames +#include + +extern char os_process_name[]; +extern PKCHAR osfn_bkgfile[]; +extern int save_prtype; +extern int ipc_isatty; +extern int ipc_in, ipc_out; + +/* ZZSETK -- Internal kernel routine, used by the zmain to set the values + * of certain internal kernel parameters. + */ +int +ZZSETK ( + char *ospn, + char *osbfn, + int prtype, + int isatty, + int in, + int out +) +{ + strcpy (os_process_name, ospn); + strcpy ((char *)osfn_bkgfile, osbfn); + save_prtype = prtype; + ipc_isatty = isatty; + ipc_in = in; + ipc_out = out; + + return (XOK); +} diff --git a/unix/os/zzstrt.c b/unix/os/zzstrt.c new file mode 100644 index 00000000..32138e09 --- /dev/null +++ b/unix/os/zzstrt.c @@ -0,0 +1,628 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include + +#ifdef CYGWIN +# include +#else +#ifdef LINUX +# include +# undef SOLARIS +#endif +#endif + +#ifdef SHLIB +#ifdef SOLARIS +#include +#include +#include +#include +#include +#else +#include +#include +#endif +#endif + +#ifdef sun +#include +#endif + +#ifdef SOLARIS +#include +#endif + +#ifdef LINUXPPC +#define MACUNIX +#endif + +#ifdef MACOSX +#include +#include +#ifndef MACINTEL +#define MACUNIX +#endif +#endif + +#define import_spp +#define import_kernel +#define import_knames +#define import_xnames +#define import_prtype +#include + +/* + * ZZSTRT,ZZSTOP -- Routines to perform initialization and cleanup functions + * during process startup and shutdown, when the IRAF kernel routines are being + * called from a program which does not have a ZMAIN. + */ + +/* #define DEBUG */ + +static int prtype, ipc_isatty=NO; +static int ipc_in = 0, ipc_out = 0; +static char os_process_name[SZ_FNAME]; +static char osfn_bkgfile[SZ_PATHNAME]; +extern int errno; + +#ifdef SHLIB +extern char *((*environ)[]); + +extern int sh_debug; /* map shared image writeable */ +static short debug_ieee = 0; +extern unsigned USHLIB[], VSHLIB[]; /* shared library descriptors */ +static unsigned vshlib[8]; +#define v_version vshlib[0] /* shared image version number */ +#define v_base vshlib[1] /* exported shimage addresses */ +#define v_etext vshlib[2] +#define v_edata vshlib[3] +#define v_end vshlib[4] +#define u_version USHLIB[0] /* application version number */ +#define sh_machtype USHLIB[6] /* machine architecture */ +#endif + +#define align(a) ((a)&(~pmask)) + +#ifdef i386 +/* The following kludge is required due to a 386i linker error to prevent + * a BSS size of 0 for small processes with a short BSS segment. If BSS is + * set to zero in the file header but some BSS storage is required, the image + * will die on a segmentation violation during startup while trying to + * initialize the value of "environ". + */ +int BSS_kludge[256]; +#endif + +void ready_ (void); + +extern int ZAWSET(), ZOPNTY(), ZZSETK(); + + + +/* ZZSTRT -- Initialize the IRAF kernel at process startup time. + */ +int +ZZSTRT (void) +{ + XINT wsetsize=0L, junk; +#ifdef SHLIB + static int fd = 0; + struct stat fi; + char *segname; + XCHAR *bp; +#endif +#ifndef LINUX64 + extern void sfpucw_(); +#endif + extern int spp_debug(); + + + spp_debug (); + + /* Initialize globals. + */ + sprintf (os_process_name, "%d", getpid()); + strcpy (osfn_bkgfile, ""); + prtype = PR_HOST; + + /* Initialize the kernel file descriptor. */ + zfd[0].fp = stdin; zfd[0].flags = KF_NOSEEK; + zfd[1].fp = stdout; zfd[1].flags = KF_NOSEEK; + zfd[2].fp = stderr; zfd[2].flags = KF_NOSEEK; + +#ifdef SHLIB + /* Map in the Sun/IRAF shared library, if the calling process was + * linked with the shared library, and the shared library has not + * already been mapped (fd != 0). (See unix/shlib for more info). + * (This is rather monolithic and should probably be isolated to a + * separate module, but we are not trying for a general solution here). + */ + if (USHLIB[0] && (!fd || (fd && fstat(fd,&fi) == -1))) { + register unsigned pgsize, pmask; + unsigned t_off, t_len; + unsigned d_off, d_len; + unsigned b_off, b_len; + unsigned b_start, b_bytes; + static char envdef[SZ_FNAME]; + char shimage[SZ_FNAME]; + char *shlib, *arch; + extern char *getenv(); + caddr_t addr; + unsigned hsize; +#ifdef SOLARIS + register Elf32_Phdr *phdr; + register Elf32_Ehdr *ehdr; + caddr_t t_loc, d_loc, b_loc; + int adjust, phnum, nseg, i; + struct utsname uts; + Elf32_Phdr *phdr_array; + Elf32_Phdr seg[32]; + Elf *elf; +#else + unsigned t_loc, d_loc, b_loc; +#endif + + /* Determine the architecture of the shared library. */ + switch (sh_machtype) { + case 1: /* see shlib/mkshlib.csh */ + arch = "sparc"; break; + case 2: + arch = "i386"; break; + case 3: + arch = "f68881"; break; + case 4: + arch = "ffpa"; break; + case 5: + arch = "ssun"; break; + case 6: + arch = "sf2c"; break; + default: + arch = "fsoft"; break; + } + + /* Define IRAFARCH if not already defined in the process + * environment or if the definition does not match the architecture + * of the executable being run. This is necessary for irafpath(), + * below, to successfully find the shared image. + */ + sprintf (envdef, "IRAFARCH=%s", arch); + if (!(arch = getenv("IRAFARCH")) || strcmp(envdef,arch)) + putenv (envdef); + +#ifdef SOLARIS + /* Open the shared library file. In the case of Solaris the + * statically linked shared library doesn't work for both Solaris + * 2.3 and 2.4, and a separate shared library is required for + * each. Call uname() to get the OS version and use the + * appropriate shared library. If this isn't found attempt to + * fallback on the generic version. + */ + uname (&uts); + sprintf (shimage, "S%d_%s.e", u_version, uts.release); + shlib = irafpath (shimage); + if (shlib == NULL || (fd = open (shlib, 0)) == -1) { + sprintf (shimage, "S%d.e", u_version); + shlib = irafpath (shimage); + } + if (shlib == NULL || (fd = open (shlib, 0)) == -1) { + fprintf (stderr, + "Error: cannot open iraf shared library %s\n", shlib); + exit (1); + } +#else + /* Open the shared library file */ + sprintf (shimage, "S%d.e", u_version); + shlib = irafpath (shimage); + if (shlib == NULL || (fd = open (shlib, 0)) == -1) { + fprintf (stderr, + "Error: cannot open iraf shared library %s\n", shlib); + exit (1); + } +#endif + +#ifdef SOLARIS + /* With Solaris executables are ELF format files. The file + * and program headers tell where everything is and how to map + * the image segments. + */ + elf_version (EV_CURRENT); + elf = elf_begin (fd, ELF_C_READ, NULL); + if (!elf) { + fprintf (stderr, "%s: not an ELF format file\n", shlib); + exit (2); + } + if (!(ehdr = elf32_getehdr (elf))) { + fprintf (stderr, "%s: cannot read file header\n", shlib); + exit (1); + } + if ((phnum = ehdr->e_phnum) <= 0 || + !(phdr_array = elf32_getphdr (elf))) { + fprintf (stderr, "%s: cannot read program header table\n", + shlib); + exit (1); + } + + /* Get a list of the loadable segments. */ + for (i=0, nseg=0; i < phnum; i++) { + phdr = (Elf32_Phdr *)((char *)phdr_array + i*ehdr->e_phentsize); + if (phdr->p_type == PT_LOAD) + seg[nseg++] = *phdr; + } + + /* Read in the vshlib array, which is stored in the text segment + * of the shared image. + */ + if (nseg) { + phdr = &seg[0]; + hsize = (unsigned)((char *)VSHLIB) - USHLIB[1]; + /* lseek (fd, phdr->p_offset + (long)hsize, 0); */ + lseek (fd, (off_t)hsize, 0); + if (read (fd, (char *)vshlib, sizeof(vshlib)) != + sizeof(vshlib)) { + fprintf (stderr, "Read error on %s\n", shlib); + exit (1); + } + } else { + fprintf (stderr, + "Error: cannot open iraf shared library %s\n", shlib); + exit (1); + } + + pgsize = sysconf (_SC_PAGESIZE); + pmask = pgsize - 1; + + /* Determine the file and memory offsets of each segment of the + * shared image. + */ + phdr = &seg[0]; + adjust = phdr->p_offset % pgsize; + + t_off = phdr->p_offset - adjust; + t_loc = (caddr_t) ((int)phdr->p_vaddr - adjust); + t_len = phdr->p_filesz + adjust; + + phdr = &seg[1]; + adjust = phdr->p_offset % pgsize; + + d_off = phdr->p_offset - adjust; + d_loc = (caddr_t) ((int)phdr->p_vaddr - adjust); + d_len = phdr->p_filesz + adjust; + + /* Map the BSS segment beginning with the first hardware page + * following the end of the data segment. + */ + b_off = 0; /* anywhere will do */ + b_loc = (caddr_t) align ((int)d_loc + d_len + pgsize); + b_len = phdr->p_vaddr + phdr->p_memsz - (int)b_loc; + + b_start = phdr->p_vaddr + phdr->p_filesz; + b_bytes = phdr->p_memsz - phdr->p_filesz; + +#else !SOLARIS + /* Compute the location and size of each segment of the shared + * image memory. The shared image is mapped at address s_base. + */ + hsize = (unsigned)((char *)VSHLIB) - USHLIB[1]; + lseek (fd, (off_t)hsize, 0); + if (read (fd, (char *)vshlib, sizeof(vshlib)) != sizeof(vshlib)) { + fprintf (stderr, "Read error on %s\n", shlib); + exit (1); + } + +#ifdef i386 + /* Map the shared image on a Sun-386i (SysV COFF format). + */ + pgsize = getpagesize(); + pmask = pgsize - 1; + + /* Determine the file and memory offsets of each segment of the + * shared image. + */ + + t_off = 0; /* file offset */ + t_loc = v_base; /* location in memory */ + t_len = v_etext - v_base; /* segment length */ + + d_off = align (v_etext) - v_base; /* map file page twice */ + d_loc = align (v_etext); + d_len = v_edata - d_loc; + + b_off = 0; /* anywhere will do */ + b_loc = align (d_loc + d_len + pmask); + b_len = v_end - b_loc; + + b_start = v_edata; + b_bytes = v_end - v_edata; +#else + /* Map the shared image on a Sun-3 or Sun-4. + */ + pgsize = PAGSIZ; + pmask = pgsize - 1; + + /* Determine the file and memory offsets of each segment of the + * shared image. We cannot use the macros since the + * text segment does not begin at the default location. Also, + * the size of the BSS segment in the file header is not correct + * (under SunOS 4.0), so we compute directly from _end. + */ + + t_off = 0; /* file offset */ + t_loc = v_base; /* location in memory */ + t_len = v_etext - v_base; /* segment length */ + + d_off = align (t_len + pmask); + d_loc = (v_etext + SEGSIZ-1) / SEGSIZ * SEGSIZ; + d_len = v_edata - d_loc; + + /* Map the BSS segment beginning with the first hardware page + * following the end of the data segment. This need not be + * the same as the PAGSIZ used for a.out. v_edata-1 is the + * address of the last byte of the data segment. + */ + b_off = 0; /* anywhere will do */ + b_loc = ((v_edata-1) & ~(getpagesize()-1)) + getpagesize(); + b_len = v_end - b_loc; + + b_start = v_edata; + b_bytes = v_end - v_edata; +#endif i386 +#endif SOLARIS + +#ifdef DEBUG + fprintf (stderr, " text: %8x %8x %8x -> %8x etext = %8x\n", + t_loc, t_len, t_off, t_loc + t_len, v_etext); + fprintf (stderr, " data: %8x %8x %8x -> %8x edata = %8x\n", + d_loc, d_len, d_off, d_loc + d_len, v_edata); + fprintf (stderr, " bss: %8x %8x %8x -> %8x end = %8x\n", + b_loc, b_len, b_off, b_loc + b_len, v_end); + fprintf (stderr, " zero: %8x %8x %8s -> %8x\n", + b_start, b_bytes, " ", b_start + b_bytes); +#endif DEBUG + + /* Map the header region of the "text" segment read-write. + * This area contains any commons exported by the shared image. + */ + addr = mmap (t_loc, hsize, PROT_READ|PROT_WRITE, + MAP_PRIVATE|MAP_FIXED, fd, t_off); + if ((int)addr == -1) { + segname = "header"; + goto maperr; + } + + /* Map the text segment read-only shared, unless the sh_debug + * flag is set (-w command line option), in which case the shared + * text is mapped private so that it may be modified, e.g., to + * set breakpoints while debugging a process. + */ + addr = mmap (t_loc+hsize, t_len-hsize, PROT_READ|PROT_EXEC, + (sh_debug?MAP_PRIVATE:MAP_SHARED)|MAP_FIXED, fd, t_off+hsize); + if ((int)addr == -1) { + segname = "text"; + goto maperr; + } + + /* Map the data segment read-write. */ + addr = mmap (d_loc, d_len, PROT_READ|PROT_WRITE|PROT_EXEC, + MAP_PRIVATE|MAP_FIXED, fd, d_off); + if ((int)addr == -1) { + segname = "data"; + goto maperr; + } + + /* The BSS section has to be initialized to zero. We can map this + * onto any convenient file data provided we map it private and + * promptly modify (zero) the pages. We assume here that the size + * of the BSS segment does not exceed the file size; this would + * not be true in general but should always be true in our case. + */ + addr = mmap (b_loc, b_len, PROT_READ|PROT_WRITE|PROT_EXEC, + MAP_PRIVATE|MAP_FIXED, fd, b_off); + + if ((int)addr == -1) { + segname = "bss"; +maperr: fprintf (stderr, "Error: cannot map the iraf shared library"); + fprintf (stderr, ", seg=%s, errno=%d\n", segname, errno); + exit (2); + } + + /* Zero the bss segment. */ + bzero (b_start, b_bytes); + + /* Verify that the version number and base address match. */ + if (USHLIB[0] != VSHLIB[0] || USHLIB[1] != VSHLIB[1]) { + fprintf (stderr, + "Error: iraf shared library mismatch, please relink\n"); + exit (3); } + + /* Link the memory allocator function in the main process to stubs + * in the shared library, so that the library routines will + * allocate memory in the data space of the client. + */ +#ifdef SOLARIS + VLIBINIT (environ, malloc, realloc, free, + dlopen, dlclose, dlsym, dlerror); +#else + VLIBINIT (environ, malloc, realloc, free); +#endif + } +#endif /* SHLIB */ + + /* Dummy routine called to indicate that mapping is complete. */ + ready_(); + +#if defined(MACOSX) || defined(CYGWIN) + /* Clears the exception-occurred bits in the FP status register. + */ + feclearexcept (FE_ALL_EXCEPT); +#else + +#if defined(LINUX) + /* Enable the common IEEE exceptions. Newer Linux systems disable + * these by default, the usual SYSV behavior. + */ + + /* Old code; replaced by SFPUCW in as$zsvjmp.s + asm ("fclex"); + setfpucw (0x1372); + */ + { + /* 0x332: round to nearest, 64 bit precision, mask P-U-D. */ +#ifdef MACUNIX + int fpucw = _FPU_IEEE; +#else + int fpucw = 0x332; +#endif +#ifdef LINUX64 + /* + XINT fpucw = 0x332; + SFPUCW (&fpucw); + */ + fpu_control_t cw = + (_FPU_EXTENDED | _FPU_MASK_PM | _FPU_MASK_UM | _FPU_MASK_DM); + _FPU_SETCW(cw); +#else + sfpucw_ (&fpucw); +#endif + } +#endif +#endif + +#ifdef SOLARIS + /* Enable the common IEEE exceptions. _ieee_enbint is as$enbint.s. + */ +#ifdef X86 + fpsetsticky (0x0); + fpsetmask (FP_X_INV | FP_X_OFL | FP_X_DZ); +#else + _ieee_enbint ( + (1 << (int)fp_division) | + (1 << (int)fp_overflow) | + (1 << (int)fp_invalid) + ); +#endif + +#else +#ifdef SUNOS + /* The following enables the common IEEE floating point exceptions + * invalid, overflow, and divzero, causing the program to abort if + * any of these are detected. If ZZSTRT is called from an IRAF + * program the abort action will normally be overidden when the IRAF + * main posts it's own handler for X_ARITH class exceptions. + */ + ieee_handler ("set", "common", SIGFPE_ABORT); + + /* The following disables recomputation of subnormal results or + * operands, which is done in software with an exception handler + * for machines with Weitek hardware, hence is very slow. This + * is a deviation from the IEEE standard, but is consistent with + * the behavior of most non-IEEE hardware, and well designed + * software should not generate any subnormal values in any case, + * let alone depend upon small deviations in the value of such + * subnormals. + */ + abrupt_underflow_(); + + /* The bitflag variable debug_ieee may be set nonzero to modify + * the default behavior (rounding direction and precision) of + * the IEEE hardware. + */ +# define FP_NEAREST 0001 /* round toward nearest */ +# define FP_TOZERO 0002 /* round toward zero */ +# define FP_NEGATIVE 0004 /* round toward negative infinity */ +# define FP_POSITIVE 0010 /* round toward positive infinity */ +# define FP_EXTENDED 0020 /* round to extended precision */ +# define FP_DOUBLE 0040 /* round to ieee double precision */ +# define FP_SINGLE 0100 /* round to ieee single precision */ + + if (debug_ieee) { + char *set = "set"; + char *direction = "direction"; + char *precision = "precision"; + + /* Set the rounding direction mode. */ + if (debug_ieee & FP_NEAREST) + ieee_flags (set, direction, "nearest", NULL); + if (debug_ieee & FP_TOZERO) + ieee_flags (set, direction, "tozero", NULL); + if (debug_ieee & FP_NEGATIVE) + ieee_flags (set, direction, "negative", NULL); + if (debug_ieee & FP_POSITIVE) + ieee_flags (set, direction, "positive", NULL); + + /* Set the rounding precision mode. */ + if (debug_ieee & FP_EXTENDED) + ieee_flags (set, precision, "extended", NULL); + if (debug_ieee & FP_DOUBLE) + ieee_flags (set, precision, "double", NULL); + if (debug_ieee & FP_SINGLE) + ieee_flags (set, precision, "single", NULL); + } +#else +#ifdef mc68000 + /* Enable the IEEE floating point exceptions, for old versions of + * SunOS. Pretty much obsolete now... + */ +# define FP_INEXACT 0000010 +# define FP_DIVIDE 0000020 +# define FP_UNDERFLOW 0000040 +# define FP_OVERFLOW 0000100 +# define FP_INVALID 0000200 +# define FP_INEX1 0000400 +# define FP_INEX2 0001000 +# define FP_DZ 0002000 +# define FP_UNFL 0004000 +# define FP_OVFL 0010000 +# define FP_OPERR 0020000 +# define FP_SNAN 0040000 +# define FP_BSUN 0100000 + { + int mode = FP_BSUN|FP_SNAN|FP_OPERR|FP_DZ|FP_OVFL|FP_INVALID; + fpmode_ (&mode); + } +#endif +#endif +#endif + +#ifdef SYSV + /* Initialize the time zone data structures. */ + tzset(); +#endif + + /* Place a query call to ZAWSET to set the process working set limit + * to the IRAF default value, in case we did not inherit a working set + * limit value from the parent process. + */ + ZAWSET (&wsetsize, &junk, &junk, &junk); + + /* Initialize the stdio streams. */ + { XINT ro = READ_ONLY, wo = WRITE_ONLY, chan; + + ZOPNTY ((PKCHAR *)U_STDIN, &ro, &chan); + ZOPNTY ((PKCHAR *)U_STDOUT, &wo, &chan); + ZOPNTY ((PKCHAR *)U_STDERR, &wo, &chan); + } + + /* Pass the values of the kernel parameters into the kernel. */ + ZZSETK (os_process_name, osfn_bkgfile, prtype, ipc_isatty, + &ipc_in, &ipc_out); + + return (XOK); +} + + +/* ZZSTOP -- Clean up prior to process shutdown. + */ +int ZZSTOP (void) { return (XOK); } + + +/* ready -- This is a dummy routine used when debugging to allow a breakpoint + * to be set at a convenient point after the shared image has been mapped in. + */ +void ready_ (void) {} + diff --git a/unix/portkit/README b/unix/portkit/README new file mode 100644 index 00000000..17177d88 --- /dev/null +++ b/unix/portkit/README @@ -0,0 +1,356 @@ +UNIX/IRAF (Berkeley UNIX) Porting Notes +18 January 1986 (dct), 28 March 1988 (sr) +----------------------------------------- + +The 4.3BSD VAX version of UNIX/IRAF will run almost without change on other +BSD-based systems. In particular, the kernel should not have to be changed. +The changes which are required are due to machine differences, e.g., in the +assemblers and machine constants. The affected files are summarized below. + +Source for much of the existing IRAF system documentation is in the +directory iraf/doc, with notes on previous ports in iraf/doc/ports. +Other documentation is generally in "doc" subdirectories throughout the system. +It is useful to be familiar with Doug Tody's paper "The IRAF Data Reduction and +Analysis System" (IRAF System Handbook, Vol. 3A), as it is with "A Reference +Manual for the IRAF System Interface" (Vol. 3B). You will want to read and +refer to the UNIX/IRAF Installation and Maintenance Guide as well. + +Please keep a detailed notes file in $iraf/local on any files edited for +the port, similar to the ones in "$iraf/doc/ports". + +Virtually all the work on the port (excluding any new device interfaces) +should be in the Host System Interface (HSI) directories, which in this +case are rooted at "iraf/unix". A source tape may also contain other HSI's, +such as "iraf/vms". + +Summary of Steps Required for a BSD-derived UNIX Port + + o create the `iraf' account and root directory + o read the source distribution tape (UNIX "tar" format) + o edit system-dependent files in the HSI + o bootstrap the HSI utilities + o test the bootstrap utilities + o perform a full IRAF sysgen + o configure the device tables and complete the installation + o test and benchmark the system + +Edit the Files that Describe the Host System +------------------------------------------------------------------------------ +The Host System Interface comprises all the subdirectories of "$iraf/unix", +but in general for a new port only a handful of files need be modified; the +most likely of these are listed here. + +unix/as/*.s + All of the assembler sources are of course different for a VAX and + other machines. The various UNIX assemblers for the MC68000 + UNIX implementations are also different, e.g., in the comment + convention, use of $ or # to denote a numeric constant, etc. + Despite the differences there are many similarities, and the + translation is usually not difficult. Note that only a couple of + assembler sources are required, although half a dozen or so should + eventually be implemented for efficiency reasons. + + To modify the AS directory for a non-VAX, rename the original + AS directory to "vaxas", create a new "as" directory, and code at + least ZSVJMP.S (see below) for your machine. Other assembler routines + in "vaxas" may be coded later for enhanced efficiency. + +unix/as/zsvjmp.s + The "zsvjmp.s" distributed in the source tape is for VAX/UNIX. + This is the only assembler routine required for running IRAF; + it executes a non-local goto in the context of the "calling routine" + (this is why we cannot simply use the UNIX "setjmp / longjmp" + calls directly). See also LEN_JMPBUF in config.h and spp.h. + + In the VAX "zsvjmp.s" the location of the "mem" common block is fixed + at virtual address zero. This is desirable, but not essential. + However, it is essential that it be at least aligned to an even 64-bit + boundary in memory, due to requirements of the SPP language. + + Note that as long as the library function "setjmp(3)" is implemented, + all "zsvjmp.s" has to do is manipulate a few words, and jump to "setjmp" + without putting anything on the stack. + +pkg/cl/main.c +pkg/cl/pfiles.c + In a recent port to a machine requiring 64-bit alignment of double + precision words in memory (HP-9000 Series 800), we had to modify some + code in these two files. The symptom showed up after the CL was + running, when giving the command "lpar urand" after loading the + "utilities" package; a fatal bus error ensued. We have not checked + the fix out thoroughly yet, so it is not merged into the master + system. If you run into a situation like this, please contact me for + the modification. + +unix/boot/mkpkg/scanlib.c + This file contains code that opens and reads IRAF object libraries + in order to compare the insertion dates against source file dates. + Not all UNIX systems store the date or module names the same way, + so if you later find that MKPKG is always recompiling all modules, + you will need to modify this file. + +unix/boot/spp/xc.c + This is the IRAF XC compiler. Among other things, it preprocesses + SPP code into Fortran and executes the host system compilers and linker. + Examine the occurrences of "f77" and "cc", and make sure the right + libraries are in FORTLIB[123]. It is assumed that "f77" can compile C + code and "cc" can run the loader in the current version, requiring + minor code additions if not. + +unix/boot/spp/rpp/ratlibc/ratdef.h + If your compilers do anything with Fortran external identifiers other + than appending an underscore to them, including leaving them intact, + edit this file. + +unix/boot/spp/rpp/ratlibc/ratdef.h + If your Fortran compiler does anything with external identifiers + other than appending a trailing underscore (including doing nothing + with them at all), edit this file. In it, the names of Fortran + routines that may be called from C are given with the trailing + underscore. + +unix/boot/spp/xpp/xppcode.c + See the comments about type coercion for INT2 and INT4, and edit if + necessary. + +unix/gdev/* + No changes should be required, unless new graphics devices have to be + interfaced. + +unix/hlib/config.h + This file should be inspected for machine dependencies; e.g., + LEN_JUMPBUF may need modification; note that it should be 1 greater + than what is allocated for "jmp_buf" in "". + +unix/hlib/iraf.h + Do not confuse this file with the "iraf.h" in hlib/libc (which is for + inclusion in C programs). There are several things to check in this + file, e.g. the value of the "indefinites" INDEFR, etc. In particular, + be sure to map the Fortran intrinsics "and, or, xor," and "not" if + your Fortran compiler uses different names for them. Also, if Fortran + external identifiers are not distinguished from their C counterparts + automatically by the compilers, there may be some name collisions + between SPP and C routines, which would show up as runtime errors. + (E.g. if "blogs" were both an SPP routine and a UNIX routine, rename + "blogs" to "xblogs" or something in iraf.h [and libc/xnames.h]. + In a recent port we redefined "getpid" as "xgetpd", "rename" as + "xfrnam", and "getuid" as "xgetud".) + +unix/hlib/irafuser.csh + Edit the three compile/link flags (HSI_**) for the Host System Interface + routines -- there is little or no floating point used in the HSI. + Also edit the pathname to the IRAF root directory if yours is different. + +unix/hlib/mach.h (see portkit/mach.h.ieee) +unix/hlib/[dir]1mach.f (see portkit/[dir]1mach.f.ieee) + Change the machine constants to those for your hardware. If the machine + has IEEE floating point, these constants are independent of the host + operating system (e.g., SUN or ISI). The directory "unix/portkit" + contains several files ending in ".ieee" as examples. These files + should not be used to simply replace those in the distributed source + tape, as they may not be up to date; a diff/merge is recommended, or + just use them for reference in editing the distributed versions. + + In only the machine epsilon and byte-swap flags usually need + to be changed; the values for INDEF, MAX_LONG, etc. are the same for + most modern minicomputers. + + The utility $iraf/sys/osb$zzeps.f may be used to determine the machine + epsilon. The values determined for a SUN/MC68020 with software + floating point were the following: + + EPSILONR (1.192e-7) + EPSILOND (2.220d-16) + + BYTE_SWAP = NO means the most significant byte of a word comes first + in a stream of bytes, as in the MC68*** machines (this is called + "big-endian"). VAXes have swapped bytes. Note the examples in + $iraf/unix/portkit/*.IEEE. + +unix/hlib/mkiraf.csh + Change the IRAF root pathnames in these files. + +unix/hlib/libc/iraf.h +/usr/include/iraf.h -> $iraf/unix/hlib/libc/iraf.h + Replace ALL existing occurrences of the IRAF root pathname with your + own pathname to the IRAF root directory. This would normally be + done by the "install" script, but you may not wish to install IRAF + solely for purposes of the port. Also edit the value of TMP to be + the location of a publicly writeable scratch directory. If symbolic + links are available, simply establish one in "/usr/include" pointing + to "iraf.h" (you probably have to be superuser to do this). If not, + copy "iraf.h" to "/usr/include", and remember to do so again after any + subsequent edits. + +unix/hlib/libc/kernel.h + The only parameter which might need to be modified is _NFILE, which + should reflect the host sytem's open file capacity (this will be defined + in in many BSD derived systems). + +unix/hlib/libc/knames.h + If your compilers do anything with Fortran external identifiers other + than appending an underscore to them, including leaving them intact, + edit this file. + +unix/hlib/libc/libc.h + "libc.h" contains some definitions for external names of certain + Fortran identifiers such as common blocks -- in a few places, C + code needs access to these locations (see paragraph labelled + "[MACHDEP]"). On the VAX, all f77 external identifiers are given + a trailing underscore. + +unix/hlib/libc/spp.h (see portkit/spp.h.ieee) + Enter the EPSILON[RD]'s determined earlier for hlib/mach.h and the + INDEF's. Also, make sure LEN_JUMPBUF matches the one in + "hlib/config.h". In general, look for the string "MACHDEP" in these + files. + +unix/hlib/libc/xnames.h + See comments under "unix/hlib/iraf.h" concerning name collisions. + +unix/os/zxwhen.c + This file contains machine-specific hardware exception codes. + +This ends the list of likely source files to be edited. +Later, when installing a new version of UNIX/IRAF it is usually best to +install the new UNIX directories as well, and then modify or replace the +above files as necessary for your machine. All revisions are thus +automatically picked up, and the modifications required for your machine +are probably relatively minor. + + +Bootstrap the HSI Utilities +------------------------------------------------------------------------ +This may take a while (10's of minutes), so it is advisable to spool the +output. + + % cd $iraf/unix + % sh -x mkpkg.sh >& spool & + +Examine the spool file for any compilation errors and attempt to deduce +and correct any that are encountered. + +Test the Bootstrap Utilities +-------------------------------------------------------------------------------- +When the bootstrap has completed successfully, it is time to test the +bootstrap utilities. The most important of these are XC and MKPKG. +For purposes of a port, you may establish symbolic links to the bootstrap +utilities and later runtime executables within the IRAF directory system, rather +than in a public directory. This should be "$iraf/local/bin". +Edit the ".login" file of the "iraf" account to include +"$iraf/local/bin" in its search path, and establish the links as follows: + +% cd $iraf/local +% mkdir bin +% cd $iraf/local/bin +% ln -s $iraf/bin/cl.e cl +% ln -s $iraf/unix/hlib/generic.e generic +% ln -s $iraf/unix/hlib/mkiraf.csh mkiraf +% ln -s $iraf/unix/hlib/mkmlist.csh mkmlist +% ln -s $iraf/unix/hlib/mkpkg.e mkpkg +% ln -s $iraf/unix/hlib/rmbin.e rmbin +% ln -s $iraf/unix/hlib/rmfiles.e rmfiles +% ln -s $iraf/unix/hlib/rtar.e rtar +% ln -s $iraf/unix/hlib/sgidispatch.e sgidispatch +% ln -s $iraf/unix/hlib/wtar.e wtar +% ln -s $iraf/unix/hlib/xc.e xc" + +unix/hlib/mkpkg.inc + Edit "mkpkg.inc" to establish compiler and linker switches for SPP + programs. + +unix/hlib/mkpkg.sf + The special file list "mkpkg.sf" will be involved later, if compiler + bugs during a sysgen require special compilation (e.g. without + optimization). In a recent port to a vector machine, separate MKPKG + flags were created for several classes of routines, those benefitting + from vectorization, those calling lower-level C routines, etc. + Contact us if you feel your Fortran compiler may have similar needs + (if so, a number of "mkpkg" files in various directories will also + need to be edited). + +Perform an IRAF Sysgen +-------------------------------------------------------------------------------- +If the bootstrap utilities appear to be in good shape, it is time to perform +a full IRAF sysgen. This will preprocess all the SPP code in IRAF into +Fortran, compile and delete the intermediate Fortran source, load all +the object libraries, and link the executables. There are invariably +problems with the Fortran compiler. There will probably be some compile +time compiler failures, maybe some linker failures, and probably some run +time IRAF bugs that end up being due to compiler bugs, usually +in the optimizer. IRAF is a large system, and we haven't gotten +through an installation yet on any host where this was not the case +(although in a couple of recent ports only a few files were affected). +You will definitely want to spool the output; even on fast machines a +full sysgen may take over 5 hours. + + % cd $iraf + % mkpkg >& spool & + +You will certainly have to perform the sysgen multiple times, as you identify +and correct problems. Files successfully compiled and loaded into object +libraries will not be compiled in succeeding sysgens, so each one takes less +time than its predecessor. Be sure to inspect the spoolfile during or after +your second sysgen to make sure this is the case. If all files are being +automatically recompiled, there is something wrong with the routine that +compares file dates in the object libraries with source file dates. Library +module dates are determined in iraf$unix/boot/mkpkg/scanlib.c, module +h_scanlibrary. Note that the bootstrap utility RMBIN may be used to +remove binary files should this be desired during multiple cycles of sysgens. + +The hardest part starts when you begin debugging problems with +the run-time system; it helps to know IRAF well enough to know how +something is supposed to work. This could well be the most labor-intensive +part of the port. Note that the file "$iraf/unix/hlib/mkpkg.sf" is +used for handling files requiring special compilation. + +Test and Benchmark the System +-------------------------------------------------------------------------------- +If all the preceding steps are complete, you are ready to begin testing +the system. A normal user would run "mkiraf" from their +desired IRAF home directory ("$iraf/local" for the IRAF account itself) +to tailor the runtime environment. Since you are doing a port instead, +you may want to simply edit the startup file ("$iraf/local/login.cl") +for the two environment variables "home" and "imdir". Most +users locate their bulk image storage directory on a temp disk +to simplify disk backups, but to keep the port compact, you could +instead create a pixel storage directory under "$iraf/local". +Edit "$iraf/local/login.cl"; replace the home directory below with +your own: + + set home = "/iraf/local/" + set imdir = "home$pix/" + +The test procedures assume a complete installation, so even though +you don't know if the port is successful yet, you might as well configure +the device tables and complete the installation as in the "UNIX/IRAF +Installation and Maintenance Guide", section 2.3 (at least install the +magtape devices in "dev$devices" as in section 2.3.2). Since +we cannot guarantee that a binary image file from a VAX/UNIX system +will be readable by an arbitrary host system, we will have you delete +the old binary image (currently implemented as three files), then +unpack a machine-independent image file to replace it. Contact us +if the file "fitspix" is not present in the $iraf/dev directory. + + % cd $iraf/local + % cl + [IRAF banner, message of the day, top-level packages.] + cl> cd dev + cl> delete pix.imh,..pix.imh,pix.pix # if present + cl> set imdir = HDR$ + cl> dataio + da> rfits fitspix 1 pix + da> bye + cl> cd local + cl> mkdir pix + cl> reset imdir = "home$pix/" + +You may now undertake the Test Procedures in Volume 1A of the IRAF User +Handbook. + +Benchmark the System +-------------------------------------------------------------------------------- +When the system is running reasonably well and is bug-free, you can +accomplish further testing by running the Benchmark Utilities. See the +paper entitled "A Set of Benchmarks for Measuring IRAF System Performance", +in the IRAF System Handbook, Volume 3A. diff --git a/unix/portkit/d1mach.f.ieee b/unix/portkit/d1mach.f.ieee new file mode 100644 index 00000000..22bc2512 --- /dev/null +++ b/unix/portkit/d1mach.f.ieee @@ -0,0 +1,273 @@ +c +c---------------------------------------------------------------------- +c function: d1mach +c this routine is from the port mathematical subroutine library +c it is described in the bell laboratories computing science +c technical report #47 by p.a. fox, a.d. hall and n.l. schryer +c a modification to the "i out of bounds" error message +c has been made by c. a. mcgonegal - april, 1978 +c---------------------------------------------------------------------- +c + double precision function d1mach(i) +c +c double-precision machine constants +c +c d1mach( 1) = b**(emin-1), the smallest positive magnitude. +c +c d1mach( 2) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c d1mach( 3) = b**(-t), the smallest relative spacing. +c +c d1mach( 4) = b**(1-t), the largest relative spacing. +c +c d1mach( 5) = log10(b) +c +c to alter this function for a particular environment, +c the desired set of data statements should be activated by +c removing the c from column 1. +c +c where possible, octal or hexadecimal constants have been used +c to specify the constants exactly which has in some cases +c required the use of equivalent integer arrays. +c + integer small(4) + integer large(4) + integer right(4) + integer diver(4) + integer log10(4) +c + double precision dmach(5) +c + equivalence (dmach(1),small(1)) + equivalence (dmach(2),large(1)) + equivalence (dmach(3),right(1)) + equivalence (dmach(4),diver(1)) + equivalence (dmach(5),log10(1)) +c +c machine constants for the burroughs 1700 system. +c +c data small(1) / zc00800000 / +c data small(2) / z000000000 / +c +c data large(1) / zdffffffff / +c data large(2) / zfffffffff / +c +c data right(1) / zcc5800000 / +c data right(2) / z000000000 / +c +c data diver(1) / zcc6800000 / +c data diver(2) / z000000000 / +c +c data log10(1) / zd00e730e7 / +c data log10(2) / zc77800dc0 / +c +c machine constants for the burroughs 5700 system. +c +c data small(1) / o1771000000000000 / +c data small(2) / o0000000000000000 / +c +c data large(1) / o0777777777777777 / +c data large(2) / o0007777777777777 / +c +c data right(1) / o1461000000000000 / +c data right(2) / o0000000000000000 / +c +c data diver(1) / o1451000000000000 / +c data diver(2) / o0000000000000000 / +c +c data log10(1) / o1157163034761674 / +c data log10(2) / o0006677466732724 / +c +c machine constants for the burroughs 6700/7700 systems. +c +c data small(1) / o1771000000000000 / +c data small(2) / o7770000000000000 / +c +c data large(1) / o0777777777777777 / +c data large(2) / o7777777777777777 / +c +c data right(1) / o1461000000000000 / +c data right(2) / o0000000000000000 / +c +c data diver(1) / o1451000000000000 / +c data diver(2) / o0000000000000000 / +c +c data log10(1) / o1157163034761674 / +c data log10(2) / o0006677466732724 / +c +c machine constants for the cdc 6000/7000 series. +c +c data small(1) / 00604000000000000000b / +c data small(2) / 00000000000000000000b / +c +c data large(1) / 37767777777777777777b / +c data large(2) / 37167777777777777777b / +c +c data right(1) / 15604000000000000000b / +c data right(2) / 15000000000000000000b / +c +c data diver(1) / 15614000000000000000b / +c data diver(2) / 15010000000000000000b / +c +c data log10(1) / 17164642023241175717b / +c data log10(2) / 16367571421742254654b / +c +c machine constants for the cray 1 +c +c data small(1) / 200004000000000000000b / +c data small(2) / 000000000000000000000b / +c +c data large(1) / 577767777777777777777b / +c data large(2) / 000007777777777777776b / +c +c data right(1) / 376424000000000000000b / +c data right(2) / 000000000000000000000b / +c +c data diver(1) / 376434000000000000000b / +c data diver(2) / 000000000000000000000b / +c +c data log10(1) / 377774642023241175717b / +c data log10(2) / 000007571421742254654b / +c +c machine constants for the data general eclipse s/200 +c +c note - it may be appropriate to include the following card - +c static dmach(5) +c +c data small/20k,3*0/,large/77777k,3*177777k/ +c data right/31420k,3*0/,diver/32020k,3*0/ +c data log10/40423k,42023k,50237k,74776k/ +c +c machine constants for the harris slash 6 and slash 7 +c +c data small(1),small(2) / '20000000, '00000201 / +c data large(1),large(2) / '37777777, '37777577 / +c data right(1),right(2) / '20000000, '00000333 / +c data diver(1),diver(2) / '20000000, '00000334 / +c data log10(1),log10(2) / '23210115, '10237777 / +c +c machine constants for the honeywell 600/6000 series. +c +c data small(1),small(2) / o402400000000, o000000000000 / +c data large(1),large(2) / o376777777777, o777777777777 / +c data right(1),right(2) / o604400000000, o000000000000 / +c data diver(1),diver(2) / o606400000000, o000000000000 / +c data log10(1),log10(2) / o776464202324, o117571775714 / +c +c machine constants for the ibm 360/370 series, +c the xerox sigma 5/7/9 and the sel systems 85/86. +c +c data small(1),small(2) / z00100000, z00000000 / +c data large(1),large(2) / z7fffffff, zffffffff / +c data right(1),right(2) / z33100000, z00000000 / +c data diver(1),diver(2) / z34100000, z00000000 / +c data log10(1),log10(2) / z41134413, z509f79ff / +c +c machine constants for the pdp-10 (ka processor). +c +c data small(1),small(2) / "033400000000, "000000000000 / +c data large(1),large(2) / "377777777777, "344777777777 / +c data right(1),right(2) / "113400000000, "000000000000 / +c data diver(1),diver(2) / "114400000000, "000000000000 / +c data log10(1),log10(2) / "177464202324, "144117571776 / +c +c machine constants for the pdp-10 (ki processor). +c +c data small(1),small(2) / "000400000000, "000000000000 / +c data large(1),large(2) / "377777777777, "377777777777 / +c data right(1),right(2) / "103400000000, "000000000000 / +c data diver(1),diver(2) / "104400000000, "000000000000 / +c data log10(1),log10(2) / "177464202324, "476747767461 / +c +c machine constants for pdp-11 fortran's supporting +c 32-bit integers (expressed in integer and octal). +c + data small(1),small(2) / 8388608, 0 / + data large(1),large(2) / 2147483647, -1 / + data right(1),right(2) / 612368384, 0 / + data diver(1),diver(2) / 620756992, 0 / + data log10(1),log10(2) / 1067065498, -2063872008 / +c +c data small(1),small(2) / o00040000000, o00000000000 / +c data large(1),large(2) / o17777777777, o37777777777 / +c data right(1),right(2) / o04440000000, o00000000000 / +c data diver(1),diver(2) / o04500000000, o00000000000 / +c data log10(1),log10(2) / o07746420232, o20476747770 / +c +c machine constants for pdp-11 fortran's supporting +c 16-bit integers (expressed in integer and octal). +c +c data small(1),small(2) / 128, 0 / +c data small(3),small(4) / 0, 0 / +c +c data large(1),large(2) / 32767, -1 / +c data large(3),large(4) / -1, -1 / +c +c data right(1),right(2) / 9344, 0 / +c data right(3),right(4) / 0, 0 / +c +c data diver(1),diver(2) / 9472, 0 / +c data diver(3),diver(4) / 0, 0 / +c +c data log10(1),log10(2) / 16282, 8346 / +c data log10(3),log10(4) / -31493, -12296 / +c +c data small(1),small(2) / o000200, o000000 / +c data small(3),small(4) / o000000, o000000 / +c +c data large(1),large(2) / o077777, o177777 / +c data large(3),large(4) / o177777, o177777 / +c +c data right(1),right(2) / o022200, o000000 / +c data right(3),right(4) / o000000, o000000 / +c +c data diver(1),diver(2) / o022400, o000000 / +c data diver(3),diver(4) / o000000, o000000 / +c +c data log10(1),log10(2) / o037632, o020232 / +c data log10(3),log10(4) / o102373, o147770 / +c +c machine constants for the univac 1100 series. +c +c data small(1),small(2) / o000040000000, o000000000000 / +c data large(1),large(2) / o377777777777, o777777777777 / +c data right(1),right(2) / o170540000000, o000000000000 / +c data diver(1),diver(2) / o170640000000, o000000000000 / +c data log10(1),log10(2) / o177746420232, o411757177572 / +c +c machine constants for the vax-11 with +c fortran iv-plus compiler +c +c data small(1),small(2) / z00000080, z00000000 / +c data large(1),large(2) / zffff7fff, zffffffff / +c data right(1),right(2) / z00002480, z00000000 / +c data diver(1),diver(2) / z00002500, z00000000 / +c data log10(1),log10(2) / z209a3f9a, zcffa84fb / +c +c machine constants for IEEE floating point standard on 68000. First +c expressed as hex constants, then as two word integer. +c +c data small(1), small(2) / x'00080000', x'00000000' / +c data large(1), large(2) / x'7FDFFFFF', x'FFFFFFFF' / +c data right(1), right(2) / x'3CA00000', x'00000000' / +c data diver(1), diver(2) / x'3CB00000', x'00000000' / +c data log10(1), log10(2) / x'3FE62E42', x'FEFA39EF' / +c +c These IEEE values are written as integer constants below - +c +c data small(1),small(2) /524288, 0/ +c data large(1),large(2) /2145386495, -1/ +c data right(1),right(2) /970, 0/ +c data diver(1),diver(2) /971, 0/ +c data log10(1),log10(2) /1072049730, -17155601/ +c +c if (i .lt. 1 .or. i .gt. 5) goto 100 +c + d1mach = dmach(i) + return +c +c100 iwunit = i1mach(4) +c write(iwunit, 99) +c 99 format(24hd1mach - i out of bounds) +c stop + end diff --git a/unix/portkit/i1mach.f.ieee b/unix/portkit/i1mach.f.ieee new file mode 100644 index 00000000..cac890bd --- /dev/null +++ b/unix/portkit/i1mach.f.ieee @@ -0,0 +1,379 @@ +c i1mach from portlib 03/25/82 + integer function i1mach(i) +c +c i/o unit numbers. +c +c i1mach( 1) = the standard input unit. +c +c i1mach( 2) = the standard output unit. +c +c i1mach( 3) = the standard punch unit. +c +c i1mach( 4) = the standard error message unit. +c +c words. +c +c i1mach( 5) = the number of bits per integer storage unit. +c +c i1mach( 6) = the number of characters per integer storage unit. +c +c integers. +c +c assume integers are represented in the s-digit, base-a form +c +c sign ( x(s-1)*a**(s-1) + ... + x(1)*a + x(0) ) +c +c where 0 .le. x(i) .lt. a for i=0,...,s-1. +c +c i1mach( 7) = a, the base. +c +c i1mach( 8) = s, the number of base-a digits. +c +c i1mach( 9) = a**s - 1, the largest magnitude. +c +c floating-point numbers. +c +c assume floating-point numbers are represented in the t-digit, +c base-b form +c +c sign (b**e)*( (x(1)/b) + ... + (x(t)/b**t) ) +c +c where 0 .le. x(i) .lt. b for i=1,...,t, +c 0 .lt. x(1), and emin .le. e .le. emax. +c +c i1mach(10) = b, the base. +c +c single-precision +c +c i1mach(11) = t, the number of base-b digits. +c +c i1mach(12) = emin, the smallest exponent e. +c +c i1mach(13) = emax, the largest exponent e. +c +c double-precision +c +c i1mach(14) = t, the number of base-b digits. +c +c i1mach(15) = emin, the smallest exponent e. +c +c i1mach(16) = emax, the largest exponent e. +c +c to alter this function for a particular environment, +c the desired set of data statements should be activated by +c removing the c from column 1. also, the values of +c i1mach(1) - i1mach(4) should be checked for consistency +c with the local operating system. +c + integer imach(16),output +c + equivalence (imach(4),output) +c +c machine constants for the burroughs 1700 system. +c +c data imach( 1) / 7 / +c data imach( 2) / 2 / +c data imach( 3) / 2 / +c data imach( 4) / 2 / +c data imach( 5) / 36 / +c data imach( 6) / 4 / +c data imach( 7) / 2 / +c data imach( 8) / 33 / +c data imach( 9) / z1ffffffff / +c data imach(10) / 2 / +c data imach(11) / 24 / +c data imach(12) / -256 / +c data imach(13) / 255 / +c data imach(14) / 60 / +c data imach(15) / -256 / +c data imach(16) / 255 / +c +c machine constants for the burroughs 5700 system. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 48 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 39 / +c data imach( 9) / o0007777777777777 / +c data imach(10) / 8 / +c data imach(11) / 13 / +c data imach(12) / -50 / +c data imach(13) / 76 / +c data imach(14) / 26 / +c data imach(15) / -50 / +c data imach(16) / 76 / +c +c machine constants for the burroughs 6700/7700 systems. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 48 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 39 / +c data imach( 9) / o0007777777777777 / +c data imach(10) / 8 / +c data imach(11) / 13 / +c data imach(12) / -50 / +c data imach(13) / 76 / +c data imach(14) / 26 / +c data imach(15) / -32754 / +c data imach(16) / 32780 / +c +c machine constants for the cdc 6000/7000 series. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 60 / +c data imach( 6) / 10 / +c data imach( 7) / 2 / +c data imach( 8) / 48 / +c data imach( 9) / 00007777777777777777b / +c data imach(10) / 2 / +c data imach(11) / 48 / +c data imach(12) / -974 / +c data imach(13) / 1070 / +c data imach(14) / 96 / +c data imach(15) / -927 / +c data imach(16) / 1070 / +c +c machine constants for the cray 1 +c +c data imach( 1) / 100 / +c data imach( 2) / 101 / +c data imach( 3) / 102 / +c data imach( 4) / 101 / +c data imach( 5) / 64 / +c data imach( 6) / 8 / +c data imach( 7) / 2 / +c data imach( 8) / 63 / +c data imach( 9) / 777777777777777777777b / +c data imach(10) / 2 / +c data imach(11) / 48 / +c data imach(12) / -8192 / +c data imach(13) / 8191 / +c data imach(14) / 96 / +c data imach(15) / -8192 / +c data imach(16) / 8191 / +c +c machine constants for the data general eclipse s/200 +c +c data imach( 1) / 11 / +c data imach( 2) / 12 / +c data imach( 3) / 8 / +c data imach( 4) / 10 / +c data imach( 5) / 16 / +c data imach( 6) / 2 / +c data imach( 7) / 2 / +c data imach( 8) / 15 / +c data imach( 9) /32767 / +c data imach(10) / 16 / +c data imach(11) / 6 / +c data imach(12) / -64 / +c data imach(13) / 63 / +c data imach(14) / 14 / +c data imach(15) / -64 / +c data imach(16) / 63 / +c +c machine constants for the harris 220 +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 0 / +c data imach( 4) / 6 / +c data imach( 5) / 24 / +c data imach( 6) / 3 / +c data imach( 7) / 2 / +c data imach( 8) / 23 / +c data imach( 9) / 8388607 / +c data imach(10) / 2 / +c data imach(11) / 23 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 38 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c +c machine constants for the honeywell 600/6000 series. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 43 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / 0377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 63 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c +c machine constants for the ibm 360/370 series. +c the xerox sigma 5/7/9 and the sel systems 85/86. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 32 / +c data imach( 6) / 4 / +c data imach( 7) / 2 / +c data imach( 8) / 31 / +c data imach( 9) / z7fffffff / +c data imach(10) / 16 / +c data imach(11) / 6 / +c data imach(12) / -64 / +c data imach(13) / 63 / +c data imach(14) / 14 / +c data imach(15) / -64 / +c data imach(16) / 63 / +c +c machine constants for the pdp-10 (ka processor). +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 5 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / "377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -128 / +c data imach(13) / 127 / +c data imach(14) / 54 / +c data imach(15) / -101 / +c data imach(16) / 127 / +c +c machine constants for the pdp-10 (ki processor). +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 5 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / "377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -128 / +c data imach(13) / 127 / +c data imach(14) / 62 / +c data imach(15) / -128 / +c data imach(16) / 127 / +c +c machine constants for pdp-11 fortran"s supporting +c 32-bit integer arithmetic. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 32 / +c data imach( 6) / 4 / +c data imach( 7) / 2 / +c data imach( 8) / 31 / +c data imach( 9) / 2147483647 / +c data imach(10) / 2 / +c data imach(11) / 24 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 56 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c +c machine constants for pdp-11 fortran"s supporting +c 16-bit integer arithmetic. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 16 / +c data imach( 6) / 2 / +c data imach( 7) / 2 / +c data imach( 8) / 15 / +c data imach( 9) /32767 / +c data imach(10) / 2 / +c data imach(11) / 24 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 56 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c +c machine constants for the univac 1100 series. +c +c note that the punch unit, i1mach(3), has been set to 7 +c which is appropriate for the univac-for system. +c if you have the univac-ftn system, set it to 1. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / o377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -128 / +c data imach(13) / 127 / +c data imach(14) / 60 / +c data imach(15) /-1024 / +c data imach(16) / 1023 / +c +c machine constants for IEEE binary floating point standard +c + data imach( 1) / 5 / + data imach( 2) / 6 / + data imach( 3) / 5 / + data imach( 4) / 6 / + data imach( 5) / 32 / + data imach( 6) / 4 / + data imach( 7) / 2 / + data imach( 8) / 31 / + data imach( 9) / 2147483647 / + data imach(10) / 2 / + data imach(11) / 24 / + data imach(12) / -128 / + data imach(13) / 127 / + data imach(14) / 53 / + data imach(15) / -1023 / + data imach(16) / 1024 / +c +c----------------------------------------------------------------------- +c delete next two statements after supplying the proper data statements. +c data imach (5) /0/ +c if (imach(5) .eq. 0) +c 1call uliber(2,45h i1mach - machine dependent constants not set,45) +c----------------------------------------------------------------------- +c if (i .lt. 1 .or. i .gt. 16) go to 10 +c + i1mach=imach(i) + return +c +c 10 call uliber(1,34h error in i1mach - i out of bounds,34) +c +c stop +c + end diff --git a/unix/portkit/ishift.s.68000 b/unix/portkit/ishift.s.68000 new file mode 100644 index 00000000..cfd6d7e9 --- /dev/null +++ b/unix/portkit/ishift.s.68000 @@ -0,0 +1,44 @@ +|# IAND, IOR, ISHIFT -- Bitwise boolean integer functions for the NCAR +|# package. The shift function must rotate the bits left and around +|# if the nbits to shift argument is positive, and zero fill at the left +|# if the shift is negative (right shift). +|# +|# (SUN/UNIX MC68xxx version) + +|# AND -- Bitwise boolean AND: C = AND (A, B) + .text + .globl _iand_ +_iand_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + andl a0@,d0 + rts + + +|# OR -- Bitwise boolean OR: C = OR (A, B) + .text + .globl _ior_ +_ior_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + orl a0@,d0 + rts + + +|# ISHIFT -- Bitwise shift: C = ISHIFT (A, NBITS), +=left + .text + .globl _ishift_ +_ishift_: + movl sp@(4),a0 + movl a0@,d0 + movl sp@(8),a0 + movl a0@,d1 + blt L1 + roll d1,d0 |# left rotate (high bits come in at right) + rts +L1: + negl d1 + lsrl d1,d0 |# logical shift right (zero at left) + rts diff --git a/unix/portkit/mach.h.ieee b/unix/portkit/mach.h.ieee new file mode 100644 index 00000000..f8264d69 --- /dev/null +++ b/unix/portkit/mach.h.ieee @@ -0,0 +1,37 @@ +# Machine Parameters + +define SZB_CHAR 2 # machine bytes per char +define SZB_ADDR 1 # machine bytes per address increment +define SZ_VMPAGE 256 # page size (1 if no virtual mem.) +define MAX_DIGITS 25 # max digits in a number +define NDIGITS_RP 7 # number of digits of real precision +define NDIGITS_DP 17 # number of digits of precision (double) +define MAX_EXPONENT 38 # max exponent, base 10 +define MAX_EXPONENTR 38 +define MAX_EXPONENTD 38 + +define MAX_SHORT 32767 # largest numbers +define MAX_INT 2147483647 +define MAX_LONG 2147483647 +define MAX_REAL 0.99e37 # anything larger is INDEF +define MAX_DOUBLE 0.99e37 +define NBITS_BYTE 8 # nbits in a machine byte +define NBITS_SHORT 16 # nbits in a short +define NBITS_INT 32 # nbits in an integer +define EPSILONR (1.192e-7) # smallest E such that 1.0 + E > 1.0 +define EPSILOND (2.220d-16) # double precision epsilon +define EPSILON EPSILONR + +define INDEFS (-32767) # indefinite valued pixels +define INDEFL (-2147483647) +define INDEFI INDEFL +define INDEFR 1.6e38 +define INDEFD 1.6d38 +define INDEFX (INDEF,INDEF) +define INDEF INDEFR + +# Is byte swapping (i.e., a call to bswap2 or bswap4) needed for a 2 or 4 byte +# MII integer to convert to or from MII format on this machine? + +define BYTE_SWAP2 NO +define BYTE_SWAP4 NO diff --git a/unix/portkit/r1mach.f.ieee b/unix/portkit/r1mach.f.ieee new file mode 100644 index 00000000..c13509fc --- /dev/null +++ b/unix/portkit/r1mach.f.ieee @@ -0,0 +1,191 @@ +c r1mach from portlib 03/25/82 + real function r1mach(i) +c +c single-precision machine constants +c r1mach(1) = b**(emin-1), the smallest positive magnitude. +c +c r1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c r1mach(3) = b**(-t), the smallest relative spacing. +c +c r1mach(4) = b**(1-t), the largest relative spacing. +c +c r1mach(5) = log10(b) +c +c to alter this function for a particular environment, +c the desired set of data statements should be activated by +c removing the c from column 1. +c +c where possible, octal or hexadecimal constants have been used +c to specify the constants exactly which has in some cases +c required the use of equivalent integer arrays. +c + integer small(2) + integer large(2) + integer right(2) + integer diver(2) + integer log10(2) +c + real rmach(5) +c + equivalence (rmach(1),small(1)) + equivalence (rmach(2),large(1)) + equivalence (rmach(3),right(1)) + equivalence (rmach(4),diver(1)) + equivalence (rmach(5),log10(1)) +c +c machine constants for the burroughs 1700 system. +c +c data rmach(1) / z400800000 / +c data rmach(2) / z5ffffffff / +c data rmach(3) / z4e9800000 / +c data rmach(4) / z4ea800000 / +c data rmach(5) / z500e730e8 / +c +c machine constants for the burroughs 5700/6700/7700 systems. +c +c data rmach(1) / 01771000000000000 / +c data rmach(2) / o0777777777777777 / +c data rmach(3) / o1311000000000000 / +c data rmach(4) / o1301000000000000 / +c data rmach(5) / o1157163034761675 / +c +c machine constants for the cdc 6000/7000 series. +c +c data rmach(1) / 00014000000000000000b / +c data rmach(2) / 37767777777777777777b / +c data rmach(3) / 16404000000000000000b / +c data rmach(4) / 16414000000000000000b / +c data rmach(5) / 17164642023241175720b / +c +c machine constants for the cray 1 +c +c data rmach(1) / 200004000000000000000b / +c data rmach(2) / 577777777777777777777b / +c data rmach(3) / 377214000000000000000b / +c data rmach(4) / 377224000000000000000b / +c data rmach(5) / 377774642023241175720b / +c +c machine constants for the data general eclipse s/200 +c +c note - it may be appropriate to include the following card - +c static rmach(5) +c +c data small/20k,0/,large/77777k,177777k/ +c data right/35420k,0/,diver/36020k,0/ +c data log10/40423k,42023k/ +c +c machine constants for the harris 220 +c +c data small(1),small(2) / "20000000, "00000201 / +c data large(1),large(2) / "37777777, "00000177 / +c data right(1),right(2) / "20000000, "00000352 / +c data diver(1),diver(2) / "20000000, "00000353 / +c data log10(1),log10(2) / "23210115, "00000377 / +c +c machine constants for the honeywell 600/6000 series. +c +c data rmach(1) / o402400000000 / +c data rmach(2) / o376777777777 / +c data rmach(3) / o714400000000 / +c data rmach(4) / o716400000000 / +c data rmach(5) / o776464202324 / +c +c machine constants for the ibm 360/370 series, +c the xerox sigma 5/7/9 and the sel systems 85/86. +c +c data rmach(1) / z00100000 / +c data rmach(2) / z7fffffff / +c data rmach(3) / z3b100000 / +c data rmach(4) / z3c100000 / +c data rmach(5) / z41134413 / +c +c machine constants for the pdp-10 (ka or ki processor). +c +c data rmach(1) / "000400000000 / +c data rmach(2) / "377777777777 / +c data rmach(3) / "146400000000 / +c data rmach(4) / "147400000000 / +c data rmach(5) / "177464202324 / +c +c machine constants for pdp-11 fortran"s supporting +c 32-bit integers (expressed in integer and octal). +c +c KPNO -- Hex machine constants for the VAX, which stores the bytes of +c a real variable in a funny order. +c +c No standard hex constants in fortran!!! +c data small(1) / x'00000080' / +c data large(1) / x'ffff7fff' / +c data right(1) / x'00003480' / +c data diver(1) / x'00003500' / +c data log10(1) / x'209b359a' / +c +c data small(1) / 128 / +c data large(1) / -32769 / +c data right(1) / 13440 / +c data diver(1) / 13696 / +c data log10(1) / 547042714 / +c +c data small(1) / 8388608 / +c data large(1) / 2147483647 / +c data right(1) / 880803840 / +c data diver(1) / 889192448 / +c data log10(1) / 1067065499 / +c +c data rmach(1) / o00040000000 / +c data rmach(2) / o17777777777 / +c data rmach(3) / o06440000000 / +c data rmach(4) / o06500000000 / +c data rmach(5) / o07746420233 / +c +c machine constants for pdp-11 fortran"s supporting +c 16-bit integers (expressed in integer and octal). +c +c data small(1),small(2) / 128, 0 / +c data large(1),large(2) / 32767, -1 / +c data right(1),right(2) / 13440, 0 / +c data diver(1),diver(2) / 13568, 0 / +c data log10(1),log10(2) / 16282, 8347 / +c +c data small(1),small(2) / o000200, o000000 / +c data large(1),large(2) / o077777, o177777 / +c data right(1),right(2) / o032200, o000000 / +c data diver(1),diver(2) / o032400, o000000 / +c data log10(1),log10(2) / o037632, o020233 / +c +c machine constants for the univac 1100 series. +c +c data rmach(1) / o000400000000 / +c data rmach(2) / o377777777777 / +c data rmach(3) / o146400000000 / +c data rmach(4) / o147400000000 / +c data rmach(5) / o177464202324 / +c +c machine constants for IEEE single precision floating point on 68000. +c +c data small(1) / x'100000' / +c data large(1) / x'7EFFFFFF' / +c data right(1) / x'33800000' / +c data diver(1) / x'34000000' / +c data log10(1) / x'3F317218' / +c + data small(1) / 1048576 / + data large(1) / 2130706431 / + data right(1) / 864026624 / + data diver(1) / 872415232 / + data log10(1) / 1060205080 / +c +c----------------------------------------------------------------------- +c delete next two statements after supplying the proper data statements. +c data rmach(5) /0./ +c if (rmach(5) .eq. 0.0) +c 1call uliber(2,45h r1mach - machine dependent constants not set,45) +c----------------------------------------------------------------------- +c if (i .lt. 1 .or. i .gt. 5) +c 1 call uliber (1,34h error in r1mach - i out of bounds,34) +c + r1mach = rmach(i) + return +c + end diff --git a/unix/portkit/spp.h.ieee b/unix/portkit/spp.h.ieee new file mode 100644 index 00000000..c5fd2309 --- /dev/null +++ b/unix/portkit/spp.h.ieee @@ -0,0 +1,139 @@ +/* + * SPP.H -- Language definitions for interfacing SPP to C and C to UNIX. + * Note that many of the definitions must agree with those in the SPP + * compiler and with and . + */ + +/* Assorted machine constants. [MACHDEP] + * Use osb$zzeps.f to compute the machine epsilon. + */ +#define OSOK 0 /* normal successful completion */ +#define LEN_JUMPBUF 16 /* save buffer for ZSVJMP/ZDOJMP */ +#define EPSILON (1.192e-7) /* smallest real E s.t. (1.0+E > 1.0) */ +#define EPSILOND (2.220d-16) /* double precision epsilon */ +#define MAX_LONG 2147483647 +#define FNNODE_CHAR '!' /* node name delimiter character */ + +/* Indefinite valued numbers. (potentially MACHDEP) + */ +#define INDEFS (-32767) +#define INDEFL (0x80000001) +#define INDEFI INDEFL +#define INDEFR 1.6e38 +#define INDEFD 1.6e38 +#define INDEFX (INDEF,INDEF) +#define INDEF INDEFR + + +/* Oft used constants. + */ +#define SZ_LINE 161 +#define SZ_FNAME 63 +#define SZ_PATHNAME 127 +#define EOS '\0' +#define ERR (-1) +#define OK 0 +#define YES 1 +#define NO 0 +#define MAX_DIGITS 25 +#define min(a,b) (((a)<(b))?(a):(b)) +#define max(a,b) (((a)>(b))?(a):(b)) + +# ifndef NULL +#define NULL 0 +# endif + +# ifndef EOF +#define EOF (-1) +#endif + +/* SPP constants. + */ +#define XEOS 0 +#define XERR (-1) +#define XEOF (-2) +#define XBOF (-3) +#define XOK 0 +#define XNO 0 +#define XYES 1 + +#define BOFL (-3L) +#define EOFL (-2L) + +/* SPP datatypes. (potentially MACHDEP) + */ +# ifndef XCHAR +#define XCHAR short +# endif + +# ifndef XINT +#define XINT int +# endif + +#define PKCHAR XCHAR +#define XUBYTE unsigned char +#define XBOOL int +#define XSHORT short +#define XUSHORT unsigned short +#define XLONG long +#define XREAL float +#define XDOUBLE double +#define XCOMPLEX struct cplx +#define XSTRUCT int +#define XPOINTER int + +struct cplx { + float r; + float i; +}; + +#define TY_BOOL 1 /* SPP datatype codes */ +#define TY_CHAR 2 +#define TY_SHORT 3 +#define TY_INT 4 +#define TY_LONG 5 +#define TY_REAL 6 +#define TY_DOUBLE 7 +#define TY_COMPLEX 8 +#define TY_STRUCT 9 +#define TY_POINTER 10 + + +/* File I/O constants. + */ +#define READ_ONLY 1 /* file access modes */ +#define READ_WRITE 2 +#define WRITE_ONLY 3 +#define APPEND 4 +#define NEW_FILE 5 + +#define TEXT_FILE 11 /* file types */ +#define BINARY_FILE 12 +#define DIRECTORY_FILE 13 + +#define CLIN 1 +#define CLOUT 2 +#define STDIN 3 +#define STDOUT 4 +#define STDERR 5 +#define STDGRAPH 6 +#define STDIMAGE 7 +#define STDPLOT 8 +#define PSIOCTRL 9 + +/* Filename Mapping definitions. + */ + +#define VFN_READ 1 /* VFN access modes for VFNOPEN */ +#define VFN_WRITE 2 +#define VFN_UNMAP 3 + +#define VFN_NOUPDATE 0 /* update flag for VFNCLOSE */ +#define VFN_UPDATE 1 + +/* Oft referenced functions. + */ +XCHAR *c_sppstr(); +XCHAR *c_strupk(); +char *c_strpak(); +#define D_spp diff --git a/unix/portkit/zsvjmp.s.68000 b/unix/portkit/zsvjmp.s.68000 new file mode 100644 index 00000000..efebe43e --- /dev/null +++ b/unix/portkit/zsvjmp.s.68000 @@ -0,0 +1,37 @@ +|# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +|# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +|# the registers, effecting a call in the context of the procedure which +|# originally called ZSVJMP, but with the new status code. These are Fortran +|# callable procedures. +|# +|# (SUN/UNIX MC68xxx version) + + .text + .globl _zsvjmp_ + + |# The following has nothing to do with ZSVJMP, and is included here + |# only because this assembler module is loaded with every process. + |# This code sets the value of the symbol MEM (the Mem common) to zero, + |# setting the origin for IRAF pointers to zero rather than some + |# arbitrary value, and ensuring that the MEM common is aligned for + |# all datatypes as well as page aligned. A further advantage is that + |# references to NULL pointers will cause a memory violation. + + .globl _mem_ + _mem_ = 0 + + JMPBUF = 4 + STATUS = 8 + + |# The strategy here is to build on the services provided by the C + |# setjmp/longjmp. Note that we cannot do this by writing a C function + |# which calls setjmp, because the procedure which calls setjmp cannot + |# return before the longjmp is executed. + +_zsvjmp_: |# CALL ZSVJMP (JMPBUF, STATUS) + movl sp@(JMPBUF),a0 |# set A0 to point to jmp_buf + movl sp@(STATUS),a1 |# A1 = status variable + movl a1,a0@ |# JB[0] = addr of status variable + clrl a1@ |# return zero status + addql #4,sp@(JMPBUF) |# skip first cell of jmp_buf + jmp _setjmp |# let setjmp do the rest. diff --git a/unix/portkit/zsvjmp.s.FX b/unix/portkit/zsvjmp.s.FX new file mode 100644 index 00000000..1f15102e --- /dev/null +++ b/unix/portkit/zsvjmp.s.FX @@ -0,0 +1,49 @@ +|# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +|# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +|# the registers, effecting a call in the context of the procedure which +|# originally called ZSVJMP, but with the new status code. These are Fortran +|# callable procedures. +|# +|# (Alliant/UNIX MC68xxx version) + + .text + .globl _zsvjmp_ + .globl _zdojmp_ + + |# The following has nothing to do with ZSVJMP, and is included here + |# only because this assembler module is loaded with every process. + |# This code sets the value of the symbol MEM (the Mem common) to zero, + |# setting the origin for IRAF pointers to zero rather than some + |# arbitrary value, and ensuring that the MEM common is aligned for + |# all datatypes as well as page aligned. A further advantage is that + |# references to NULL pointers will cause a memory violation. + + .globl _mem_ + _mem_ = 0 + +_zsvjmp_: |# call zsvjmp (jmpbuf, status) + movl a0@(4), sp@- |# save pointer to status variable + movl a0@, sp@- |# save pointer to jmpbuf + + movl a0@, sp@- |# call alliant setcontext proc + movl sp, a0 + pea 1 + jsr _setcontext + addql #8, sp + + movl sp@+, a0 |# A0 = &jmpbuf + movl sp@+, a1 |# A1 = &status + + movl a1, a0@(2240) |# save &status in jmpbuf + clrl a1@ |# set status to zero + lea sp@(4), a1 + movl a1, a0@(68) + movl sp@, a0@(74) + rts + +_zdojmp_: + movl a0@, a1 |# A1 = &jmpbuf + movl a1@(2240), a2 |# A2 = &status + movl a0@(4), a3 |# pointer to status value + movl a3@, a2@ |# set status value + jsr _resetcontext diff --git a/unix/portkit/zsvjmp.s.HP800 b/unix/portkit/zsvjmp.s.HP800 new file mode 100644 index 00000000..ce98ff19 --- /dev/null +++ b/unix/portkit/zsvjmp.s.HP800 @@ -0,0 +1,48 @@ +; ZSVJMP.S -- Routine written by Jim Dillon of HP Software Evaluation and +; Migration Center, Cupertino, CA, 2/3/88. +; +mem + .BLOCK 0 + .ALIGN 8 + .IMPORT mem,DATA + .EXPORT mem +; + .code +; +; This routine calls setjmp without the allocation of a +; stack frame for the calling routine, ie zsvjmp. This allows +; the zsvjmp routine to be part of the iraf kernel and +; be functionally equivalent to versions of zsvjmp under other +; host systems. +; +; +; savejump(jmpbuf, status) +; jmp_buf jmpbuf; +; int status; +; saves the caller's jump-buf, not yours; +; we may be called from Fortran. + + .proc + .import setjmp + .export zsvjmp + .callinfo +zsvjmp +; +; save address to status word in jmp_buf[0] +; + stw arg1,0(0,arg0) + ldi 0,1 + stws 1,0(0,arg1) +; +; call setjmp with jmp_buf[1]..jmp_buf[51] +; + addi 4,arg0,arg0 + b setjmp + nop +; +; setjmp will return directly to the caller of zsvjmp at this +; point, so the next statement will never be reached. +; + nop + .procend +; diff --git a/unix/portkit/zsvjmp.s.ISI b/unix/portkit/zsvjmp.s.ISI new file mode 100644 index 00000000..0e7de609 --- /dev/null +++ b/unix/portkit/zsvjmp.s.ISI @@ -0,0 +1,52 @@ +/* + * ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor + * registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores + * the registers, effecting a call in the context of the procedure which + * originally called ZSVJMP, but with the new status code. These are Fortran + * callable procedures. + * + * (ISI/UNIX version for the MC68000) + */ + + .text + .globl _zsvjmp_ + .globl _zdojmp_ + + /* The following has nothing to do with ZSVJMP, and is included here + * only because this assembler module is loaded with every process. + * This code sets the value of the symbol MEM (the Mem common) to zero, + * setting the origin for IRAF pointers to zero rather than some + * arbitrary value, and ensuring that the MEM common is aligned for + * all datatypes as well as page aligned. A further advantage is that + * references to NULL pointers will cause a memory violation. + */ + + .globl _mem_ + .set _mem_, 0 + + .set JMPBUF, 4 + .set STATUS, 8 + .set REGMASK, 0xfcfc /* D2-D7,A2-A5,A6,A7=sp */ + +_zsvjmp_: + movl sp@(JMPBUF),a0 /* set A0 to point to jmpbuf */ + movl sp@(STATUS),a1 /* A1 = status variable */ + movl a1,a0@ /* JB[1] = addr of status variable */ + clrl a1@ /* status = 0 */ + movl sp@+,a1 /* A1 = return address */ + movl a1,a0@(4) /* JB[3] = return address for longjmp */ + moveml #REGMASK,a0@(8) /* save register */ + jmp a1@ /* return from subroutine */ + +_zdojmp_: + movl sp@(STATUS),a0 + movl a0@,d0 /* D0 = status value */ + bne L1 /* branch if not equal to zero */ + moveq #1,d0 /* status must be nonzero */ +L1: + movl sp@(JMPBUF),a0 /* set A0 to point to jmpbuf */ + movl a0@,a1 /* get addr of zsvjmp status variable */ + movl d0,a1@ /* set the status value */ + moveml a0@(8),#REGMASK /* restore registers */ + movl a0@(4),a1 /* get return address of zsvjmp */ + jmp a1@ /* return from zsvjmp */ diff --git a/unix/portkit/zsvjmp.s.SPARC b/unix/portkit/zsvjmp.s.SPARC new file mode 100644 index 00000000..7f6bb7eb --- /dev/null +++ b/unix/portkit/zsvjmp.s.SPARC @@ -0,0 +1,59 @@ +!# ZSVJMP, ZDOJMP -- Set up a jump (non-local goto) by saving the processor +!# registers in the buffer jmpbuf. A subsequent call to ZDOJMP restores +!# the registers, effecting a call in the context of the procedure which +!# originally called ZSVJMP, but with the new status code. These are Fortran +!# callable procedures. +!# +!# (SUN/UNIX sparc version) + + .seg "text" + .global _zsvjmp_ + .global _zdojmp_ + + !# The following has nothing to do with ZSVJMP, and is included here + !# only because this assembler module is loaded with every process. + !# This code sets the value of the symbol MEM (the Mem common) to zero, + !# setting the origin for IRAF pointers to zero rather than some + !# arbitrary value, and ensuring that the MEM common is aligned for + !# all datatypes as well as page aligned. A further advantage is that + !# references to NULL pointers will cause a memory violation. + + .global _mem_ + _mem_ = 0 + + !# The following requires a jmpbuf of length at least 6 ints. + .proc 0 +_zsvjmp_: + save %sp, -0x60, %sp + call _sigblock + clr %o0 + st %o0, [%i0 + 0x8] + st %i1, [%i0 + 0x14] + clr %o0 + st %o0, [%i1] + st %i7, [%i0] + st %fp, [%i0 + 0x4] + add %i0, 0xc, %o1 + call _sigstack + clr %o0 + ret + restore %g0, 0x0, %o0 + + .proc 0 +_zdojmp_: + save %sp, -0x40, %sp + ta 0x3 + ld [%i0 + 0x4], %fp + sub %fp, 0x60, %sp + call _sigsetmask + ld [%i0 + 0x8], %o0 + add %i0, 0xc, %o0 + call _sigstack + clr %o1 + ld [%i0 + 0x14], %o0 + ld [%i1], %i1 + st %i1, [%o0] + ld [%i0], %i7 + ret + restore %i1, 0x0, %o0 + .seg "data" diff --git a/unix/reboot b/unix/reboot new file mode 100755 index 00000000..bdc99b41 --- /dev/null +++ b/unix/reboot @@ -0,0 +1,26 @@ +#!/bin/sh +# REBOOT -- Bootstrap IRAF. The HSI system may be booted either of two ways, +# VOS or NOVOS. Booting VOS gives the HSI utility programs the ability to +# deal with VOS filename mapping, but requires the VOS system libraries libsys +# and libos. A NOVOS HSI is standalone. The procedure to build IRAF from +# only the sources is to boot NOVOS, compile the VOS system libraries with +# mkpkg, and then rebuild the HSI VOS. +# +# External dependencies: "iraf" should be defined in the user's environment +# before running this script. This is normally done by sourcing the iraf/local +# .login file (which is automatic if the reboot is performed using the iraf +# account). + +source hlib/irafuser.sh + +/bin/echo "iraf = $iraf" +/bin/echo "mach = $MACH" +/bin/echo "HSI_CF = $HSI_CF" +/bin/echo "HSI_LIBS = $HSI_LIBS" + +if [ "`echo $HSI_CF | grep NOVOS`" != "" ]; then + echo "HSI is being built NOVOS, should be rebuilt once VOS is compiled" +fi + +/bin/echo "---------------------- REBOOT -----------------------" +sh -x mkpkg.sh diff --git a/unix/rmbin.sh b/unix/rmbin.sh new file mode 100644 index 00000000..f1aad040 --- /dev/null +++ b/unix/rmbin.sh @@ -0,0 +1,7 @@ +# RMBIN -- Shell script to strip the binaries from the HSI. This is normally +# done with the HSI bootstrap program 'rmbin', but this script can be used +# instead if the rmbin executable is not available for some reason. +# +# USAGE: 'sh -x rmbin.sh'. + +/bin/rm -f `find . \! -type d -print | grep '\.[aoe]$'` diff --git a/unix/setarch.sh b/unix/setarch.sh new file mode 100644 index 00000000..7d81459b --- /dev/null +++ b/unix/setarch.sh @@ -0,0 +1,9 @@ +# Set the HSI architecture. + +# Set the link 'as'. +if [ "`ls -d as`" = "as" ]; then rm -rf as; fi + ln -s as.$MACH as + +# Ditto for 'bin'. +if [ "`ls -d bin`" = "bin" ]; then rm -rf bin; fi + ln -s bin.$MACH bin diff --git a/unix/shlib/README b/unix/shlib/README new file mode 100644 index 00000000..9d465314 --- /dev/null +++ b/unix/shlib/README @@ -0,0 +1,2 @@ +SHLIB -- Code for building and maintaining the Sun/IRAF shared library. +This directory contains the ==> Solaris/IRAF <== version of SHLIB. diff --git a/unix/shlib/S.nm.added b/unix/shlib/S.nm.added new file mode 100644 index 00000000..e69de29b diff --git a/unix/shlib/S.nm.deleted b/unix/shlib/S.nm.deleted new file mode 100644 index 00000000..e69de29b diff --git a/unix/shlib/S.nm.f68881 b/unix/shlib/S.nm.f68881 new file mode 100644 index 00000000..4aac0990 --- /dev/null +++ b/unix/shlib/S.nm.f68881 @@ -0,0 +1,2605 @@ +_aabsd_ +_aabsi_ +_aabsl_ +_aabsr_ +_aabss_ +_aabsx_ +_aaddd_ +_aaddi_ +_aaddkd_ +_aaddki_ +_aaddkl_ +_aaddkr_ +_aaddks_ +_aaddkx_ +_aaddl_ +_aaddr_ +_aadds_ +_aaddx_ +_aandi_ +_aandki_ +_aandkl_ +_aandks_ +_aandl_ +_aands_ +_aavgd_ +_aavgi_ +_aavgl_ +_aavgr_ +_aavgs_ +_aavgx_ +_abavd_ +_abavi_ +_abavl_ +_abavr_ +_abavs_ +_abavx_ +_abeqc_ +_abeqd_ +_abeqi_ +_abeqkc_ +_abeqkd_ +_abeqki_ +_abeqkl_ +_abeqkr_ +_abeqks_ +_abeqkx_ +_abeql_ +_abeqr_ +_abeqs_ +_abeqx_ +_abgec_ +_abged_ +_abgei_ +_abgekc_ +_abgekd_ +_abgeki_ +_abgekl_ +_abgekr_ +_abgeks_ +_abgekx_ +_abgel_ +_abger_ +_abges_ +_abgex_ +_abgtc_ +_abgtd_ +_abgti_ +_abgtkc_ +_abgtkd_ +_abgtki_ +_abgtkl_ +_abgtkr_ +_abgtks_ +_abgtkx_ +_abgtl_ +_abgtr_ +_abgts_ +_abgtx_ +_ablec_ +_abled_ +_ablei_ +_ablekc_ +_ablekd_ +_ableki_ +_ablekl_ +_ablekr_ +_ableks_ +_ablekx_ +_ablel_ +_abler_ +_ables_ +_ablex_ +_abltc_ +_abltd_ +_ablti_ +_abltkc_ +_abltkd_ +_abltki_ +_abltkl_ +_abltkr_ +_abltks_ +_abltkx_ +_abltl_ +_abltr_ +_ablts_ +_abltx_ +_abnec_ +_abned_ +_abnei_ +_abnekc_ +_abnekd_ +_abneki_ +_abnekl_ +_abnekr_ +_abneks_ +_abnekx_ +_abnel_ +_abner_ +_abnes_ +_abnex_ +_abori_ +_aborki_ +_aborkl_ +_aborks_ +_aborl_ +_abors_ +_absud_ +_absui_ +_absul_ +_absur_ +_absus_ +_acht_ +_achtb_ +_achtbb_ +_achtbc_ +_achtbd_ +_achtbi_ +_achtbl_ +_achtbr_ +_achtbs_ +_achtbu_ +_achtbx_ +_achtc_ +_achtcb_ +_achtcc_ +_achtcd_ +_achtci_ +_achtcl_ +_achtcr_ +_achtcs_ +_achtcu_ +_achtcx_ +_achtd_ +_achtdb_ +_achtdc_ +_achtdd_ +_achtdi_ +_achtdl_ +_achtdr_ +_achtds_ +_achtdu_ +_achtdx_ +_achti_ +_achtib_ +_achtic_ +_achtid_ +_achtii_ +_achtil_ +_achtir_ +_achtis_ +_achtiu_ +_achtix_ +_achtl_ +_achtlb_ +_achtlc_ +_achtld_ +_achtli_ +_achtll_ +_achtlr_ +_achtls_ +_achtlu_ +_achtlx_ +_achtr_ +_achtrb_ +_achtrc_ +_achtrd_ +_achtri_ +_achtrl_ +_achtrr_ +_achtrs_ +_achtru_ +_achtrx_ +_achts_ +_achtsb_ +_achtsc_ +_achtsd_ +_achtsi_ +_achtsl_ +_achtsr_ +_achtss_ +_achtsu_ +_achtsx_ +_achtu_ +_achtub_ +_achtuc_ +_achtud_ +_achtui_ +_achtul_ +_achtur_ +_achtus_ +_achtuu_ +_achtux_ +_achtx_ +_achtxb_ +_achtxc_ +_achtxd_ +_achtxi_ +_achtxl_ +_achtxr_ +_achtxs_ +_achtxu_ +_achtxx_ +_acjgx_ +_aclrb_ +_aclrc_ +_aclrd_ +_aclri_ +_aclrl_ +_aclrr_ +_aclrs_ +_aclrx_ +_acnvd_ +_acnvi_ +_acnvl_ +_acnvr_ +_acnvrd_ +_acnvri_ +_acnvrl_ +_acnvrr_ +_acnvrs_ +_acnvs_ +_adivd_ +_adivi_ +_adivkd_ +_adivki_ +_adivkl_ +_adivkr_ +_adivks_ +_adivkx_ +_adivl_ +_adivr_ +_adivs_ +_adivx_ +_adotd_ +_adoti_ +_adotl_ +_adotr_ +_adots_ +_adotx_ +_advzd_ +_advzi_ +_advzl_ +_advzr_ +_advzs_ +_advzx_ +_aelogd_ +_aelogr_ +_aexpd_ +_aexpi_ +_aexpkd_ +_aexpki_ +_aexpkl_ +_aexpkr_ +_aexpks_ +_aexpkx_ +_aexpl_ +_aexpr_ +_aexps_ +_aexpx_ +_afftrr_ +_afftrx_ +_afftxr_ +_afftxx_ +_agltc_ +_agltd_ +_aglti_ +_agltl_ +_agltr_ +_aglts_ +_agltx_ +_ahgmc_ +_ahgmd_ +_ahgmi_ +_ahgml_ +_ahgmr_ +_ahgms_ +_ahivc_ +_ahivd_ +_ahivi_ +_ahivl_ +_ahivr_ +_ahivs_ +_ahivx_ +_aiftrr_ +_aiftrx_ +_aiftxr_ +_aiftxx_ +_aimgd_ +_aimgi_ +_aimgl_ +_aimgr_ +_aimgs_ +_alimc_ +_alimd_ +_alimi_ +_aliml_ +_alimr_ +_alims_ +_alimx_ +_allnd_ +_allni_ +_allnl_ +_allnr_ +_allns_ +_allnx_ +_alogd_ +_alogi_ +_alogl_ +_alogr_ +_alogs_ +_alogx_ +_alovc_ +_alovd_ +_alovi_ +_alovl_ +_alovr_ +_alovs_ +_alovx_ +_altad_ +_altai_ +_altal_ +_altar_ +_altas_ +_altax_ +_altmd_ +_altmi_ +_altml_ +_altmr_ +_altms_ +_altmx_ +_altrd_ +_altri_ +_altrl_ +_altrr_ +_altrs_ +_altrx_ +_aluid_ +_aluii_ +_aluil_ +_aluir_ +_aluis_ +_alutc_ +_alutd_ +_aluti_ +_alutl_ +_alutr_ +_aluts_ +_amagd_ +_amagi_ +_amagl_ +_amagr_ +_amags_ +_amagx_ +_amapd_ +_amapi_ +_amapl_ +_amapr_ +_amaps_ +_amaxc_ +_amaxd_ +_amaxi_ +_amaxkc_ +_amaxkd_ +_amaxki_ +_amaxkl_ +_amaxkr_ +_amaxks_ +_amaxkx_ +_amaxl_ +_amaxr_ +_amaxs_ +_amaxx_ +_amed3c_ +_amed3d_ +_amed3i_ +_amed3l_ +_amed3r_ +_amed3s_ +_amed4c_ +_amed4d_ +_amed4i_ +_amed4l_ +_amed4r_ +_amed4s_ +_amed5c_ +_amed5d_ +_amed5i_ +_amed5l_ +_amed5r_ +_amed5s_ +_amedc_ +_amedd_ +_amedi_ +_amedl_ +_amedr_ +_ameds_ +_amedx_ +_amgsd_ +_amgsi_ +_amgsl_ +_amgsr_ +_amgss_ +_amgsx_ +_aminc_ +_amind_ +_amini_ +_aminkc_ +_aminkd_ +_aminki_ +_aminkl_ +_aminkr_ +_aminks_ +_aminkx_ +_aminl_ +_aminr_ +_amins_ +_aminx_ +_amodd_ +_amodi_ +_amodkd_ +_amodki_ +_amodkl_ +_amodkr_ +_amodks_ +_amodl_ +_amodr_ +_amods_ +_amovc_ +_amovd_ +_amovi_ +_amovkc_ +_amovkd_ +_amovki_ +_amovkl_ +_amovkr_ +_amovks_ +_amovkx_ +_amovl_ +_amovr_ +_amovs_ +_amovx_ +_amuld_ +_amuli_ +_amulkd_ +_amulki_ +_amulkl_ +_amulkr_ +_amulks_ +_amulkx_ +_amull_ +_amulr_ +_amuls_ +_amulx_ +_andi_ +_andl_ +_ands_ +_anegd_ +_anegi_ +_anegl_ +_anegr_ +_anegs_ +_anegx_ +_anoti_ +_anotl_ +_anots_ +_apkxd_ +_apkxi_ +_apkxl_ +_apkxr_ +_apkxs_ +_apkxx_ +_apold_ +_apolr_ +_apowd_ +_apowi_ +_apowkd_ +_apowki_ +_apowkl_ +_apowkr_ +_apowks_ +_apowkx_ +_apowl_ +_apowr_ +_apows_ +_apowx_ +_aravd_ +_aravi_ +_aravl_ +_aravr_ +_aravs_ +_aravx_ +_arcpd_ +_arcpi_ +_arcpl_ +_arcpr_ +_arcps_ +_arcpx_ +_arczd_ +_arczi_ +_arczl_ +_arczr_ +_arczs_ +_arczx_ +_aread_ +_areadb_ +_argtd_ +_argti_ +_argtl_ +_argtr_ +_argts_ +_argtx_ +_arltd_ +_arlti_ +_arltl_ +_arltr_ +_arlts_ +_arltx_ +_aselc_ +_aseld_ +_aseli_ +_asell_ +_aselr_ +_asels_ +_aselx_ +_asokc_ +_asokd_ +_asoki_ +_asokl_ +_asokr_ +_asoks_ +_asokx_ +_asqrd_ +_asqri_ +_asqrl_ +_asqrr_ +_asqrs_ +_asqrx_ +_asrtc_ +_asrtd_ +_asrti_ +_asrtl_ +_asrtr_ +_asrts_ +_asrtx_ +_assqd_ +_assqi_ +_assql_ +_assqr_ +_assqs_ +_assqx_ +_asubd_ +_asubi_ +_asubkd_ +_asubki_ +_asubkl_ +_asubkr_ +_asubks_ +_asubkx_ +_asubl_ +_asubr_ +_asubs_ +_asubx_ +_asumd_ +_asumi_ +_asuml_ +_asumr_ +_asums_ +_asumx_ +_aupxd_ +_aupxi_ +_aupxl_ +_aupxr_ +_aupxs_ +_aupxx_ +_aveqc_ +_aveqd_ +_aveqi_ +_aveql_ +_aveqr_ +_aveqs_ +_aveqx_ +_await_ +_awaitb_ +_awritb_ +_awrite_ +_awsud_ +_awsui_ +_awsul_ +_awsur_ +_awsus_ +_awsux_ +_awvgd_ +_awvgi_ +_awvgl_ +_awvgr_ +_awvgs_ +_awvgx_ +_axori_ +_axorki_ +_axorkl_ +_axorks_ +_axorl_ +_axors_ +_begmem_ +_bitmov_ +_bitpak_ +_bitupk_ +_brktie_ +_bswap2_ +_bswap4_ +_bswap8_ +_btoi_ +_bytmov_ +_cctoc_ +_chdept_ +_chfeth_ +_chrlwr_ +_chrpak_ +_chrupk_ +_chrupr_ +_clccos_ +_clcenr_ +_clcfeh_ +_clcfid_ +_clcfre_ +_clcint_ +_clclit_ +_clcmak_ +_clcmd_ +_clcmdw_ +_clcnek_ +_clcpst_ +_clcscn_ +_clepst_ +_clgcur_ +_clgetb_ +_clgetc_ +_clgetd_ +_clgeti_ +_clgetl_ +_clgetr_ +_clgets_ +_clgetx_ +_clgfil_ +_clgkey_ +_clglpb_ +_clglpc_ +_clglpd_ +_clglpi_ +_clglpl_ +_clglpr_ +_clglps_ +_clglpx_ +_clglsr_ +_clgpsa_ +_clgpsb_ +_clgpsc_ +_clgpsd_ +_clgpsi_ +_clgpsl_ +_clgpsr_ +_clgpss_ +_clgpst_ +_clgpsx_ +_clgstr_ +_clgwrd_ +_clktie_ +_cllpst_ +_clopen_ +_clopst_ +_clpcls_ +_clplen_ +_clpopi_ +_clpops_ +_clpopu_ +_clppsa_ +_clppsb_ +_clppsc_ +_clppsd_ +_clppsi_ +_clppsl_ +_clppsr_ +_clppss_ +_clppst_ +_clppsx_ +_clprew_ +_clprif_ +_clpsee_ +_clpsit_ +_clpstr_ +_clputb_ +_clputc_ +_clputd_ +_clputi_ +_clputl_ +_clputr_ +_clputs_ +_clputx_ +_clreqr_ +_clscan_ +_clseti_ +_clstai_ +_cnvdae_ +_cnvtie_ +_coerce_ +_cputie_ +_ctocc_ +_ctod_ +_ctoi_ +_ctol_ +_ctor_ +_ctotok_ +_ctowrd_ +_ctox_ +_d1mach_ +_deletg_ +_diropn_ +_dtcscl_ +_dtoc3_ +_dtoc_ +_elogd_ +_elogr_ +_envfid_ +_envfit_ +_envfre_ +_envgeb_ +_envged_ +_envgei_ +_envger_ +_envges_ +_envinr_ +_envint_ +_envlit_ +_envmak_ +_envnet_ +_envpus_ +_envret_ +_envscn_ +_eprinf_ +_erract_ +_errcoe_ +_errget_ +_evexpr_ +_f77pak_ +_f77upk_ +_falloc_ +_fcanpb_ +_fcldir_ +_fclobr_ +_fcopy_ +_fcopyo_ +_fdebug_ +_fdevbf_ +_fdevbk_ +_fdevtx_ +_fdirne_ +_fexbuf_ +_ffa_ +_ffault_ +_ffilbf_ +_ffilsz_ +_ffldir_ +_fflsbf_ +_ffs_ +_fft842_ +_fgdev0_ +_fgdevm_ +_fgetfd_ +_fgtdir_ +_filbuf_ +_filerr_ +_filopn_ +_finfo_ +_finit_ +_fioclp_ +_fioqfh_ +_fixmem_ +_flsbuf_ +_fmaccs_ +_fmapfn_ +_fmcloe_ +_fmcopo_ +_fmcopy_ +_fmdebg_ +_fmdele_ +_fmfcdg_ +_fmfcfe_ +_fmfcit_ +_fmfcsc_ +_fmfinf_ +_fmfopn_ +_fmgetd_ +_fmiobd_ +_fmioed_ +_fmioek_ +_fmiopr_ +_fmiorr_ +_fmiosf_ +_fmiotk_ +_fmkbfs_ +_fmkcoy_ +_fmkdir_ +_fmkpbf_ +_fmlfad_ +_fmlfae_ +_fmlfat_ +_fmlfbd_ +_fmlfbe_ +_fmlfbt_ +_fmlfce_ +_fmlfcy_ +_fmlfde_ +_fmlfne_ +_fmlfon_ +_fmlfpe_ +_fmlfsi_ +_fmlfst_ +_fmlfue_ +_fmlocd_ +_fmloct_ +_fmnexe_ +_fmopen_ +_fmrebd_ +_fmrene_ +_fmretd_ +_fmseti_ +_fmstai_ +_fmsync_ +_fmterr_ +_fmtint_ +_fmtred_ +_fmtsel_ +_fmtstr_ +_fmunlk_ +_fnextn_ +_fnldir_ +_fnroot_ +_fntclb_ +_fntcls_ +_fntdir_ +_fntedt_ +_fntget_ +_fntgfb_ +_fntgfn_ +_fntleb_ +_fntmkt_ +_fntopb_ +_fntopn_ +_fntopt_ +_fntreb_ +_fntree_ +_fntrfb_ +_fnulle_ +_fopdir_ +_fopnbf_ +_fopntx_ +_fowner_ +_fpathe_ +_fpequd_ +_fpequr_ +_fpfixd_ +_fpfixr_ +_fpnonr_ +_fpnord_ +_fpnorr_ +_fpradv_ +_fprfmt_ +_fprinf_ +_fprntf_ +_fptdir_ +_fputtx_ +_freadp_ +_fredio_ +_fredir_ +_frenae_ +_frmbfs_ +_frmtmp_ +_frtnfd_ +_fsetev_ +_fsetfd_ +_fseti_ +_fsfdee_ +_fsfgee_ +_fsfopn_ +_fskdir_ +_fstati_ +_fstatl_ +_fstats_ +_fstdfe_ +_fstdir_ +_fstrfp_ +_fsvtfn_ +_fswapd_ +_fwatio_ +_fwritp_ +_fwtacc_ +_gactie_ +_gadraw_ +_gamove_ +_gargb_ +_gargc_ +_gargd_ +_gargi_ +_gargl_ +_gargr_ +_gargrd_ +_gargs_ +_gargsr_ +_gargtk_ +_gargwd_ +_gargx_ +_gascae_ +_gcancl_ +_gclear_ +_gclose_ +_gctod_ +_gctol_ +_gctox_ +_gctran_ +_gcurps_ +_gdeace_ +_gescae_ +_getci_ +_gethot_ +_getlie_ +_getlle_ +_getloe_ +_gexflr_ +_gexfls_ +_gexflt_ +_gfill_ +_gflush_ +_gframe_ +_gfrint_ +_ggcell_ +_ggcur_ +_ggetb_ +_ggeti_ +_ggetr_ +_ggets_ +_ggscae_ +_ggview_ +_ggwind_ +_gkical_ +_gkiclr_ +_gkicls_ +_gkides_ +_gkieof_ +_gkiese_ +_gkiexe_ +_gkifat_ +_gkifen_ +_gkiffh_ +_gkifia_ +_gkiflh_ +_gkiger_ +_gkiges_ +_gkigey_ +_gkiinl_ +_gkiint_ +_gkimfe_ +_gkiops_ +_gkiplt_ +_gkipmt_ +_gkipoe_ +_gkipor_ +_gkipuy_ +_gkiree_ +_gkirer_ +_gkires_ +_gkirey_ +_gkiser_ +_gkises_ +_gkisul_ +_gkitet_ +_gkitxt_ +_gkiwre_ +_gkpcal_ +_gkpcle_ +_gkpclr_ +_gkpcls_ +_gkpdes_ +_gkpdup_ +_gkpese_ +_gkpfat_ +_gkpfia_ +_gkpflh_ +_gkpger_ +_gkpges_ +_gkpgey_ +_gkpgrm_ +_gkpinl_ +_gkpmfe_ +_gkpops_ +_gkpplt_ +_gkppmt_ +_gkppoe_ +_gkppor_ +_gkppst_ +_gkppuy_ +_gkpres_ +_gkpser_ +_gkpses_ +_gkptet_ +_gkptxg_ +_gkptxt_ +_gkpunn_ +_glabax_ +_glbdrd_ +_glbene_ +_glbeq_ +_glbfis_ +_glbgek_ +_glblas_ +_glblob_ +_glbple_ +_glbsep_ +_glbses_ +_glbset_ +_glbtin_ +_glbveg_ +_gline_ +_gltoc_ +_gmark_ +_gmftie_ +_gopen_ +_gpagee_ +_gpatme_ +_gpatmh_ +_gpcell_ +_gplcae_ +_gplcal_ +_gplclb_ +_gplcll_ +_gplclr_ +_gplclt_ +_gplflh_ +_gpline_ +_gploto_ +_gplotv_ +_gplret_ +_gplsee_ +_gplwci_ +_gpmark_ +_gqsort_ +_gqvery_ +_grdraw_ +_grdwcs_ +_greace_ +_greset_ +_grmove_ +_grscae_ +_gscan_ +_gscur_ +_gseti_ +_gsetr_ +_gsets_ +_gstati_ +_gstatr_ +_gstats_ +_gstrct_ +_gstrcy_ +_gstrmh_ +_gstsei_ +_gstser_ +_gsview_ +_gswind_ +_gtdise_ +_gtext_ +_gtickr_ +_gtliny_ +_gtndis_ +_gttyld_ +_gtxset_ +_gtybih_ +_gtycas_ +_gtycle_ +_gtyeny_ +_gtyexs_ +_gtyfey_ +_gtyfiy_ +_gtygeb_ +_gtygei_ +_gtyger_ +_gtyges_ +_gtyins_ +_gtyopn_ +_gtysce_ +_gumark_ +_gvline_ +_gvmark_ +_gwcsme_ +_gwrwcs_ +_i1mach_ +_idbcle_ +_idbfid_ +_idbgeg_ +_idbkwp_ +_idbned_ +_idbopn_ +_idbpug_ +_ieegnd_ +_ieegnr_ +_ieepad_ +_ieepar_ +_ieesnd_ +_ieesnr_ +_ieeupd_ +_ieeupr_ +_ieevpd_ +_ieevpr_ +_ieevud_ +_ieevur_ +_ikiacs_ +_ikicle_ +_ikicoy_ +_ikidee_ +_ikiint_ +_ikildr_ +_ikimke_ +_ikiopn_ +_ikiopx_ +_ikipae_ +_ikiree_ +_ikiupr_ +_imaccf_ +_imaccs_ +_imaddb_ +_imaddd_ +_imaddf_ +_imaddi_ +_imaddl_ +_imaddr_ +_imadds_ +_imaflp_ +_imalin_ +_imaplv_ +_imastr_ +_imbln1_ +_imbln2_ +_imbln3_ +_imbtrn_ +_imcfnl_ +_imcopy_ +_imcssz_ +_imctrt_ +_imdect_ +_imdele_ +_imdelf_ +_imdmap_ +_imerr_ +_imflpl_ +_imflps_ +_imflsd_ +_imflsh_ +_imflsi_ +_imflsl_ +_imflsr_ +_imflss_ +_imflsx_ +_imfluh_ +_imfnpy_ +_imfnss_ +_imgclr_ +_imgetb_ +_imgetc_ +_imgetd_ +_imgeti_ +_imgetl_ +_imgetr_ +_imgets_ +_imgfte_ +_imggsc_ +_imggsd_ +_imggsi_ +_imggsl_ +_imggsr_ +_imggss_ +_imggsx_ +_imgibf_ +_imgime_ +_imgl1d_ +_imgl1i_ +_imgl1l_ +_imgl1r_ +_imgl1s_ +_imgl1x_ +_imgl2d_ +_imgl2i_ +_imgl2l_ +_imgl2r_ +_imgl2s_ +_imgl2x_ +_imgl3d_ +_imgl3i_ +_imgl3l_ +_imgl3r_ +_imgl3s_ +_imgl3x_ +_imgnfn_ +_imgnld_ +_imgnli_ +_imgnll_ +_imgnln_ +_imgnlr_ +_imgnls_ +_imgnlx_ +_imgobf_ +_imgs1d_ +_imgs1i_ +_imgs1l_ +_imgs1r_ +_imgs1s_ +_imgs1x_ +_imgs2d_ +_imgs2i_ +_imgs2l_ +_imgs2r_ +_imgs2s_ +_imgs2x_ +_imgs3d_ +_imgs3i_ +_imgs3l_ +_imgs3r_ +_imgs3s_ +_imgs3x_ +_imgsen_ +_imgstr_ +_iminie_ +_imioff_ +_imisec_ +_imloop_ +_immaky_ +_immap_ +_immapz_ +_imnote_ +_imofnl_ +_imofns_ +_imofnu_ +_imopsf_ +_impakd_ +_impaki_ +_impakl_ +_impakr_ +_impaks_ +_impakx_ +_impare_ +_impgsd_ +_impgsi_ +_impgsl_ +_impgsr_ +_impgss_ +_impgsx_ +_impl1d_ +_impl1i_ +_impl1l_ +_impl1r_ +_impl1s_ +_impl1x_ +_impl2d_ +_impl2i_ +_impl2l_ +_impl2r_ +_impl2s_ +_impl2x_ +_impl3d_ +_impl3i_ +_impl3l_ +_impl3r_ +_impl3s_ +_impl3x_ +_impml1_ +_impml2_ +_impml3_ +_impmlr_ +_impmlv_ +_impmmo_ +_impmmp_ +_impmon_ +_impms1_ +_impms2_ +_impms3_ +_impmsr_ +_impmsv_ +_impnld_ +_impnli_ +_impnll_ +_impnln_ +_impnlr_ +_impnls_ +_impnlx_ +_imps1d_ +_imps1i_ +_imps1l_ +_imps1r_ +_imps1s_ +_imps1x_ +_imps2d_ +_imps2i_ +_imps2l_ +_imps2r_ +_imps2s_ +_imps2x_ +_imps3d_ +_imps3i_ +_imps3l_ +_imps3r_ +_imps3s_ +_imps3x_ +_impstr_ +_imputb_ +_imputd_ +_imputh_ +_imputi_ +_imputl_ +_imputr_ +_imputs_ +_imrbpx_ +_imrdpx_ +_imrene_ +_imrmbs_ +_imsamp_ +_imsetf_ +_imseti_ +_imsetr_ +_imsinb_ +_imsmpl_ +_imsmps_ +_imsslv_ +_imstai_ +_imstas_ +_imtcle_ +_imtgem_ +_imtlen_ +_imtmae_ +_imtopn_ +_imtopp_ +_imtrew_ +_imtrgm_ +_imunmp_ +_imupkd_ +_imupki_ +_imupkl_ +_imupkr_ +_imupks_ +_imupkx_ +_imwbpx_ +_imwrie_ +_imwrpx_ +_intrde_ +_intree_ +_intrrt_ +_irafmn_ +_itob_ +_itoc_ +_iwcare_ +_iwcfis_ +_iwents_ +_iwfind_ +_iwgbis_ +_iwputr_ +_iwputy_ +_iwrfis_ +_iwsetp_ +_kardbf_ +_kardgd_ +_kardlp_ +_kardpl_ +_kardpr_ +_kardsf_ +_kawrbf_ +_kawrgd_ +_kawrlp_ +_kawrpl_ +_kawrpr_ +_kawrsf_ +_kawtbf_ +_kawtgd_ +_kawtlp_ +_kawtpl_ +_kawtpr_ +_kawtsf_ +_kbzard_ +_kbzawr_ +_kbzawt_ +_kbzcls_ +_kbzopn_ +_kbzstt_ +_kclcpr_ +_kcldir_ +_kcldpr_ +_kclsbf_ +_kclsgd_ +_kclslp_ +_kclspl_ +_kclssf_ +_kclstx_ +_kclsty_ +_kdvall_ +_kdvown_ +_kfacss_ +_kfaloc_ +_kfchdr_ +_kfdele_ +_kfgcwd_ +_kfinfo_ +_kflstx_ +_kflsty_ +_kfmkcp_ +_kfmkdr_ +_kfpath_ +_kfprot_ +_kfrnam_ +_kfsubd_ +_kfxdir_ +_kgettx_ +_kgetty_ +_kgfdir_ +_kicont_ +_kidece_ +_kience_ +_kienvt_ +_kierrr_ +_kiexte_ +_kifine_ +_kiflux_ +_kifman_ +_kifren_ +_kigetn_ +_kigets_ +_kignoe_ +_kiinit_ +_kiloce_ +_kimapn_ +_kintpr_ +_kiopes_ +_kirece_ +_kisend_ +_kisenv_ +_kishot_ +_kixnoe_ +_kmallc_ +_knottx_ +_knotty_ +_kopcpr_ +_kopdir_ +_kopdpr_ +_kopnbf_ +_kopngd_ +_kopnlp_ +_kopnpl_ +_kopnsf_ +_kopntx_ +_kopnty_ +_koscmd_ +_kputtx_ +_kputty_ +_krealc_ +_ksared_ +_ksawat_ +_ksawre_ +_ksektx_ +_ksekty_ +_ksttbf_ +_ksttgd_ +_ksttlp_ +_ksttpl_ +_ksttpr_ +_ksttsf_ +_kstttx_ +_ksttty_ +_ktzcls_ +_ktzfls_ +_ktzget_ +_ktznot_ +_ktzopn_ +_ktzput_ +_ktzsek_ +_ktzstt_ +_kzclmt_ +_kzopmt_ +_kzrdmt_ +_kzrwmt_ +_kzstmt_ +_kzwrmt_ +_kzwtmt_ +_lexnum_ +_lnocle_ +_lnofeh_ +_lnoopn_ +_lnosae_ +_locpr_ +_locva_ +_lpopen_ +_lpzard_ +_lpzawe_ +_lpzawt_ +_ltoc_ +_m75put_ +_maideh_ +_mallo1_ +_mgdptr_ +_mgtfwa_ +_miilen_ +_miinem_ +_miipa2_ +_miipa6_ +_miipa8_ +_miipad_ +_miipak_ +_miipar_ +_miipke_ +_miirec_ +_miired_ +_miirei_ +_miirel_ +_miirer_ +_miires_ +_miiup2_ +_miiup6_ +_miiup8_ +_miiupd_ +_miiupk_ +_miiupr_ +_miiwrc_ +_miiwrd_ +_miiwri_ +_miiwrl_ +_miiwrr_ +_miiwrs_ +_miocle_ +_miogld_ +_miogli_ +_miogll_ +_mioglr_ +_miogls_ +_mioglx_ +_mioopn_ +_mioopo_ +_miopld_ +_miopli_ +_miopll_ +_mioplr_ +_miopls_ +_mioplx_ +_miosee_ +_miosei_ +_miosti_ +_msvfwa_ +_mtalle_ +_mtcap_ +_mtclre_ +_mtdeae_ +_mtdevd_ +_mtfile_ +_mtgets_ +_mtglok_ +_mtloce_ +_mtopen_ +_mtpare_ +_mtposn_ +_mtpute_ +_mtreae_ +_mtrewd_ +_mtsavd_ +_mtsavs_ +_mtskid_ +_mtstas_ +_mtsync_ +_mtupde_ +_mwalld_ +_mwalls_ +_mwaxtn_ +_mwc1td_ +_mwc1tr_ +_mwc2td_ +_mwc2tr_ +_mwcloe_ +_mwcopd_ +_mwcops_ +_mwctfe_ +_mwctrd_ +_mwctrr_ +_mwfins_ +_mwflop_ +_mwgaxp_ +_mwgaxt_ +_mwgctd_ +_mwgctr_ +_mwgltd_ +_mwgltr_ +_mwgsym_ +_mwgwas_ +_mwgwsd_ +_mwgwsr_ +_mwgwtd_ +_mwgwtr_ +_mwinvd_ +_mwinvr_ +_mwload_ +_mwloam_ +_mwltrd_ +_mwltrr_ +_mwlubb_ +_mwlude_ +_mwmkid_ +_mwmmud_ +_mwmmur_ +_mwnewm_ +_mwnewy_ +_mwopem_ +_mwopen_ +_mwrefr_ +_mwrote_ +_mwsave_ +_mwsavm_ +_mwsaxp_ +_mwscae_ +_mwsctn_ +_mwsdes_ +_mwseti_ +_mwshit_ +_mwsltd_ +_mwsltr_ +_mwssym_ +_mwstai_ +_mwswas_ +_mwswsd_ +_mwswsr_ +_mwswtd_ +_mwswte_ +_mwswtr_ +_mwtrad_ +_mwtrar_ +_mwv1td_ +_mwv1tr_ +_mwv2td_ +_mwv2tr_ +_mwvmud_ +_mwvmur_ +_mwvtrd_ +_mwvtrr_ +_noti_ +_notl_ +_nots_ +_nowhie_ +_nscan_ +_oifacs_ +_oifcle_ +_oifcoy_ +_oifdee_ +_oifgpe_ +_oifmke_ +_oifopn_ +_oifopx_ +_oifree_ +_oifupr_ +_oifwpr_ +_onerrr_ +_onexit_ +_ord1_ +_ord2_ +_ori_ +_orl_ +_ors_ +_oscmd_ +_osfnik_ +_osfnlk_ +_osfnms_ +_osfnpe_ +_osfnrk_ +_osfntt_ +_osfnuk_ +_pagefe_ +_pagefs_ +_pargb_ +_pargc_ +_pargd_ +_pargg_ +_pargi_ +_pargl_ +_pargr_ +_pargs_ +_pargsr_ +_pargx_ +_patamh_ +_patfit_ +_patgel_ +_patgse_ +_patinx_ +_patloe_ +_patmae_ +_patmah_ +_patomh_ +_patsts_ +_pggetd_ +_pggete_ +_pggetr_ +_pgpage_ +_pgpeed_ +_pgpusd_ +_pgsett_ +_placcs_ +_plallc_ +_plascp_ +_plbox_ +_plcire_ +_plcler_ +_plcloe_ +_plcome_ +_plcoms_ +_plcree_ +_pldebg_ +_pldebt_ +_plempy_ +_plfacs_ +_plfcle_ +_plfcoy_ +_plfdee_ +_plfnul_ +_plfopn_ +_plfree_ +_plfupr_ +_plgete_ +_plglls_ +_plglpi_ +_plglpl_ +_plglps_ +_plglri_ +_plglrl_ +_plglrs_ +_plgsie_ +_pll2pi_ +_pll2pl_ +_pll2ps_ +_pll2ri_ +_pll2rl_ +_pll2rs_ +_pllcot_ +_pllemy_ +_plleql_ +_plline_ +_pllinl_ +_pllinp_ +_plliny_ +_pllneg_ +_plload_ +_plloaf_ +_plloam_ +_plloop_ +_pllprs_ +_plnewy_ +_plopen_ +_plp2li_ +_plp2ll_ +_plp2ls_ +_plp2ri_ +_plp2rl_ +_plp2rs_ +_plpixi_ +_plpixl_ +_plpixs_ +_plplls_ +_plplpi_ +_plplpl_ +_plplps_ +_plplri_ +_plplrl_ +_plplrs_ +_plpoit_ +_plpoln_ +_plr2li_ +_plr2ll_ +_plr2ls_ +_plr2pi_ +_plr2pl_ +_plr2ps_ +_plrani_ +_plranl_ +_plrans_ +_plrcle_ +_plregp_ +_plreqi_ +_plreql_ +_plreqs_ +_plrget_ +_plrgex_ +_plrop_ +_plropn_ +_plrpri_ +_plrprl_ +_plrprs_ +_plrset_ +_plsave_ +_plsavf_ +_plsavm_ +_plsect_ +_plsecy_ +_plsete_ +_plseti_ +_plssie_ +_plsslv_ +_plstai_ +_plstel_ +_plubox_ +_plucie_ +_plupde_ +_plupon_ +_plvald_ +_pmaccs_ +_pmascp_ +_pmbox_ +_pmcire_ +_pmcler_ +_pmempy_ +_pmglls_ +_pmglpi_ +_pmglpl_ +_pmglps_ +_pmglri_ +_pmglrl_ +_pmglrs_ +_pmline_ +_pmliny_ +_pmnewk_ +_pmplls_ +_pmplpi_ +_pmplpl_ +_pmplps_ +_pmplri_ +_pmplrl_ +_pmplrs_ +_pmpoit_ +_pmpoln_ +_pmrcle_ +_pmrgex_ +_pmrop_ +_pmropn_ +_pmrset_ +_pmsect_ +_pmsecy_ +_pmsete_ +_pmseti_ +_pmstel_ +_prchdr_ +_prclcr_ +_prcldr_ +_prcloe_ +_prdone_ +_prdumn_ +_prenve_ +_prenvt_ +_prfilf_ +_prfinc_ +_prgete_ +_prgetr_ +_prkill_ +_pronic_ +_propcr_ +_propdr_ +_propen_ +_proscd_ +_protet_ +_prpsio_ +_prpsld_ +_prredr_ +_prsigl_ +_prstai_ +_prupde_ +_prvret_ +_przclr_ +_psioit_ +_psioxr_ +_putcc_ +_putci_ +_putlie_ +_qmaccs_ +_qmgetc_ +_qmscan_ +_qmscao_ +_qmsetm_ +_qmsetr_ +_qmsets_ +_qmsymb_ +_qmupds_ +_qpaccf_ +_qpaccs_ +_qpaddb_ +_qpaddc_ +_qpaddd_ +_qpaddf_ +_qpaddi_ +_qpaddl_ +_qpaddr_ +_qpadds_ +_qpaddx_ +_qpargt_ +_qpastr_ +_qpbind_ +_qpcfnl_ +_qpcloe_ +_qpclot_ +_qpcopf_ +_qpcopy_ +_qpctod_ +_qpctoi_ +_qpdele_ +_qpdelf_ +_qpdsym_ +_qpdtye_ +_qpelee_ +_qpexad_ +_qpexai_ +_qpexar_ +_qpexcd_ +_qpexce_ +_qpexci_ +_qpexcr_ +_qpexdc_ +_qpexde_ +_qpexdg_ +_qpexdr_ +_qpexee_ +_qpexfe_ +_qpexge_ +_qpexgr_ +_qpexmk_ +_qpexmr_ +_qpexon_ +_qpexpd_ +_qpexpi_ +_qpexpn_ +_qpexpr_ +_qpexps_ +_qpexpt_ +_qpexrd_ +_qpexsd_ +_qpexsi_ +_qpexsr_ +_qpfacs_ +_qpfcle_ +_qpfcos_ +_qpfcoy_ +_qpfdee_ +_qpflur_ +_qpfopn_ +_qpfopx_ +_qpfree_ +_qpfupr_ +_qpfwfr_ +_qpfzcl_ +_qpfzop_ +_qpfzrd_ +_qpfzst_ +_qpfzwr_ +_qpfzwt_ +_qpgetb_ +_qpgetc_ +_qpgetd_ +_qpgeti_ +_qpgetk_ +_qpgetl_ +_qpgetm_ +_qpgetr_ +_qpgets_ +_qpgetx_ +_qpgmsm_ +_qpgnfn_ +_qpgpsm_ +_qpgstr_ +_qpinht_ +_qpioce_ +_qpioge_ +_qpiogr_ +_qpiogs_ +_qpiolk_ +_qpiols_ +_qpiomx_ +_qpioon_ +_qpiope_ +_qpiops_ +_qpiori_ +_qpiors_ +_qpiort_ +_qpiosc_ +_qpiose_ +_qpiosi_ +_qpiosr_ +_qpiost_ +_qpiowt_ +_qplenf_ +_qplenl_ +_qplesd_ +_qplesi_ +_qplesr_ +_qploas_ +_qpmaxd_ +_qpmaxi_ +_qpmaxr_ +_qpmind_ +_qpmini_ +_qpminr_ +_qpmkfe_ +_qpnexk_ +_qpofnl_ +_qpofns_ +_qpofnu_ +_qpopen_ +_qpopet_ +_qppare_ +_qpparl_ +_qppcle_ +_qppopn_ +_qppstr_ +_qpputb_ +_qpputc_ +_qpputd_ +_qpputi_ +_qpputl_ +_qpputm_ +_qpputr_ +_qpputs_ +_qpputx_ +_qpquef_ +_qprawk_ +_qpread_ +_qprebd_ +_qprene_ +_qprenf_ +_qprlmd_ +_qprlmi_ +_qprlmr_ +_qpsavs_ +_qpseel_ +_qpseti_ +_qpsizf_ +_qpstai_ +_qpsync_ +_qpungk_ +_qpwrie_ +_r1mach_ +_r2tr_ +_r2tx_ +_r4syn_ +_r4tr_ +_r4tx_ +_r8syn_ +_r8tr_ +_r8tx_ +_rdukey_ +_reopen_ +_resetn_ +_salloc_ +_scanc_ +_sfree_ +_shifti_ +_shiftl_ +_shifts_ +_smark_ +_sprinf_ +_sscan_ +_stallc_ +_stcloe_ +_stentr_ +_stfacs_ +_stfadr_ +_stfcle_ +_stfcos_ +_stfcoy_ +_stfcte_ +_stfdee_ +_stfgeb_ +_stfgei_ +_stfgen_ +_stfges_ +_stfget_ +_stfind_ +_stfinl_ +_stfins_ +_stfmeb_ +_stfmke_ +_stfnee_ +_stfopn_ +_stfopx_ +_stforb_ +_stfrdr_ +_stfree_ +_stfrek_ +_stfrfr_ +_stfrgb_ +_stfrne_ +_stfupr_ +_stfwfr_ +_stfwgb_ +_sthash_ +_sthead_ +_stinfo_ +_stkmkg_ +_stmark_ +_stname_ +_stnext_ +_stnsys_ +_stopen_ +_stpstr_ +_strcle_ +_strdic_ +_strefb_ +_streff_ +_streq_ +_strese_ +_strge_ +_strgt_ +_strids_ +_stridx_ +_strlds_ +_strldx_ +_strle_ +_strlt_ +_strlwr_ +_strmac_ +_strmah_ +_strncp_ +_strne_ +_stropn_ +_strpak_ +_strse1_ +_strseh_ +_strsrt_ +_strtbl_ +_strupk_ +_strupr_ +_stsave_ +_stsize_ +_stsque_ +_sttyco_ +_sttyet_ +_sttygg_ +_sttynm_ +_sttyse_ +_sttysm_ +_sttytt_ +_syserr_ +_sysers_ +_sysged_ +_sysges_ +_sysgsg_ +_sysid_ +_sysmte_ +_syspac_ +_syspat_ +_syspte_ +_sysret_ +_syssct_ +_tsleep_ +_ttopen_ +_ttseti_ +_ttsets_ +_ttstai_ +_ttstas_ +_ttybih_ +_ttybre_ +_ttycas_ +_ttycds_ +_ttycle_ +_ttycln_ +_ttyclr_ +_ttyctl_ +_ttydee_ +_ttydey_ +_ttyeny_ +_ttyexs_ +_ttyfey_ +_ttyfiy_ +_ttygds_ +_ttygeb_ +_ttygei_ +_ttyger_ +_ttyges_ +_ttygoo_ +_ttygpe_ +_ttygse_ +_ttyins_ +_ttyint_ +_ttylod_ +_ttyods_ +_ttyopn_ +_ttypue_ +_ttypus_ +_ttyred_ +_ttysce_ +_ttysei_ +_ttyso_ +_ttysti_ +_ttysui_ +_ttywre_ +_ungete_ +_ungeti_ +_unread_ +_urand_ +_vfnadd_ +_vfncle_ +_vfndee_ +_vfndel_ +_vfnene_ +_vfnenr_ +_vfnexr_ +_vfngen_ +_vfnise_ +_vfnman_ +_vfnmap_ +_vfnmau_ +_vfnopn_ +_vfnsqe_ +_vfntre_ +_vfnunn_ +_vfnunp_ +_vlibinit_ +_vmallc_ +_vvfncm_ +_vvfnee_ +_vvfnip_ +_vvfnis_ +_vvfnre_ +_wfdecs_ +_wffnld_ +_wfinit_ +_wfsmph_ +_wfsmpn_ +_wfsmpt_ +_wftand_ +_wftant_ +_wftanv_ +_xalloe_ +_xcallc_ +_xdeale_ +_xdevor_ +_xdevss_ +_xeract_ +_xerfmg_ +_xerpop_ +_xerpsh_ +_xerpsr_ +_xerpuc_ +_xerpue_ +_xerret_ +_xerror_ +_xersel_ +_xervey_ +_xevadg_ +_xevbip_ +_xevbop_ +_xevcan_ +_xever1_ +_xever2_ +_xeverr_ +_xevfrp_ +_xevgek_ +_xevinp_ +_xevmap_ +_xevnee_ +_xevpae_ +_xevpah_ +_xevqut_ +_xevstt_ +_xevunp_ +_xfaccs_ +_xfatal_ +_xfchdr_ +_xfcloe_ +_xfdele_ +_xffluh_ +_xfgetc_ +_xfgetr_ +_xfnote_ +_xfopen_ +_xfputc_ +_xfputr_ +_xfread_ +_xfrnam_ +_xfscan_ +_xfseek_ +_xfungc_ +_xfwrie_ +_xgdevt_ +_xgtpid_ +_xgtuid_ +_xisaty_ +_xmallc_ +_xmfree_ +_xmjbuf_ +_xmktep_ +_xonerr_ +_xonext_ +_xori_ +_xorl_ +_xors_ +_xpages_ +_xprinf_ +_xqsort_ +_xrealc_ +_xsizef_ +_xstdeh_ +_xstrcp_ +_xstrct_ +_xstrcy_ +_xstrln_ +_xtoc_ +_xttyse_ +_xwhen_ +_xxscan_ +_zardbf_ +_zardgd_ +_zardks_ +_zardlp_ +_zardmt_ +_zardnu_ +_zardpl_ +_zardpr_ +_zardps_ +_zardsf_ +_zawrbf_ +_zawrgd_ +_zawrks_ +_zawrlp_ +_zawrmt_ +_zawrnu_ +_zawrpl_ +_zawrpr_ +_zawrps_ +_zawrsf_ +_zawset_ +_zawtbf_ +_zawtgd_ +_zawtks_ +_zawtlp_ +_zawtmt_ +_zawtnu_ +_zawtpl_ +_zawtpr_ +_zawtps_ +_zawtsf_ +_zclcpr_ +_zcldir_ +_zcldpr_ +_zclm70_ +_zclm75_ +_zclsbf_ +_zclsgd_ +_zclsks_ +_zclslp_ +_zclsmt_ +_zclsnu_ +_zclspl_ +_zclsps_ +_zclssf_ +_zclstt_ +_zclstx_ +_zclsty_ +_zdojmp_ +_zdvall_ +_zdvown_ +_zfacss_ +_zfaloc_ +_zfchdr_ +_zfdele_ +_zfgcwd_ +_zfinfo_ +_zflsnu_ +_zflstt_ +_zflstx_ +_zflsty_ +_zfmkcp_ +_zfmkdr_ +_zfnbrk_ +_zfpath_ +_zfprot_ +_zfrnam_ +_zfsubd_ +_zfxdir_ +_zgcmdl_ +_zgetnu_ +_zgettt_ +_zgettx_ +_zgetty_ +_zgfdir_ +_zghost_ +_zgtime_ +_zgtpid_ +_zintpr_ +_zlocpr_ +_zlocva_ +_zmaloc_ +_zmfree_ +_znotnu_ +_znottt_ +_znottx_ +_znotty_ +_zopcpr_ +_zopdir_ +_zopdpr_ +_zopm70_ +_zopm75_ +_zopnbf_ +_zopngd_ +_zopnks_ +_zopnlp_ +_zopnmt_ +_zopnnu_ +_zopnpl_ +_zopnsf_ +_zopntt_ +_zopntx_ +_zopnty_ +_zoscmd_ +_zpanic_ +_zputnu_ +_zputtt_ +_zputtx_ +_zputty_ +_zraloc_ +_zrdm70_ +_zrdm75_ +_zseknu_ +_zsektt_ +_zsektx_ +_zsekty_ +_zsestt_ +_zsettt_ +_zstm70_ +_zstm75_ +_zststt_ +_zsttbf_ +_zsttgd_ +_zsttks_ +_zsttlp_ +_zsttmt_ +_zsttnu_ +_zsttpl_ +_zsttpr_ +_zsttps_ +_zsttsf_ +_zstttt_ +_zstttx_ +_zsttty_ +_zsvjmp_ +_zttgeg_ +_zttger_ +_zttloe_ +_zttloo_ +_zttlov_ +_zttpbf_ +_zttplk_ +_zttpug_ +_zttquy_ +_zttttt_ +_zttupe_ +_zwmsec_ +_zwrm70_ +_zwrm75_ +_zwtm70_ +_zwtm75_ +_zxgmes_ +_zxwhen_ +_zzclmt_ +_zzopmt_ +_zzrdii_ +_zzrdmt_ +_zzrwmt_ +_zzsetk_ +_zzstmt_ +_zzwrii_ +_zzwrmt_ +_zzwtmt_ +_zzzend_ +_wfarcd_ +_wfarct_ +_wfarcv_ +_wfglsd_ +_wfglst_ +_wfglsv_ +_wfmspd_ +_wfmspf_ +_wfmspi_ +_wfmspl_ +_wfmspt_ +_wfmspv_ +_wfmspy_ +_wfsind_ +_wfsint_ +_wfsinv_ +_mtence_ +_mtfnae_ +_mtgtyn_ +_mtneeo_ +_ieemad_ +_ieemar_ +_ieestd_ +_ieestr_ +_ieezsd_ +_ieezsr_ +_qpfwar_ +_mwshow_ +_onerre_ +_onexie_ +_glbmip_ +_mwmkir_ +_mtclen_ +_gimcor_ +_gimcrr_ +_gimder_ +_gimeng_ +_gimgeg_ +_gimins_ +_gimlop_ +_gimqur_ +_gimrat_ +_gimreg_ +_gimrep_ +_gimres_ +_gimrex_ +_gimseg_ +_gimser_ +_gimwrp_ +_gimwrs_ +_gkiwee_ +_gmprif_ +_gmsg_ +_gmsgb_ +_gmsgc_ +_gmsgd_ +_gmsgi_ +_gmsgl_ +_gmsgr_ +_gmsgs_ +_gmsgx_ +_gopeni_ +_aselkc_ +_aselkd_ +_aselki_ +_aselkl_ +_aselkr_ +_aselks_ +_aselkx_ +_clcloe_ +_gimdig_ +_gimfrg_ +_gimfrp_ +_gimiod_ +_gimioe_ +_gimsex_ +_ndopen_ +_zardnd_ +_zawrnd_ +_zawtnd_ +_zclsnd_ +_zopnnd_ +_zsttnd_ +_evvexr_ +_evvfre_ +_xvvadg_ +_xvvbip_ +_xvvbop_ +_xvvcan_ +_xvvche_ +_xvver1_ +_xvver2_ +_xvverr_ +_xvvfrp_ +_xvvgek_ +_xvvinp_ +_xvvlos_ +_xvvmap_ +_xvvnee_ +_xvvnud_ +_xvvnui_ +_xvvnul_ +_xvvnur_ +_xvvnus_ +_xvvpae_ +_xvvpah_ +_xvvqut_ +_xvvstt_ +_xvvunp_ +_kimape_ +_xerpoi_ diff --git a/unix/shlib/S.nm.ffpa b/unix/shlib/S.nm.ffpa new file mode 100644 index 00000000..5b3f6a3c --- /dev/null +++ b/unix/shlib/S.nm.ffpa @@ -0,0 +1,2605 @@ +_aabsd_ +_aabsi_ +_aabsl_ +_aabsr_ +_aabss_ +_aabsx_ +_aaddd_ +_aaddi_ +_aaddkd_ +_aaddki_ +_aaddkl_ +_aaddkr_ +_aaddks_ +_aaddkx_ +_aaddl_ +_aaddr_ +_aadds_ +_aaddx_ +_aandi_ +_aandki_ +_aandkl_ +_aandks_ +_aandl_ +_aands_ +_aavgd_ +_aavgi_ +_aavgl_ +_aavgr_ +_aavgs_ +_aavgx_ +_abavd_ +_abavi_ +_abavl_ +_abavr_ +_abavs_ +_abavx_ +_abeqc_ +_abeqd_ +_abeqi_ +_abeqkc_ +_abeqkd_ +_abeqki_ +_abeqkl_ +_abeqkr_ +_abeqks_ +_abeqkx_ +_abeql_ +_abeqr_ +_abeqs_ +_abeqx_ +_abgec_ +_abged_ +_abgei_ +_abgekc_ +_abgekd_ +_abgeki_ +_abgekl_ +_abgekr_ +_abgeks_ +_abgekx_ +_abgel_ +_abger_ +_abges_ +_abgex_ +_abgtc_ +_abgtd_ +_abgti_ +_abgtkc_ +_abgtkd_ +_abgtki_ +_abgtkl_ +_abgtkr_ +_abgtks_ +_abgtkx_ +_abgtl_ +_abgtr_ +_abgts_ +_abgtx_ +_ablec_ +_abled_ +_ablei_ +_ablekc_ +_ablekd_ +_ableki_ +_ablekl_ +_ablekr_ +_ableks_ +_ablekx_ +_ablel_ +_abler_ +_ables_ +_ablex_ +_abltc_ +_abltd_ +_ablti_ +_abltkc_ +_abltkd_ +_abltki_ +_abltkl_ +_abltkr_ +_abltks_ +_abltkx_ +_abltl_ +_abltr_ +_ablts_ +_abltx_ +_abnec_ +_abned_ +_abnei_ +_abnekc_ +_abnekd_ +_abneki_ +_abnekl_ +_abnekr_ +_abneks_ +_abnekx_ +_abnel_ +_abner_ +_abnes_ +_abnex_ +_abori_ +_aborki_ +_aborkl_ +_aborks_ +_aborl_ +_abors_ +_absud_ +_absui_ +_absul_ +_absur_ +_absus_ +_acht_ +_achtb_ +_achtbb_ +_achtbc_ +_achtbd_ +_achtbi_ +_achtbl_ +_achtbr_ +_achtbs_ +_achtbu_ +_achtbx_ +_achtc_ +_achtcb_ +_achtcc_ +_achtcd_ +_achtci_ +_achtcl_ +_achtcr_ +_achtcs_ +_achtcu_ +_achtcx_ +_achtd_ +_achtdb_ +_achtdc_ +_achtdd_ +_achtdi_ +_achtdl_ +_achtdr_ +_achtds_ +_achtdu_ +_achtdx_ +_achti_ +_achtib_ +_achtic_ +_achtid_ +_achtii_ +_achtil_ +_achtir_ +_achtis_ +_achtiu_ +_achtix_ +_achtl_ +_achtlb_ +_achtlc_ +_achtld_ +_achtli_ +_achtll_ +_achtlr_ +_achtls_ +_achtlu_ +_achtlx_ +_achtr_ +_achtrb_ +_achtrc_ +_achtrd_ +_achtri_ +_achtrl_ +_achtrr_ +_achtrs_ +_achtru_ +_achtrx_ +_achts_ +_achtsb_ +_achtsc_ +_achtsd_ +_achtsi_ +_achtsl_ +_achtsr_ +_achtss_ +_achtsu_ +_achtsx_ +_achtu_ +_achtub_ +_achtuc_ +_achtud_ +_achtui_ +_achtul_ +_achtur_ +_achtus_ +_achtuu_ +_achtux_ +_achtx_ +_achtxb_ +_achtxc_ +_achtxd_ +_achtxi_ +_achtxl_ +_achtxr_ +_achtxs_ +_achtxu_ +_achtxx_ +_acjgx_ +_aclrb_ +_aclrc_ +_aclrd_ +_aclri_ +_aclrl_ +_aclrr_ +_aclrs_ +_aclrx_ +_acnvd_ +_acnvi_ +_acnvl_ +_acnvr_ +_acnvrd_ +_acnvri_ +_acnvrl_ +_acnvrr_ +_acnvrs_ +_acnvs_ +_adivd_ +_adivi_ +_adivkd_ +_adivki_ +_adivkl_ +_adivkr_ +_adivks_ +_adivkx_ +_adivl_ +_adivr_ +_adivs_ +_adivx_ +_adotd_ +_adoti_ +_adotl_ +_adotr_ +_adots_ +_adotx_ +_advzd_ +_advzi_ +_advzl_ +_advzr_ +_advzs_ +_advzx_ +_aelogd_ +_aelogr_ +_aexpd_ +_aexpi_ +_aexpkd_ +_aexpki_ +_aexpkl_ +_aexpkr_ +_aexpks_ +_aexpkx_ +_aexpl_ +_aexpr_ +_aexps_ +_aexpx_ +_afftrr_ +_afftrx_ +_afftxr_ +_afftxx_ +_agltc_ +_agltd_ +_aglti_ +_agltl_ +_agltr_ +_aglts_ +_agltx_ +_ahgmc_ +_ahgmd_ +_ahgmi_ +_ahgml_ +_ahgmr_ +_ahgms_ +_ahivc_ +_ahivd_ +_ahivi_ +_ahivl_ +_ahivr_ +_ahivs_ +_ahivx_ +_aiftrr_ +_aiftrx_ +_aiftxr_ +_aiftxx_ +_aimgd_ +_aimgi_ +_aimgl_ +_aimgr_ +_aimgs_ +_alimc_ +_alimd_ +_alimi_ +_aliml_ +_alimr_ +_alims_ +_alimx_ +_allnd_ +_allni_ +_allnl_ +_allnr_ +_allns_ +_allnx_ +_alogd_ +_alogi_ +_alogl_ +_alogr_ +_alogs_ +_alogx_ +_alovc_ +_alovd_ +_alovi_ +_alovl_ +_alovr_ +_alovs_ +_alovx_ +_altad_ +_altai_ +_altal_ +_altar_ +_altas_ +_altax_ +_altmd_ +_altmi_ +_altml_ +_altmr_ +_altms_ +_altmx_ +_altrd_ +_altri_ +_altrl_ +_altrr_ +_altrs_ +_altrx_ +_aluid_ +_aluii_ +_aluil_ +_aluir_ +_aluis_ +_alutc_ +_alutd_ +_aluti_ +_alutl_ +_alutr_ +_aluts_ +_amagd_ +_amagi_ +_amagl_ +_amagr_ +_amags_ +_amagx_ +_amapd_ +_amapi_ +_amapl_ +_amapr_ +_amaps_ +_amaxc_ +_amaxd_ +_amaxi_ +_amaxkc_ +_amaxkd_ +_amaxki_ +_amaxkl_ +_amaxkr_ +_amaxks_ +_amaxkx_ +_amaxl_ +_amaxr_ +_amaxs_ +_amaxx_ +_amed3c_ +_amed3d_ +_amed3i_ +_amed3l_ +_amed3r_ +_amed3s_ +_amed4c_ +_amed4d_ +_amed4i_ +_amed4l_ +_amed4r_ +_amed4s_ +_amed5c_ +_amed5d_ +_amed5i_ +_amed5l_ +_amed5r_ +_amed5s_ +_amedc_ +_amedd_ +_amedi_ +_amedl_ +_amedr_ +_ameds_ +_amedx_ +_amgsd_ +_amgsi_ +_amgsl_ +_amgsr_ +_amgss_ +_amgsx_ +_aminc_ +_amind_ +_amini_ +_aminkc_ +_aminkd_ +_aminki_ +_aminkl_ +_aminkr_ +_aminks_ +_aminkx_ +_aminl_ +_aminr_ +_amins_ +_aminx_ +_amodd_ +_amodi_ +_amodkd_ +_amodki_ +_amodkl_ +_amodkr_ +_amodks_ +_amodl_ +_amodr_ +_amods_ +_amovc_ +_amovd_ +_amovi_ +_amovkc_ +_amovkd_ +_amovki_ +_amovkl_ +_amovkr_ +_amovks_ +_amovkx_ +_amovl_ +_amovr_ +_amovs_ +_amovx_ +_amuld_ +_amuli_ +_amulkd_ +_amulki_ +_amulkl_ +_amulkr_ +_amulks_ +_amulkx_ +_amull_ +_amulr_ +_amuls_ +_amulx_ +_andi_ +_andl_ +_ands_ +_anegd_ +_anegi_ +_anegl_ +_anegr_ +_anegs_ +_anegx_ +_anoti_ +_anotl_ +_anots_ +_apkxd_ +_apkxi_ +_apkxl_ +_apkxr_ +_apkxs_ +_apkxx_ +_apold_ +_apolr_ +_apowd_ +_apowi_ +_apowkd_ +_apowki_ +_apowkl_ +_apowkr_ +_apowks_ +_apowkx_ +_apowl_ +_apowr_ +_apows_ +_apowx_ +_aravd_ +_aravi_ +_aravl_ +_aravr_ +_aravs_ +_aravx_ +_arcpd_ +_arcpi_ +_arcpl_ +_arcpr_ +_arcps_ +_arcpx_ +_arczd_ +_arczi_ +_arczl_ +_arczr_ +_arczs_ +_arczx_ +_aread_ +_areadb_ +_argtd_ +_argti_ +_argtl_ +_argtr_ +_argts_ +_argtx_ +_arltd_ +_arlti_ +_arltl_ +_arltr_ +_arlts_ +_arltx_ +_aselc_ +_aseld_ +_aseli_ +_asell_ +_aselr_ +_asels_ +_aselx_ +_asokc_ +_asokd_ +_asoki_ +_asokl_ +_asokr_ +_asoks_ +_asokx_ +_asqrd_ +_asqri_ +_asqrl_ +_asqrr_ +_asqrs_ +_asqrx_ +_asrtc_ +_asrtd_ +_asrti_ +_asrtl_ +_asrtr_ +_asrts_ +_asrtx_ +_assqd_ +_assqi_ +_assql_ +_assqr_ +_assqs_ +_assqx_ +_asubd_ +_asubi_ +_asubkd_ +_asubki_ +_asubkl_ +_asubkr_ +_asubks_ +_asubkx_ +_asubl_ +_asubr_ +_asubs_ +_asubx_ +_asumd_ +_asumi_ +_asuml_ +_asumr_ +_asums_ +_asumx_ +_aupxd_ +_aupxi_ +_aupxl_ +_aupxr_ +_aupxs_ +_aupxx_ +_aveqc_ +_aveqd_ +_aveqi_ +_aveql_ +_aveqr_ +_aveqs_ +_aveqx_ +_await_ +_awaitb_ +_awritb_ +_awrite_ +_awsud_ +_awsui_ +_awsul_ +_awsur_ +_awsus_ +_awsux_ +_awvgd_ +_awvgi_ +_awvgl_ +_awvgr_ +_awvgs_ +_awvgx_ +_axori_ +_axorki_ +_axorkl_ +_axorks_ +_axorl_ +_axors_ +_begmem_ +_bitmov_ +_bitpak_ +_bitupk_ +_brktie_ +_bswap2_ +_bswap4_ +_bswap8_ +_btoi_ +_bytmov_ +_cctoc_ +_chdept_ +_chfeth_ +_chrlwr_ +_chrpak_ +_chrupk_ +_chrupr_ +_clccos_ +_clcenr_ +_clcfeh_ +_clcfid_ +_clcfre_ +_clcint_ +_clclit_ +_clcmak_ +_clcmd_ +_clcmdw_ +_clcnek_ +_clcpst_ +_clcscn_ +_clepst_ +_clgcur_ +_clgetb_ +_clgetc_ +_clgetd_ +_clgeti_ +_clgetl_ +_clgetr_ +_clgets_ +_clgetx_ +_clgfil_ +_clgkey_ +_clglpb_ +_clglpc_ +_clglpd_ +_clglpi_ +_clglpl_ +_clglpr_ +_clglps_ +_clglpx_ +_clglsr_ +_clgpsa_ +_clgpsb_ +_clgpsc_ +_clgpsd_ +_clgpsi_ +_clgpsl_ +_clgpsr_ +_clgpss_ +_clgpst_ +_clgpsx_ +_clgstr_ +_clgwrd_ +_clktie_ +_cllpst_ +_clopen_ +_clopst_ +_clpcls_ +_clplen_ +_clpopi_ +_clpops_ +_clpopu_ +_clppsa_ +_clppsb_ +_clppsc_ +_clppsd_ +_clppsi_ +_clppsl_ +_clppsr_ +_clppss_ +_clppst_ +_clppsx_ +_clprew_ +_clprif_ +_clpsee_ +_clpsit_ +_clpstr_ +_clputb_ +_clputc_ +_clputd_ +_clputi_ +_clputl_ +_clputr_ +_clputs_ +_clputx_ +_clreqr_ +_clscan_ +_clseti_ +_clstai_ +_cnvdae_ +_cnvtie_ +_coerce_ +_cputie_ +_ctocc_ +_ctod_ +_ctoi_ +_ctol_ +_ctor_ +_ctotok_ +_ctowrd_ +_ctox_ +_d1mach_ +_deletg_ +_diropn_ +_dtcscl_ +_dtoc3_ +_dtoc_ +_elogd_ +_elogr_ +_envfid_ +_envfit_ +_envfre_ +_envgeb_ +_envged_ +_envgei_ +_envger_ +_envges_ +_envinr_ +_envint_ +_envlit_ +_envmak_ +_envnet_ +_envpus_ +_envret_ +_envscn_ +_eprinf_ +_erract_ +_errcoe_ +_errget_ +_evexpr_ +_f77pak_ +_f77upk_ +_falloc_ +_fcanpb_ +_fcldir_ +_fclobr_ +_fcopy_ +_fcopyo_ +_fdebug_ +_fdevbf_ +_fdevbk_ +_fdevtx_ +_fdirne_ +_fexbuf_ +_ffa_ +_ffault_ +_ffilbf_ +_ffilsz_ +_ffldir_ +_fflsbf_ +_ffs_ +_fft842_ +_fgdev0_ +_fgdevm_ +_fgetfd_ +_fgtdir_ +_filbuf_ +_filerr_ +_filopn_ +_finfo_ +_finit_ +_fioclp_ +_fioqfh_ +_fixmem_ +_flsbuf_ +_fmaccs_ +_fmapfn_ +_fmcloe_ +_fmcopo_ +_fmcopy_ +_fmdebg_ +_fmdele_ +_fmfcdg_ +_fmfcfe_ +_fmfcit_ +_fmfcsc_ +_fmfinf_ +_fmfopn_ +_fmgetd_ +_fmiobd_ +_fmioed_ +_fmioek_ +_fmiopr_ +_fmiorr_ +_fmiosf_ +_fmiotk_ +_fmkbfs_ +_fmkcoy_ +_fmkdir_ +_fmkpbf_ +_fmlfad_ +_fmlfae_ +_fmlfat_ +_fmlfbd_ +_fmlfbe_ +_fmlfbt_ +_fmlfce_ +_fmlfcy_ +_fmlfde_ +_fmlfne_ +_fmlfon_ +_fmlfpe_ +_fmlfsi_ +_fmlfst_ +_fmlfue_ +_fmlocd_ +_fmloct_ +_fmnexe_ +_fmopen_ +_fmrebd_ +_fmrene_ +_fmretd_ +_fmseti_ +_fmstai_ +_fmsync_ +_fmterr_ +_fmtint_ +_fmtred_ +_fmtsel_ +_fmtstr_ +_fmunlk_ +_fnextn_ +_fnldir_ +_fnroot_ +_fntclb_ +_fntcls_ +_fntdir_ +_fntedt_ +_fntget_ +_fntgfb_ +_fntgfn_ +_fntleb_ +_fntmkt_ +_fntopb_ +_fntopn_ +_fntopt_ +_fntreb_ +_fntree_ +_fntrfb_ +_fnulle_ +_fopdir_ +_fopnbf_ +_fopntx_ +_fowner_ +_fpathe_ +_fpequd_ +_fpequr_ +_fpfixd_ +_fpfixr_ +_fpnonr_ +_fpnord_ +_fpnorr_ +_fpradv_ +_fprfmt_ +_fprinf_ +_fprntf_ +_fptdir_ +_fputtx_ +_freadp_ +_fredio_ +_fredir_ +_frenae_ +_frmbfs_ +_frmtmp_ +_frtnfd_ +_fsetev_ +_fsetfd_ +_fseti_ +_fsfdee_ +_fsfgee_ +_fsfopn_ +_fskdir_ +_fstati_ +_fstatl_ +_fstats_ +_fstdfe_ +_fstdir_ +_fstrfp_ +_fsvtfn_ +_fswapd_ +_fwatio_ +_fwritp_ +_fwtacc_ +_gactie_ +_gadraw_ +_gamove_ +_gargb_ +_gargc_ +_gargd_ +_gargi_ +_gargl_ +_gargr_ +_gargrd_ +_gargs_ +_gargsr_ +_gargtk_ +_gargwd_ +_gargx_ +_gascae_ +_gcancl_ +_gclear_ +_gclose_ +_gctod_ +_gctol_ +_gctox_ +_gctran_ +_gcurps_ +_gdeace_ +_gescae_ +_getci_ +_gethot_ +_getlie_ +_getlle_ +_getloe_ +_gexflr_ +_gexfls_ +_gexflt_ +_gfill_ +_gflush_ +_gframe_ +_gfrint_ +_ggcell_ +_ggcur_ +_ggetb_ +_ggeti_ +_ggetr_ +_ggets_ +_ggscae_ +_ggview_ +_ggwind_ +_gkical_ +_gkiclr_ +_gkicls_ +_gkides_ +_gkieof_ +_gkiese_ +_gkiexe_ +_gkifat_ +_gkifen_ +_gkiffh_ +_gkifia_ +_gkiflh_ +_gkiger_ +_gkiges_ +_gkigey_ +_gkiinl_ +_gkiint_ +_gkimfe_ +_gkiops_ +_gkiplt_ +_gkipmt_ +_gkipoe_ +_gkipor_ +_gkipuy_ +_gkiree_ +_gkirer_ +_gkires_ +_gkirey_ +_gkiser_ +_gkises_ +_gkisul_ +_gkitet_ +_gkitxt_ +_gkiwre_ +_gkpcal_ +_gkpcle_ +_gkpclr_ +_gkpcls_ +_gkpdes_ +_gkpdup_ +_gkpese_ +_gkpfat_ +_gkpfia_ +_gkpflh_ +_gkpger_ +_gkpges_ +_gkpgey_ +_gkpgrm_ +_gkpinl_ +_gkpmfe_ +_gkpops_ +_gkpplt_ +_gkppmt_ +_gkppoe_ +_gkppor_ +_gkppst_ +_gkppuy_ +_gkpres_ +_gkpser_ +_gkpses_ +_gkptet_ +_gkptxg_ +_gkptxt_ +_gkpunn_ +_glabax_ +_glbdrd_ +_glbene_ +_glbeq_ +_glbfis_ +_glbgek_ +_glblas_ +_glblob_ +_glbple_ +_glbsep_ +_glbses_ +_glbset_ +_glbtin_ +_glbveg_ +_gline_ +_gltoc_ +_gmark_ +_gmftie_ +_gopen_ +_gpagee_ +_gpatme_ +_gpatmh_ +_gpcell_ +_gplcae_ +_gplcal_ +_gplclb_ +_gplcll_ +_gplclr_ +_gplclt_ +_gplflh_ +_gpline_ +_gploto_ +_gplotv_ +_gplret_ +_gplsee_ +_gplwci_ +_gpmark_ +_gqsort_ +_gqvery_ +_grdraw_ +_grdwcs_ +_greace_ +_greset_ +_grmove_ +_grscae_ +_gscan_ +_gscur_ +_gseti_ +_gsetr_ +_gsets_ +_gstati_ +_gstatr_ +_gstats_ +_gstrct_ +_gstrcy_ +_gstrmh_ +_gstsei_ +_gstser_ +_gsview_ +_gswind_ +_gtdise_ +_gtext_ +_gtickr_ +_gtliny_ +_gtndis_ +_gttyld_ +_gtxset_ +_gtybih_ +_gtycas_ +_gtycle_ +_gtyeny_ +_gtyexs_ +_gtyfey_ +_gtyfiy_ +_gtygeb_ +_gtygei_ +_gtyger_ +_gtyges_ +_gtyins_ +_gtyopn_ +_gtysce_ +_gumark_ +_gvline_ +_gvmark_ +_gwcsme_ +_gwrwcs_ +_i1mach_ +_idbcle_ +_idbfid_ +_idbgeg_ +_idbkwp_ +_idbned_ +_idbopn_ +_idbpug_ +_ieegnd_ +_ieegnr_ +_ieemad_ +_ieemar_ +_ieepad_ +_ieepar_ +_ieesnd_ +_ieesnr_ +_ieestd_ +_ieestr_ +_ieeupd_ +_ieeupr_ +_ieevpd_ +_ieevpr_ +_ieevud_ +_ieevur_ +_ieezsd_ +_ieezsr_ +_ikiacs_ +_ikicle_ +_ikicoy_ +_ikidee_ +_ikiint_ +_ikildr_ +_ikimke_ +_ikiopn_ +_ikiopx_ +_ikipae_ +_ikiree_ +_ikiupr_ +_imaccf_ +_imaccs_ +_imaddb_ +_imaddd_ +_imaddf_ +_imaddi_ +_imaddl_ +_imaddr_ +_imadds_ +_imaflp_ +_imalin_ +_imaplv_ +_imastr_ +_imbln1_ +_imbln2_ +_imbln3_ +_imbtrn_ +_imcfnl_ +_imcopy_ +_imcssz_ +_imctrt_ +_imdect_ +_imdele_ +_imdelf_ +_imdmap_ +_imerr_ +_imflpl_ +_imflps_ +_imflsd_ +_imflsh_ +_imflsi_ +_imflsl_ +_imflsr_ +_imflss_ +_imflsx_ +_imfluh_ +_imfnpy_ +_imfnss_ +_imgclr_ +_imgetb_ +_imgetc_ +_imgetd_ +_imgeti_ +_imgetl_ +_imgetr_ +_imgets_ +_imgfte_ +_imggsc_ +_imggsd_ +_imggsi_ +_imggsl_ +_imggsr_ +_imggss_ +_imggsx_ +_imgibf_ +_imgime_ +_imgl1d_ +_imgl1i_ +_imgl1l_ +_imgl1r_ +_imgl1s_ +_imgl1x_ +_imgl2d_ +_imgl2i_ +_imgl2l_ +_imgl2r_ +_imgl2s_ +_imgl2x_ +_imgl3d_ +_imgl3i_ +_imgl3l_ +_imgl3r_ +_imgl3s_ +_imgl3x_ +_imgnfn_ +_imgnld_ +_imgnli_ +_imgnll_ +_imgnln_ +_imgnlr_ +_imgnls_ +_imgnlx_ +_imgobf_ +_imgs1d_ +_imgs1i_ +_imgs1l_ +_imgs1r_ +_imgs1s_ +_imgs1x_ +_imgs2d_ +_imgs2i_ +_imgs2l_ +_imgs2r_ +_imgs2s_ +_imgs2x_ +_imgs3d_ +_imgs3i_ +_imgs3l_ +_imgs3r_ +_imgs3s_ +_imgs3x_ +_imgsen_ +_imgstr_ +_iminie_ +_imioff_ +_imisec_ +_imloop_ +_immaky_ +_immap_ +_immapz_ +_imnote_ +_imofnl_ +_imofns_ +_imofnu_ +_imopsf_ +_impakd_ +_impaki_ +_impakl_ +_impakr_ +_impaks_ +_impakx_ +_impare_ +_impgsd_ +_impgsi_ +_impgsl_ +_impgsr_ +_impgss_ +_impgsx_ +_impl1d_ +_impl1i_ +_impl1l_ +_impl1r_ +_impl1s_ +_impl1x_ +_impl2d_ +_impl2i_ +_impl2l_ +_impl2r_ +_impl2s_ +_impl2x_ +_impl3d_ +_impl3i_ +_impl3l_ +_impl3r_ +_impl3s_ +_impl3x_ +_impml1_ +_impml2_ +_impml3_ +_impmlr_ +_impmlv_ +_impmmo_ +_impmmp_ +_impmon_ +_impms1_ +_impms2_ +_impms3_ +_impmsr_ +_impmsv_ +_impnld_ +_impnli_ +_impnll_ +_impnln_ +_impnlr_ +_impnls_ +_impnlx_ +_imps1d_ +_imps1i_ +_imps1l_ +_imps1r_ +_imps1s_ +_imps1x_ +_imps2d_ +_imps2i_ +_imps2l_ +_imps2r_ +_imps2s_ +_imps2x_ +_imps3d_ +_imps3i_ +_imps3l_ +_imps3r_ +_imps3s_ +_imps3x_ +_impstr_ +_imputb_ +_imputd_ +_imputh_ +_imputi_ +_imputl_ +_imputr_ +_imputs_ +_imrbpx_ +_imrdpx_ +_imrene_ +_imrmbs_ +_imsamp_ +_imsetf_ +_imseti_ +_imsetr_ +_imsinb_ +_imsmpl_ +_imsmps_ +_imsslv_ +_imstai_ +_imstas_ +_imtcle_ +_imtgem_ +_imtlen_ +_imtmae_ +_imtopn_ +_imtopp_ +_imtrew_ +_imtrgm_ +_imunmp_ +_imupkd_ +_imupki_ +_imupkl_ +_imupkr_ +_imupks_ +_imupkx_ +_imwbpx_ +_imwrie_ +_imwrpx_ +_intrde_ +_intree_ +_intrrt_ +_irafmn_ +_itob_ +_itoc_ +_iwcare_ +_iwcfis_ +_iwents_ +_iwfind_ +_iwgbis_ +_iwputr_ +_iwputy_ +_iwrfis_ +_iwsetp_ +_kardbf_ +_kardgd_ +_kardlp_ +_kardpl_ +_kardpr_ +_kardsf_ +_kawrbf_ +_kawrgd_ +_kawrlp_ +_kawrpl_ +_kawrpr_ +_kawrsf_ +_kawtbf_ +_kawtgd_ +_kawtlp_ +_kawtpl_ +_kawtpr_ +_kawtsf_ +_kbzard_ +_kbzawr_ +_kbzawt_ +_kbzcls_ +_kbzopn_ +_kbzstt_ +_kclcpr_ +_kcldir_ +_kcldpr_ +_kclsbf_ +_kclsgd_ +_kclslp_ +_kclspl_ +_kclssf_ +_kclstx_ +_kclsty_ +_kdvall_ +_kdvown_ +_kfacss_ +_kfaloc_ +_kfchdr_ +_kfdele_ +_kfgcwd_ +_kfinfo_ +_kflstx_ +_kflsty_ +_kfmkcp_ +_kfmkdr_ +_kfpath_ +_kfprot_ +_kfrnam_ +_kfsubd_ +_kfxdir_ +_kgettx_ +_kgetty_ +_kgfdir_ +_kicont_ +_kidece_ +_kience_ +_kienvt_ +_kierrr_ +_kiexte_ +_kifine_ +_kiflux_ +_kifman_ +_kifren_ +_kigetn_ +_kigets_ +_kignoe_ +_kiinit_ +_kiloce_ +_kimapn_ +_kintpr_ +_kiopes_ +_kirece_ +_kisend_ +_kisenv_ +_kishot_ +_kixnoe_ +_kmallc_ +_knottx_ +_knotty_ +_kopcpr_ +_kopdir_ +_kopdpr_ +_kopnbf_ +_kopngd_ +_kopnlp_ +_kopnpl_ +_kopnsf_ +_kopntx_ +_kopnty_ +_koscmd_ +_kputtx_ +_kputty_ +_krealc_ +_ksared_ +_ksawat_ +_ksawre_ +_ksektx_ +_ksekty_ +_ksttbf_ +_ksttgd_ +_ksttlp_ +_ksttpl_ +_ksttpr_ +_ksttsf_ +_kstttx_ +_ksttty_ +_ktzcls_ +_ktzfls_ +_ktzget_ +_ktznot_ +_ktzopn_ +_ktzput_ +_ktzsek_ +_ktzstt_ +_kzclmt_ +_kzopmt_ +_kzrdmt_ +_kzrwmt_ +_kzstmt_ +_kzwrmt_ +_kzwtmt_ +_lexnum_ +_lnocle_ +_lnofeh_ +_lnoopn_ +_lnosae_ +_locpr_ +_locva_ +_lpopen_ +_lpzard_ +_lpzawe_ +_lpzawt_ +_ltoc_ +_m75put_ +_maideh_ +_mallo1_ +_mgdptr_ +_mgtfwa_ +_miilen_ +_miinem_ +_miipa2_ +_miipa6_ +_miipa8_ +_miipad_ +_miipak_ +_miipar_ +_miipke_ +_miirec_ +_miired_ +_miirei_ +_miirel_ +_miirer_ +_miires_ +_miiup2_ +_miiup6_ +_miiup8_ +_miiupd_ +_miiupk_ +_miiupr_ +_miiwrc_ +_miiwrd_ +_miiwri_ +_miiwrl_ +_miiwrr_ +_miiwrs_ +_miocle_ +_miogld_ +_miogli_ +_miogll_ +_mioglr_ +_miogls_ +_mioglx_ +_mioopn_ +_mioopo_ +_miopld_ +_miopli_ +_miopll_ +_mioplr_ +_miopls_ +_mioplx_ +_miosee_ +_miosei_ +_miosti_ +_msvfwa_ +_mtalle_ +_mtcap_ +_mtclre_ +_mtdeae_ +_mtdevd_ +_mtence_ +_mtfile_ +_mtfnae_ +_mtgets_ +_mtglok_ +_mtgtyn_ +_mtloce_ +_mtneeo_ +_mtopen_ +_mtpare_ +_mtposn_ +_mtpute_ +_mtreae_ +_mtrewd_ +_mtsavd_ +_mtsavs_ +_mtskid_ +_mtstas_ +_mtsync_ +_mtupde_ +_mwalld_ +_mwalls_ +_mwaxtn_ +_mwc1td_ +_mwc1tr_ +_mwc2td_ +_mwc2tr_ +_mwcloe_ +_mwcopd_ +_mwcops_ +_mwctfe_ +_mwctrd_ +_mwctrr_ +_mwfins_ +_mwflop_ +_mwgaxp_ +_mwgaxt_ +_mwgctd_ +_mwgctr_ +_mwgltd_ +_mwgltr_ +_mwgsym_ +_mwgwas_ +_mwgwsd_ +_mwgwsr_ +_mwgwtd_ +_mwgwtr_ +_mwinvd_ +_mwinvr_ +_mwload_ +_mwloam_ +_mwltrd_ +_mwltrr_ +_mwlubb_ +_mwlude_ +_mwmkid_ +_mwmmud_ +_mwmmur_ +_mwnewm_ +_mwnewy_ +_mwopem_ +_mwopen_ +_mwrefr_ +_mwrote_ +_mwsave_ +_mwsavm_ +_mwsaxp_ +_mwscae_ +_mwsctn_ +_mwsdes_ +_mwseti_ +_mwshit_ +_mwsltd_ +_mwsltr_ +_mwssym_ +_mwstai_ +_mwswas_ +_mwswsd_ +_mwswsr_ +_mwswtd_ +_mwswte_ +_mwswtr_ +_mwtrad_ +_mwtrar_ +_mwv1td_ +_mwv1tr_ +_mwv2td_ +_mwv2tr_ +_mwvmud_ +_mwvmur_ +_mwvtrd_ +_mwvtrr_ +_noti_ +_notl_ +_nots_ +_nowhie_ +_nscan_ +_oifacs_ +_oifcle_ +_oifcoy_ +_oifdee_ +_oifgpe_ +_oifmke_ +_oifopn_ +_oifopx_ +_oifree_ +_oifupr_ +_oifwpr_ +_onerrr_ +_onexit_ +_ord1_ +_ord2_ +_ori_ +_orl_ +_ors_ +_oscmd_ +_osfnik_ +_osfnlk_ +_osfnms_ +_osfnpe_ +_osfnrk_ +_osfntt_ +_osfnuk_ +_pagefe_ +_pagefs_ +_pargb_ +_pargc_ +_pargd_ +_pargg_ +_pargi_ +_pargl_ +_pargr_ +_pargs_ +_pargsr_ +_pargx_ +_patamh_ +_patfit_ +_patgel_ +_patgse_ +_patinx_ +_patloe_ +_patmae_ +_patmah_ +_patomh_ +_patsts_ +_pggetd_ +_pggete_ +_pggetr_ +_pgpage_ +_pgpeed_ +_pgpusd_ +_pgsett_ +_placcs_ +_plallc_ +_plascp_ +_plbox_ +_plcire_ +_plcler_ +_plcloe_ +_plcome_ +_plcoms_ +_plcree_ +_pldebg_ +_pldebt_ +_plempy_ +_plfacs_ +_plfcle_ +_plfcoy_ +_plfdee_ +_plfnul_ +_plfopn_ +_plfree_ +_plfupr_ +_plgete_ +_plglls_ +_plglpi_ +_plglpl_ +_plglps_ +_plglri_ +_plglrl_ +_plglrs_ +_plgsie_ +_pll2pi_ +_pll2pl_ +_pll2ps_ +_pll2ri_ +_pll2rl_ +_pll2rs_ +_pllcot_ +_pllemy_ +_plleql_ +_plline_ +_pllinl_ +_pllinp_ +_plliny_ +_pllneg_ +_plload_ +_plloaf_ +_plloam_ +_plloop_ +_pllprs_ +_plnewy_ +_plopen_ +_plp2li_ +_plp2ll_ +_plp2ls_ +_plp2ri_ +_plp2rl_ +_plp2rs_ +_plpixi_ +_plpixl_ +_plpixs_ +_plplls_ +_plplpi_ +_plplpl_ +_plplps_ +_plplri_ +_plplrl_ +_plplrs_ +_plpoit_ +_plpoln_ +_plr2li_ +_plr2ll_ +_plr2ls_ +_plr2pi_ +_plr2pl_ +_plr2ps_ +_plrani_ +_plranl_ +_plrans_ +_plrcle_ +_plregp_ +_plreqi_ +_plreql_ +_plreqs_ +_plrget_ +_plrgex_ +_plrop_ +_plropn_ +_plrpri_ +_plrprl_ +_plrprs_ +_plrset_ +_plsave_ +_plsavf_ +_plsavm_ +_plsect_ +_plsecy_ +_plsete_ +_plseti_ +_plssie_ +_plsslv_ +_plstai_ +_plstel_ +_plubox_ +_plucie_ +_plupde_ +_plupon_ +_plvald_ +_pmaccs_ +_pmascp_ +_pmbox_ +_pmcire_ +_pmcler_ +_pmempy_ +_pmglls_ +_pmglpi_ +_pmglpl_ +_pmglps_ +_pmglri_ +_pmglrl_ +_pmglrs_ +_pmline_ +_pmliny_ +_pmnewk_ +_pmplls_ +_pmplpi_ +_pmplpl_ +_pmplps_ +_pmplri_ +_pmplrl_ +_pmplrs_ +_pmpoit_ +_pmpoln_ +_pmrcle_ +_pmrgex_ +_pmrop_ +_pmropn_ +_pmrset_ +_pmsect_ +_pmsecy_ +_pmsete_ +_pmseti_ +_pmstel_ +_prchdr_ +_prclcr_ +_prcldr_ +_prcloe_ +_prdone_ +_prdumn_ +_prenve_ +_prenvt_ +_prfilf_ +_prfinc_ +_prgete_ +_prgetr_ +_prkill_ +_pronic_ +_propcr_ +_propdr_ +_propen_ +_proscd_ +_protet_ +_prpsio_ +_prpsld_ +_prredr_ +_prsigl_ +_prstai_ +_prupde_ +_prvret_ +_przclr_ +_psioit_ +_psioxr_ +_putcc_ +_putci_ +_putlie_ +_qmaccs_ +_qmgetc_ +_qmscan_ +_qmscao_ +_qmsetm_ +_qmsetr_ +_qmsets_ +_qmsymb_ +_qmupds_ +_qpaccf_ +_qpaccs_ +_qpaddb_ +_qpaddc_ +_qpaddd_ +_qpaddf_ +_qpaddi_ +_qpaddl_ +_qpaddr_ +_qpadds_ +_qpaddx_ +_qpargt_ +_qpastr_ +_qpbind_ +_qpcfnl_ +_qpcloe_ +_qpclot_ +_qpcopf_ +_qpcopy_ +_qpctod_ +_qpctoi_ +_qpdele_ +_qpdelf_ +_qpdsym_ +_qpdtye_ +_qpelee_ +_qpexad_ +_qpexai_ +_qpexar_ +_qpexcd_ +_qpexce_ +_qpexci_ +_qpexcr_ +_qpexdc_ +_qpexde_ +_qpexdg_ +_qpexdr_ +_qpexee_ +_qpexfe_ +_qpexge_ +_qpexgr_ +_qpexmk_ +_qpexmr_ +_qpexon_ +_qpexpd_ +_qpexpi_ +_qpexpn_ +_qpexpr_ +_qpexps_ +_qpexpt_ +_qpexrd_ +_qpexsd_ +_qpexsi_ +_qpexsr_ +_qpfacs_ +_qpfcle_ +_qpfcos_ +_qpfcoy_ +_qpfdee_ +_qpflur_ +_qpfopn_ +_qpfopx_ +_qpfree_ +_qpfupr_ +_qpfwar_ +_qpfwfr_ +_qpfzcl_ +_qpfzop_ +_qpfzrd_ +_qpfzst_ +_qpfzwr_ +_qpfzwt_ +_qpgetb_ +_qpgetc_ +_qpgetd_ +_qpgeti_ +_qpgetk_ +_qpgetl_ +_qpgetm_ +_qpgetr_ +_qpgets_ +_qpgetx_ +_qpgmsm_ +_qpgnfn_ +_qpgpsm_ +_qpgstr_ +_qpinht_ +_qpioce_ +_qpioge_ +_qpiogr_ +_qpiogs_ +_qpiolk_ +_qpiols_ +_qpiomx_ +_qpioon_ +_qpiope_ +_qpiops_ +_qpiori_ +_qpiors_ +_qpiort_ +_qpiosc_ +_qpiose_ +_qpiosi_ +_qpiosr_ +_qpiost_ +_qpiowt_ +_qplenf_ +_qplenl_ +_qplesd_ +_qplesi_ +_qplesr_ +_qploas_ +_qpmaxd_ +_qpmaxi_ +_qpmaxr_ +_qpmind_ +_qpmini_ +_qpminr_ +_qpmkfe_ +_qpnexk_ +_qpofnl_ +_qpofns_ +_qpofnu_ +_qpopen_ +_qpopet_ +_qppare_ +_qpparl_ +_qppcle_ +_qppopn_ +_qppstr_ +_qpputb_ +_qpputc_ +_qpputd_ +_qpputi_ +_qpputl_ +_qpputm_ +_qpputr_ +_qpputs_ +_qpputx_ +_qpquef_ +_qprawk_ +_qpread_ +_qprebd_ +_qprene_ +_qprenf_ +_qprlmd_ +_qprlmi_ +_qprlmr_ +_qpsavs_ +_qpseel_ +_qpseti_ +_qpsizf_ +_qpstai_ +_qpsync_ +_qpungk_ +_qpwrie_ +_r1mach_ +_r2tr_ +_r2tx_ +_r4syn_ +_r4tr_ +_r4tx_ +_r8syn_ +_r8tr_ +_r8tx_ +_rdukey_ +_reopen_ +_resetn_ +_salloc_ +_scanc_ +_sfree_ +_shifti_ +_shiftl_ +_shifts_ +_smark_ +_sprinf_ +_sscan_ +_stallc_ +_stcloe_ +_stentr_ +_stfacs_ +_stfadr_ +_stfcle_ +_stfcos_ +_stfcoy_ +_stfcte_ +_stfdee_ +_stfgeb_ +_stfgei_ +_stfgen_ +_stfges_ +_stfget_ +_stfind_ +_stfinl_ +_stfins_ +_stfmeb_ +_stfmke_ +_stfnee_ +_stfopn_ +_stfopx_ +_stforb_ +_stfrdr_ +_stfree_ +_stfrek_ +_stfrfr_ +_stfrgb_ +_stfrne_ +_stfupr_ +_stfwfr_ +_stfwgb_ +_sthash_ +_sthead_ +_stinfo_ +_stkmkg_ +_stmark_ +_stname_ +_stnext_ +_stnsys_ +_stopen_ +_stpstr_ +_strcle_ +_strdic_ +_strefb_ +_streff_ +_streq_ +_strese_ +_strge_ +_strgt_ +_strids_ +_stridx_ +_strlds_ +_strldx_ +_strle_ +_strlt_ +_strlwr_ +_strmac_ +_strmah_ +_strncp_ +_strne_ +_stropn_ +_strpak_ +_strse1_ +_strseh_ +_strsrt_ +_strtbl_ +_strupk_ +_strupr_ +_stsave_ +_stsize_ +_stsque_ +_sttyco_ +_sttyet_ +_sttygg_ +_sttynm_ +_sttyse_ +_sttysm_ +_sttytt_ +_syserr_ +_sysers_ +_sysged_ +_sysges_ +_sysgsg_ +_sysid_ +_sysmte_ +_syspac_ +_syspat_ +_syspte_ +_sysret_ +_syssct_ +_tsleep_ +_ttopen_ +_ttseti_ +_ttsets_ +_ttstai_ +_ttstas_ +_ttybih_ +_ttybre_ +_ttycas_ +_ttycds_ +_ttycle_ +_ttycln_ +_ttyclr_ +_ttyctl_ +_ttydee_ +_ttydey_ +_ttyeny_ +_ttyexs_ +_ttyfey_ +_ttyfiy_ +_ttygds_ +_ttygeb_ +_ttygei_ +_ttyger_ +_ttyges_ +_ttygoo_ +_ttygpe_ +_ttygse_ +_ttyins_ +_ttyint_ +_ttylod_ +_ttyods_ +_ttyopn_ +_ttypue_ +_ttypus_ +_ttyred_ +_ttysce_ +_ttysei_ +_ttyso_ +_ttysti_ +_ttysui_ +_ttywre_ +_ungete_ +_ungeti_ +_unread_ +_urand_ +_vfnadd_ +_vfncle_ +_vfndee_ +_vfndel_ +_vfnene_ +_vfnenr_ +_vfnexr_ +_vfngen_ +_vfnise_ +_vfnman_ +_vfnmap_ +_vfnmau_ +_vfnopn_ +_vfnsqe_ +_vfntre_ +_vfnunn_ +_vfnunp_ +_vlibinit_ +_vmallc_ +_vvfncm_ +_vvfnee_ +_vvfnip_ +_vvfnis_ +_vvfnre_ +_wfarcd_ +_wfarct_ +_wfarcv_ +_wfdecs_ +_wffnld_ +_wfglsd_ +_wfglst_ +_wfglsv_ +_wfinit_ +_wfmspd_ +_wfmspf_ +_wfmspi_ +_wfmspl_ +_wfmspt_ +_wfmspv_ +_wfmspy_ +_wfsind_ +_wfsint_ +_wfsinv_ +_wfsmph_ +_wfsmpn_ +_wfsmpt_ +_wftand_ +_wftant_ +_wftanv_ +_xalloe_ +_xcallc_ +_xdeale_ +_xdevor_ +_xdevss_ +_xeract_ +_xerfmg_ +_xerpop_ +_xerpsh_ +_xerpsr_ +_xerpuc_ +_xerpue_ +_xerret_ +_xerror_ +_xersel_ +_xervey_ +_xevadg_ +_xevbip_ +_xevbop_ +_xevcan_ +_xever1_ +_xever2_ +_xeverr_ +_xevfrp_ +_xevgek_ +_xevinp_ +_xevmap_ +_xevnee_ +_xevpae_ +_xevpah_ +_xevqut_ +_xevstt_ +_xevunp_ +_xfaccs_ +_xfatal_ +_xfchdr_ +_xfcloe_ +_xfdele_ +_xffluh_ +_xfgetc_ +_xfgetr_ +_xfnote_ +_xfopen_ +_xfputc_ +_xfputr_ +_xfread_ +_xfrnam_ +_xfscan_ +_xfseek_ +_xfungc_ +_xfwrie_ +_xgdevt_ +_xgtpid_ +_xgtuid_ +_xisaty_ +_xmallc_ +_xmfree_ +_xmjbuf_ +_xmktep_ +_xonerr_ +_xonext_ +_xori_ +_xorl_ +_xors_ +_xpages_ +_xprinf_ +_xqsort_ +_xrealc_ +_xsizef_ +_xstdeh_ +_xstrcp_ +_xstrct_ +_xstrcy_ +_xstrln_ +_xtoc_ +_xttyse_ +_xwhen_ +_xxscan_ +_zardbf_ +_zardgd_ +_zardks_ +_zardlp_ +_zardmt_ +_zardnu_ +_zardpl_ +_zardpr_ +_zardps_ +_zardsf_ +_zawrbf_ +_zawrgd_ +_zawrks_ +_zawrlp_ +_zawrmt_ +_zawrnu_ +_zawrpl_ +_zawrpr_ +_zawrps_ +_zawrsf_ +_zawset_ +_zawtbf_ +_zawtgd_ +_zawtks_ +_zawtlp_ +_zawtmt_ +_zawtnu_ +_zawtpl_ +_zawtpr_ +_zawtps_ +_zawtsf_ +_zclcpr_ +_zcldir_ +_zcldpr_ +_zclm70_ +_zclm75_ +_zclsbf_ +_zclsgd_ +_zclsks_ +_zclslp_ +_zclsmt_ +_zclsnu_ +_zclspl_ +_zclsps_ +_zclssf_ +_zclstt_ +_zclstx_ +_zclsty_ +_zdojmp_ +_zdvall_ +_zdvown_ +_zfacss_ +_zfaloc_ +_zfchdr_ +_zfdele_ +_zfgcwd_ +_zfinfo_ +_zflsnu_ +_zflstt_ +_zflstx_ +_zflsty_ +_zfmkcp_ +_zfmkdr_ +_zfnbrk_ +_zfpath_ +_zfprot_ +_zfrnam_ +_zfsubd_ +_zfxdir_ +_zgcmdl_ +_zgetnu_ +_zgettt_ +_zgettx_ +_zgetty_ +_zgfdir_ +_zghost_ +_zgtime_ +_zgtpid_ +_zintpr_ +_zlocpr_ +_zlocva_ +_zmaloc_ +_zmfree_ +_znotnu_ +_znottt_ +_znottx_ +_znotty_ +_zopcpr_ +_zopdir_ +_zopdpr_ +_zopm70_ +_zopm75_ +_zopnbf_ +_zopngd_ +_zopnks_ +_zopnlp_ +_zopnmt_ +_zopnnu_ +_zopnpl_ +_zopnsf_ +_zopntt_ +_zopntx_ +_zopnty_ +_zoscmd_ +_zpanic_ +_zputnu_ +_zputtt_ +_zputtx_ +_zputty_ +_zraloc_ +_zrdm70_ +_zrdm75_ +_zseknu_ +_zsektt_ +_zsektx_ +_zsekty_ +_zsestt_ +_zsettt_ +_zstm70_ +_zstm75_ +_zststt_ +_zsttbf_ +_zsttgd_ +_zsttks_ +_zsttlp_ +_zsttmt_ +_zsttnu_ +_zsttpl_ +_zsttpr_ +_zsttps_ +_zsttsf_ +_zstttt_ +_zstttx_ +_zsttty_ +_zsvjmp_ +_zttgeg_ +_zttger_ +_zttloe_ +_zttloo_ +_zttlov_ +_zttpbf_ +_zttplk_ +_zttpug_ +_zttquy_ +_zttttt_ +_zttupe_ +_zwmsec_ +_zwrm70_ +_zwrm75_ +_zwtm70_ +_zwtm75_ +_zxgmes_ +_zxwhen_ +_zzclmt_ +_zzopmt_ +_zzrdii_ +_zzrdmt_ +_zzrwmt_ +_zzsetk_ +_zzstmt_ +_zzwrii_ +_zzwrmt_ +_zzwtmt_ +_zzzend_ +_mwshow_ +_onerre_ +_onexie_ +_glbmip_ +_mwmkir_ +_mtclen_ +_gimcor_ +_gimcrr_ +_gimder_ +_gimeng_ +_gimgeg_ +_gimins_ +_gimlop_ +_gimqur_ +_gimrat_ +_gimreg_ +_gimrep_ +_gimres_ +_gimrex_ +_gimseg_ +_gimser_ +_gimwrp_ +_gimwrs_ +_gkiwee_ +_gmprif_ +_gmsg_ +_gmsgb_ +_gmsgc_ +_gmsgd_ +_gmsgi_ +_gmsgl_ +_gmsgr_ +_gmsgs_ +_gmsgx_ +_gopeni_ +_aselkc_ +_aselkd_ +_aselki_ +_aselkl_ +_aselkr_ +_aselks_ +_aselkx_ +_clcloe_ +_evvexr_ +_evvfre_ +_gimdig_ +_gimfrg_ +_gimfrp_ +_gimiod_ +_gimioe_ +_gimsex_ +_ndopen_ +_xvvadg_ +_xvvbip_ +_xvvbop_ +_xvvcan_ +_xvvche_ +_xvver1_ +_xvver2_ +_xvverr_ +_xvvfrp_ +_xvvgek_ +_xvvinp_ +_xvvlos_ +_xvvmap_ +_xvvnee_ +_xvvnud_ +_xvvnui_ +_xvvnul_ +_xvvnur_ +_xvvnus_ +_xvvpae_ +_xvvpah_ +_xvvqut_ +_xvvstt_ +_xvvunp_ +_zardnd_ +_zawrnd_ +_zawtnd_ +_zclsnd_ +_zopnnd_ +_zsttnd_ +_kimape_ +_xerpoi_ diff --git a/unix/shlib/S.nm.generic b/unix/shlib/S.nm.generic new file mode 100644 index 00000000..e69de29b diff --git a/unix/shlib/S.nm.i386 b/unix/shlib/S.nm.i386 new file mode 100644 index 00000000..9f3f4b82 --- /dev/null +++ b/unix/shlib/S.nm.i386 @@ -0,0 +1,2440 @@ +aabsd_ +aabsi_ +aabsl_ +aabsr_ +aabss_ +aabsx_ +aaddd_ +aaddi_ +aaddkd_ +aaddki_ +aaddkl_ +aaddkr_ +aaddks_ +aaddkx_ +aaddl_ +aaddr_ +aadds_ +aaddx_ +aandi_ +aandki_ +aandkl_ +aandks_ +aandl_ +aands_ +aavgd_ +aavgi_ +aavgl_ +aavgr_ +aavgs_ +aavgx_ +abavd_ +abavi_ +abavl_ +abavr_ +abavs_ +abavx_ +abeqc_ +abeqd_ +abeqi_ +abeqkc_ +abeqkd_ +abeqki_ +abeqkl_ +abeqkr_ +abeqks_ +abeqkx_ +abeql_ +abeqr_ +abeqs_ +abeqx_ +abgec_ +abged_ +abgei_ +abgekc_ +abgekd_ +abgeki_ +abgekl_ +abgekr_ +abgeks_ +abgekx_ +abgel_ +abger_ +abges_ +abgex_ +abgtc_ +abgtd_ +abgti_ +abgtkc_ +abgtkd_ +abgtki_ +abgtkl_ +abgtkr_ +abgtks_ +abgtkx_ +abgtl_ +abgtr_ +abgts_ +abgtx_ +ablec_ +abled_ +ablei_ +ablekc_ +ablekd_ +ableki_ +ablekl_ +ablekr_ +ableks_ +ablekx_ +ablel_ +abler_ +ables_ +ablex_ +abltc_ +abltd_ +ablti_ +abltkc_ +abltkd_ +abltki_ +abltkl_ +abltkr_ +abltks_ +abltkx_ +abltl_ +abltr_ +ablts_ +abltx_ +abnec_ +abned_ +abnei_ +abnekc_ +abnekd_ +abneki_ +abnekl_ +abnekr_ +abneks_ +abnekx_ +abnel_ +abner_ +abnes_ +abnex_ +abori_ +aborki_ +aborkl_ +aborks_ +aborl_ +abors_ +absud_ +absui_ +absul_ +absur_ +absus_ +acht_ +achtb_ +achtbb_ +achtbc_ +achtbd_ +achtbi_ +achtbl_ +achtbr_ +achtbs_ +achtbu_ +achtbx_ +achtc_ +achtcb_ +achtcc_ +achtcd_ +achtci_ +achtcl_ +achtcr_ +achtcs_ +achtcu_ +achtcx_ +achtd_ +achtdb_ +achtdc_ +achtdd_ +achtdi_ +achtdl_ +achtdr_ +achtds_ +achtdu_ +achtdx_ +achti_ +achtib_ +achtic_ +achtid_ +achtii_ +achtil_ +achtir_ +achtis_ +achtiu_ +achtix_ +achtl_ +achtlb_ +achtlc_ +achtld_ +achtli_ +achtll_ +achtlr_ +achtls_ +achtlu_ +achtlx_ +achtr_ +achtrb_ +achtrc_ +achtrd_ +achtri_ +achtrl_ +achtrr_ +achtrs_ +achtru_ +achtrx_ +achts_ +achtsb_ +achtsc_ +achtsd_ +achtsi_ +achtsl_ +achtsr_ +achtss_ +achtsu_ +achtsx_ +achtu_ +achtub_ +achtuc_ +achtud_ +achtui_ +achtul_ +achtur_ +achtus_ +achtuu_ +achtux_ +achtx_ +achtxb_ +achtxc_ +achtxd_ +achtxi_ +achtxl_ +achtxr_ +achtxs_ +achtxu_ +achtxx_ +acjgx_ +aclrb_ +aclrc_ +aclrd_ +aclri_ +aclrl_ +aclrr_ +aclrs_ +aclrx_ +acnvd_ +acnvi_ +acnvl_ +acnvr_ +acnvrd_ +acnvri_ +acnvrl_ +acnvrr_ +acnvrs_ +acnvs_ +adivd_ +adivi_ +adivkd_ +adivki_ +adivkl_ +adivkr_ +adivks_ +adivkx_ +adivl_ +adivr_ +adivs_ +adivx_ +adotd_ +adoti_ +adotl_ +adotr_ +adots_ +adotx_ +advzd_ +advzi_ +advzl_ +advzr_ +advzs_ +advzx_ +aelogd_ +aelogr_ +aexpd_ +aexpi_ +aexpkd_ +aexpki_ +aexpkl_ +aexpkr_ +aexpks_ +aexpkx_ +aexpl_ +aexpr_ +aexps_ +aexpx_ +afftrr_ +afftrx_ +afftxr_ +afftxx_ +agltc_ +agltd_ +aglti_ +agltl_ +agltr_ +aglts_ +agltx_ +ahgmc_ +ahgmd_ +ahgmi_ +ahgml_ +ahgmr_ +ahgms_ +ahivc_ +ahivd_ +ahivi_ +ahivl_ +ahivr_ +ahivs_ +ahivx_ +aiftrr_ +aiftrx_ +aiftxr_ +aiftxx_ +aimgd_ +aimgi_ +aimgl_ +aimgr_ +aimgs_ +alimc_ +alimd_ +alimi_ +aliml_ +alimr_ +alims_ +alimx_ +allnd_ +allni_ +allnl_ +allnr_ +allns_ +allnx_ +alogd_ +alogi_ +alogl_ +alogr_ +alogs_ +alogx_ +alovc_ +alovd_ +alovi_ +alovl_ +alovr_ +alovs_ +alovx_ +altad_ +altai_ +altal_ +altar_ +altas_ +altax_ +altmd_ +altmi_ +altml_ +altmr_ +altms_ +altmx_ +altrd_ +altri_ +altrl_ +altrr_ +altrs_ +altrx_ +aluid_ +aluii_ +aluil_ +aluir_ +aluis_ +alutc_ +alutd_ +aluti_ +alutl_ +alutr_ +aluts_ +amagd_ +amagi_ +amagl_ +amagr_ +amags_ +amagx_ +amapd_ +amapi_ +amapl_ +amapr_ +amaps_ +amaxc_ +amaxd_ +amaxi_ +amaxkc_ +amaxkd_ +amaxki_ +amaxkl_ +amaxkr_ +amaxks_ +amaxkx_ +amaxl_ +amaxr_ +amaxs_ +amaxx_ +amed3c_ +amed3d_ +amed3i_ +amed3l_ +amed3r_ +amed3s_ +amed4c_ +amed4d_ +amed4i_ +amed4l_ +amed4r_ +amed4s_ +amed5c_ +amed5d_ +amed5i_ +amed5l_ +amed5r_ +amed5s_ +amedc_ +amedd_ +amedi_ +amedl_ +amedr_ +ameds_ +amedx_ +amgsd_ +amgsi_ +amgsl_ +amgsr_ +amgss_ +amgsx_ +aminc_ +amind_ +amini_ +aminkc_ +aminkd_ +aminki_ +aminkl_ +aminkr_ +aminks_ +aminkx_ +aminl_ +aminr_ +amins_ +aminx_ +amodd_ +amodi_ +amodkd_ +amodki_ +amodkl_ +amodkr_ +amodks_ +amodl_ +amodr_ +amods_ +amovc_ +amovd_ +amovi_ +amovkc_ +amovkd_ +amovki_ +amovkl_ +amovkr_ +amovks_ +amovkx_ +amovl_ +amovr_ +amovs_ +amovx_ +amuld_ +amuli_ +amulkd_ +amulki_ +amulkl_ +amulkr_ +amulks_ +amulkx_ +amull_ +amulr_ +amuls_ +amulx_ +andi_ +andl_ +ands_ +anegd_ +anegi_ +anegl_ +anegr_ +anegs_ +anegx_ +anoti_ +anotl_ +anots_ +apkxd_ +apkxi_ +apkxl_ +apkxr_ +apkxs_ +apkxx_ +apold_ +apolr_ +apowd_ +apowi_ +apowkd_ +apowki_ +apowkl_ +apowkr_ +apowks_ +apowkx_ +apowl_ +apowr_ +apows_ +apowx_ +aravd_ +aravi_ +aravl_ +aravr_ +aravs_ +aravx_ +arcpd_ +arcpi_ +arcpl_ +arcpr_ +arcps_ +arcpx_ +arczd_ +arczi_ +arczl_ +arczr_ +arczs_ +arczx_ +aread_ +areadb_ +argtd_ +argti_ +argtl_ +argtr_ +argts_ +argtx_ +arltd_ +arlti_ +arltl_ +arltr_ +arlts_ +arltx_ +aselc_ +aseld_ +aseli_ +asell_ +aselr_ +asels_ +aselx_ +asokc_ +asokd_ +asoki_ +asokl_ +asokr_ +asoks_ +asokx_ +asqrd_ +asqri_ +asqrl_ +asqrr_ +asqrs_ +asqrx_ +asrtc_ +asrtd_ +asrti_ +asrtl_ +asrtr_ +asrts_ +asrtx_ +assqd_ +assqi_ +assql_ +assqr_ +assqs_ +assqx_ +asubd_ +asubi_ +asubkd_ +asubki_ +asubkl_ +asubkr_ +asubks_ +asubkx_ +asubl_ +asubr_ +asubs_ +asubx_ +asumd_ +asumi_ +asuml_ +asumr_ +asums_ +asumx_ +aupxd_ +aupxi_ +aupxl_ +aupxr_ +aupxs_ +aupxx_ +aveqc_ +aveqd_ +aveqi_ +aveql_ +aveqr_ +aveqs_ +aveqx_ +await_ +awaitb_ +awritb_ +awrite_ +awsud_ +awsui_ +awsul_ +awsur_ +awsus_ +awsux_ +awvgd_ +awvgi_ +awvgl_ +awvgr_ +awvgs_ +awvgx_ +axori_ +axorki_ +axorkl_ +axorks_ +axorl_ +axors_ +begmem_ +bitmov_ +bitpak_ +bitupk_ +brktie_ +bswap2_ +bswap4_ +bswap8_ +btoi_ +bytmov_ +cctoc_ +chdept_ +chfeth_ +chrlwr_ +chrpak_ +chrupk_ +chrupr_ +clcenr_ +clcfeh_ +clcfid_ +clcfre_ +clcint_ +clcmak_ +clcmd_ +clcmdw_ +clcnek_ +clcpst_ +clgcur_ +clgetb_ +clgetc_ +clgetd_ +clgeti_ +clgetl_ +clgetr_ +clgets_ +clgetx_ +clgfil_ +clgkey_ +clglpb_ +clglpc_ +clglpd_ +clglpi_ +clglpl_ +clglpr_ +clglps_ +clglpx_ +clglsr_ +clgpsb_ +clgpsc_ +clgpsd_ +clgpsi_ +clgpsl_ +clgpsr_ +clgpss_ +clgpst_ +clgpsx_ +clgstr_ +clgwrd_ +clktie_ +clopen_ +clopst_ +clpcls_ +clplen_ +clpopi_ +clpops_ +clpopu_ +clppsb_ +clppsc_ +clppsd_ +clppsi_ +clppsl_ +clppsr_ +clppss_ +clppst_ +clppsx_ +clprew_ +clprif_ +clpsee_ +clpsit_ +clpstr_ +clputb_ +clputc_ +clputd_ +clputi_ +clputl_ +clputr_ +clputs_ +clputx_ +clreqr_ +clscan_ +clseti_ +clstai_ +cnvdae_ +cnvtie_ +coerce_ +cputie_ +ctocc_ +ctod_ +ctoi_ +ctol_ +ctor_ +ctotok_ +ctowrd_ +ctox_ +d1mach_ +deletg_ +diropn_ +dtcscl_ +dtoc3_ +dtoc_ +elogd_ +elogr_ +envfid_ +envfit_ +envfre_ +envgeb_ +envged_ +envgei_ +envger_ +envges_ +envinr_ +envint_ +envlit_ +envmak_ +envnet_ +envpus_ +envret_ +envscn_ +eprinf_ +erract_ +errcoe_ +errget_ +evexpr_ +f77pak_ +f77upk_ +falloc_ +fatal_ +fcanpb_ +fchdir_ +fcldir_ +fclobr_ +fcopy_ +fcopyo_ +fdebug_ +fdevbf_ +fdevbk_ +fdevtx_ +fdirne_ +fexbuf_ +ffa_ +ffault_ +ffilbf_ +ffilsz_ +ffldir_ +fflsbf_ +ffs_ +fft842_ +fgdev0_ +fgdevm_ +fgetfd_ +fgtdir_ +filbuf_ +filerr_ +filopn_ +finfo_ +finit_ +fioclp_ +fioqfh_ +fixmem_ +flsbuf_ +fmaccs_ +fmapfn_ +fmcloe_ +fmcopo_ +fmcopy_ +fmdebg_ +fmdele_ +fmfcdg_ +fmfcfe_ +fmfcit_ +fmfcsc_ +fmfinf_ +fmfopn_ +fmgetd_ +fmiobd_ +fmioed_ +fmioek_ +fmiopr_ +fmiorr_ +fmiosf_ +fmiotk_ +fmkbfs_ +fmkcoy_ +fmkdir_ +fmkpbf_ +fmlfad_ +fmlfae_ +fmlfat_ +fmlfbd_ +fmlfbe_ +fmlfbt_ +fmlfce_ +fmlfcy_ +fmlfde_ +fmlfne_ +fmlfon_ +fmlfpe_ +fmlfsi_ +fmlfst_ +fmlfue_ +fmlocd_ +fmloct_ +fmnexe_ +fmopen_ +fmrebd_ +fmrene_ +fmretd_ +fmseti_ +fmstai_ +fmsync_ +fmterr_ +fmtint_ +fmtred_ +fmtsel_ +fmtstr_ +fmunlk_ +fnextn_ +fnldir_ +fnroot_ +fntclb_ +fntcls_ +fntdir_ +fntedt_ +fntget_ +fntgfb_ +fntgfn_ +fntleb_ +fntmkt_ +fntopb_ +fntopn_ +fntopt_ +fntreb_ +fntree_ +fntrfb_ +fnulle_ +fopdir_ +fopnbf_ +fopntx_ +fowner_ +fpathe_ +fpequd_ +fpequr_ +fpfixd_ +fpfixr_ +fpnonr_ +fpnord_ +fpnorr_ +fpradv_ +fprfmt_ +fprinf_ +fprntf_ +fptdir_ +fputtx_ +freadp_ +fredio_ +fredir_ +frenae_ +frmbfs_ +frmtmp_ +frtnfd_ +fscan_ +fsetev_ +fsetfd_ +fseti_ +fsfdee_ +fsfgee_ +fsfopn_ +fskdir_ +fstati_ +fstatl_ +fstats_ +fstdfe_ +fstdir_ +fstrfp_ +fsvtfn_ +fswapd_ +fwatio_ +fwritp_ +fwtacc_ +gactie_ +gadraw_ +gamove_ +gargb_ +gargc_ +gargd_ +gargi_ +gargl_ +gargr_ +gargrd_ +gargs_ +gargsr_ +gargtk_ +gargwd_ +gargx_ +gascae_ +gcancl_ +gclear_ +gclose_ +gctod_ +gctol_ +gctox_ +gctran_ +gcurps_ +gdeace_ +gescae_ +getci_ +gethot_ +getlie_ +getlle_ +getloe_ +getpid_ +getuid_ +gexflr_ +gexfls_ +gexflt_ +gfill_ +gflush_ +gframe_ +gfrint_ +ggcell_ +ggcur_ +ggetb_ +ggeti_ +ggetr_ +ggets_ +ggscae_ +ggview_ +ggwind_ +gkical_ +gkiclr_ +gkicls_ +gkides_ +gkieof_ +gkiese_ +gkiexe_ +gkifat_ +gkifen_ +gkiffh_ +gkifia_ +gkiflh_ +gkiger_ +gkiges_ +gkigey_ +gkiinl_ +gkiint_ +gkimfe_ +gkiops_ +gkiplt_ +gkipmt_ +gkipoe_ +gkipor_ +gkipuy_ +gkiree_ +gkirer_ +gkires_ +gkirey_ +gkiser_ +gkises_ +gkisul_ +gkitet_ +gkitxt_ +gkiwre_ +gkpcal_ +gkpcle_ +gkpclr_ +gkpcls_ +gkpdes_ +gkpdup_ +gkpese_ +gkpfat_ +gkpfia_ +gkpflh_ +gkpger_ +gkpges_ +gkpgey_ +gkpgrm_ +gkpinl_ +gkpmfe_ +gkpops_ +gkpplt_ +gkppmt_ +gkppoe_ +gkppor_ +gkppst_ +gkppuy_ +gkpres_ +gkpser_ +gkpses_ +gkptet_ +gkptxg_ +gkptxt_ +gkpunn_ +glabax_ +glbdrd_ +glbene_ +glbeq_ +glbfis_ +glbgek_ +glblas_ +glblob_ +glbple_ +glbsep_ +glbses_ +glbset_ +glbtin_ +glbveg_ +gline_ +gltoc_ +gmark_ +gmftie_ +gopen_ +gpagee_ +gpatme_ +gpatmh_ +gpcell_ +gplcae_ +gplcal_ +gplclb_ +gplcll_ +gplclr_ +gplclt_ +gplflh_ +gpline_ +gploto_ +gplotv_ +gplret_ +gplsee_ +gplwci_ +gpmark_ +gqvery_ +grdraw_ +grdwcs_ +greace_ +greset_ +grmove_ +grscae_ +gscan_ +gscur_ +gseti_ +gsetr_ +gsets_ +gstati_ +gstatr_ +gstats_ +gstrct_ +gstrcy_ +gstrmh_ +gstsei_ +gstser_ +gsview_ +gswind_ +gtdise_ +gtext_ +gtickr_ +gtliny_ +gtndis_ +gttyld_ +gtxset_ +gumark_ +gvline_ +gvmark_ +gwcsme_ +gwrwcs_ +i1mach_ +idbcle_ +idbfid_ +idbgeg_ +idbkwp_ +idbned_ +idbopn_ +idbpug_ +ieepad_ +ieepar_ +ieeupd_ +ieeupr_ +ieevpd_ +ieevpr_ +ieevud_ +ieevur_ +ikiacs_ +ikicle_ +ikicoy_ +ikidee_ +ikiint_ +ikildr_ +ikimke_ +ikiopn_ +ikiopx_ +ikipae_ +ikiree_ +ikiupr_ +imaccf_ +imaccs_ +imaddb_ +imaddd_ +imaddf_ +imaddi_ +imaddl_ +imaddr_ +imadds_ +imaflp_ +imalin_ +imaplv_ +imastr_ +imbln1_ +imbln2_ +imbln3_ +imbtrn_ +imcfnl_ +imcopy_ +imcssz_ +imctrt_ +imdect_ +imdele_ +imdelf_ +imdmap_ +imerr_ +imflpl_ +imflps_ +imflsd_ +imflsh_ +imflsi_ +imflsl_ +imflsr_ +imflss_ +imflsx_ +imfluh_ +imfnpy_ +imfnss_ +imgclr_ +imgetb_ +imgetc_ +imgetd_ +imgeti_ +imgetl_ +imgetr_ +imgets_ +imgfte_ +imggsc_ +imggsd_ +imggsi_ +imggsl_ +imggsr_ +imggss_ +imggsx_ +imgibf_ +imgime_ +imgl1d_ +imgl1i_ +imgl1l_ +imgl1r_ +imgl1s_ +imgl1x_ +imgl2d_ +imgl2i_ +imgl2l_ +imgl2r_ +imgl2s_ +imgl2x_ +imgl3d_ +imgl3i_ +imgl3l_ +imgl3r_ +imgl3s_ +imgl3x_ +imgnfn_ +imgnld_ +imgnli_ +imgnll_ +imgnln_ +imgnlr_ +imgnls_ +imgnlx_ +imgobf_ +imgs1d_ +imgs1i_ +imgs1l_ +imgs1r_ +imgs1s_ +imgs1x_ +imgs2d_ +imgs2i_ +imgs2l_ +imgs2r_ +imgs2s_ +imgs2x_ +imgs3d_ +imgs3i_ +imgs3l_ +imgs3r_ +imgs3s_ +imgs3x_ +imgsen_ +imgstr_ +iminie_ +imioff_ +imisec_ +imloop_ +immaky_ +immap_ +immapz_ +imnote_ +imofnl_ +imofns_ +imofnu_ +imopsf_ +impakd_ +impaki_ +impakl_ +impakr_ +impaks_ +impakx_ +impare_ +impgsd_ +impgsi_ +impgsl_ +impgsr_ +impgss_ +impgsx_ +impl1d_ +impl1i_ +impl1l_ +impl1r_ +impl1s_ +impl1x_ +impl2d_ +impl2i_ +impl2l_ +impl2r_ +impl2s_ +impl2x_ +impl3d_ +impl3i_ +impl3l_ +impl3r_ +impl3s_ +impl3x_ +impml1_ +impml2_ +impml3_ +impmlv_ +impmmo_ +impmmp_ +impmon_ +impms1_ +impms2_ +impms3_ +impmsv_ +impnld_ +impnli_ +impnll_ +impnln_ +impnlr_ +impnls_ +impnlx_ +imps1d_ +imps1i_ +imps1l_ +imps1r_ +imps1s_ +imps1x_ +imps2d_ +imps2i_ +imps2l_ +imps2r_ +imps2s_ +imps2x_ +imps3d_ +imps3i_ +imps3l_ +imps3r_ +imps3s_ +imps3x_ +impstr_ +imputb_ +imputd_ +imputh_ +imputi_ +imputl_ +imputr_ +imputs_ +imrbpx_ +imrdpx_ +imrene_ +imrmbs_ +imsamp_ +imsetf_ +imseti_ +imsetr_ +imsinb_ +imsmpl_ +imsmps_ +imsslv_ +imstai_ +imstas_ +imtcle_ +imtgem_ +imtlen_ +imtmae_ +imtopn_ +imtopp_ +imtrew_ +imtrgm_ +imunmp_ +imupkd_ +imupki_ +imupkl_ +imupkr_ +imupks_ +imupkx_ +imwbpx_ +imwrie_ +imwrpx_ +intrde_ +intree_ +intrrt_ +irafmn_ +itob_ +itoc_ +iwcare_ +iwcfis_ +iwents_ +iwfind_ +iwgbis_ +iwputr_ +iwputy_ +iwrfis_ +iwsetp_ +kardbf_ +kardgd_ +kardlp_ +kardpl_ +kardpr_ +kardsf_ +kawrbf_ +kawrgd_ +kawrlp_ +kawrpl_ +kawrpr_ +kawrsf_ +kawtbf_ +kawtgd_ +kawtlp_ +kawtpl_ +kawtpr_ +kawtsf_ +kbzard_ +kbzawr_ +kbzawt_ +kbzcls_ +kbzopn_ +kbzstt_ +kclcpr_ +kcldir_ +kcldpr_ +kclsbf_ +kclsgd_ +kclslp_ +kclspl_ +kclssf_ +kclstx_ +kclsty_ +kdvall_ +kdvown_ +kfacss_ +kfaloc_ +kfchdr_ +kfdele_ +kfgcwd_ +kfinfo_ +kflstx_ +kflsty_ +kfmkcp_ +kfmkdr_ +kfpath_ +kfprot_ +kfrnam_ +kfsubd_ +kfxdir_ +kgettx_ +kgetty_ +kgfdir_ +kicont_ +kidece_ +kience_ +kienvt_ +kierrr_ +kiexte_ +kifine_ +kiflux_ +kifman_ +kifren_ +kigetn_ +kigets_ +kignoe_ +kiinit_ +kiloce_ +kimapn_ +kintpr_ +kiopes_ +kirece_ +kisend_ +kisenv_ +kishot_ +kmallc_ +knottx_ +knotty_ +kopcpr_ +kopdir_ +kopdpr_ +kopnbf_ +kopngd_ +kopnlp_ +kopnpl_ +kopnsf_ +kopntx_ +kopnty_ +koscmd_ +kputtx_ +kputty_ +krealc_ +ksared_ +ksawat_ +ksawre_ +ksektx_ +ksekty_ +ksttbf_ +ksttgd_ +ksttlp_ +ksttpl_ +ksttpr_ +ksttsf_ +kstttx_ +ksttty_ +ktzcls_ +ktzfls_ +ktzget_ +ktznot_ +ktzopn_ +ktzput_ +ktzsek_ +ktzstt_ +kzclmt_ +kzopmt_ +kzrdmt_ +kzrwmt_ +kzwrmt_ +kzwtmt_ +lexnum_ +lnocle_ +lnofeh_ +lnoopn_ +lnosae_ +locpr_ +locva_ +lpopen_ +lpzard_ +lpzawe_ +lpzawt_ +ltoc_ +m75put_ +maideh_ +mallo1_ +mgdptr_ +mgtfwa_ +miilen_ +miinem_ +miipa2_ +miipa6_ +miipa8_ +miipad_ +miipak_ +miipar_ +miipke_ +miirec_ +miired_ +miirei_ +miirel_ +miirer_ +miires_ +miiup2_ +miiup6_ +miiup8_ +miiupd_ +miiupk_ +miiupr_ +miiwrc_ +miiwrd_ +miiwri_ +miiwrl_ +miiwrr_ +miiwrs_ +miocle_ +miogld_ +miogli_ +miogll_ +mioglr_ +miogls_ +mioglx_ +mioopn_ +mioopo_ +miopld_ +miopli_ +miopll_ +mioplr_ +miopls_ +mioplx_ +miosee_ +miosei_ +miosti_ +msvfwa_ +mtalle_ +mtclre_ +mtdeae_ +mtdevd_ +mtfile_ +mtgets_ +mtloce_ +mtopen_ +mtosdv_ +mtpare_ +mtposn_ +mtpute_ +mtreae_ +mtrewd_ +mtsavd_ +mtsavs_ +mtskid_ +mtstas_ +mtsync_ +mtupde_ +mwalld_ +mwalls_ +mwaxtn_ +mwc1td_ +mwc1tr_ +mwc2td_ +mwc2tr_ +mwcloe_ +mwcopd_ +mwcops_ +mwctfe_ +mwctrd_ +mwctrr_ +mwfins_ +mwflop_ +mwgaxp_ +mwgaxt_ +mwgctd_ +mwgctr_ +mwgltd_ +mwgltr_ +mwgwas_ +mwgwsd_ +mwgwsr_ +mwgwtd_ +mwgwtr_ +mwinvd_ +mwinvr_ +mwload_ +mwloam_ +mwltrd_ +mwltrr_ +mwlubb_ +mwlude_ +mwmkid_ +mwmmud_ +mwmmur_ +mwnewm_ +mwnewy_ +mwopem_ +mwopen_ +mwrefr_ +mwrote_ +mwsave_ +mwsavm_ +mwsaxp_ +mwscae_ +mwsctn_ +mwsdes_ +mwseti_ +mwshit_ +mwsltd_ +mwsltr_ +mwssym_ +mwstai_ +mwswas_ +mwswsd_ +mwswsr_ +mwswtd_ +mwswte_ +mwswtr_ +mwtrad_ +mwtrar_ +mwv1td_ +mwv1tr_ +mwv2td_ +mwv2tr_ +mwvmud_ +mwvmur_ +mwvtrd_ +mwvtrr_ +noti_ +notl_ +nots_ +nowhie_ +nscan_ +oifacs_ +oifcle_ +oifcoy_ +oifdee_ +oifgpe_ +oifmke_ +oifopn_ +oifopx_ +oifree_ +oifupr_ +oifwpr_ +onerrr_ +onexit_ +ord1_ +ord2_ +ori_ +orl_ +ors_ +oscmd_ +osfnik_ +osfnlk_ +osfnms_ +osfnpe_ +osfnrk_ +osfntt_ +osfnuk_ +pagefe_ +pagefs_ +pargb_ +pargc_ +pargd_ +pargg_ +pargi_ +pargl_ +pargr_ +pargs_ +pargsr_ +pargx_ +patamh_ +patfit_ +patgel_ +patgse_ +patinx_ +patloe_ +patmae_ +patmah_ +patomh_ +patsts_ +pggetd_ +pggete_ +pggetr_ +pgpage_ +pgpeed_ +pgpusd_ +pgsett_ +placcs_ +plallc_ +plascp_ +plbox_ +plcire_ +plcler_ +plcloe_ +plcome_ +plcoms_ +plcree_ +pldebg_ +pldebt_ +plempy_ +plgete_ +plglls_ +plglpi_ +plglpl_ +plglps_ +plglri_ +plglrl_ +plglrs_ +plgsie_ +pll2pi_ +pll2pl_ +pll2ps_ +pll2ri_ +pll2rl_ +pll2rs_ +pllcot_ +pllemy_ +plleql_ +plline_ +pllinl_ +pllinp_ +plliny_ +pllneg_ +plload_ +plloaf_ +plloam_ +plloop_ +pllprs_ +plnewy_ +plopen_ +plp2li_ +plp2ll_ +plp2ls_ +plp2ri_ +plp2rl_ +plp2rs_ +plpixi_ +plpixl_ +plpixs_ +plplls_ +plplpi_ +plplpl_ +plplps_ +plplri_ +plplrl_ +plplrs_ +plpoit_ +plpoln_ +plr2li_ +plr2ll_ +plr2ls_ +plr2pi_ +plr2pl_ +plr2ps_ +plrani_ +plranl_ +plrans_ +plrcle_ +plregp_ +plreqi_ +plreql_ +plreqs_ +plrget_ +plrgex_ +plrop_ +plropn_ +plrpri_ +plrprl_ +plrprs_ +plrset_ +plsave_ +plsavf_ +plsavm_ +plsect_ +plsecy_ +plsete_ +plseti_ +plssie_ +plsslv_ +plstai_ +plstel_ +plubox_ +plucie_ +plupde_ +plupon_ +plvald_ +pmaccs_ +pmascp_ +pmbox_ +pmcire_ +pmcler_ +pmempy_ +pmglls_ +pmglpi_ +pmglpl_ +pmglps_ +pmglri_ +pmglrl_ +pmglrs_ +pmline_ +pmliny_ +pmnewk_ +pmplls_ +pmplpi_ +pmplpl_ +pmplps_ +pmplri_ +pmplrl_ +pmplrs_ +pmpoit_ +pmpoln_ +pmrcle_ +pmrgex_ +pmrop_ +pmropn_ +pmrset_ +pmsect_ +pmsecy_ +pmsete_ +pmseti_ +pmstel_ +prchdr_ +prclcr_ +prcldr_ +prcloe_ +prdone_ +prdumn_ +prenve_ +prenvt_ +prfilf_ +prfinc_ +prgete_ +prgetr_ +prkill_ +pronic_ +propcr_ +propdr_ +propen_ +proscd_ +protet_ +prpsio_ +prpsld_ +prredr_ +prsigl_ +prstai_ +prupde_ +prvret_ +przclr_ +psioit_ +psioxr_ +putcc_ +putci_ +putlie_ +qmaccs_ +qmgetc_ +qmscan_ +qmscao_ +qmsetm_ +qmsets_ +qmsymb_ +qpaccf_ +qpaccs_ +qpaddb_ +qpaddc_ +qpaddd_ +qpaddf_ +qpaddi_ +qpaddl_ +qpaddr_ +qpadds_ +qpaddx_ +qpargt_ +qpastr_ +qpbind_ +qpcfnl_ +qpcloe_ +qpclot_ +qpcopf_ +qpcopy_ +qpctod_ +qpctoi_ +qpdele_ +qpdelf_ +qpdsym_ +qpdtye_ +qpelee_ +qpexcd_ +qpexce_ +qpexci_ +qpexcr_ +qpexdc_ +qpexde_ +qpexdg_ +qpexdr_ +qpexee_ +qpexfe_ +qpexgr_ +qpexmk_ +qpexmr_ +qpexon_ +qpexpd_ +qpexpi_ +qpexpn_ +qpexpr_ +qpexps_ +qpexpt_ +qpexrd_ +qpexsd_ +qpexsi_ +qpexsr_ +qpfacs_ +qpfcle_ +qpfcos_ +qpfcoy_ +qpfdee_ +qpflur_ +qpfopn_ +qpfopx_ +qpfree_ +qpfupr_ +qpfwfr_ +qpfzcl_ +qpfzop_ +qpfzrd_ +qpfzst_ +qpfzwr_ +qpfzwt_ +qpgetb_ +qpgetc_ +qpgetd_ +qpgeti_ +qpgetk_ +qpgetl_ +qpgetm_ +qpgetr_ +qpgets_ +qpgetx_ +qpgmsm_ +qpgnfn_ +qpgpsm_ +qpgstr_ +qpinht_ +qpioce_ +qpioge_ +qpiogr_ +qpiogs_ +qpiolk_ +qpiols_ +qpiomx_ +qpioon_ +qpiope_ +qpiops_ +qpiori_ +qpiors_ +qpiort_ +qpiosc_ +qpiose_ +qpiosi_ +qpiosr_ +qpiost_ +qpiowt_ +qplenf_ +qplenl_ +qploas_ +qpmkfe_ +qpnexk_ +qpofnl_ +qpofns_ +qpofnu_ +qpopen_ +qpopet_ +qppare_ +qpparl_ +qppcle_ +qppopn_ +qppstr_ +qpputb_ +qpputc_ +qpputd_ +qpputi_ +qpputl_ +qpputm_ +qpputr_ +qpputs_ +qpputx_ +qpquef_ +qprawk_ +qpread_ +qprebd_ +qprene_ +qprenf_ +qpsavs_ +qpseel_ +qpseti_ +qpsizf_ +qpstai_ +qpsync_ +qpungk_ +qpwrie_ +r1mach_ +r2tr_ +r2tx_ +r4syn_ +r4tr_ +r4tx_ +r8syn_ +r8tr_ +r8tx_ +rdukey_ +rename_ +reopen_ +resetn_ +salloc_ +scan_ +scanc_ +sfree_ +shifti_ +shiftl_ +shifts_ +smark_ +sprinf_ +sscan_ +stallc_ +stcloe_ +stentr_ +stfacs_ +stfadr_ +stfcle_ +stfcos_ +stfcoy_ +stfcte_ +stfdee_ +stfgeb_ +stfgei_ +stfgen_ +stfges_ +stfget_ +stfind_ +stfinl_ +stfins_ +stfmeb_ +stfmke_ +stfnee_ +stfopn_ +stfopx_ +stforb_ +stfrdr_ +stfree_ +stfrek_ +stfrfr_ +stfrgb_ +stfrne_ +stfupr_ +stfwfr_ +stfwgb_ +sthash_ +sthead_ +stinfo_ +stkmkg_ +stmark_ +stname_ +stnext_ +stnsys_ +stopen_ +stpstr_ +strcle_ +strdic_ +strefb_ +streff_ +streq_ +strese_ +strge_ +strgt_ +strids_ +stridx_ +strlds_ +strldx_ +strle_ +strlt_ +strlwr_ +strmac_ +strmah_ +strncp_ +strne_ +stropn_ +strpak_ +strse1_ +strseh_ +strsrt_ +strtbl_ +strupk_ +strupr_ +stsave_ +stsize_ +stsque_ +sttyco_ +sttyet_ +sttygg_ +sttynm_ +sttyse_ +sttysm_ +sttytt_ +syserr_ +sysers_ +sysged_ +sysges_ +sysgsg_ +sysid_ +sysmte_ +syspac_ +syspat_ +syspte_ +sysret_ +syssct_ +tsleep_ +ttopen_ +ttseti_ +ttsets_ +ttstai_ +ttstas_ +ttybih_ +ttybre_ +ttycas_ +ttycds_ +ttycle_ +ttycln_ +ttyclr_ +ttyctl_ +ttydee_ +ttydey_ +ttyeny_ +ttyexs_ +ttyfey_ +ttyfiy_ +ttygds_ +ttygeb_ +ttygei_ +ttyger_ +ttyges_ +ttygoo_ +ttygpe_ +ttygse_ +ttyins_ +ttyint_ +ttylod_ +ttyods_ +ttyopn_ +ttypue_ +ttypus_ +ttyred_ +ttysce_ +ttysei_ +ttyso_ +ttysti_ +ttysui_ +ttywre_ +ungete_ +ungeti_ +unread_ +urand_ +vfnadd_ +vfncle_ +vfndee_ +vfndel_ +vfnene_ +vfnenr_ +vfnexr_ +vfngen_ +vfnise_ +vfnman_ +vfnmap_ +vfnmau_ +vfnopn_ +vfnsqe_ +vfntre_ +vfnunn_ +vfnunp_ +vlibinit_ +vmallc_ +vvfncm_ +vvfnee_ +vvfnip_ +vvfnis_ +vvfnre_ +wfdecs_ +wffnld_ +wfinit_ +wfsmph_ +wfsmpn_ +wfsmpt_ +wftand_ +wftant_ +wftanv_ +xalloe_ +xcallc_ +xdeale_ +xdevor_ +xdevss_ +xeract_ +xerfmg_ +xerpop_ +xerpsh_ +xerpsr_ +xerpuc_ +xerpue_ +xerret_ +xerror_ +xersel_ +xervey_ +xevadg_ +xevbip_ +xevbop_ +xevcan_ +xever1_ +xever2_ +xeverr_ +xevfrp_ +xevgek_ +xevinp_ +xevmap_ +xevnee_ +xevpae_ +xevpah_ +xevqut_ +xevstt_ +xevunp_ +xfaccs_ +xfcloe_ +xfdele_ +xffluh_ +xfgetc_ +xfgetr_ +xfnote_ +xfopen_ +xfputc_ +xfputr_ +xfread_ +xfseek_ +xfungc_ +xfwrie_ +xgdevt_ +xisaty_ +xmallc_ +xmfree_ +xmjbuf_ +xmktep_ +xonerr_ +xonext_ +xori_ +xorl_ +xors_ +xpages_ +xprinf_ +xqsort_ +xrealc_ +xsizef_ +xstdeh_ +xstrcp_ +xstrct_ +xstrcy_ +xstrln_ +xtoc_ +xttyse_ +xwhen_ +zardbf_ +zardgd_ +zardks_ +zardlp_ +zardmt_ +zardnu_ +zardpl_ +zardpr_ +zardps_ +zardsf_ +zawrbf_ +zawrgd_ +zawrks_ +zawrlp_ +zawrmt_ +zawrnu_ +zawrpl_ +zawrpr_ +zawrps_ +zawrsf_ +zawset_ +zawtbf_ +zawtgd_ +zawtks_ +zawtlp_ +zawtmt_ +zawtnu_ +zawtpl_ +zawtpr_ +zawtps_ +zawtsf_ +zclcpr_ +zcldir_ +zcldpr_ +zclm70_ +zclm75_ +zclsbf_ +zclsgd_ +zclsks_ +zclslp_ +zclsmt_ +zclsnu_ +zclspl_ +zclsps_ +zclssf_ +zclstt_ +zclstx_ +zclsty_ +zdojmp_ +zdvall_ +zdvown_ +zfacss_ +zfaloc_ +zfchdr_ +zfdele_ +zfgcwd_ +zfinfo_ +zflsnu_ +zflstt_ +zflstx_ +zflsty_ +zfmkcp_ +zfmkdr_ +zfnbrk_ +zfpath_ +zfprot_ +zfrnam_ +zfsubd_ +zfxdir_ +zgcmdl_ +zgetnu_ +zgettt_ +zgettx_ +zgetty_ +zgfdir_ +zghost_ +zgtime_ +zgtpid_ +zintpr_ +zlocpr_ +zlocva_ +zmaloc_ +zmfree_ +znotnu_ +znottt_ +znottx_ +znotty_ +zopcpr_ +zopdir_ +zopdpr_ +zopm70_ +zopm75_ +zopnbf_ +zopngd_ +zopnks_ +zopnlp_ +zopnmt_ +zopnnu_ +zopnpl_ +zopnsf_ +zopntt_ +zopntx_ +zopnty_ +zoscmd_ +zpanic_ +zputnu_ +zputtt_ +zputtx_ +zputty_ +zraloc_ +zrdm70_ +zrdm75_ +zseknu_ +zsektt_ +zsektx_ +zsekty_ +zsestt_ +zsettt_ +zstm70_ +zstm75_ +zststt_ +zsttbf_ +zsttgd_ +zsttks_ +zsttlp_ +zsttmt_ +zsttnu_ +zsttpl_ +zsttpr_ +zsttps_ +zsttsf_ +zstttt_ +zstttx_ +zsttty_ +zsvjmp_ +zttgeg_ +zttger_ +zttloe_ +zttloo_ +zttlov_ +zttpbf_ +zttplk_ +zttpug_ +zttquy_ +zttttt_ +zttupe_ +zwmsec_ +zwrm70_ +zwrm75_ +zwtm70_ +zwtm75_ +zxgmes_ +zxwhen_ +zzclmt_ +zzfbmt_ +zzffmt_ +zzopmt_ +zzposmt_ +zzrbmt_ +zzrdii_ +zzrdmt_ +zzrfmt_ +zzrwmt_ +zzsetk_ +zzwrii_ +zzwrmt_ +zzwtmt_ +zzzend_ diff --git a/unix/shlib/S.nm.new b/unix/shlib/S.nm.new new file mode 100644 index 00000000..fb54dd3b --- /dev/null +++ b/unix/shlib/S.nm.new @@ -0,0 +1,2864 @@ +aabsd_ +aabsi_ +aabsl_ +aabsr_ +aabss_ +aabsx_ +aaddd_ +aaddi_ +aaddkd_ +aaddki_ +aaddkl_ +aaddkr_ +aaddks_ +aaddkx_ +aaddl_ +aaddr_ +aadds_ +aaddx_ +aandi_ +aandki_ +aandkl_ +aandks_ +aandl_ +aands_ +aavgd_ +aavgi_ +aavgl_ +aavgr_ +aavgs_ +aavgx_ +abavd_ +abavi_ +abavl_ +abavr_ +abavs_ +abavx_ +abeqc_ +abeqd_ +abeqi_ +abeqkc_ +abeqkd_ +abeqki_ +abeqkl_ +abeqkr_ +abeqks_ +abeqkx_ +abeql_ +abeqr_ +abeqs_ +abeqx_ +abgec_ +abged_ +abgei_ +abgekc_ +abgekd_ +abgeki_ +abgekl_ +abgekr_ +abgeks_ +abgekx_ +abgel_ +abger_ +abges_ +abgex_ +abgtc_ +abgtd_ +abgti_ +abgtkc_ +abgtkd_ +abgtki_ +abgtkl_ +abgtkr_ +abgtks_ +abgtkx_ +abgtl_ +abgtr_ +abgts_ +abgtx_ +ablec_ +abled_ +ablei_ +ablekc_ +ablekd_ +ableki_ +ablekl_ +ablekr_ +ableks_ +ablekx_ +ablel_ +abler_ +ables_ +ablex_ +abltc_ +abltd_ +ablti_ +abltkc_ +abltkd_ +abltki_ +abltkl_ +abltkr_ +abltks_ +abltkx_ +abltl_ +abltr_ +ablts_ +abltx_ +abnec_ +abned_ +abnei_ +abnekc_ +abnekd_ +abneki_ +abnekl_ +abnekr_ +abneks_ +abnekx_ +abnel_ +abner_ +abnes_ +abnex_ +abori_ +aborki_ +aborkl_ +aborks_ +aborl_ +abors_ +absud_ +absui_ +absul_ +absur_ +absus_ +acht_ +achtb_ +achtbb_ +achtbc_ +achtbd_ +achtbi_ +achtbl_ +achtbr_ +achtbs_ +achtbu_ +achtbx_ +achtc_ +achtcb_ +achtcc_ +achtcd_ +achtci_ +achtcl_ +achtcr_ +achtcs_ +achtcu_ +achtcx_ +achtd_ +achtdb_ +achtdc_ +achtdd_ +achtdi_ +achtdl_ +achtdr_ +achtds_ +achtdu_ +achtdx_ +achti_ +achtib_ +achtic_ +achtid_ +achtii_ +achtil_ +achtir_ +achtis_ +achtiu_ +achtix_ +achtl_ +achtlb_ +achtlc_ +achtld_ +achtli_ +achtll_ +achtlr_ +achtls_ +achtlu_ +achtlx_ +achtr_ +achtrb_ +achtrc_ +achtrd_ +achtri_ +achtrl_ +achtrr_ +achtrs_ +achtru_ +achtrx_ +achts_ +achtsb_ +achtsc_ +achtsd_ +achtsi_ +achtsl_ +achtsr_ +achtss_ +achtsu_ +achtsx_ +achtu_ +achtub_ +achtuc_ +achtud_ +achtui_ +achtul_ +achtur_ +achtus_ +achtuu_ +achtux_ +achtx_ +achtxb_ +achtxc_ +achtxd_ +achtxi_ +achtxl_ +achtxr_ +achtxs_ +achtxu_ +achtxx_ +acjgx_ +aclrb_ +aclrc_ +aclrd_ +aclri_ +aclrl_ +aclrr_ +aclrs_ +aclrx_ +acnvd_ +acnvi_ +acnvl_ +acnvr_ +acnvrd_ +acnvri_ +acnvrl_ +acnvrr_ +acnvrs_ +acnvs_ +adivd_ +adivi_ +adivkd_ +adivki_ +adivkl_ +adivkr_ +adivks_ +adivkx_ +adivl_ +adivr_ +adivs_ +adivx_ +adotd_ +adoti_ +adotl_ +adotr_ +adots_ +adotx_ +advzd_ +advzi_ +advzl_ +advzr_ +advzs_ +advzx_ +aelogd_ +aelogr_ +aexpd_ +aexpi_ +aexpkd_ +aexpki_ +aexpkl_ +aexpkr_ +aexpks_ +aexpkx_ +aexpl_ +aexpr_ +aexps_ +aexpx_ +afftrr_ +afftrx_ +afftxr_ +afftxx_ +agltc_ +agltd_ +aglti_ +agltl_ +agltr_ +aglts_ +agltx_ +ahgmc_ +ahgmd_ +ahgmi_ +ahgml_ +ahgmr_ +ahgms_ +ahivc_ +ahivd_ +ahivi_ +ahivl_ +ahivr_ +ahivs_ +ahivx_ +aiftrr_ +aiftrx_ +aiftxr_ +aiftxx_ +aimgd_ +aimgi_ +aimgl_ +aimgr_ +aimgs_ +alani_ +alanki_ +alankl_ +alanks_ +alanl_ +alans_ +alimc_ +alimd_ +alimi_ +aliml_ +alimr_ +alims_ +alimx_ +allnd_ +allni_ +allnl_ +allnr_ +allns_ +allnx_ +alogd_ +alogi_ +alogl_ +alogr_ +alogs_ +alogx_ +alori_ +alorki_ +alorkl_ +alorks_ +alorl_ +alors_ +alovc_ +alovd_ +alovi_ +alovl_ +alovr_ +alovs_ +alovx_ +altad_ +altai_ +altal_ +altar_ +altas_ +altax_ +altmd_ +altmi_ +altml_ +altmr_ +altms_ +altmx_ +altrd_ +altri_ +altrl_ +altrr_ +altrs_ +altrx_ +aluid_ +aluii_ +aluil_ +aluir_ +aluis_ +alutc_ +alutd_ +aluti_ +alutl_ +alutr_ +aluts_ +amagd_ +amagi_ +amagl_ +amagr_ +amags_ +amagx_ +amapd_ +amapi_ +amapl_ +amapr_ +amaps_ +amaxc_ +amaxd_ +amaxi_ +amaxkc_ +amaxkd_ +amaxki_ +amaxkl_ +amaxkr_ +amaxks_ +amaxkx_ +amaxl_ +amaxr_ +amaxs_ +amaxx_ +amed3c_ +amed3d_ +amed3i_ +amed3l_ +amed3r_ +amed3s_ +amed4c_ +amed4d_ +amed4i_ +amed4l_ +amed4r_ +amed4s_ +amed5c_ +amed5d_ +amed5i_ +amed5l_ +amed5r_ +amed5s_ +amedc_ +amedd_ +amedi_ +amedl_ +amedr_ +ameds_ +amedx_ +amgsd_ +amgsi_ +amgsl_ +amgsr_ +amgss_ +amgsx_ +aminc_ +amind_ +amini_ +aminkc_ +aminkd_ +aminki_ +aminkl_ +aminkr_ +aminks_ +aminkx_ +aminl_ +aminr_ +amins_ +aminx_ +amodd_ +amodi_ +amodkd_ +amodki_ +amodkl_ +amodkr_ +amodks_ +amodl_ +amodr_ +amods_ +amovc_ +amovd_ +amovi_ +amovkc_ +amovkd_ +amovki_ +amovkl_ +amovkr_ +amovks_ +amovkx_ +amovl_ +amovr_ +amovs_ +amovx_ +amuld_ +amuli_ +amulkd_ +amulki_ +amulkl_ +amulkr_ +amulks_ +amulkx_ +amull_ +amulr_ +amuls_ +amulx_ +andi_ +andl_ +ands_ +anegd_ +anegi_ +anegl_ +anegr_ +anegs_ +anegx_ +anoti_ +anotl_ +anots_ +apkxd_ +apkxi_ +apkxl_ +apkxr_ +apkxs_ +apkxx_ +apold_ +apolr_ +apowd_ +apowi_ +apowkd_ +apowki_ +apowkl_ +apowkr_ +apowks_ +apowkx_ +apowl_ +apowr_ +apows_ +apowx_ +aravd_ +aravi_ +aravl_ +aravr_ +aravs_ +aravx_ +arcpd_ +arcpi_ +arcpl_ +arcpr_ +arcps_ +arcpx_ +arczd_ +arczi_ +arczl_ +arczr_ +arczs_ +arczx_ +aread_ +areadb_ +argtd_ +argti_ +argtl_ +argtr_ +argts_ +argtx_ +arltd_ +arlti_ +arltl_ +arltr_ +arlts_ +arltx_ +aselc_ +aseld_ +aseli_ +aselkc_ +aselkd_ +aselki_ +aselkl_ +aselkr_ +aselks_ +aselkx_ +asell_ +aselr_ +asels_ +aselx_ +asokc_ +asokd_ +asoki_ +asokl_ +asokr_ +asoks_ +asokx_ +asqrd_ +asqri_ +asqrl_ +asqrr_ +asqrs_ +asqrx_ +asrtc_ +asrtd_ +asrti_ +asrtl_ +asrtr_ +asrts_ +asrtx_ +assqd_ +assqi_ +assql_ +assqr_ +assqs_ +assqx_ +asubd_ +asubi_ +asubkd_ +asubki_ +asubkl_ +asubkr_ +asubks_ +asubkx_ +asubl_ +asubr_ +asubs_ +asubx_ +asumd_ +asumi_ +asuml_ +asumr_ +asums_ +asumx_ +aupxd_ +aupxi_ +aupxl_ +aupxr_ +aupxs_ +aupxx_ +aveqc_ +aveqd_ +aveqi_ +aveql_ +aveqr_ +aveqs_ +aveqx_ +await_ +awaitb_ +awritb_ +awrite_ +awsud_ +awsui_ +awsul_ +awsur_ +awsus_ +awsux_ +awvgd_ +awvgi_ +awvgl_ +awvgr_ +awvgs_ +awvgx_ +axori_ +axorki_ +axorkl_ +axorks_ +axorl_ +axors_ +begmem_ +bitmov_ +bitpak_ +bitupk_ +brktie_ +bswap2_ +bswap4_ +bswap8_ +btoi_ +bytmov_ +cctoc_ +chdept_ +chfeth_ +chrlwr_ +chrpak_ +chrupk_ +chrupr_ +clccos_ +clcenr_ +clcfeh_ +clcfid_ +clcfre_ +clcint_ +clclit_ +clcloe_ +clcmak_ +clcmd_ +clcmdw_ +clcnek_ +clcpst_ +clcscn_ +clepst_ +clgcur_ +clgetb_ +clgetc_ +clgetd_ +clgeti_ +clgetl_ +clgetr_ +clgets_ +clgetx_ +clgfil_ +clgkey_ +clglpb_ +clglpc_ +clglpd_ +clglpi_ +clglpl_ +clglpr_ +clglps_ +clglpx_ +clglsr_ +clgpsa_ +clgpsb_ +clgpsc_ +clgpsd_ +clgpsi_ +clgpsl_ +clgpsr_ +clgpss_ +clgpst_ +clgpsx_ +clgstr_ +clgwrd_ +clktie_ +cllpst_ +clopen_ +clopst_ +clpcls_ +clplen_ +clpopi_ +clpops_ +clpopu_ +clppsa_ +clppsb_ +clppsc_ +clppsd_ +clppsi_ +clppsl_ +clppsr_ +clppss_ +clppst_ +clppsx_ +clprew_ +clprif_ +clpsee_ +clpsit_ +clpstr_ +clputb_ +clputc_ +clputd_ +clputi_ +clputl_ +clputr_ +clputs_ +clputx_ +clreqr_ +clscan_ +clseti_ +clstai_ +cnvdae_ +cnvtie_ +coerce_ +cputie_ +ctocc_ +ctod_ +ctoi_ +ctol_ +ctor_ +ctotok_ +ctowrd_ +ctox_ +d1mach_ +deletg_ +diropn_ +dtcscl_ +dtmday_ +dtmdee_ +dtmdes_ +dtmene_ +dtmens_ +dtmlte_ +dtoc3_ +dtoc_ +elogd_ +elogr_ +envfid_ +envfit_ +envfre_ +envgeb_ +envged_ +envgei_ +envger_ +envges_ +envinr_ +envint_ +envlit_ +envmak_ +envnet_ +envpus_ +envret_ +envscn_ +eprinf_ +erract_ +errcoe_ +errget_ +evexpr_ +evvexr_ +evvfre_ +f77pak_ +f77upk_ +falloc_ +fcanpb_ +fcldir_ +fclobr_ +fcopy_ +fcopyo_ +fdebug_ +fdevbf_ +fdevbk_ +fdevtx_ +fdirne_ +fexbuf_ +ffa_ +ffault_ +ffilbf_ +ffilsz_ +ffldir_ +fflsbf_ +ffs_ +fft842_ +fgdev0_ +fgdevm_ +fgetfd_ +fgtdir_ +filbuf_ +filerr_ +filopn_ +finfo_ +finit_ +fioclp_ +fioqfh_ +fixmem_ +flsbuf_ +fmaccs_ +fmapfn_ +fmcloe_ +fmcopo_ +fmcopy_ +fmdebg_ +fmdele_ +fmfcdg_ +fmfcfe_ +fmfcit_ +fmfcsc_ +fmfinf_ +fmfopn_ +fmgetd_ +fmiobd_ +fmioed_ +fmioek_ +fmiopr_ +fmiorr_ +fmiosf_ +fmiotk_ +fmkbfs_ +fmkcoy_ +fmkdir_ +fmkpbf_ +fmlfad_ +fmlfae_ +fmlfat_ +fmlfbd_ +fmlfbe_ +fmlfbt_ +fmlfce_ +fmlfcy_ +fmlfde_ +fmlfne_ +fmlfon_ +fmlfpe_ +fmlfsi_ +fmlfst_ +fmlfue_ +fmlocd_ +fmloct_ +fmnexe_ +fmopen_ +fmrebd_ +fmrene_ +fmretd_ +fmseti_ +fmstai_ +fmsync_ +fmterr_ +fmtint_ +fmtred_ +fmtsel_ +fmtstr_ +fmunlk_ +fnextn_ +fnldir_ +fnroot_ +fntclb_ +fntcls_ +fntdir_ +fntedt_ +fntget_ +fntgfb_ +fntgfn_ +fntleb_ +fntmkt_ +fntopb_ +fntopn_ +fntopt_ +fntreb_ +fntree_ +fntrfb_ +fnulle_ +fopdir_ +fopnbf_ +fopntx_ +fowner_ +fpathe_ +fpequd_ +fpequr_ +fpfixd_ +fpfixr_ +fpnonr_ +fpnord_ +fpnorr_ +fpradv_ +fprfmt_ +fprinf_ +fprntf_ +fptdir_ +fputtx_ +freadp_ +fredio_ +fredir_ +frenae_ +frmbfs_ +frmtmp_ +frtnfd_ +fsetev_ +fsetfd_ +fseti_ +fsfdee_ +fsfgee_ +fsfopn_ +fskdir_ +fstati_ +fstatl_ +fstats_ +fstdfe_ +fstdir_ +fstrfp_ +fsvtfn_ +fswapd_ +futime_ +fwatio_ +fwritp_ +fwtacc_ +fxfacp_ +fxfacs_ +fxfact_ +fxfadr_ +fxfakb_ +fxfakc_ +fxfakd_ +fxfaki_ +fxfakr_ +fxfalc_ +fxfald_ +fxfalr_ +fxfalu_ +fxfasr_ +fxfbls_ +fxfbyt_ +fxfche_ +fxfchm_ +fxfchp_ +fxfchv_ +fxfcle_ +fxfcll_ +fxfcnx_ +fxfcoj_ +fxfcoy_ +fxfcte_ +fxfdae_ +fxfdee_ +fxfdiw_ +fxfdur_ +fxfenb_ +fxfenc_ +fxfend_ +fxfene_ +fxfeni_ +fxfenl_ +fxfenr_ +fxfens_ +fxfexh_ +fxfexr_ +fxffac_ +fxffcr_ +fxffiw_ +fxffog_ +fxffpd_ +fxfgas_ +fxfgeb_ +fxfged_ +fxfgei_ +fxfgen_ +fxfger_ +fxfget_ +fxfglm_ +fxfgsr_ +fxfhdt_ +fxfhee_ +fxfhef_ +fxfint_ +fxfisk_ +fxfkse_ +fxfksl_ +fxfksm_ +fxfksn_ +fxfkss_ +fxfkst_ +fxfksx_ +fxflor_ +fxfmad_ +fxfmar_ +fxfmas_ +fxfmay_ +fxfmea_ +fxfnoe_ +fxfnul_ +fxfopn_ +fxfopx_ +fxfove_ +fxfovt_ +fxfpaa_ +fxfpld_ +fxfple_ +fxfplf_ +fxfplo_ +fxfplp_ +fxfprr_ +fxfred_ +fxfree_ +fxfrek_ +fxfren_ +fxfrep_ +fxfrfr_ +fxfrhr_ +fxfsee_ +fxfsev_ +fxfsex_ +fxfskn_ +fxfstr_ +fxftox_ +fxfuad_ +fxfuna_ +fxfupd_ +fxfupr_ +fxfwrr_ +fxfwrs_ +fxfxal_ +fxfxhd_ +fxfxn1_ +fxfzcl_ +fxfzop_ +fxfzrd_ +fxfzst_ +fxfzwr_ +fxfzwt_ +gactie_ +gadraw_ +gamove_ +gargb_ +gargc_ +gargd_ +gargi_ +gargl_ +gargr_ +gargrd_ +gargs_ +gargsr_ +gargtk_ +gargwd_ +gargx_ +gascae_ +gcancl_ +gclear_ +gclose_ +gctod_ +gctol_ +gctox_ +gctran_ +gcurps_ +gdeace_ +gescae_ +getci_ +gethot_ +getlie_ +getlle_ +getloe_ +gexflr_ +gexfls_ +gexflt_ +gfill_ +gflush_ +gframe_ +gfrint_ +ggcell_ +ggcur_ +ggetb_ +ggeti_ +ggetr_ +ggets_ +ggscae_ +ggview_ +ggwind_ +gimcor_ +gimcrr_ +gimder_ +gimdig_ +gimeng_ +gimfrg_ +gimfrp_ +gimgeg_ +gimins_ +gimiod_ +gimioe_ +gimlop_ +gimqur_ +gimrat_ +gimreg_ +gimrep_ +gimres_ +gimrex_ +gimseg_ +gimser_ +gimsex_ +gimwrp_ +gimwrs_ +gkical_ +gkiclr_ +gkicls_ +gkides_ +gkieof_ +gkiese_ +gkiexe_ +gkifat_ +gkifen_ +gkiffh_ +gkifia_ +gkiflh_ +gkiger_ +gkiges_ +gkigey_ +gkiinl_ +gkiint_ +gkimfe_ +gkiops_ +gkiplt_ +gkipmt_ +gkipoe_ +gkipor_ +gkipuy_ +gkiree_ +gkirer_ +gkires_ +gkirey_ +gkiser_ +gkises_ +gkisul_ +gkitet_ +gkitxt_ +gkiwee_ +gkiwre_ +gkpcal_ +gkpcle_ +gkpclr_ +gkpcls_ +gkpdes_ +gkpdup_ +gkpese_ +gkpfat_ +gkpfia_ +gkpflh_ +gkpger_ +gkpges_ +gkpgey_ +gkpgrm_ +gkpinl_ +gkpmfe_ +gkpops_ +gkpplt_ +gkppmt_ +gkppoe_ +gkppor_ +gkppst_ +gkppuy_ +gkpres_ +gkpser_ +gkpses_ +gkptet_ +gkptxg_ +gkptxt_ +gkpunn_ +glabax_ +glbdrd_ +glbene_ +glbeq_ +glbfis_ +glbgek_ +glblas_ +glblob_ +glbmip_ +glbple_ +glbsep_ +glbses_ +glbset_ +glbtin_ +glbveg_ +gline_ +gltoc_ +gmark_ +gmftie_ +gmprif_ +gmsg_ +gmsgb_ +gmsgc_ +gmsgd_ +gmsgi_ +gmsgl_ +gmsgr_ +gmsgs_ +gmsgx_ +gmttot_ +gopen_ +gopeni_ +gpagee_ +gpatme_ +gpatmh_ +gpcell_ +gplcae_ +gplcal_ +gplclb_ +gplcll_ +gplclr_ +gplclt_ +gplflh_ +gpline_ +gploto_ +gplotv_ +gplret_ +gplsee_ +gplwci_ +gpmark_ +gqsort_ +gqvery_ +grdraw_ +grdwcs_ +greace_ +greset_ +grmove_ +grscae_ +gscan_ +gscur_ +gseti_ +gsetr_ +gsets_ +gstati_ +gstatr_ +gstats_ +gstrct_ +gstrcy_ +gstrmh_ +gstsei_ +gstser_ +gsview_ +gswind_ +gtdise_ +gtext_ +gtickr_ +gtliny_ +gtndis_ +gttyld_ +gtxset_ +gtybih_ +gtycas_ +gtycle_ +gtyeny_ +gtyexs_ +gtyfey_ +gtyfiy_ +gtygeb_ +gtygei_ +gtyger_ +gtyges_ +gtyins_ +gtyopn_ +gtysce_ +gumark_ +gvline_ +gvmark_ +gwcsme_ +gwrwcs_ +i1mach_ +idbcle_ +idbfid_ +idbfir_ +idbgeg_ +idbkwp_ +idbned_ +idbopn_ +idbpug_ +ieegmd_ +ieegmr_ +ieegnd_ +ieegnr_ +ieemad_ +ieemar_ +ieepad_ +ieepar_ +ieesmd_ +ieesmr_ +ieesnd_ +ieesnr_ +ieestd_ +ieestr_ +ieeupd_ +ieeupr_ +ieevpd_ +ieevpr_ +ieevud_ +ieevur_ +ieezsd_ +ieezsr_ +ikiacs_ +ikicle_ +ikicoy_ +ikidee_ +ikideg_ +ikiext_ +ikiged_ +ikigen_ +ikiger_ +ikiint_ +ikildr_ +ikimke_ +ikiopn_ +ikiopx_ +ikipae_ +ikiree_ +ikiupr_ +ikivan_ +imaccf_ +imaccs_ +imaddb_ +imaddd_ +imaddf_ +imaddi_ +imaddl_ +imaddr_ +imadds_ +imaflp_ +imalin_ +imaplv_ +imastr_ +imbln1_ +imbln2_ +imbln3_ +imbtrn_ +imcfnl_ +imcopy_ +imcssz_ +imctrt_ +imdect_ +imdele_ +imdelf_ +imdmap_ +imerr_ +imflpl_ +imflps_ +imflsd_ +imflsh_ +imflsi_ +imflsl_ +imflsr_ +imflss_ +imflsx_ +imfluh_ +imfnpy_ +imfnss_ +imgclr_ +imgetb_ +imgetc_ +imgetd_ +imgeti_ +imgetl_ +imgetr_ +imgets_ +imgfte_ +imggsc_ +imggsd_ +imggsi_ +imggsl_ +imggsr_ +imggss_ +imggsx_ +imgibf_ +imgime_ +imgl1d_ +imgl1i_ +imgl1l_ +imgl1r_ +imgl1s_ +imgl1x_ +imgl2d_ +imgl2i_ +imgl2l_ +imgl2r_ +imgl2s_ +imgl2x_ +imgl3d_ +imgl3i_ +imgl3l_ +imgl3r_ +imgl3s_ +imgl3x_ +imgnfn_ +imgnld_ +imgnli_ +imgnll_ +imgnln_ +imgnlr_ +imgnls_ +imgnlx_ +imgobf_ +imgs1d_ +imgs1i_ +imgs1l_ +imgs1r_ +imgs1s_ +imgs1x_ +imgs2d_ +imgs2i_ +imgs2l_ +imgs2r_ +imgs2s_ +imgs2x_ +imgs3d_ +imgs3i_ +imgs3l_ +imgs3r_ +imgs3s_ +imgs3x_ +imgsen_ +imgstr_ +iminie_ +imioff_ +imisec_ +imloop_ +immaky_ +immap_ +immapz_ +imnote_ +imofnl_ +imofns_ +imofnu_ +imopsf_ +impakd_ +impaki_ +impakl_ +impakr_ +impaks_ +impakx_ +impare_ +impgsd_ +impgsi_ +impgsl_ +impgsr_ +impgss_ +impgsx_ +impl1d_ +impl1i_ +impl1l_ +impl1r_ +impl1s_ +impl1x_ +impl2d_ +impl2i_ +impl2l_ +impl2r_ +impl2s_ +impl2x_ +impl3d_ +impl3i_ +impl3l_ +impl3r_ +impl3s_ +impl3x_ +impml1_ +impml2_ +impml3_ +impmlr_ +impmlv_ +impmmo_ +impmmp_ +impmon_ +impms1_ +impms2_ +impms3_ +impmsr_ +impmsv_ +impnld_ +impnli_ +impnll_ +impnln_ +impnlr_ +impnls_ +impnlx_ +imps1d_ +imps1i_ +imps1l_ +imps1r_ +imps1s_ +imps1x_ +imps2d_ +imps2i_ +imps2l_ +imps2r_ +imps2s_ +imps2x_ +imps3d_ +imps3i_ +imps3l_ +imps3r_ +imps3s_ +imps3x_ +impstr_ +imputb_ +imputd_ +imputh_ +imputi_ +imputl_ +imputr_ +imputs_ +imrbpx_ +imrdpx_ +imrene_ +imrmbs_ +imsamp_ +imsetf_ +imseti_ +imsetr_ +imsinb_ +imsmpl_ +imsmps_ +imsslv_ +imstai_ +imstar_ +imstas_ +imtcle_ +imtgem_ +imtlen_ +imtmae_ +imtopn_ +imtopp_ +imtrew_ +imtrgm_ +imunmp_ +imupkd_ +imupki_ +imupkl_ +imupkr_ +imupks_ +imupkx_ +imwbpx_ +imwrie_ +imwrpx_ +intrde_ +intree_ +intrrt_ +irafmn_ +itob_ +itoc_ +iwcare_ +iwcfis_ +iwents_ +iwfind_ +iwgbis_ +iwputr_ +iwputy_ +iwrfis_ +iwsetp_ +kardbf_ +kardgd_ +kardlp_ +kardpl_ +kardpr_ +kardsf_ +kawrbf_ +kawrgd_ +kawrlp_ +kawrpl_ +kawrpr_ +kawrsf_ +kawtbf_ +kawtgd_ +kawtlp_ +kawtpl_ +kawtpr_ +kawtsf_ +kbzard_ +kbzawr_ +kbzawt_ +kbzcls_ +kbzopn_ +kbzstt_ +kclcpr_ +kcldir_ +kcldpr_ +kclsbf_ +kclsgd_ +kclslp_ +kclspl_ +kclssf_ +kclstx_ +kclsty_ +kdvall_ +kdvown_ +kfacss_ +kfaloc_ +kfchdr_ +kfdele_ +kfgcwd_ +kfinfo_ +kflstx_ +kflsty_ +kfmkcp_ +kfmkdr_ +kfpath_ +kfprot_ +kfrnam_ +kfsubd_ +kfutim_ +kfxdir_ +kgettx_ +kgetty_ +kgfdir_ +kicont_ +kidece_ +kience_ +kienvt_ +kierrr_ +kiexte_ +kifine_ +kiflux_ +kifman_ +kifren_ +kigetn_ +kigets_ +kignoe_ +kiinit_ +kiloce_ +kimape_ +kimapn_ +kintpr_ +kiopes_ +kirece_ +kisend_ +kisenv_ +kishot_ +kixnoe_ +kmallc_ +knottx_ +knotty_ +kopcpr_ +kopdir_ +kopdpr_ +kopnbf_ +kopngd_ +kopnlp_ +kopnpl_ +kopnsf_ +kopntx_ +kopnty_ +koscmd_ +kputtx_ +kputty_ +krealc_ +ksared_ +ksawat_ +ksawre_ +ksektx_ +ksekty_ +ksttbf_ +ksttgd_ +ksttlp_ +ksttpl_ +ksttpr_ +ksttsf_ +kstttx_ +ksttty_ +ktzcls_ +ktzfls_ +ktzget_ +ktznot_ +ktzopn_ +ktzput_ +ktzsek_ +ktzstt_ +kzclmt_ +kzopmt_ +kzrdmt_ +kzrwmt_ +kzstmt_ +kzwrmt_ +kzwtmt_ +lexnum_ +lnocle_ +lnofeh_ +lnoopn_ +lnosae_ +locpr_ +locva_ +lpopen_ +lpzard_ +lpzawe_ +lpzawt_ +lsttot_ +ltoc_ +m75put_ +maideh_ +mallo1_ +mgdptr_ +mgtfwa_ +miilen_ +miinem_ +miipa2_ +miipa6_ +miipa8_ +miipad_ +miipak_ +miipar_ +miipke_ +miirec_ +miired_ +miirei_ +miirel_ +miirer_ +miires_ +miiup2_ +miiup6_ +miiup8_ +miiupd_ +miiupk_ +miiupr_ +miiwrc_ +miiwrd_ +miiwri_ +miiwrl_ +miiwrr_ +miiwrs_ +miocle_ +miogld_ +miogli_ +miogll_ +mioglr_ +miogls_ +mioglx_ +mioopn_ +mioopo_ +miopld_ +miopli_ +miopll_ +mioplr_ +miopls_ +mioplx_ +miosee_ +miosei_ +miosti_ +msvfwa_ +mtalle_ +mtcap_ +mtclen_ +mtclre_ +mtdeae_ +mtdevd_ +mtence_ +mtfile_ +mtfnae_ +mtgets_ +mtglok_ +mtgtyn_ +mtloce_ +mtneeo_ +mtopen_ +mtpare_ +mtposn_ +mtpute_ +mtreae_ +mtrewd_ +mtsavd_ +mtsavs_ +mtskid_ +mtstas_ +mtsync_ +mtupde_ +mwalld_ +mwalls_ +mwaxtn_ +mwc1td_ +mwc1tr_ +mwc2td_ +mwc2tr_ +mwcloe_ +mwcopd_ +mwcops_ +mwctfe_ +mwctrd_ +mwctrr_ +mwfins_ +mwflop_ +mwgaxp_ +mwgaxt_ +mwgctd_ +mwgctr_ +mwgltd_ +mwgltr_ +mwgsym_ +mwgwas_ +mwgwsd_ +mwgwsr_ +mwgwtd_ +mwgwtr_ +mwinvd_ +mwinvr_ +mwload_ +mwloam_ +mwltrd_ +mwltrr_ +mwlubb_ +mwlude_ +mwmkid_ +mwmkir_ +mwmmud_ +mwmmur_ +mwnewm_ +mwnewy_ +mwopem_ +mwopen_ +mwrefr_ +mwrote_ +mwsave_ +mwsavm_ +mwsaxp_ +mwscae_ +mwsctn_ +mwsdes_ +mwseti_ +mwshit_ +mwshow_ +mwsltd_ +mwsltr_ +mwssym_ +mwstai_ +mwswas_ +mwswsd_ +mwswsr_ +mwswtd_ +mwswte_ +mwswtr_ +mwtrad_ +mwtrar_ +mwv1td_ +mwv1tr_ +mwv2td_ +mwv2tr_ +mwvmud_ +mwvmur_ +mwvtrd_ +mwvtrr_ +ndopen_ +noti_ +notl_ +nots_ +nowhie_ +nscan_ +oifacs_ +oifcle_ +oifcoy_ +oifdee_ +oifgpe_ +oifmke_ +oifopn_ +oifopx_ +oifrdr_ +oifree_ +oiftrm_ +oifupr_ +oifwrr_ +onerre_ +onerrr_ +onexie_ +onexit_ +ord1_ +ord2_ +ori_ +orl_ +ors_ +oscmd_ +osfnik_ +osfnlk_ +osfnms_ +osfnpe_ +osfnrk_ +osfntt_ +osfnuk_ +pagefe_ +pagefs_ +pargb_ +pargc_ +pargd_ +pargg_ +pargi_ +pargl_ +pargr_ +pargs_ +pargsr_ +pargx_ +patamh_ +patfit_ +patgel_ +patgse_ +patinx_ +patloe_ +patmae_ +patmah_ +patomh_ +patsts_ +pggetd_ +pggete_ +pggetr_ +pgpage_ +pgpeed_ +pgpusd_ +pgsett_ +placcs_ +plallc_ +plascp_ +plbox_ +plcire_ +plcler_ +plcloe_ +plcome_ +plcoms_ +plcree_ +pldebg_ +pldebt_ +plempe_ +plempy_ +plfacs_ +plfcle_ +plfcoy_ +plfdee_ +plfnul_ +plfopn_ +plfree_ +plfupr_ +plgete_ +plglls_ +plglpi_ +plglpl_ +plglps_ +plglri_ +plglrl_ +plglrs_ +plgsie_ +pll2pi_ +pll2pl_ +pll2ps_ +pll2ri_ +pll2rl_ +pll2rs_ +pllcot_ +pllemy_ +plleql_ +plline_ +pllinl_ +pllinp_ +plliny_ +plllen_ +pllneg_ +plload_ +plloaf_ +plloam_ +plloop_ +pllprs_ +plnewy_ +plopen_ +plp2li_ +plp2ll_ +plp2ls_ +plp2ri_ +plp2rl_ +plp2rs_ +plpixi_ +plpixl_ +plpixs_ +plplls_ +plplpi_ +plplpl_ +plplps_ +plplri_ +plplrl_ +plplrs_ +plpoit_ +plpoln_ +plr2li_ +plr2ll_ +plr2ls_ +plr2pi_ +plr2pl_ +plr2ps_ +plrani_ +plranl_ +plrans_ +plrcle_ +plrefe_ +plregp_ +plreqi_ +plreql_ +plreqs_ +plrget_ +plrgex_ +plrop_ +plropn_ +plrpri_ +plrprl_ +plrprs_ +plrset_ +plsave_ +plsavf_ +plsavm_ +plsect_ +plsecy_ +plsete_ +plseti_ +plssie_ +plsslv_ +plstai_ +plstel_ +plubox_ +plucie_ +plupde_ +plupon_ +plvald_ +pmaccs_ +pmascp_ +pmbox_ +pmcire_ +pmcler_ +pmempy_ +pmglls_ +pmglpi_ +pmglpl_ +pmglps_ +pmglri_ +pmglrl_ +pmglrs_ +pmline_ +pmliny_ +pmnewk_ +pmplls_ +pmplpi_ +pmplpl_ +pmplps_ +pmplri_ +pmplrl_ +pmplrs_ +pmpoit_ +pmpoln_ +pmrcle_ +pmrgex_ +pmrop_ +pmropn_ +pmrset_ +pmsect_ +pmsecy_ +pmsete_ +pmseti_ +pmstai_ +pmstel_ +poll_ +pollce_ +pollcr_ +pollgs_ +pollon_ +pollpt_ +pollst_ +polltt_ +pollzo_ +prchdr_ +prclcr_ +prcldr_ +prcloe_ +prdone_ +prdumn_ +prenve_ +prenvt_ +prfilf_ +prfinc_ +prgete_ +prgetr_ +prkill_ +pronic_ +propcr_ +propdr_ +propen_ +proscd_ +protet_ +prpsio_ +prpsld_ +prredr_ +prseti_ +prsigl_ +prstai_ +prupde_ +prvret_ +przclr_ +pscenr_ +pscens_ +pschwh_ +pscloe_ +psdept_ +psesct_ +psfone_ +psfonr_ +psfoor_ +psgett_ +pshear_ +psindt_ +psioit_ +psioxr_ +pslink_ +psnewe_ +psopen_ +psoutt_ +pspage_ +pspagk_ +psrigy_ +psrjps_ +pssets_ +pssett_ +pssety_ +psspft_ +pstese_ +pstexh_ +pstrar_ +pswrig_ +pswrtk_ +psxpos_ +psypos_ +putcc_ +putci_ +putlie_ +qmaccs_ +qmgetc_ +qmscan_ +qmscao_ +qmsetm_ +qmsetr_ +qmsets_ +qmspai_ +qmspar_ +qmsymb_ +qmupds_ +qpaccf_ +qpaccs_ +qpaddb_ +qpaddc_ +qpaddd_ +qpaddf_ +qpaddi_ +qpaddl_ +qpaddr_ +qpadds_ +qpaddx_ +qpargt_ +qpastr_ +qpbind_ +qpcfnl_ +qpcloe_ +qpclot_ +qpcopf_ +qpcopy_ +qpctod_ +qpctoi_ +qpdele_ +qpdelf_ +qpdsym_ +qpdtye_ +qpelee_ +qpexad_ +qpexai_ +qpexar_ +qpexcd_ +qpexce_ +qpexci_ +qpexcr_ +qpexdc_ +qpexde_ +qpexdg_ +qpexdr_ +qpexee_ +qpexfe_ +qpexge_ +qpexgr_ +qpexmk_ +qpexmr_ +qpexon_ +qpexpd_ +qpexpi_ +qpexpn_ +qpexpr_ +qpexps_ +qpexpt_ +qpexrd_ +qpexsd_ +qpexsi_ +qpexsr_ +qpfacs_ +qpfcle_ +qpfcos_ +qpfcoy_ +qpfdee_ +qpflur_ +qpfopn_ +qpfopx_ +qpfree_ +qpfupr_ +qpfwar_ +qpfwfr_ +qpfzcl_ +qpfzop_ +qpfzrd_ +qpfzst_ +qpfzwr_ +qpfzwt_ +qpgetb_ +qpgetc_ +qpgetd_ +qpgeti_ +qpgetk_ +qpgetl_ +qpgetm_ +qpgetr_ +qpgets_ +qpgetx_ +qpgmsm_ +qpgnfn_ +qpgpsm_ +qpgstr_ +qpinht_ +qpioce_ +qpioge_ +qpiogr_ +qpiogs_ +qpiolk_ +qpiols_ +qpiomx_ +qpioon_ +qpiope_ +qpiops_ +qpiori_ +qpiors_ +qpiort_ +qpiosc_ +qpiose_ +qpiosi_ +qpiosr_ +qpiost_ +qpiour_ +qpiovr_ +qpiowt_ +qplenf_ +qplenl_ +qplesd_ +qplesi_ +qplesr_ +qploas_ +qpmaxd_ +qpmaxi_ +qpmaxr_ +qpmind_ +qpmini_ +qpminr_ +qpmkfe_ +qpnexk_ +qpofnl_ +qpofns_ +qpofnu_ +qpopen_ +qpopet_ +qppare_ +qpparl_ +qppcle_ +qppopn_ +qppstr_ +qpputb_ +qpputc_ +qpputd_ +qpputi_ +qpputl_ +qpputm_ +qpputr_ +qpputs_ +qpputx_ +qpquef_ +qprawk_ +qpread_ +qprebd_ +qprene_ +qprenf_ +qprlmd_ +qprlmi_ +qprlmr_ +qpsavs_ +qpseel_ +qpseti_ +qpsetr_ +qpsizf_ +qpstai_ +qpstar_ +qpsync_ +qpungk_ +qpwrie_ +qpxgvd_ +qpxgvi_ +qpxgvl_ +qpxgvr_ +qpxgvs_ +r1mach_ +r2tr_ +r2tx_ +r4syn_ +r4tr_ +r4tx_ +r8syn_ +r8tr_ +r8tx_ +rdukey_ +reopen_ +resetn_ +salloc_ +scanc_ +sfree_ +shifti_ +shiftl_ +shifts_ +smark_ +sprinf_ +sscan_ +stallc_ +stcloe_ +stentr_ +stfacs_ +stfadr_ +stfcle_ +stfcos_ +stfcoy_ +stfcte_ +stfdee_ +stfgeb_ +stfgei_ +stfgen_ +stfges_ +stfget_ +stfind_ +stfinl_ +stfins_ +stfmeb_ +stfmke_ +stfnee_ +stfopn_ +stfopx_ +stforb_ +stfrdr_ +stfree_ +stfrek_ +stfrfr_ +stfrgb_ +stfrne_ +stfupr_ +stfwfr_ +stfwgb_ +sthash_ +sthead_ +stinfo_ +stkmkg_ +stmark_ +stname_ +stnext_ +stnsys_ +stopen_ +stpstr_ +strcle_ +strdic_ +strefb_ +streff_ +streq_ +strese_ +strge_ +strgee_ +strgt_ +strids_ +stridx_ +strlds_ +strldx_ +strle_ +strlt_ +strlwr_ +strmac_ +strmah_ +strncp_ +strne_ +stropn_ +strpak_ +strse1_ +strsee_ +strseh_ +strsrt_ +strtbl_ +strupk_ +strupr_ +stsave_ +stsize_ +stsque_ +sttyco_ +sttyet_ +sttygg_ +sttynm_ +sttyse_ +sttysm_ +sttytt_ +syserr_ +sysers_ +sysged_ +sysges_ +sysgsg_ +sysid_ +sysmte_ +syspac_ +syspat_ +syspte_ +sysret_ +syssct_ +tsleep_ +ttopen_ +ttseti_ +ttsets_ +ttstai_ +ttstas_ +ttybih_ +ttybre_ +ttycas_ +ttycds_ +ttycle_ +ttycln_ +ttyclr_ +ttyctl_ +ttydee_ +ttydey_ +ttyeny_ +ttyexs_ +ttyfey_ +ttyfiy_ +ttygds_ +ttygeb_ +ttygei_ +ttyger_ +ttyges_ +ttygoo_ +ttygpe_ +ttygse_ +ttyins_ +ttyint_ +ttylod_ +ttyods_ +ttyopn_ +ttypue_ +ttypus_ +ttyred_ +ttysce_ +ttysei_ +ttyso_ +ttysti_ +ttysui_ +ttywre_ +ungete_ +ungeti_ +unread_ +urand_ +vfnadd_ +vfncle_ +vfndee_ +vfndel_ +vfnene_ +vfnenr_ +vfnexr_ +vfngen_ +vfnise_ +vfnman_ +vfnmap_ +vfnmau_ +vfnopn_ +vfnsqe_ +vfntre_ +vfnunn_ +vfnunp_ +vlibinit_ +vmallc_ +vvfncm_ +vvfnee_ +vvfnip_ +vvfnis_ +vvfnre_ +wfaitd_ +wfaitt_ +wfaitv_ +wfarcd_ +wfarct_ +wfarcv_ +wfcard_ +wfcart_ +wfcarv_ +wfcscd_ +wfcsct_ +wfcscv_ +wfdecs_ +wffnld_ +wfglsd_ +wfglst_ +wfglsv_ +wfgsbb_ +wfgsbg_ +wfgsbl_ +wfgsce_ +wfgscf_ +wfgsdr_ +wfgsel_ +wfgson_ +wfgsre_ +wfinit_ +wfmerd_ +wfmert_ +wfmerv_ +wfmold_ +wfmolt_ +wfmolv_ +wfmspd_ +wfmspf_ +wfmspi_ +wfmspl_ +wfmspt_ +wfmspv_ +wfmspy_ +wfpard_ +wfpart_ +wfparv_ +wfpcod_ +wfpcot_ +wfpcov_ +wfqscd_ +wfqsct_ +wfqscv_ +wfsind_ +wfsint_ +wfsinv_ +wfsmph_ +wfsmpn_ +wfsmpt_ +wfstgd_ +wfstgt_ +wfstgv_ +wftand_ +wftant_ +wftanv_ +wftnxd_ +wftnxt_ +wftnxv_ +wftnxy_ +wftscd_ +wftsct_ +wftscv_ +wfzead_ +wfzeat_ +wfzeav_ +wfzpxd_ +wfzpxt_ +wfzpxv_ +wfzpxy_ +xalloe_ +xcallc_ +xdeale_ +xdevor_ +xdevss_ +xeract_ +xerfmg_ +xerpoi_ +xerpop_ +xerpsh_ +xerpsr_ +xerpuc_ +xerpue_ +xerret_ +xerror_ +xersel_ +xervey_ +xevadg_ +xevbip_ +xevbop_ +xevcan_ +xever1_ +xever2_ +xeverr_ +xevfrp_ +xevgek_ +xevinp_ +xevmap_ +xevnee_ +xevpae_ +xevpah_ +xevqut_ +xevstt_ +xevunp_ +xfaccs_ +xfatal_ +xfchdr_ +xfcloe_ +xfdele_ +xffluh_ +xfgetc_ +xfgetr_ +xfnote_ +xfopen_ +xfputc_ +xfputr_ +xfread_ +xfrnam_ +xfscan_ +xfseek_ +xfungc_ +xfwrie_ +xgdevt_ +xgtpid_ +xgtuid_ +xisaty_ +xmallc_ +xmfree_ +xmjbuf_ +xmktep_ +xonerr_ +xonext_ +xori_ +xorl_ +xors_ +xpages_ +xprinf_ +xqsort_ +xrealc_ +xsizef_ +xstdeh_ +xstrcp_ +xstrct_ +xstrcy_ +xstrln_ +xtoc_ +xttyse_ +xvvadg_ +xvvbip_ +xvvbop_ +xvvcan_ +xvvche_ +xvver1_ +xvver2_ +xvverr_ +xvvfrp_ +xvvgek_ +xvvinp_ +xvvlos_ +xvvmap_ +xvvnee_ +xvvnud_ +xvvnui_ +xvvnul_ +xvvnur_ +xvvnus_ +xvvpae_ +xvvpah_ +xvvqut_ +xvvstt_ +xvvunp_ +xwhen_ +xxscan_ +zardbf_ +zardgd_ +zardks_ +zardlp_ +zardmt_ +zardnd_ +zardnu_ +zardpl_ +zardpr_ +zardps_ +zardsf_ +zawrbf_ +zawrgd_ +zawrks_ +zawrlp_ +zawrmt_ +zawrnd_ +zawrnu_ +zawrpl_ +zawrpr_ +zawrps_ +zawrsf_ +zawset_ +zawtbf_ +zawtgd_ +zawtks_ +zawtlp_ +zawtmt_ +zawtnd_ +zawtnu_ +zawtpl_ +zawtpr_ +zawtps_ +zawtsf_ +zclcpr_ +zcldir_ +zcldpr_ +zclm70_ +zclm75_ +zclsbf_ +zclsgd_ +zclsks_ +zclslp_ +zclsmt_ +zclsnd_ +zclsnu_ +zclspl_ +zclsps_ +zclssf_ +zclstt_ +zclstx_ +zclsty_ +zdojmp_ +zdvall_ +zdvown_ +zfacss_ +zfaloc_ +zfchdr_ +zfdele_ +zfgcwd_ +zfinfo_ +zflsnu_ +zflstt_ +zflstx_ +zflsty_ +zfmkcp_ +zfmkdr_ +zfnbrk_ +zfpath_ +zfpoll_ +zfprot_ +zfrnam_ +zfsubd_ +zfutim_ +zfxdir_ +zgcmdl_ +zgetnu_ +zgettt_ +zgettx_ +zgetty_ +zgfdir_ +zghost_ +zgmtco_ +zgtime_ +zgtpid_ +zintpr_ +zlocpr_ +zlocva_ +zmaloc_ +zmfree_ +znotnu_ +znottt_ +znottx_ +znotty_ +zopcpr_ +zopdir_ +zopdpr_ +zopm70_ +zopm75_ +zopnbf_ +zopngd_ +zopnks_ +zopnlp_ +zopnmt_ +zopnnd_ +zopnnu_ +zopnpl_ +zopnsf_ +zopntt_ +zopntx_ +zopnty_ +zoscmd_ +zpanic_ +zputnu_ +zputtt_ +zputtx_ +zputty_ +zraloc_ +zrdm70_ +zrdm75_ +zseknu_ +zsektt_ +zsektx_ +zsekty_ +zsestt_ +zsettt_ +zstm70_ +zstm75_ +zststt_ +zsttbf_ +zsttgd_ +zsttks_ +zsttlp_ +zsttmt_ +zsttnd_ +zsttnu_ +zsttpl_ +zsttpr_ +zsttps_ +zsttsf_ +zstttt_ +zstttx_ +zsttty_ +zttgeg_ +zttger_ +zttloe_ +zttloo_ +zttlov_ +zttpbf_ +zttplk_ +zttpug_ +zttquy_ +zttttt_ +zttupe_ +zwmsec_ +zwrm70_ +zwrm75_ +zwtm70_ +zwtm75_ +zxgmes_ +zxwhen_ +zzclmt_ +zzopmt_ +zzrdii_ +zzrdmt_ +zzrwmt_ +zzsetk_ +zzstmt_ +zzwrii_ +zzwrmt_ +zzwtmt_ +zzzend_ diff --git a/unix/shlib/S.nm.old b/unix/shlib/S.nm.old new file mode 100644 index 00000000..fb54dd3b --- /dev/null +++ b/unix/shlib/S.nm.old @@ -0,0 +1,2864 @@ +aabsd_ +aabsi_ +aabsl_ +aabsr_ +aabss_ +aabsx_ +aaddd_ +aaddi_ +aaddkd_ +aaddki_ +aaddkl_ +aaddkr_ +aaddks_ +aaddkx_ +aaddl_ +aaddr_ +aadds_ +aaddx_ +aandi_ +aandki_ +aandkl_ +aandks_ +aandl_ +aands_ +aavgd_ +aavgi_ +aavgl_ +aavgr_ +aavgs_ +aavgx_ +abavd_ +abavi_ +abavl_ +abavr_ +abavs_ +abavx_ +abeqc_ +abeqd_ +abeqi_ +abeqkc_ +abeqkd_ +abeqki_ +abeqkl_ +abeqkr_ +abeqks_ +abeqkx_ +abeql_ +abeqr_ +abeqs_ +abeqx_ +abgec_ +abged_ +abgei_ +abgekc_ +abgekd_ +abgeki_ +abgekl_ +abgekr_ +abgeks_ +abgekx_ +abgel_ +abger_ +abges_ +abgex_ +abgtc_ +abgtd_ +abgti_ +abgtkc_ +abgtkd_ +abgtki_ +abgtkl_ +abgtkr_ +abgtks_ +abgtkx_ +abgtl_ +abgtr_ +abgts_ +abgtx_ +ablec_ +abled_ +ablei_ +ablekc_ +ablekd_ +ableki_ +ablekl_ +ablekr_ +ableks_ +ablekx_ +ablel_ +abler_ +ables_ +ablex_ +abltc_ +abltd_ +ablti_ +abltkc_ +abltkd_ +abltki_ +abltkl_ +abltkr_ +abltks_ +abltkx_ +abltl_ +abltr_ +ablts_ +abltx_ +abnec_ +abned_ +abnei_ +abnekc_ +abnekd_ +abneki_ +abnekl_ +abnekr_ +abneks_ +abnekx_ +abnel_ +abner_ +abnes_ +abnex_ +abori_ +aborki_ +aborkl_ +aborks_ +aborl_ +abors_ +absud_ +absui_ +absul_ +absur_ +absus_ +acht_ +achtb_ +achtbb_ +achtbc_ +achtbd_ +achtbi_ +achtbl_ +achtbr_ +achtbs_ +achtbu_ +achtbx_ +achtc_ +achtcb_ +achtcc_ +achtcd_ +achtci_ +achtcl_ +achtcr_ +achtcs_ +achtcu_ +achtcx_ +achtd_ +achtdb_ +achtdc_ +achtdd_ +achtdi_ +achtdl_ +achtdr_ +achtds_ +achtdu_ +achtdx_ +achti_ +achtib_ +achtic_ +achtid_ +achtii_ +achtil_ +achtir_ +achtis_ +achtiu_ +achtix_ +achtl_ +achtlb_ +achtlc_ +achtld_ +achtli_ +achtll_ +achtlr_ +achtls_ +achtlu_ +achtlx_ +achtr_ +achtrb_ +achtrc_ +achtrd_ +achtri_ +achtrl_ +achtrr_ +achtrs_ +achtru_ +achtrx_ +achts_ +achtsb_ +achtsc_ +achtsd_ +achtsi_ +achtsl_ +achtsr_ +achtss_ +achtsu_ +achtsx_ +achtu_ +achtub_ +achtuc_ +achtud_ +achtui_ +achtul_ +achtur_ +achtus_ +achtuu_ +achtux_ +achtx_ +achtxb_ +achtxc_ +achtxd_ +achtxi_ +achtxl_ +achtxr_ +achtxs_ +achtxu_ +achtxx_ +acjgx_ +aclrb_ +aclrc_ +aclrd_ +aclri_ +aclrl_ +aclrr_ +aclrs_ +aclrx_ +acnvd_ +acnvi_ +acnvl_ +acnvr_ +acnvrd_ +acnvri_ +acnvrl_ +acnvrr_ +acnvrs_ +acnvs_ +adivd_ +adivi_ +adivkd_ +adivki_ +adivkl_ +adivkr_ +adivks_ +adivkx_ +adivl_ +adivr_ +adivs_ +adivx_ +adotd_ +adoti_ +adotl_ +adotr_ +adots_ +adotx_ +advzd_ +advzi_ +advzl_ +advzr_ +advzs_ +advzx_ +aelogd_ +aelogr_ +aexpd_ +aexpi_ +aexpkd_ +aexpki_ +aexpkl_ +aexpkr_ +aexpks_ +aexpkx_ +aexpl_ +aexpr_ +aexps_ +aexpx_ +afftrr_ +afftrx_ +afftxr_ +afftxx_ +agltc_ +agltd_ +aglti_ +agltl_ +agltr_ +aglts_ +agltx_ +ahgmc_ +ahgmd_ +ahgmi_ +ahgml_ +ahgmr_ +ahgms_ +ahivc_ +ahivd_ +ahivi_ +ahivl_ +ahivr_ +ahivs_ +ahivx_ +aiftrr_ +aiftrx_ +aiftxr_ +aiftxx_ +aimgd_ +aimgi_ +aimgl_ +aimgr_ +aimgs_ +alani_ +alanki_ +alankl_ +alanks_ +alanl_ +alans_ +alimc_ +alimd_ +alimi_ +aliml_ +alimr_ +alims_ +alimx_ +allnd_ +allni_ +allnl_ +allnr_ +allns_ +allnx_ +alogd_ +alogi_ +alogl_ +alogr_ +alogs_ +alogx_ +alori_ +alorki_ +alorkl_ +alorks_ +alorl_ +alors_ +alovc_ +alovd_ +alovi_ +alovl_ +alovr_ +alovs_ +alovx_ +altad_ +altai_ +altal_ +altar_ +altas_ +altax_ +altmd_ +altmi_ +altml_ +altmr_ +altms_ +altmx_ +altrd_ +altri_ +altrl_ +altrr_ +altrs_ +altrx_ +aluid_ +aluii_ +aluil_ +aluir_ +aluis_ +alutc_ +alutd_ +aluti_ +alutl_ +alutr_ +aluts_ +amagd_ +amagi_ +amagl_ +amagr_ +amags_ +amagx_ +amapd_ +amapi_ +amapl_ +amapr_ +amaps_ +amaxc_ +amaxd_ +amaxi_ +amaxkc_ +amaxkd_ +amaxki_ +amaxkl_ +amaxkr_ +amaxks_ +amaxkx_ +amaxl_ +amaxr_ +amaxs_ +amaxx_ +amed3c_ +amed3d_ +amed3i_ +amed3l_ +amed3r_ +amed3s_ +amed4c_ +amed4d_ +amed4i_ +amed4l_ +amed4r_ +amed4s_ +amed5c_ +amed5d_ +amed5i_ +amed5l_ +amed5r_ +amed5s_ +amedc_ +amedd_ +amedi_ +amedl_ +amedr_ +ameds_ +amedx_ +amgsd_ +amgsi_ +amgsl_ +amgsr_ +amgss_ +amgsx_ +aminc_ +amind_ +amini_ +aminkc_ +aminkd_ +aminki_ +aminkl_ +aminkr_ +aminks_ +aminkx_ +aminl_ +aminr_ +amins_ +aminx_ +amodd_ +amodi_ +amodkd_ +amodki_ +amodkl_ +amodkr_ +amodks_ +amodl_ +amodr_ +amods_ +amovc_ +amovd_ +amovi_ +amovkc_ +amovkd_ +amovki_ +amovkl_ +amovkr_ +amovks_ +amovkx_ +amovl_ +amovr_ +amovs_ +amovx_ +amuld_ +amuli_ +amulkd_ +amulki_ +amulkl_ +amulkr_ +amulks_ +amulkx_ +amull_ +amulr_ +amuls_ +amulx_ +andi_ +andl_ +ands_ +anegd_ +anegi_ +anegl_ +anegr_ +anegs_ +anegx_ +anoti_ +anotl_ +anots_ +apkxd_ +apkxi_ +apkxl_ +apkxr_ +apkxs_ +apkxx_ +apold_ +apolr_ +apowd_ +apowi_ +apowkd_ +apowki_ +apowkl_ +apowkr_ +apowks_ +apowkx_ +apowl_ +apowr_ +apows_ +apowx_ +aravd_ +aravi_ +aravl_ +aravr_ +aravs_ +aravx_ +arcpd_ +arcpi_ +arcpl_ +arcpr_ +arcps_ +arcpx_ +arczd_ +arczi_ +arczl_ +arczr_ +arczs_ +arczx_ +aread_ +areadb_ +argtd_ +argti_ +argtl_ +argtr_ +argts_ +argtx_ +arltd_ +arlti_ +arltl_ +arltr_ +arlts_ +arltx_ +aselc_ +aseld_ +aseli_ +aselkc_ +aselkd_ +aselki_ +aselkl_ +aselkr_ +aselks_ +aselkx_ +asell_ +aselr_ +asels_ +aselx_ +asokc_ +asokd_ +asoki_ +asokl_ +asokr_ +asoks_ +asokx_ +asqrd_ +asqri_ +asqrl_ +asqrr_ +asqrs_ +asqrx_ +asrtc_ +asrtd_ +asrti_ +asrtl_ +asrtr_ +asrts_ +asrtx_ +assqd_ +assqi_ +assql_ +assqr_ +assqs_ +assqx_ +asubd_ +asubi_ +asubkd_ +asubki_ +asubkl_ +asubkr_ +asubks_ +asubkx_ +asubl_ +asubr_ +asubs_ +asubx_ +asumd_ +asumi_ +asuml_ +asumr_ +asums_ +asumx_ +aupxd_ +aupxi_ +aupxl_ +aupxr_ +aupxs_ +aupxx_ +aveqc_ +aveqd_ +aveqi_ +aveql_ +aveqr_ +aveqs_ +aveqx_ +await_ +awaitb_ +awritb_ +awrite_ +awsud_ +awsui_ +awsul_ +awsur_ +awsus_ +awsux_ +awvgd_ +awvgi_ +awvgl_ +awvgr_ +awvgs_ +awvgx_ +axori_ +axorki_ +axorkl_ +axorks_ +axorl_ +axors_ +begmem_ +bitmov_ +bitpak_ +bitupk_ +brktie_ +bswap2_ +bswap4_ +bswap8_ +btoi_ +bytmov_ +cctoc_ +chdept_ +chfeth_ +chrlwr_ +chrpak_ +chrupk_ +chrupr_ +clccos_ +clcenr_ +clcfeh_ +clcfid_ +clcfre_ +clcint_ +clclit_ +clcloe_ +clcmak_ +clcmd_ +clcmdw_ +clcnek_ +clcpst_ +clcscn_ +clepst_ +clgcur_ +clgetb_ +clgetc_ +clgetd_ +clgeti_ +clgetl_ +clgetr_ +clgets_ +clgetx_ +clgfil_ +clgkey_ +clglpb_ +clglpc_ +clglpd_ +clglpi_ +clglpl_ +clglpr_ +clglps_ +clglpx_ +clglsr_ +clgpsa_ +clgpsb_ +clgpsc_ +clgpsd_ +clgpsi_ +clgpsl_ +clgpsr_ +clgpss_ +clgpst_ +clgpsx_ +clgstr_ +clgwrd_ +clktie_ +cllpst_ +clopen_ +clopst_ +clpcls_ +clplen_ +clpopi_ +clpops_ +clpopu_ +clppsa_ +clppsb_ +clppsc_ +clppsd_ +clppsi_ +clppsl_ +clppsr_ +clppss_ +clppst_ +clppsx_ +clprew_ +clprif_ +clpsee_ +clpsit_ +clpstr_ +clputb_ +clputc_ +clputd_ +clputi_ +clputl_ +clputr_ +clputs_ +clputx_ +clreqr_ +clscan_ +clseti_ +clstai_ +cnvdae_ +cnvtie_ +coerce_ +cputie_ +ctocc_ +ctod_ +ctoi_ +ctol_ +ctor_ +ctotok_ +ctowrd_ +ctox_ +d1mach_ +deletg_ +diropn_ +dtcscl_ +dtmday_ +dtmdee_ +dtmdes_ +dtmene_ +dtmens_ +dtmlte_ +dtoc3_ +dtoc_ +elogd_ +elogr_ +envfid_ +envfit_ +envfre_ +envgeb_ +envged_ +envgei_ +envger_ +envges_ +envinr_ +envint_ +envlit_ +envmak_ +envnet_ +envpus_ +envret_ +envscn_ +eprinf_ +erract_ +errcoe_ +errget_ +evexpr_ +evvexr_ +evvfre_ +f77pak_ +f77upk_ +falloc_ +fcanpb_ +fcldir_ +fclobr_ +fcopy_ +fcopyo_ +fdebug_ +fdevbf_ +fdevbk_ +fdevtx_ +fdirne_ +fexbuf_ +ffa_ +ffault_ +ffilbf_ +ffilsz_ +ffldir_ +fflsbf_ +ffs_ +fft842_ +fgdev0_ +fgdevm_ +fgetfd_ +fgtdir_ +filbuf_ +filerr_ +filopn_ +finfo_ +finit_ +fioclp_ +fioqfh_ +fixmem_ +flsbuf_ +fmaccs_ +fmapfn_ +fmcloe_ +fmcopo_ +fmcopy_ +fmdebg_ +fmdele_ +fmfcdg_ +fmfcfe_ +fmfcit_ +fmfcsc_ +fmfinf_ +fmfopn_ +fmgetd_ +fmiobd_ +fmioed_ +fmioek_ +fmiopr_ +fmiorr_ +fmiosf_ +fmiotk_ +fmkbfs_ +fmkcoy_ +fmkdir_ +fmkpbf_ +fmlfad_ +fmlfae_ +fmlfat_ +fmlfbd_ +fmlfbe_ +fmlfbt_ +fmlfce_ +fmlfcy_ +fmlfde_ +fmlfne_ +fmlfon_ +fmlfpe_ +fmlfsi_ +fmlfst_ +fmlfue_ +fmlocd_ +fmloct_ +fmnexe_ +fmopen_ +fmrebd_ +fmrene_ +fmretd_ +fmseti_ +fmstai_ +fmsync_ +fmterr_ +fmtint_ +fmtred_ +fmtsel_ +fmtstr_ +fmunlk_ +fnextn_ +fnldir_ +fnroot_ +fntclb_ +fntcls_ +fntdir_ +fntedt_ +fntget_ +fntgfb_ +fntgfn_ +fntleb_ +fntmkt_ +fntopb_ +fntopn_ +fntopt_ +fntreb_ +fntree_ +fntrfb_ +fnulle_ +fopdir_ +fopnbf_ +fopntx_ +fowner_ +fpathe_ +fpequd_ +fpequr_ +fpfixd_ +fpfixr_ +fpnonr_ +fpnord_ +fpnorr_ +fpradv_ +fprfmt_ +fprinf_ +fprntf_ +fptdir_ +fputtx_ +freadp_ +fredio_ +fredir_ +frenae_ +frmbfs_ +frmtmp_ +frtnfd_ +fsetev_ +fsetfd_ +fseti_ +fsfdee_ +fsfgee_ +fsfopn_ +fskdir_ +fstati_ +fstatl_ +fstats_ +fstdfe_ +fstdir_ +fstrfp_ +fsvtfn_ +fswapd_ +futime_ +fwatio_ +fwritp_ +fwtacc_ +fxfacp_ +fxfacs_ +fxfact_ +fxfadr_ +fxfakb_ +fxfakc_ +fxfakd_ +fxfaki_ +fxfakr_ +fxfalc_ +fxfald_ +fxfalr_ +fxfalu_ +fxfasr_ +fxfbls_ +fxfbyt_ +fxfche_ +fxfchm_ +fxfchp_ +fxfchv_ +fxfcle_ +fxfcll_ +fxfcnx_ +fxfcoj_ +fxfcoy_ +fxfcte_ +fxfdae_ +fxfdee_ +fxfdiw_ +fxfdur_ +fxfenb_ +fxfenc_ +fxfend_ +fxfene_ +fxfeni_ +fxfenl_ +fxfenr_ +fxfens_ +fxfexh_ +fxfexr_ +fxffac_ +fxffcr_ +fxffiw_ +fxffog_ +fxffpd_ +fxfgas_ +fxfgeb_ +fxfged_ +fxfgei_ +fxfgen_ +fxfger_ +fxfget_ +fxfglm_ +fxfgsr_ +fxfhdt_ +fxfhee_ +fxfhef_ +fxfint_ +fxfisk_ +fxfkse_ +fxfksl_ +fxfksm_ +fxfksn_ +fxfkss_ +fxfkst_ +fxfksx_ +fxflor_ +fxfmad_ +fxfmar_ +fxfmas_ +fxfmay_ +fxfmea_ +fxfnoe_ +fxfnul_ +fxfopn_ +fxfopx_ +fxfove_ +fxfovt_ +fxfpaa_ +fxfpld_ +fxfple_ +fxfplf_ +fxfplo_ +fxfplp_ +fxfprr_ +fxfred_ +fxfree_ +fxfrek_ +fxfren_ +fxfrep_ +fxfrfr_ +fxfrhr_ +fxfsee_ +fxfsev_ +fxfsex_ +fxfskn_ +fxfstr_ +fxftox_ +fxfuad_ +fxfuna_ +fxfupd_ +fxfupr_ +fxfwrr_ +fxfwrs_ +fxfxal_ +fxfxhd_ +fxfxn1_ +fxfzcl_ +fxfzop_ +fxfzrd_ +fxfzst_ +fxfzwr_ +fxfzwt_ +gactie_ +gadraw_ +gamove_ +gargb_ +gargc_ +gargd_ +gargi_ +gargl_ +gargr_ +gargrd_ +gargs_ +gargsr_ +gargtk_ +gargwd_ +gargx_ +gascae_ +gcancl_ +gclear_ +gclose_ +gctod_ +gctol_ +gctox_ +gctran_ +gcurps_ +gdeace_ +gescae_ +getci_ +gethot_ +getlie_ +getlle_ +getloe_ +gexflr_ +gexfls_ +gexflt_ +gfill_ +gflush_ +gframe_ +gfrint_ +ggcell_ +ggcur_ +ggetb_ +ggeti_ +ggetr_ +ggets_ +ggscae_ +ggview_ +ggwind_ +gimcor_ +gimcrr_ +gimder_ +gimdig_ +gimeng_ +gimfrg_ +gimfrp_ +gimgeg_ +gimins_ +gimiod_ +gimioe_ +gimlop_ +gimqur_ +gimrat_ +gimreg_ +gimrep_ +gimres_ +gimrex_ +gimseg_ +gimser_ +gimsex_ +gimwrp_ +gimwrs_ +gkical_ +gkiclr_ +gkicls_ +gkides_ +gkieof_ +gkiese_ +gkiexe_ +gkifat_ +gkifen_ +gkiffh_ +gkifia_ +gkiflh_ +gkiger_ +gkiges_ +gkigey_ +gkiinl_ +gkiint_ +gkimfe_ +gkiops_ +gkiplt_ +gkipmt_ +gkipoe_ +gkipor_ +gkipuy_ +gkiree_ +gkirer_ +gkires_ +gkirey_ +gkiser_ +gkises_ +gkisul_ +gkitet_ +gkitxt_ +gkiwee_ +gkiwre_ +gkpcal_ +gkpcle_ +gkpclr_ +gkpcls_ +gkpdes_ +gkpdup_ +gkpese_ +gkpfat_ +gkpfia_ +gkpflh_ +gkpger_ +gkpges_ +gkpgey_ +gkpgrm_ +gkpinl_ +gkpmfe_ +gkpops_ +gkpplt_ +gkppmt_ +gkppoe_ +gkppor_ +gkppst_ +gkppuy_ +gkpres_ +gkpser_ +gkpses_ +gkptet_ +gkptxg_ +gkptxt_ +gkpunn_ +glabax_ +glbdrd_ +glbene_ +glbeq_ +glbfis_ +glbgek_ +glblas_ +glblob_ +glbmip_ +glbple_ +glbsep_ +glbses_ +glbset_ +glbtin_ +glbveg_ +gline_ +gltoc_ +gmark_ +gmftie_ +gmprif_ +gmsg_ +gmsgb_ +gmsgc_ +gmsgd_ +gmsgi_ +gmsgl_ +gmsgr_ +gmsgs_ +gmsgx_ +gmttot_ +gopen_ +gopeni_ +gpagee_ +gpatme_ +gpatmh_ +gpcell_ +gplcae_ +gplcal_ +gplclb_ +gplcll_ +gplclr_ +gplclt_ +gplflh_ +gpline_ +gploto_ +gplotv_ +gplret_ +gplsee_ +gplwci_ +gpmark_ +gqsort_ +gqvery_ +grdraw_ +grdwcs_ +greace_ +greset_ +grmove_ +grscae_ +gscan_ +gscur_ +gseti_ +gsetr_ +gsets_ +gstati_ +gstatr_ +gstats_ +gstrct_ +gstrcy_ +gstrmh_ +gstsei_ +gstser_ +gsview_ +gswind_ +gtdise_ +gtext_ +gtickr_ +gtliny_ +gtndis_ +gttyld_ +gtxset_ +gtybih_ +gtycas_ +gtycle_ +gtyeny_ +gtyexs_ +gtyfey_ +gtyfiy_ +gtygeb_ +gtygei_ +gtyger_ +gtyges_ +gtyins_ +gtyopn_ +gtysce_ +gumark_ +gvline_ +gvmark_ +gwcsme_ +gwrwcs_ +i1mach_ +idbcle_ +idbfid_ +idbfir_ +idbgeg_ +idbkwp_ +idbned_ +idbopn_ +idbpug_ +ieegmd_ +ieegmr_ +ieegnd_ +ieegnr_ +ieemad_ +ieemar_ +ieepad_ +ieepar_ +ieesmd_ +ieesmr_ +ieesnd_ +ieesnr_ +ieestd_ +ieestr_ +ieeupd_ +ieeupr_ +ieevpd_ +ieevpr_ +ieevud_ +ieevur_ +ieezsd_ +ieezsr_ +ikiacs_ +ikicle_ +ikicoy_ +ikidee_ +ikideg_ +ikiext_ +ikiged_ +ikigen_ +ikiger_ +ikiint_ +ikildr_ +ikimke_ +ikiopn_ +ikiopx_ +ikipae_ +ikiree_ +ikiupr_ +ikivan_ +imaccf_ +imaccs_ +imaddb_ +imaddd_ +imaddf_ +imaddi_ +imaddl_ +imaddr_ +imadds_ +imaflp_ +imalin_ +imaplv_ +imastr_ +imbln1_ +imbln2_ +imbln3_ +imbtrn_ +imcfnl_ +imcopy_ +imcssz_ +imctrt_ +imdect_ +imdele_ +imdelf_ +imdmap_ +imerr_ +imflpl_ +imflps_ +imflsd_ +imflsh_ +imflsi_ +imflsl_ +imflsr_ +imflss_ +imflsx_ +imfluh_ +imfnpy_ +imfnss_ +imgclr_ +imgetb_ +imgetc_ +imgetd_ +imgeti_ +imgetl_ +imgetr_ +imgets_ +imgfte_ +imggsc_ +imggsd_ +imggsi_ +imggsl_ +imggsr_ +imggss_ +imggsx_ +imgibf_ +imgime_ +imgl1d_ +imgl1i_ +imgl1l_ +imgl1r_ +imgl1s_ +imgl1x_ +imgl2d_ +imgl2i_ +imgl2l_ +imgl2r_ +imgl2s_ +imgl2x_ +imgl3d_ +imgl3i_ +imgl3l_ +imgl3r_ +imgl3s_ +imgl3x_ +imgnfn_ +imgnld_ +imgnli_ +imgnll_ +imgnln_ +imgnlr_ +imgnls_ +imgnlx_ +imgobf_ +imgs1d_ +imgs1i_ +imgs1l_ +imgs1r_ +imgs1s_ +imgs1x_ +imgs2d_ +imgs2i_ +imgs2l_ +imgs2r_ +imgs2s_ +imgs2x_ +imgs3d_ +imgs3i_ +imgs3l_ +imgs3r_ +imgs3s_ +imgs3x_ +imgsen_ +imgstr_ +iminie_ +imioff_ +imisec_ +imloop_ +immaky_ +immap_ +immapz_ +imnote_ +imofnl_ +imofns_ +imofnu_ +imopsf_ +impakd_ +impaki_ +impakl_ +impakr_ +impaks_ +impakx_ +impare_ +impgsd_ +impgsi_ +impgsl_ +impgsr_ +impgss_ +impgsx_ +impl1d_ +impl1i_ +impl1l_ +impl1r_ +impl1s_ +impl1x_ +impl2d_ +impl2i_ +impl2l_ +impl2r_ +impl2s_ +impl2x_ +impl3d_ +impl3i_ +impl3l_ +impl3r_ +impl3s_ +impl3x_ +impml1_ +impml2_ +impml3_ +impmlr_ +impmlv_ +impmmo_ +impmmp_ +impmon_ +impms1_ +impms2_ +impms3_ +impmsr_ +impmsv_ +impnld_ +impnli_ +impnll_ +impnln_ +impnlr_ +impnls_ +impnlx_ +imps1d_ +imps1i_ +imps1l_ +imps1r_ +imps1s_ +imps1x_ +imps2d_ +imps2i_ +imps2l_ +imps2r_ +imps2s_ +imps2x_ +imps3d_ +imps3i_ +imps3l_ +imps3r_ +imps3s_ +imps3x_ +impstr_ +imputb_ +imputd_ +imputh_ +imputi_ +imputl_ +imputr_ +imputs_ +imrbpx_ +imrdpx_ +imrene_ +imrmbs_ +imsamp_ +imsetf_ +imseti_ +imsetr_ +imsinb_ +imsmpl_ +imsmps_ +imsslv_ +imstai_ +imstar_ +imstas_ +imtcle_ +imtgem_ +imtlen_ +imtmae_ +imtopn_ +imtopp_ +imtrew_ +imtrgm_ +imunmp_ +imupkd_ +imupki_ +imupkl_ +imupkr_ +imupks_ +imupkx_ +imwbpx_ +imwrie_ +imwrpx_ +intrde_ +intree_ +intrrt_ +irafmn_ +itob_ +itoc_ +iwcare_ +iwcfis_ +iwents_ +iwfind_ +iwgbis_ +iwputr_ +iwputy_ +iwrfis_ +iwsetp_ +kardbf_ +kardgd_ +kardlp_ +kardpl_ +kardpr_ +kardsf_ +kawrbf_ +kawrgd_ +kawrlp_ +kawrpl_ +kawrpr_ +kawrsf_ +kawtbf_ +kawtgd_ +kawtlp_ +kawtpl_ +kawtpr_ +kawtsf_ +kbzard_ +kbzawr_ +kbzawt_ +kbzcls_ +kbzopn_ +kbzstt_ +kclcpr_ +kcldir_ +kcldpr_ +kclsbf_ +kclsgd_ +kclslp_ +kclspl_ +kclssf_ +kclstx_ +kclsty_ +kdvall_ +kdvown_ +kfacss_ +kfaloc_ +kfchdr_ +kfdele_ +kfgcwd_ +kfinfo_ +kflstx_ +kflsty_ +kfmkcp_ +kfmkdr_ +kfpath_ +kfprot_ +kfrnam_ +kfsubd_ +kfutim_ +kfxdir_ +kgettx_ +kgetty_ +kgfdir_ +kicont_ +kidece_ +kience_ +kienvt_ +kierrr_ +kiexte_ +kifine_ +kiflux_ +kifman_ +kifren_ +kigetn_ +kigets_ +kignoe_ +kiinit_ +kiloce_ +kimape_ +kimapn_ +kintpr_ +kiopes_ +kirece_ +kisend_ +kisenv_ +kishot_ +kixnoe_ +kmallc_ +knottx_ +knotty_ +kopcpr_ +kopdir_ +kopdpr_ +kopnbf_ +kopngd_ +kopnlp_ +kopnpl_ +kopnsf_ +kopntx_ +kopnty_ +koscmd_ +kputtx_ +kputty_ +krealc_ +ksared_ +ksawat_ +ksawre_ +ksektx_ +ksekty_ +ksttbf_ +ksttgd_ +ksttlp_ +ksttpl_ +ksttpr_ +ksttsf_ +kstttx_ +ksttty_ +ktzcls_ +ktzfls_ +ktzget_ +ktznot_ +ktzopn_ +ktzput_ +ktzsek_ +ktzstt_ +kzclmt_ +kzopmt_ +kzrdmt_ +kzrwmt_ +kzstmt_ +kzwrmt_ +kzwtmt_ +lexnum_ +lnocle_ +lnofeh_ +lnoopn_ +lnosae_ +locpr_ +locva_ +lpopen_ +lpzard_ +lpzawe_ +lpzawt_ +lsttot_ +ltoc_ +m75put_ +maideh_ +mallo1_ +mgdptr_ +mgtfwa_ +miilen_ +miinem_ +miipa2_ +miipa6_ +miipa8_ +miipad_ +miipak_ +miipar_ +miipke_ +miirec_ +miired_ +miirei_ +miirel_ +miirer_ +miires_ +miiup2_ +miiup6_ +miiup8_ +miiupd_ +miiupk_ +miiupr_ +miiwrc_ +miiwrd_ +miiwri_ +miiwrl_ +miiwrr_ +miiwrs_ +miocle_ +miogld_ +miogli_ +miogll_ +mioglr_ +miogls_ +mioglx_ +mioopn_ +mioopo_ +miopld_ +miopli_ +miopll_ +mioplr_ +miopls_ +mioplx_ +miosee_ +miosei_ +miosti_ +msvfwa_ +mtalle_ +mtcap_ +mtclen_ +mtclre_ +mtdeae_ +mtdevd_ +mtence_ +mtfile_ +mtfnae_ +mtgets_ +mtglok_ +mtgtyn_ +mtloce_ +mtneeo_ +mtopen_ +mtpare_ +mtposn_ +mtpute_ +mtreae_ +mtrewd_ +mtsavd_ +mtsavs_ +mtskid_ +mtstas_ +mtsync_ +mtupde_ +mwalld_ +mwalls_ +mwaxtn_ +mwc1td_ +mwc1tr_ +mwc2td_ +mwc2tr_ +mwcloe_ +mwcopd_ +mwcops_ +mwctfe_ +mwctrd_ +mwctrr_ +mwfins_ +mwflop_ +mwgaxp_ +mwgaxt_ +mwgctd_ +mwgctr_ +mwgltd_ +mwgltr_ +mwgsym_ +mwgwas_ +mwgwsd_ +mwgwsr_ +mwgwtd_ +mwgwtr_ +mwinvd_ +mwinvr_ +mwload_ +mwloam_ +mwltrd_ +mwltrr_ +mwlubb_ +mwlude_ +mwmkid_ +mwmkir_ +mwmmud_ +mwmmur_ +mwnewm_ +mwnewy_ +mwopem_ +mwopen_ +mwrefr_ +mwrote_ +mwsave_ +mwsavm_ +mwsaxp_ +mwscae_ +mwsctn_ +mwsdes_ +mwseti_ +mwshit_ +mwshow_ +mwsltd_ +mwsltr_ +mwssym_ +mwstai_ +mwswas_ +mwswsd_ +mwswsr_ +mwswtd_ +mwswte_ +mwswtr_ +mwtrad_ +mwtrar_ +mwv1td_ +mwv1tr_ +mwv2td_ +mwv2tr_ +mwvmud_ +mwvmur_ +mwvtrd_ +mwvtrr_ +ndopen_ +noti_ +notl_ +nots_ +nowhie_ +nscan_ +oifacs_ +oifcle_ +oifcoy_ +oifdee_ +oifgpe_ +oifmke_ +oifopn_ +oifopx_ +oifrdr_ +oifree_ +oiftrm_ +oifupr_ +oifwrr_ +onerre_ +onerrr_ +onexie_ +onexit_ +ord1_ +ord2_ +ori_ +orl_ +ors_ +oscmd_ +osfnik_ +osfnlk_ +osfnms_ +osfnpe_ +osfnrk_ +osfntt_ +osfnuk_ +pagefe_ +pagefs_ +pargb_ +pargc_ +pargd_ +pargg_ +pargi_ +pargl_ +pargr_ +pargs_ +pargsr_ +pargx_ +patamh_ +patfit_ +patgel_ +patgse_ +patinx_ +patloe_ +patmae_ +patmah_ +patomh_ +patsts_ +pggetd_ +pggete_ +pggetr_ +pgpage_ +pgpeed_ +pgpusd_ +pgsett_ +placcs_ +plallc_ +plascp_ +plbox_ +plcire_ +plcler_ +plcloe_ +plcome_ +plcoms_ +plcree_ +pldebg_ +pldebt_ +plempe_ +plempy_ +plfacs_ +plfcle_ +plfcoy_ +plfdee_ +plfnul_ +plfopn_ +plfree_ +plfupr_ +plgete_ +plglls_ +plglpi_ +plglpl_ +plglps_ +plglri_ +plglrl_ +plglrs_ +plgsie_ +pll2pi_ +pll2pl_ +pll2ps_ +pll2ri_ +pll2rl_ +pll2rs_ +pllcot_ +pllemy_ +plleql_ +plline_ +pllinl_ +pllinp_ +plliny_ +plllen_ +pllneg_ +plload_ +plloaf_ +plloam_ +plloop_ +pllprs_ +plnewy_ +plopen_ +plp2li_ +plp2ll_ +plp2ls_ +plp2ri_ +plp2rl_ +plp2rs_ +plpixi_ +plpixl_ +plpixs_ +plplls_ +plplpi_ +plplpl_ +plplps_ +plplri_ +plplrl_ +plplrs_ +plpoit_ +plpoln_ +plr2li_ +plr2ll_ +plr2ls_ +plr2pi_ +plr2pl_ +plr2ps_ +plrani_ +plranl_ +plrans_ +plrcle_ +plrefe_ +plregp_ +plreqi_ +plreql_ +plreqs_ +plrget_ +plrgex_ +plrop_ +plropn_ +plrpri_ +plrprl_ +plrprs_ +plrset_ +plsave_ +plsavf_ +plsavm_ +plsect_ +plsecy_ +plsete_ +plseti_ +plssie_ +plsslv_ +plstai_ +plstel_ +plubox_ +plucie_ +plupde_ +plupon_ +plvald_ +pmaccs_ +pmascp_ +pmbox_ +pmcire_ +pmcler_ +pmempy_ +pmglls_ +pmglpi_ +pmglpl_ +pmglps_ +pmglri_ +pmglrl_ +pmglrs_ +pmline_ +pmliny_ +pmnewk_ +pmplls_ +pmplpi_ +pmplpl_ +pmplps_ +pmplri_ +pmplrl_ +pmplrs_ +pmpoit_ +pmpoln_ +pmrcle_ +pmrgex_ +pmrop_ +pmropn_ +pmrset_ +pmsect_ +pmsecy_ +pmsete_ +pmseti_ +pmstai_ +pmstel_ +poll_ +pollce_ +pollcr_ +pollgs_ +pollon_ +pollpt_ +pollst_ +polltt_ +pollzo_ +prchdr_ +prclcr_ +prcldr_ +prcloe_ +prdone_ +prdumn_ +prenve_ +prenvt_ +prfilf_ +prfinc_ +prgete_ +prgetr_ +prkill_ +pronic_ +propcr_ +propdr_ +propen_ +proscd_ +protet_ +prpsio_ +prpsld_ +prredr_ +prseti_ +prsigl_ +prstai_ +prupde_ +prvret_ +przclr_ +pscenr_ +pscens_ +pschwh_ +pscloe_ +psdept_ +psesct_ +psfone_ +psfonr_ +psfoor_ +psgett_ +pshear_ +psindt_ +psioit_ +psioxr_ +pslink_ +psnewe_ +psopen_ +psoutt_ +pspage_ +pspagk_ +psrigy_ +psrjps_ +pssets_ +pssett_ +pssety_ +psspft_ +pstese_ +pstexh_ +pstrar_ +pswrig_ +pswrtk_ +psxpos_ +psypos_ +putcc_ +putci_ +putlie_ +qmaccs_ +qmgetc_ +qmscan_ +qmscao_ +qmsetm_ +qmsetr_ +qmsets_ +qmspai_ +qmspar_ +qmsymb_ +qmupds_ +qpaccf_ +qpaccs_ +qpaddb_ +qpaddc_ +qpaddd_ +qpaddf_ +qpaddi_ +qpaddl_ +qpaddr_ +qpadds_ +qpaddx_ +qpargt_ +qpastr_ +qpbind_ +qpcfnl_ +qpcloe_ +qpclot_ +qpcopf_ +qpcopy_ +qpctod_ +qpctoi_ +qpdele_ +qpdelf_ +qpdsym_ +qpdtye_ +qpelee_ +qpexad_ +qpexai_ +qpexar_ +qpexcd_ +qpexce_ +qpexci_ +qpexcr_ +qpexdc_ +qpexde_ +qpexdg_ +qpexdr_ +qpexee_ +qpexfe_ +qpexge_ +qpexgr_ +qpexmk_ +qpexmr_ +qpexon_ +qpexpd_ +qpexpi_ +qpexpn_ +qpexpr_ +qpexps_ +qpexpt_ +qpexrd_ +qpexsd_ +qpexsi_ +qpexsr_ +qpfacs_ +qpfcle_ +qpfcos_ +qpfcoy_ +qpfdee_ +qpflur_ +qpfopn_ +qpfopx_ +qpfree_ +qpfupr_ +qpfwar_ +qpfwfr_ +qpfzcl_ +qpfzop_ +qpfzrd_ +qpfzst_ +qpfzwr_ +qpfzwt_ +qpgetb_ +qpgetc_ +qpgetd_ +qpgeti_ +qpgetk_ +qpgetl_ +qpgetm_ +qpgetr_ +qpgets_ +qpgetx_ +qpgmsm_ +qpgnfn_ +qpgpsm_ +qpgstr_ +qpinht_ +qpioce_ +qpioge_ +qpiogr_ +qpiogs_ +qpiolk_ +qpiols_ +qpiomx_ +qpioon_ +qpiope_ +qpiops_ +qpiori_ +qpiors_ +qpiort_ +qpiosc_ +qpiose_ +qpiosi_ +qpiosr_ +qpiost_ +qpiour_ +qpiovr_ +qpiowt_ +qplenf_ +qplenl_ +qplesd_ +qplesi_ +qplesr_ +qploas_ +qpmaxd_ +qpmaxi_ +qpmaxr_ +qpmind_ +qpmini_ +qpminr_ +qpmkfe_ +qpnexk_ +qpofnl_ +qpofns_ +qpofnu_ +qpopen_ +qpopet_ +qppare_ +qpparl_ +qppcle_ +qppopn_ +qppstr_ +qpputb_ +qpputc_ +qpputd_ +qpputi_ +qpputl_ +qpputm_ +qpputr_ +qpputs_ +qpputx_ +qpquef_ +qprawk_ +qpread_ +qprebd_ +qprene_ +qprenf_ +qprlmd_ +qprlmi_ +qprlmr_ +qpsavs_ +qpseel_ +qpseti_ +qpsetr_ +qpsizf_ +qpstai_ +qpstar_ +qpsync_ +qpungk_ +qpwrie_ +qpxgvd_ +qpxgvi_ +qpxgvl_ +qpxgvr_ +qpxgvs_ +r1mach_ +r2tr_ +r2tx_ +r4syn_ +r4tr_ +r4tx_ +r8syn_ +r8tr_ +r8tx_ +rdukey_ +reopen_ +resetn_ +salloc_ +scanc_ +sfree_ +shifti_ +shiftl_ +shifts_ +smark_ +sprinf_ +sscan_ +stallc_ +stcloe_ +stentr_ +stfacs_ +stfadr_ +stfcle_ +stfcos_ +stfcoy_ +stfcte_ +stfdee_ +stfgeb_ +stfgei_ +stfgen_ +stfges_ +stfget_ +stfind_ +stfinl_ +stfins_ +stfmeb_ +stfmke_ +stfnee_ +stfopn_ +stfopx_ +stforb_ +stfrdr_ +stfree_ +stfrek_ +stfrfr_ +stfrgb_ +stfrne_ +stfupr_ +stfwfr_ +stfwgb_ +sthash_ +sthead_ +stinfo_ +stkmkg_ +stmark_ +stname_ +stnext_ +stnsys_ +stopen_ +stpstr_ +strcle_ +strdic_ +strefb_ +streff_ +streq_ +strese_ +strge_ +strgee_ +strgt_ +strids_ +stridx_ +strlds_ +strldx_ +strle_ +strlt_ +strlwr_ +strmac_ +strmah_ +strncp_ +strne_ +stropn_ +strpak_ +strse1_ +strsee_ +strseh_ +strsrt_ +strtbl_ +strupk_ +strupr_ +stsave_ +stsize_ +stsque_ +sttyco_ +sttyet_ +sttygg_ +sttynm_ +sttyse_ +sttysm_ +sttytt_ +syserr_ +sysers_ +sysged_ +sysges_ +sysgsg_ +sysid_ +sysmte_ +syspac_ +syspat_ +syspte_ +sysret_ +syssct_ +tsleep_ +ttopen_ +ttseti_ +ttsets_ +ttstai_ +ttstas_ +ttybih_ +ttybre_ +ttycas_ +ttycds_ +ttycle_ +ttycln_ +ttyclr_ +ttyctl_ +ttydee_ +ttydey_ +ttyeny_ +ttyexs_ +ttyfey_ +ttyfiy_ +ttygds_ +ttygeb_ +ttygei_ +ttyger_ +ttyges_ +ttygoo_ +ttygpe_ +ttygse_ +ttyins_ +ttyint_ +ttylod_ +ttyods_ +ttyopn_ +ttypue_ +ttypus_ +ttyred_ +ttysce_ +ttysei_ +ttyso_ +ttysti_ +ttysui_ +ttywre_ +ungete_ +ungeti_ +unread_ +urand_ +vfnadd_ +vfncle_ +vfndee_ +vfndel_ +vfnene_ +vfnenr_ +vfnexr_ +vfngen_ +vfnise_ +vfnman_ +vfnmap_ +vfnmau_ +vfnopn_ +vfnsqe_ +vfntre_ +vfnunn_ +vfnunp_ +vlibinit_ +vmallc_ +vvfncm_ +vvfnee_ +vvfnip_ +vvfnis_ +vvfnre_ +wfaitd_ +wfaitt_ +wfaitv_ +wfarcd_ +wfarct_ +wfarcv_ +wfcard_ +wfcart_ +wfcarv_ +wfcscd_ +wfcsct_ +wfcscv_ +wfdecs_ +wffnld_ +wfglsd_ +wfglst_ +wfglsv_ +wfgsbb_ +wfgsbg_ +wfgsbl_ +wfgsce_ +wfgscf_ +wfgsdr_ +wfgsel_ +wfgson_ +wfgsre_ +wfinit_ +wfmerd_ +wfmert_ +wfmerv_ +wfmold_ +wfmolt_ +wfmolv_ +wfmspd_ +wfmspf_ +wfmspi_ +wfmspl_ +wfmspt_ +wfmspv_ +wfmspy_ +wfpard_ +wfpart_ +wfparv_ +wfpcod_ +wfpcot_ +wfpcov_ +wfqscd_ +wfqsct_ +wfqscv_ +wfsind_ +wfsint_ +wfsinv_ +wfsmph_ +wfsmpn_ +wfsmpt_ +wfstgd_ +wfstgt_ +wfstgv_ +wftand_ +wftant_ +wftanv_ +wftnxd_ +wftnxt_ +wftnxv_ +wftnxy_ +wftscd_ +wftsct_ +wftscv_ +wfzead_ +wfzeat_ +wfzeav_ +wfzpxd_ +wfzpxt_ +wfzpxv_ +wfzpxy_ +xalloe_ +xcallc_ +xdeale_ +xdevor_ +xdevss_ +xeract_ +xerfmg_ +xerpoi_ +xerpop_ +xerpsh_ +xerpsr_ +xerpuc_ +xerpue_ +xerret_ +xerror_ +xersel_ +xervey_ +xevadg_ +xevbip_ +xevbop_ +xevcan_ +xever1_ +xever2_ +xeverr_ +xevfrp_ +xevgek_ +xevinp_ +xevmap_ +xevnee_ +xevpae_ +xevpah_ +xevqut_ +xevstt_ +xevunp_ +xfaccs_ +xfatal_ +xfchdr_ +xfcloe_ +xfdele_ +xffluh_ +xfgetc_ +xfgetr_ +xfnote_ +xfopen_ +xfputc_ +xfputr_ +xfread_ +xfrnam_ +xfscan_ +xfseek_ +xfungc_ +xfwrie_ +xgdevt_ +xgtpid_ +xgtuid_ +xisaty_ +xmallc_ +xmfree_ +xmjbuf_ +xmktep_ +xonerr_ +xonext_ +xori_ +xorl_ +xors_ +xpages_ +xprinf_ +xqsort_ +xrealc_ +xsizef_ +xstdeh_ +xstrcp_ +xstrct_ +xstrcy_ +xstrln_ +xtoc_ +xttyse_ +xvvadg_ +xvvbip_ +xvvbop_ +xvvcan_ +xvvche_ +xvver1_ +xvver2_ +xvverr_ +xvvfrp_ +xvvgek_ +xvvinp_ +xvvlos_ +xvvmap_ +xvvnee_ +xvvnud_ +xvvnui_ +xvvnul_ +xvvnur_ +xvvnus_ +xvvpae_ +xvvpah_ +xvvqut_ +xvvstt_ +xvvunp_ +xwhen_ +xxscan_ +zardbf_ +zardgd_ +zardks_ +zardlp_ +zardmt_ +zardnd_ +zardnu_ +zardpl_ +zardpr_ +zardps_ +zardsf_ +zawrbf_ +zawrgd_ +zawrks_ +zawrlp_ +zawrmt_ +zawrnd_ +zawrnu_ +zawrpl_ +zawrpr_ +zawrps_ +zawrsf_ +zawset_ +zawtbf_ +zawtgd_ +zawtks_ +zawtlp_ +zawtmt_ +zawtnd_ +zawtnu_ +zawtpl_ +zawtpr_ +zawtps_ +zawtsf_ +zclcpr_ +zcldir_ +zcldpr_ +zclm70_ +zclm75_ +zclsbf_ +zclsgd_ +zclsks_ +zclslp_ +zclsmt_ +zclsnd_ +zclsnu_ +zclspl_ +zclsps_ +zclssf_ +zclstt_ +zclstx_ +zclsty_ +zdojmp_ +zdvall_ +zdvown_ +zfacss_ +zfaloc_ +zfchdr_ +zfdele_ +zfgcwd_ +zfinfo_ +zflsnu_ +zflstt_ +zflstx_ +zflsty_ +zfmkcp_ +zfmkdr_ +zfnbrk_ +zfpath_ +zfpoll_ +zfprot_ +zfrnam_ +zfsubd_ +zfutim_ +zfxdir_ +zgcmdl_ +zgetnu_ +zgettt_ +zgettx_ +zgetty_ +zgfdir_ +zghost_ +zgmtco_ +zgtime_ +zgtpid_ +zintpr_ +zlocpr_ +zlocva_ +zmaloc_ +zmfree_ +znotnu_ +znottt_ +znottx_ +znotty_ +zopcpr_ +zopdir_ +zopdpr_ +zopm70_ +zopm75_ +zopnbf_ +zopngd_ +zopnks_ +zopnlp_ +zopnmt_ +zopnnd_ +zopnnu_ +zopnpl_ +zopnsf_ +zopntt_ +zopntx_ +zopnty_ +zoscmd_ +zpanic_ +zputnu_ +zputtt_ +zputtx_ +zputty_ +zraloc_ +zrdm70_ +zrdm75_ +zseknu_ +zsektt_ +zsektx_ +zsekty_ +zsestt_ +zsettt_ +zstm70_ +zstm75_ +zststt_ +zsttbf_ +zsttgd_ +zsttks_ +zsttlp_ +zsttmt_ +zsttnd_ +zsttnu_ +zsttpl_ +zsttpr_ +zsttps_ +zsttsf_ +zstttt_ +zstttx_ +zsttty_ +zttgeg_ +zttger_ +zttloe_ +zttloo_ +zttlov_ +zttpbf_ +zttplk_ +zttpug_ +zttquy_ +zttttt_ +zttupe_ +zwmsec_ +zwrm70_ +zwrm75_ +zwtm70_ +zwtm75_ +zxgmes_ +zxwhen_ +zzclmt_ +zzopmt_ +zzrdii_ +zzrdmt_ +zzrwmt_ +zzsetk_ +zzstmt_ +zzwrii_ +zzwrmt_ +zzwtmt_ +zzzend_ diff --git a/unix/shlib/S.nm.pg b/unix/shlib/S.nm.pg new file mode 100644 index 00000000..478203ad --- /dev/null +++ b/unix/shlib/S.nm.pg @@ -0,0 +1,2423 @@ +_aabsd_ +_aabsi_ +_aabsl_ +_aabsr_ +_aabss_ +_aabsx_ +_aaddd_ +_aaddi_ +_aaddkd_ +_aaddki_ +_aaddkl_ +_aaddkr_ +_aaddks_ +_aaddkx_ +_aaddl_ +_aaddr_ +_aadds_ +_aaddx_ +_aandi_ +_aandki_ +_aandkl_ +_aandks_ +_aandl_ +_aands_ +_aavgd_ +_aavgi_ +_aavgl_ +_aavgr_ +_aavgs_ +_aavgx_ +_abavd_ +_abavi_ +_abavl_ +_abavr_ +_abavs_ +_abavx_ +_abeqc_ +_abeqd_ +_abeqi_ +_abeqkc_ +_abeqkd_ +_abeqki_ +_abeqkl_ +_abeqkr_ +_abeqks_ +_abeqkx_ +_abeql_ +_abeqr_ +_abeqs_ +_abeqx_ +_abgec_ +_abged_ +_abgei_ +_abgekc_ +_abgekd_ +_abgeki_ +_abgekl_ +_abgekr_ +_abgeks_ +_abgekx_ +_abgel_ +_abger_ +_abges_ +_abgex_ +_abgtc_ +_abgtd_ +_abgti_ +_abgtkc_ +_abgtkd_ +_abgtki_ +_abgtkl_ +_abgtkr_ +_abgtks_ +_abgtkx_ +_abgtl_ +_abgtr_ +_abgts_ +_abgtx_ +_ablec_ +_abled_ +_ablei_ +_ablekc_ +_ablekd_ +_ableki_ +_ablekl_ +_ablekr_ +_ableks_ +_ablekx_ +_ablel_ +_abler_ +_ables_ +_ablex_ +_abltc_ +_abltd_ +_ablti_ +_abltkc_ +_abltkd_ +_abltki_ +_abltkl_ +_abltkr_ +_abltks_ +_abltkx_ +_abltl_ +_abltr_ +_ablts_ +_abltx_ +_abnec_ +_abned_ +_abnei_ +_abnekc_ +_abnekd_ +_abneki_ +_abnekl_ +_abnekr_ +_abneks_ +_abnekx_ +_abnel_ +_abner_ +_abnes_ +_abnex_ +_abori_ +_aborki_ +_aborkl_ +_aborks_ +_aborl_ +_abors_ +_absud_ +_absui_ +_absul_ +_absur_ +_absus_ +_acht_ +_achtb_ +_achtbb_ +_achtbc_ +_achtbd_ +_achtbi_ +_achtbl_ +_achtbr_ +_achtbs_ +_achtbu_ +_achtbx_ +_achtc_ +_achtcb_ +_achtcc_ +_achtcd_ +_achtci_ +_achtcl_ +_achtcr_ +_achtcs_ +_achtcu_ +_achtcx_ +_achtd_ +_achtdb_ +_achtdc_ +_achtdd_ +_achtdi_ +_achtdl_ +_achtdr_ +_achtds_ +_achtdu_ +_achtdx_ +_achti_ +_achtib_ +_achtic_ +_achtid_ +_achtii_ +_achtil_ +_achtir_ +_achtis_ +_achtiu_ +_achtix_ +_achtl_ +_achtlb_ +_achtlc_ +_achtld_ +_achtli_ +_achtll_ +_achtlr_ +_achtls_ +_achtlu_ +_achtlx_ +_achtr_ +_achtrb_ +_achtrc_ +_achtrd_ +_achtri_ +_achtrl_ +_achtrr_ +_achtrs_ +_achtru_ +_achtrx_ +_achts_ +_achtsb_ +_achtsc_ +_achtsd_ +_achtsi_ +_achtsl_ +_achtsr_ +_achtss_ +_achtsu_ +_achtsx_ +_achtu_ +_achtub_ +_achtuc_ +_achtud_ +_achtui_ +_achtul_ +_achtur_ +_achtus_ +_achtuu_ +_achtux_ +_achtx_ +_achtxb_ +_achtxc_ +_achtxd_ +_achtxi_ +_achtxl_ +_achtxr_ +_achtxs_ +_achtxu_ +_achtxx_ +_acjgx_ +_aclrb_ +_aclrc_ +_aclrd_ +_aclri_ +_aclrl_ +_aclrr_ +_aclrs_ +_aclrx_ +_acnvd_ +_acnvi_ +_acnvl_ +_acnvr_ +_acnvrd_ +_acnvri_ +_acnvrl_ +_acnvrr_ +_acnvrs_ +_acnvs_ +_adivd_ +_adivi_ +_adivkd_ +_adivki_ +_adivkl_ +_adivkr_ +_adivks_ +_adivkx_ +_adivl_ +_adivr_ +_adivs_ +_adivx_ +_adotd_ +_adoti_ +_adotl_ +_adotr_ +_adots_ +_adotx_ +_advzd_ +_advzi_ +_advzl_ +_advzr_ +_advzs_ +_advzx_ +_aelogd_ +_aelogr_ +_aexpd_ +_aexpi_ +_aexpkd_ +_aexpki_ +_aexpkl_ +_aexpkr_ +_aexpks_ +_aexpkx_ +_aexpl_ +_aexpr_ +_aexps_ +_aexpx_ +_afftrr_ +_afftrx_ +_afftxr_ +_afftxx_ +_agltc_ +_agltd_ +_aglti_ +_agltl_ +_agltr_ +_aglts_ +_agltx_ +_ahgmc_ +_ahgmd_ +_ahgmi_ +_ahgml_ +_ahgmr_ +_ahgms_ +_ahivc_ +_ahivd_ +_ahivi_ +_ahivl_ +_ahivr_ +_ahivs_ +_ahivx_ +_aiftrr_ +_aiftrx_ +_aiftxr_ +_aiftxx_ +_aimgd_ +_aimgi_ +_aimgl_ +_aimgr_ +_aimgs_ +_alimc_ +_alimd_ +_alimi_ +_aliml_ +_alimr_ +_alims_ +_alimx_ +_allnd_ +_allni_ +_allnl_ +_allnr_ +_allns_ +_allnx_ +_alogd_ +_alogi_ +_alogl_ +_alogr_ +_alogs_ +_alogx_ +_alovc_ +_alovd_ +_alovi_ +_alovl_ +_alovr_ +_alovs_ +_alovx_ +_altad_ +_altai_ +_altal_ +_altar_ +_altas_ +_altax_ +_altmd_ +_altmi_ +_altml_ +_altmr_ +_altms_ +_altmx_ +_altrd_ +_altri_ +_altrl_ +_altrr_ +_altrs_ +_altrx_ +_aluid_ +_aluii_ +_aluil_ +_aluir_ +_aluis_ +_alutc_ +_alutd_ +_aluti_ +_alutl_ +_alutr_ +_aluts_ +_amagd_ +_amagi_ +_amagl_ +_amagr_ +_amags_ +_amagx_ +_amapd_ +_amapi_ +_amapl_ +_amapr_ +_amaps_ +_amaxc_ +_amaxd_ +_amaxi_ +_amaxkc_ +_amaxkd_ +_amaxki_ +_amaxkl_ +_amaxkr_ +_amaxks_ +_amaxkx_ +_amaxl_ +_amaxr_ +_amaxs_ +_amaxx_ +_amed3c_ +_amed3d_ +_amed3i_ +_amed3l_ +_amed3r_ +_amed3s_ +_amed4c_ +_amed4d_ +_amed4i_ +_amed4l_ +_amed4r_ +_amed4s_ +_amed5c_ +_amed5d_ +_amed5i_ +_amed5l_ +_amed5r_ +_amed5s_ +_amedc_ +_amedd_ +_amedi_ +_amedl_ +_amedr_ +_ameds_ +_amedx_ +_amgsd_ +_amgsi_ +_amgsl_ +_amgsr_ +_amgss_ +_amgsx_ +_aminc_ +_amind_ +_amini_ +_aminkc_ +_aminkd_ +_aminki_ +_aminkl_ +_aminkr_ +_aminks_ +_aminkx_ +_aminl_ +_aminr_ +_amins_ +_aminx_ +_amodd_ +_amodi_ +_amodkd_ +_amodki_ +_amodkl_ +_amodkr_ +_amodks_ +_amodl_ +_amodr_ +_amods_ +_amovc_ +_amovd_ +_amovi_ +_amovkc_ +_amovkd_ +_amovki_ +_amovkl_ +_amovkr_ +_amovks_ +_amovkx_ +_amovl_ +_amovr_ +_amovs_ +_amovx_ +_amuld_ +_amuli_ +_amulkd_ +_amulki_ +_amulkl_ +_amulkr_ +_amulks_ +_amulkx_ +_amull_ +_amulr_ +_amuls_ +_amulx_ +_andi_ +_andl_ +_ands_ +_anegd_ +_anegi_ +_anegl_ +_anegr_ +_anegs_ +_anegx_ +_anoti_ +_anotl_ +_anots_ +_apkxd_ +_apkxi_ +_apkxl_ +_apkxr_ +_apkxs_ +_apkxx_ +_apold_ +_apolr_ +_apowd_ +_apowi_ +_apowkd_ +_apowki_ +_apowkl_ +_apowkr_ +_apowks_ +_apowkx_ +_apowl_ +_apowr_ +_apows_ +_apowx_ +_aravd_ +_aravi_ +_aravl_ +_aravr_ +_aravs_ +_aravx_ +_arcpd_ +_arcpi_ +_arcpl_ +_arcpr_ +_arcps_ +_arcpx_ +_arczd_ +_arczi_ +_arczl_ +_arczr_ +_arczs_ +_arczx_ +_aread_ +_areadb_ +_argtd_ +_argti_ +_argtl_ +_argtr_ +_argts_ +_argtx_ +_arltd_ +_arlti_ +_arltl_ +_arltr_ +_arlts_ +_arltx_ +_aselc_ +_aseld_ +_aseli_ +_asell_ +_aselr_ +_asels_ +_aselx_ +_asokc_ +_asokd_ +_asoki_ +_asokl_ +_asokr_ +_asoks_ +_asokx_ +_asqrd_ +_asqri_ +_asqrl_ +_asqrr_ +_asqrs_ +_asqrx_ +_asrtc_ +_asrtd_ +_asrti_ +_asrtl_ +_asrtr_ +_asrts_ +_asrtx_ +_assqd_ +_assqi_ +_assql_ +_assqr_ +_assqs_ +_assqx_ +_asubd_ +_asubi_ +_asubkd_ +_asubki_ +_asubkl_ +_asubkr_ +_asubks_ +_asubkx_ +_asubl_ +_asubr_ +_asubs_ +_asubx_ +_asumd_ +_asumi_ +_asuml_ +_asumr_ +_asums_ +_asumx_ +_aupxd_ +_aupxi_ +_aupxl_ +_aupxr_ +_aupxs_ +_aupxx_ +_aveqc_ +_aveqd_ +_aveqi_ +_aveql_ +_aveqr_ +_aveqs_ +_aveqx_ +_await_ +_awaitb_ +_awritb_ +_awrite_ +_awsud_ +_awsui_ +_awsul_ +_awsur_ +_awsus_ +_awsux_ +_awvgd_ +_awvgi_ +_awvgl_ +_awvgr_ +_awvgs_ +_awvgx_ +_axori_ +_axorki_ +_axorkl_ +_axorks_ +_axorl_ +_axors_ +_begmem_ +_bitmov_ +_bitpak_ +_bitupk_ +_brktie_ +_bswap2_ +_bswap4_ +_bswap8_ +_btoi_ +_bytmov_ +_cctoc_ +_chdept_ +_chfeth_ +_chrlwr_ +_chrpak_ +_chrupk_ +_chrupr_ +_clcenr_ +_clcfeh_ +_clcfid_ +_clcfre_ +_clcint_ +_clcmak_ +_clcmd_ +_clcmdw_ +_clcnek_ +_clcpst_ +_clgcur_ +_clgetb_ +_clgetc_ +_clgetd_ +_clgeti_ +_clgetl_ +_clgetr_ +_clgets_ +_clgetx_ +_clgfil_ +_clgkey_ +_clglpb_ +_clglpc_ +_clglpd_ +_clglpi_ +_clglpl_ +_clglpr_ +_clglps_ +_clglpx_ +_clglsr_ +_clgpsb_ +_clgpsc_ +_clgpsd_ +_clgpsi_ +_clgpsl_ +_clgpsr_ +_clgpss_ +_clgpst_ +_clgpsx_ +_clgstr_ +_clgwrd_ +_clktie_ +_clopen_ +_clopst_ +_clpcls_ +_clplen_ +_clpopi_ +_clpops_ +_clpopu_ +_clppsb_ +_clppsc_ +_clppsd_ +_clppsi_ +_clppsl_ +_clppsr_ +_clppss_ +_clppst_ +_clppsx_ +_clprew_ +_clprif_ +_clpsee_ +_clpsit_ +_clpstr_ +_clputb_ +_clputc_ +_clputd_ +_clputi_ +_clputl_ +_clputr_ +_clputs_ +_clputx_ +_clreqr_ +_clscan_ +_clseti_ +_clstai_ +_cnvdae_ +_cnvtie_ +_coerce_ +_cputie_ +_ctocc_ +_ctod_ +_ctoi_ +_ctol_ +_ctor_ +_ctotok_ +_ctowrd_ +_ctox_ +_d1mach_ +_deletg_ +_diropn_ +_dtcscl_ +_dtoc3_ +_dtoc_ +_elogd_ +_elogr_ +_envfid_ +_envfit_ +_envfre_ +_envgeb_ +_envged_ +_envgei_ +_envger_ +_envges_ +_envinr_ +_envint_ +_envlit_ +_envmak_ +_envnet_ +_envpus_ +_envret_ +_envscn_ +_eprinf_ +_erract_ +_errcoe_ +_errget_ +_evexpr_ +_f77pak_ +_f77upk_ +_falloc_ +_fatal_ +_fcanpb_ +_fchdir_ +_fcldir_ +_fclobr_ +_fcopy_ +_fcopyo_ +_fdebug_ +_fdevbf_ +_fdevbk_ +_fdevtx_ +_fdirne_ +_fexbuf_ +_ffa_ +_ffault_ +_ffilbf_ +_ffilsz_ +_ffldir_ +_fflsbf_ +_ffs_ +_fft842_ +_fgdev0_ +_fgdevm_ +_fgetfd_ +_fgtdir_ +_filbuf_ +_filerr_ +_filopn_ +_finfo_ +_finit_ +_fioclp_ +_fioqfh_ +_fixmem_ +_flsbuf_ +_fmaccs_ +_fmapfn_ +_fmcloe_ +_fmcopo_ +_fmcopy_ +_fmdebg_ +_fmdele_ +_fmfcdg_ +_fmfcfe_ +_fmfcit_ +_fmfcsc_ +_fmfinf_ +_fmfopn_ +_fmgetd_ +_fmiobd_ +_fmioed_ +_fmioek_ +_fmiopr_ +_fmiorr_ +_fmiosf_ +_fmiotk_ +_fmkbfs_ +_fmkcoy_ +_fmkdir_ +_fmkpbf_ +_fmlfad_ +_fmlfae_ +_fmlfat_ +_fmlfbd_ +_fmlfbe_ +_fmlfbt_ +_fmlfce_ +_fmlfcy_ +_fmlfde_ +_fmlfne_ +_fmlfon_ +_fmlfpe_ +_fmlfsi_ +_fmlfst_ +_fmlfue_ +_fmlocd_ +_fmloct_ +_fmnexe_ +_fmopen_ +_fmrebd_ +_fmrene_ +_fmretd_ +_fmseti_ +_fmstai_ +_fmsync_ +_fmterr_ +_fmtint_ +_fmtred_ +_fmtsel_ +_fmtstr_ +_fmunlk_ +_fnextn_ +_fnldir_ +_fnroot_ +_fntclb_ +_fntcls_ +_fntdir_ +_fntedt_ +_fntget_ +_fntgfb_ +_fntgfn_ +_fntleb_ +_fntmkt_ +_fntopb_ +_fntopn_ +_fntopt_ +_fntreb_ +_fntree_ +_fntrfb_ +_fnulle_ +_fopdir_ +_fopnbf_ +_fopntx_ +_fowner_ +_fpathe_ +_fpequd_ +_fpequr_ +_fpfixd_ +_fpfixr_ +_fpnonr_ +_fpnord_ +_fpnorr_ +_fpradv_ +_fprfmt_ +_fprinf_ +_fprntf_ +_fptdir_ +_fputtx_ +_freadp_ +_fredio_ +_fredir_ +_frenae_ +_frmbfs_ +_frmtmp_ +_frtnfd_ +_fscan_ +_fsetev_ +_fsetfd_ +_fseti_ +_fsfdee_ +_fsfgee_ +_fsfopn_ +_fskdir_ +_fstati_ +_fstatl_ +_fstats_ +_fstdfe_ +_fstdir_ +_fstrfp_ +_fsvtfn_ +_fswapd_ +_fwatio_ +_fwritp_ +_fwtacc_ +_gactie_ +_gadraw_ +_gamove_ +_gargb_ +_gargc_ +_gargd_ +_gargi_ +_gargl_ +_gargr_ +_gargrd_ +_gargs_ +_gargsr_ +_gargtk_ +_gargwd_ +_gargx_ +_gascae_ +_gcancl_ +_gclear_ +_gclose_ +_gctod_ +_gctol_ +_gctox_ +_gctran_ +_gcurps_ +_gdeace_ +_gescae_ +_getci_ +_gethot_ +_getlie_ +_getlle_ +_getloe_ +_getpid_ +_getuid_ +_gexflr_ +_gexfls_ +_gexflt_ +_gfill_ +_gflush_ +_gframe_ +_gfrint_ +_ggcell_ +_ggcur_ +_ggetb_ +_ggeti_ +_ggetr_ +_ggets_ +_ggscae_ +_ggview_ +_ggwind_ +_gkical_ +_gkiclr_ +_gkicls_ +_gkides_ +_gkieof_ +_gkiese_ +_gkiexe_ +_gkifat_ +_gkifen_ +_gkiffh_ +_gkifia_ +_gkiflh_ +_gkiger_ +_gkiges_ +_gkigey_ +_gkiinl_ +_gkiint_ +_gkimfe_ +_gkiops_ +_gkiplt_ +_gkipmt_ +_gkipoe_ +_gkipor_ +_gkipuy_ +_gkiree_ +_gkirer_ +_gkires_ +_gkirey_ +_gkiser_ +_gkises_ +_gkisul_ +_gkitet_ +_gkitxt_ +_gkiwre_ +_gkpcal_ +_gkpcle_ +_gkpclr_ +_gkpcls_ +_gkpdes_ +_gkpdup_ +_gkpese_ +_gkpfat_ +_gkpfia_ +_gkpflh_ +_gkpger_ +_gkpges_ +_gkpgey_ +_gkpgrm_ +_gkpinl_ +_gkpmfe_ +_gkpops_ +_gkpplt_ +_gkppmt_ +_gkppoe_ +_gkppor_ +_gkppst_ +_gkppuy_ +_gkpres_ +_gkpser_ +_gkpses_ +_gkptet_ +_gkptxg_ +_gkptxt_ +_gkpunn_ +_glabax_ +_glbdrd_ +_glbene_ +_glbeq_ +_glbfis_ +_glbgek_ +_glblas_ +_glblob_ +_glbple_ +_glbsep_ +_glbses_ +_glbset_ +_glbtin_ +_glbveg_ +_gline_ +_gltoc_ +_gmark_ +_gmftie_ +_gopen_ +_gpagee_ +_gpatme_ +_gpatmh_ +_gpcell_ +_gplcae_ +_gplcal_ +_gplclb_ +_gplcll_ +_gplclr_ +_gplclt_ +_gplflh_ +_gpline_ +_gploto_ +_gplotv_ +_gplret_ +_gplsee_ +_gplwci_ +_gpmark_ +_gqvery_ +_grdraw_ +_grdwcs_ +_greace_ +_greset_ +_grmove_ +_grscae_ +_gscan_ +_gscur_ +_gseti_ +_gsetr_ +_gsets_ +_gstati_ +_gstatr_ +_gstats_ +_gstrct_ +_gstrcy_ +_gstrmh_ +_gstsei_ +_gstser_ +_gsview_ +_gswind_ +_gtdise_ +_gtext_ +_gtickr_ +_gtliny_ +_gtndis_ +_gttyld_ +_gtxset_ +_gumark_ +_gvline_ +_gvmark_ +_gwcsme_ +_gwrwcs_ +_i1mach_ +_idbcle_ +_idbfid_ +_idbgeg_ +_idbkwp_ +_idbned_ +_idbopn_ +_idbpug_ +_ieepad_ +_ieepar_ +_ieeupd_ +_ieeupr_ +_ieevpd_ +_ieevpr_ +_ieevud_ +_ieevur_ +_ikiacs_ +_ikicle_ +_ikicoy_ +_ikidee_ +_ikiint_ +_ikildr_ +_ikimke_ +_ikiopn_ +_ikiopx_ +_ikipae_ +_ikiree_ +_ikiupr_ +_imaccf_ +_imaccs_ +_imaddb_ +_imaddd_ +_imaddf_ +_imaddi_ +_imaddl_ +_imaddr_ +_imadds_ +_imaflp_ +_imalin_ +_imaplv_ +_imastr_ +_imbln1_ +_imbln2_ +_imbln3_ +_imbtrn_ +_imcfnl_ +_imcopy_ +_imcssz_ +_imctrt_ +_imdect_ +_imdele_ +_imdelf_ +_imdmap_ +_imerr_ +_imflpl_ +_imflps_ +_imflsd_ +_imflsh_ +_imflsi_ +_imflsl_ +_imflsr_ +_imflss_ +_imflsx_ +_imfluh_ +_imfnpy_ +_imfnss_ +_imgclr_ +_imgetb_ +_imgetc_ +_imgetd_ +_imgeti_ +_imgetl_ +_imgetr_ +_imgets_ +_imgfte_ +_imggsc_ +_imggsd_ +_imggsi_ +_imggsl_ +_imggsr_ +_imggss_ +_imggsx_ +_imgibf_ +_imgime_ +_imgl1d_ +_imgl1i_ +_imgl1l_ +_imgl1r_ +_imgl1s_ +_imgl1x_ +_imgl2d_ +_imgl2i_ +_imgl2l_ +_imgl2r_ +_imgl2s_ +_imgl2x_ +_imgl3d_ +_imgl3i_ +_imgl3l_ +_imgl3r_ +_imgl3s_ +_imgl3x_ +_imgnfn_ +_imgnld_ +_imgnli_ +_imgnll_ +_imgnln_ +_imgnlr_ +_imgnls_ +_imgnlx_ +_imgobf_ +_imgs1d_ +_imgs1i_ +_imgs1l_ +_imgs1r_ +_imgs1s_ +_imgs1x_ +_imgs2d_ +_imgs2i_ +_imgs2l_ +_imgs2r_ +_imgs2s_ +_imgs2x_ +_imgs3d_ +_imgs3i_ +_imgs3l_ +_imgs3r_ +_imgs3s_ +_imgs3x_ +_imgsen_ +_imgstr_ +_iminie_ +_imioff_ +_imisec_ +_imloop_ +_immaky_ +_immap_ +_immapz_ +_imnote_ +_imofnl_ +_imofns_ +_imofnu_ +_imopsf_ +_impakd_ +_impaki_ +_impakl_ +_impakr_ +_impaks_ +_impakx_ +_impare_ +_impgsd_ +_impgsi_ +_impgsl_ +_impgsr_ +_impgss_ +_impgsx_ +_impl1d_ +_impl1i_ +_impl1l_ +_impl1r_ +_impl1s_ +_impl1x_ +_impl2d_ +_impl2i_ +_impl2l_ +_impl2r_ +_impl2s_ +_impl2x_ +_impl3d_ +_impl3i_ +_impl3l_ +_impl3r_ +_impl3s_ +_impl3x_ +_impml1_ +_impml2_ +_impml3_ +_impmlv_ +_impmmo_ +_impmmp_ +_impmon_ +_impms1_ +_impms2_ +_impms3_ +_impmsv_ +_impnld_ +_impnli_ +_impnll_ +_impnln_ +_impnlr_ +_impnls_ +_impnlx_ +_imps1d_ +_imps1i_ +_imps1l_ +_imps1r_ +_imps1s_ +_imps1x_ +_imps2d_ +_imps2i_ +_imps2l_ +_imps2r_ +_imps2s_ +_imps2x_ +_imps3d_ +_imps3i_ +_imps3l_ +_imps3r_ +_imps3s_ +_imps3x_ +_impstr_ +_imputb_ +_imputd_ +_imputh_ +_imputi_ +_imputl_ +_imputr_ +_imputs_ +_imrbpx_ +_imrdpx_ +_imrene_ +_imrmbs_ +_imsamp_ +_imsetf_ +_imseti_ +_imsetr_ +_imsinb_ +_imsmpl_ +_imsmps_ +_imsslv_ +_imstai_ +_imstas_ +_imtcle_ +_imtgem_ +_imtlen_ +_imtmae_ +_imtopn_ +_imtopp_ +_imtrew_ +_imtrgm_ +_imunmp_ +_imupkd_ +_imupki_ +_imupkl_ +_imupkr_ +_imupks_ +_imupkx_ +_imwbpx_ +_imwrie_ +_imwrpx_ +_intrde_ +_intree_ +_intrrt_ +_irafmn_ +_itob_ +_itoc_ +_iwcare_ +_iwcfis_ +_iwents_ +_iwfind_ +_iwgbis_ +_iwputr_ +_iwputy_ +_iwrfis_ +_iwsetp_ +_kardbf_ +_kardgd_ +_kardlp_ +_kardpl_ +_kardpr_ +_kardsf_ +_kawrbf_ +_kawrgd_ +_kawrlp_ +_kawrpl_ +_kawrpr_ +_kawrsf_ +_kawtbf_ +_kawtgd_ +_kawtlp_ +_kawtpl_ +_kawtpr_ +_kawtsf_ +_kbzard_ +_kbzawr_ +_kbzawt_ +_kbzcls_ +_kbzopn_ +_kbzstt_ +_kclcpr_ +_kcldir_ +_kcldpr_ +_kclsbf_ +_kclsgd_ +_kclslp_ +_kclspl_ +_kclssf_ +_kclstx_ +_kclsty_ +_kdvall_ +_kdvown_ +_kfacss_ +_kfaloc_ +_kfchdr_ +_kfdele_ +_kfgcwd_ +_kfinfo_ +_kflstx_ +_kflsty_ +_kfmkcp_ +_kfmkdr_ +_kfpath_ +_kfprot_ +_kfrnam_ +_kfsubd_ +_kfxdir_ +_kgettx_ +_kgetty_ +_kgfdir_ +_kicont_ +_kidece_ +_kience_ +_kienvt_ +_kierrr_ +_kiexte_ +_kifine_ +_kiflux_ +_kifman_ +_kifren_ +_kigetn_ +_kigets_ +_kignoe_ +_kiinit_ +_kiloce_ +_kimapn_ +_kintpr_ +_kiopes_ +_kirece_ +_kisend_ +_kisenv_ +_kishot_ +_kmallc_ +_knottx_ +_knotty_ +_kopcpr_ +_kopdir_ +_kopdpr_ +_kopnbf_ +_kopngd_ +_kopnlp_ +_kopnpl_ +_kopnsf_ +_kopntx_ +_kopnty_ +_koscmd_ +_kputtx_ +_kputty_ +_krealc_ +_ksared_ +_ksawat_ +_ksawre_ +_ksektx_ +_ksekty_ +_ksttbf_ +_ksttgd_ +_ksttlp_ +_ksttpl_ +_ksttpr_ +_ksttsf_ +_kstttx_ +_ksttty_ +_ktzcls_ +_ktzfls_ +_ktzget_ +_ktznot_ +_ktzopn_ +_ktzput_ +_ktzsek_ +_ktzstt_ +_kzclmt_ +_kzopmt_ +_kzrdmt_ +_kzrwmt_ +_kzwrmt_ +_kzwtmt_ +_lexnum_ +_lnocle_ +_lnofeh_ +_lnoopn_ +_lnosae_ +_locpr_ +_locva_ +_lpopen_ +_lpzard_ +_lpzawe_ +_lpzawt_ +_ltoc_ +_m75put_ +_maideh_ +_mallo1_ +_mgdptr_ +_mgtfwa_ +_miilen_ +_miinem_ +_miipa2_ +_miipa6_ +_miipa8_ +_miipad_ +_miipak_ +_miipar_ +_miipke_ +_miirec_ +_miired_ +_miirei_ +_miirel_ +_miirer_ +_miires_ +_miiup2_ +_miiup6_ +_miiup8_ +_miiupd_ +_miiupk_ +_miiupr_ +_miiwrc_ +_miiwrd_ +_miiwri_ +_miiwrl_ +_miiwrr_ +_miiwrs_ +_miocle_ +_miogld_ +_miogli_ +_miogll_ +_mioglr_ +_miogls_ +_mioglx_ +_mioopn_ +_mioopo_ +_miopld_ +_miopli_ +_miopll_ +_mioplr_ +_miopls_ +_mioplx_ +_miosee_ +_miosei_ +_miosti_ +_msvfwa_ +_mtalle_ +_mtclre_ +_mtdeae_ +_mtdevd_ +_mtfile_ +_mtgets_ +_mtloce_ +_mtopen_ +_mtosdv_ +_mtpare_ +_mtposn_ +_mtpute_ +_mtreae_ +_mtrewd_ +_mtsavd_ +_mtsavs_ +_mtskid_ +_mtstas_ +_mtsync_ +_mtupde_ +_mwalld_ +_mwalls_ +_mwaxtn_ +_mwc1td_ +_mwc1tr_ +_mwc2td_ +_mwc2tr_ +_mwcloe_ +_mwcopd_ +_mwcops_ +_mwctfe_ +_mwctrd_ +_mwctrr_ +_mwfins_ +_mwflop_ +_mwgaxp_ +_mwgaxt_ +_mwgctd_ +_mwgctr_ +_mwgltd_ +_mwgltr_ +_mwgwas_ +_mwgwsd_ +_mwgwsr_ +_mwgwtd_ +_mwgwtr_ +_mwinvd_ +_mwinvr_ +_mwload_ +_mwloam_ +_mwltrd_ +_mwltrr_ +_mwlubb_ +_mwlude_ +_mwmkid_ +_mwmmud_ +_mwmmur_ +_mwnewm_ +_mwnewy_ +_mwopem_ +_mwopen_ +_mwrefr_ +_mwrote_ +_mwsave_ +_mwsavm_ +_mwsaxp_ +_mwscae_ +_mwsctn_ +_mwsdes_ +_mwseti_ +_mwshit_ +_mwsltd_ +_mwsltr_ +_mwssym_ +_mwstai_ +_mwswas_ +_mwswsd_ +_mwswsr_ +_mwswtd_ +_mwswte_ +_mwswtr_ +_mwtrad_ +_mwtrar_ +_mwv1td_ +_mwv1tr_ +_mwv2td_ +_mwv2tr_ +_mwvmud_ +_mwvmur_ +_mwvtrd_ +_mwvtrr_ +_noti_ +_notl_ +_nots_ +_nowhie_ +_nscan_ +_oifacs_ +_oifcle_ +_oifcoy_ +_oifdee_ +_oifgpe_ +_oifmke_ +_oifopn_ +_oifopx_ +_oifree_ +_oifupr_ +_oifwpr_ +_onerrr_ +_onexit_ +_ord1_ +_ord2_ +_ori_ +_orl_ +_ors_ +_oscmd_ +_osfnik_ +_osfnlk_ +_osfnms_ +_osfnpe_ +_osfnrk_ +_osfntt_ +_osfnuk_ +_pagefe_ +_pagefs_ +_pargb_ +_pargc_ +_pargd_ +_pargg_ +_pargi_ +_pargl_ +_pargr_ +_pargs_ +_pargsr_ +_pargx_ +_patamh_ +_patfit_ +_patgel_ +_patgse_ +_patinx_ +_patloe_ +_patmae_ +_patmah_ +_patomh_ +_patsts_ +_pggetd_ +_pggete_ +_pggetr_ +_pgpage_ +_pgsett_ +_placcs_ +_plallc_ +_plascp_ +_plbox_ +_plcire_ +_plcler_ +_plcloe_ +_plcome_ +_plcoms_ +_plcree_ +_pldebg_ +_pldebt_ +_plempy_ +_plgete_ +_plglls_ +_plglpi_ +_plglpl_ +_plglps_ +_plglri_ +_plglrl_ +_plglrs_ +_plgsie_ +_pll2pi_ +_pll2pl_ +_pll2ps_ +_pll2ri_ +_pll2rl_ +_pll2rs_ +_pllemy_ +_plleql_ +_plline_ +_pllinl_ +_pllinp_ +_plliny_ +_pllneg_ +_plload_ +_plloaf_ +_plloam_ +_plloop_ +_pllprs_ +_plnewy_ +_plopen_ +_plp2li_ +_plp2ll_ +_plp2ls_ +_plp2ri_ +_plp2rl_ +_plp2rs_ +_plpixi_ +_plpixl_ +_plpixs_ +_plplls_ +_plplpi_ +_plplpl_ +_plplps_ +_plplri_ +_plplrl_ +_plplrs_ +_plpoit_ +_plpoln_ +_plr2li_ +_plr2ll_ +_plr2ls_ +_plr2pi_ +_plr2pl_ +_plr2ps_ +_plrani_ +_plranl_ +_plrans_ +_plregp_ +_plreqi_ +_plreql_ +_plreqs_ +_plrop_ +_plrpri_ +_plrprl_ +_plrprs_ +_plsave_ +_plsavf_ +_plsavm_ +_plsecy_ +_plsete_ +_plseti_ +_plssie_ +_plsslv_ +_plstai_ +_plstel_ +_plubox_ +_plucie_ +_plupde_ +_plupon_ +_plvald_ +_pmaccs_ +_pmascp_ +_pmbox_ +_pmcire_ +_pmcler_ +_pmempy_ +_pmglls_ +_pmglpi_ +_pmglpl_ +_pmglps_ +_pmglri_ +_pmglrl_ +_pmglrs_ +_pmline_ +_pmliny_ +_pmnewk_ +_pmplls_ +_pmplpi_ +_pmplpl_ +_pmplps_ +_pmplri_ +_pmplrl_ +_pmplrs_ +_pmpoit_ +_pmpoln_ +_pmrop_ +_pmsecy_ +_pmsete_ +_pmseti_ +_pmstel_ +_prchdr_ +_prclcr_ +_prcldr_ +_prcloe_ +_prdone_ +_prdumn_ +_prenve_ +_prenvt_ +_prfilf_ +_prfinc_ +_prgete_ +_prgetr_ +_prkill_ +_pronic_ +_propcr_ +_propdr_ +_propen_ +_proscd_ +_protet_ +_prpsio_ +_prpsld_ +_prredr_ +_prsigl_ +_prstai_ +_prupde_ +_prvret_ +_przclr_ +_psioit_ +_psioxr_ +_putcc_ +_putci_ +_putlie_ +_qmaccs_ +_qmgetc_ +_qmscan_ +_qmscao_ +_qmsetm_ +_qmsets_ +_qmsymb_ +_qpaccf_ +_qpaccs_ +_qpaddb_ +_qpaddc_ +_qpaddd_ +_qpaddf_ +_qpaddi_ +_qpaddl_ +_qpaddr_ +_qpadds_ +_qpargt_ +_qpastr_ +_qpbind_ +_qpcfnl_ +_qpcloe_ +_qpclot_ +_qpcopf_ +_qpcopy_ +_qpctod_ +_qpctoi_ +_qpdele_ +_qpdelf_ +_qpdsym_ +_qpdtye_ +_qpelee_ +_qpexcd_ +_qpexce_ +_qpexci_ +_qpexcr_ +_qpexdc_ +_qpexde_ +_qpexdg_ +_qpexdr_ +_qpexee_ +_qpexfe_ +_qpexgr_ +_qpexmk_ +_qpexmr_ +_qpexon_ +_qpexpd_ +_qpexpi_ +_qpexpn_ +_qpexpr_ +_qpexps_ +_qpexpt_ +_qpexrd_ +_qpexsd_ +_qpexsi_ +_qpexsr_ +_qpfacs_ +_qpfcle_ +_qpfcos_ +_qpfcoy_ +_qpfdee_ +_qpflur_ +_qpfopn_ +_qpfopx_ +_qpfree_ +_qpfupr_ +_qpfwfr_ +_qpfzcl_ +_qpfzop_ +_qpfzrd_ +_qpfzst_ +_qpfzwr_ +_qpfzwt_ +_qpgetb_ +_qpgetc_ +_qpgetd_ +_qpgeti_ +_qpgetk_ +_qpgetl_ +_qpgetm_ +_qpgetr_ +_qpgets_ +_qpgetx_ +_qpgmsm_ +_qpgnfn_ +_qpgpsm_ +_qpgstr_ +_qpinht_ +_qpioce_ +_qpioge_ +_qpiogr_ +_qpiogs_ +_qpiolk_ +_qpiols_ +_qpiomx_ +_qpioon_ +_qpiope_ +_qpiops_ +_qpiori_ +_qpiors_ +_qpiort_ +_qpiosc_ +_qpiose_ +_qpiosi_ +_qpiosr_ +_qpiost_ +_qpiowt_ +_qplenf_ +_qplenl_ +_qploas_ +_qpmkfe_ +_qpnexk_ +_qpofnl_ +_qpofns_ +_qpofnu_ +_qpopen_ +_qpopet_ +_qppare_ +_qpparl_ +_qppcle_ +_qppopn_ +_qppstr_ +_qpputb_ +_qpputc_ +_qpputd_ +_qpputi_ +_qpputl_ +_qpputm_ +_qpputr_ +_qpputs_ +_qpputx_ +_qpquef_ +_qprawk_ +_qpread_ +_qprebd_ +_qprene_ +_qprenf_ +_qpsavs_ +_qpseel_ +_qpseti_ +_qpsizf_ +_qpstai_ +_qpsync_ +_qpungk_ +_qpwrie_ +_r1mach_ +_r2tr_ +_r2tx_ +_r4syn_ +_r4tr_ +_r4tx_ +_r8syn_ +_r8tr_ +_r8tx_ +_rdukey_ +_rename_ +_reopen_ +_resetn_ +_salloc_ +_scan_ +_scanc_ +_sfree_ +_shifti_ +_shiftl_ +_shifts_ +_smark_ +_sprinf_ +_sscan_ +_stallc_ +_stcloe_ +_stentr_ +_stfacs_ +_stfadr_ +_stfcle_ +_stfcos_ +_stfcoy_ +_stfdee_ +_stfgeb_ +_stfgei_ +_stfgen_ +_stfges_ +_stfget_ +_stfind_ +_stfinl_ +_stfmeb_ +_stfmke_ +_stfnee_ +_stfopn_ +_stfopx_ +_stforb_ +_stfrdr_ +_stfree_ +_stfrek_ +_stfrfr_ +_stfrgb_ +_stfrne_ +_stfupr_ +_stfwfr_ +_stfwgb_ +_sthash_ +_sthead_ +_stinfo_ +_stkmkg_ +_stmark_ +_stname_ +_stnext_ +_stnsys_ +_stopen_ +_stpstr_ +_strcle_ +_strdic_ +_strefb_ +_streff_ +_streq_ +_strese_ +_strge_ +_strgt_ +_strids_ +_stridx_ +_strlds_ +_strldx_ +_strle_ +_strlt_ +_strlwr_ +_strmac_ +_strmah_ +_strncp_ +_strne_ +_stropn_ +_strpak_ +_strse1_ +_strseh_ +_strsrt_ +_strtbl_ +_strupk_ +_strupr_ +_stsave_ +_stsize_ +_stsque_ +_sttyco_ +_sttyet_ +_sttygg_ +_sttynm_ +_sttyse_ +_sttysm_ +_sttytt_ +_syserr_ +_sysers_ +_sysged_ +_sysges_ +_sysgsg_ +_sysid_ +_sysmte_ +_syspac_ +_syspat_ +_syspte_ +_sysret_ +_syssct_ +_tsleep_ +_ttopen_ +_ttseti_ +_ttsets_ +_ttstai_ +_ttstas_ +_ttybih_ +_ttybre_ +_ttycas_ +_ttycds_ +_ttycle_ +_ttycln_ +_ttyclr_ +_ttyctl_ +_ttydee_ +_ttydey_ +_ttyeny_ +_ttyexs_ +_ttyfey_ +_ttyfiy_ +_ttygds_ +_ttygeb_ +_ttygei_ +_ttyger_ +_ttyges_ +_ttygoo_ +_ttygpe_ +_ttygse_ +_ttyins_ +_ttyint_ +_ttylod_ +_ttyods_ +_ttyopn_ +_ttypue_ +_ttypus_ +_ttyred_ +_ttysce_ +_ttysei_ +_ttyso_ +_ttysti_ +_ttysui_ +_ttywre_ +_ungete_ +_ungeti_ +_unread_ +_urand_ +_vfnadd_ +_vfncle_ +_vfndee_ +_vfndel_ +_vfnene_ +_vfnenr_ +_vfnexr_ +_vfngen_ +_vfnise_ +_vfnman_ +_vfnmap_ +_vfnmau_ +_vfnopn_ +_vfnsqe_ +_vfntre_ +_vfnunn_ +_vfnunp_ +_vlibinit_ +_vmallc_ +_vvfncm_ +_vvfnee_ +_vvfnip_ +_vvfnis_ +_vvfnre_ +_wfdecs_ +_wffnld_ +_wfinit_ +_wfsmph_ +_wfsmpn_ +_wfsmpt_ +_wftand_ +_wftant_ +_wftanv_ +_xalloe_ +_xcallc_ +_xdeale_ +_xdevor_ +_xdevss_ +_xeract_ +_xerfmg_ +_xerpop_ +_xerpsh_ +_xerpsr_ +_xerpuc_ +_xerpue_ +_xerret_ +_xerror_ +_xersel_ +_xervey_ +_xevadg_ +_xevbip_ +_xevbop_ +_xevcan_ +_xever1_ +_xever2_ +_xeverr_ +_xevfrp_ +_xevgek_ +_xevinp_ +_xevmap_ +_xevnee_ +_xevpae_ +_xevpah_ +_xevqut_ +_xevstt_ +_xevunp_ +_xfaccs_ +_xfcloe_ +_xfdele_ +_xffluh_ +_xfgetc_ +_xfgetr_ +_xfnote_ +_xfopen_ +_xfputc_ +_xfputr_ +_xfread_ +_xfseek_ +_xfungc_ +_xfwrie_ +_xgdevt_ +_xisaty_ +_xmallc_ +_xmfree_ +_xmjbuf_ +_xmktep_ +_xonerr_ +_xonext_ +_xori_ +_xorl_ +_xors_ +_xpages_ +_xprinf_ +_xqsort_ +_xrealc_ +_xsizef_ +_xstdeh_ +_xstrcp_ +_xstrct_ +_xstrcy_ +_xstrln_ +_xtoc_ +_xttyse_ +_xwhen_ +_zardbf_ +_zardgd_ +_zardks_ +_zardlp_ +_zardmt_ +_zardnu_ +_zardpl_ +_zardpr_ +_zardps_ +_zardsf_ +_zawrbf_ +_zawrgd_ +_zawrks_ +_zawrlp_ +_zawrmt_ +_zawrnu_ +_zawrpl_ +_zawrpr_ +_zawrps_ +_zawrsf_ +_zawset_ +_zawtbf_ +_zawtgd_ +_zawtks_ +_zawtlp_ +_zawtmt_ +_zawtnu_ +_zawtpl_ +_zawtpr_ +_zawtps_ +_zawtsf_ +_zclcpr_ +_zcldir_ +_zcldpr_ +_zclm70_ +_zclm75_ +_zclsbf_ +_zclsgd_ +_zclsks_ +_zclslp_ +_zclsmt_ +_zclsnu_ +_zclspl_ +_zclsps_ +_zclssf_ +_zclstt_ +_zclstx_ +_zclsty_ +_zdojmp_ +_zdvall_ +_zdvown_ +_zfacss_ +_zfaloc_ +_zfchdr_ +_zfdele_ +_zfgcwd_ +_zfinfo_ +_zflsnu_ +_zflstt_ +_zflstx_ +_zflsty_ +_zfmkcp_ +_zfmkdr_ +_zfnbrk_ +_zfpath_ +_zfprot_ +_zfrnam_ +_zfsubd_ +_zfxdir_ +_zgcmdl_ +_zgetnu_ +_zgettt_ +_zgettx_ +_zgetty_ +_zgfdir_ +_zghost_ +_zgtime_ +_zgtpid_ +_zintpr_ +_zlocpr_ +_zlocva_ +_zmaloc_ +_zmfree_ +_znotnu_ +_znottt_ +_znottx_ +_znotty_ +_zopcpr_ +_zopdir_ +_zopdpr_ +_zopm70_ +_zopm75_ +_zopnbf_ +_zopngd_ +_zopnks_ +_zopnlp_ +_zopnmt_ +_zopnnu_ +_zopnpl_ +_zopnsf_ +_zopntt_ +_zopntx_ +_zopnty_ +_zoscmd_ +_zpanic_ +_zputnu_ +_zputtt_ +_zputtx_ +_zputty_ +_zraloc_ +_zrdm70_ +_zrdm75_ +_zseknu_ +_zsektt_ +_zsektx_ +_zsekty_ +_zsestt_ +_zsettt_ +_zstm70_ +_zstm75_ +_zststt_ +_zsttbf_ +_zsttgd_ +_zsttks_ +_zsttlp_ +_zsttmt_ +_zsttnu_ +_zsttpl_ +_zsttpr_ +_zsttps_ +_zsttsf_ +_zstttt_ +_zstttx_ +_zsttty_ +_zsvjmp_ +_zttgeg_ +_zttger_ +_zttloe_ +_zttloo_ +_zttlov_ +_zttpbf_ +_zttplk_ +_zttpug_ +_zttquy_ +_zttttt_ +_zttupe_ +_zwmsec_ +_zwrm70_ +_zwrm75_ +_zwtm70_ +_zwtm75_ +_zxgmes_ +_zxwhen_ +_zzclmt_ +_zzfbmt_ +_zzffmt_ +_zzopmt_ +_zzposmt_ +_zzrbmt_ +_zzrdii_ +_zzrdmt_ +_zzrfmt_ +_zzrwmt_ +_zzsetk_ +_zzwrii_ +_zzwrmt_ +_zzwtmt_ +_zzzend_ diff --git a/unix/shlib/S.nm.sparc b/unix/shlib/S.nm.sparc new file mode 100644 index 00000000..f918e82f --- /dev/null +++ b/unix/shlib/S.nm.sparc @@ -0,0 +1,2865 @@ +_aabsd_ +_aabsi_ +_aabsl_ +_aabsr_ +_aabss_ +_aabsx_ +_aaddd_ +_aaddi_ +_aaddkd_ +_aaddki_ +_aaddkl_ +_aaddkr_ +_aaddks_ +_aaddkx_ +_aaddl_ +_aaddr_ +_aadds_ +_aaddx_ +_aandi_ +_aandki_ +_aandkl_ +_aandks_ +_aandl_ +_aands_ +_aavgd_ +_aavgi_ +_aavgl_ +_aavgr_ +_aavgs_ +_aavgx_ +_abavd_ +_abavi_ +_abavl_ +_abavr_ +_abavs_ +_abavx_ +_abeqc_ +_abeqd_ +_abeqi_ +_abeqkc_ +_abeqkd_ +_abeqki_ +_abeqkl_ +_abeqkr_ +_abeqks_ +_abeqkx_ +_abeql_ +_abeqr_ +_abeqs_ +_abeqx_ +_abgec_ +_abged_ +_abgei_ +_abgekc_ +_abgekd_ +_abgeki_ +_abgekl_ +_abgekr_ +_abgeks_ +_abgekx_ +_abgel_ +_abger_ +_abges_ +_abgex_ +_abgtc_ +_abgtd_ +_abgti_ +_abgtkc_ +_abgtkd_ +_abgtki_ +_abgtkl_ +_abgtkr_ +_abgtks_ +_abgtkx_ +_abgtl_ +_abgtr_ +_abgts_ +_abgtx_ +_ablec_ +_abled_ +_ablei_ +_ablekc_ +_ablekd_ +_ableki_ +_ablekl_ +_ablekr_ +_ableks_ +_ablekx_ +_ablel_ +_abler_ +_ables_ +_ablex_ +_abltc_ +_abltd_ +_ablti_ +_abltkc_ +_abltkd_ +_abltki_ +_abltkl_ +_abltkr_ +_abltks_ +_abltkx_ +_abltl_ +_abltr_ +_ablts_ +_abltx_ +_abnec_ +_abned_ +_abnei_ +_abnekc_ +_abnekd_ +_abneki_ +_abnekl_ +_abnekr_ +_abneks_ +_abnekx_ +_abnel_ +_abner_ +_abnes_ +_abnex_ +_abori_ +_aborki_ +_aborkl_ +_aborks_ +_aborl_ +_abors_ +_absud_ +_absui_ +_absul_ +_absur_ +_absus_ +_acht_ +_achtb_ +_achtbb_ +_achtbc_ +_achtbd_ +_achtbi_ +_achtbl_ +_achtbr_ +_achtbs_ +_achtbu_ +_achtbx_ +_achtc_ +_achtcb_ +_achtcc_ +_achtcd_ +_achtci_ +_achtcl_ +_achtcr_ +_achtcs_ +_achtcu_ +_achtcx_ +_achtd_ +_achtdb_ +_achtdc_ +_achtdd_ +_achtdi_ +_achtdl_ +_achtdr_ +_achtds_ +_achtdu_ +_achtdx_ +_achti_ +_achtib_ +_achtic_ +_achtid_ +_achtii_ +_achtil_ +_achtir_ +_achtis_ +_achtiu_ +_achtix_ +_achtl_ +_achtlb_ +_achtlc_ +_achtld_ +_achtli_ +_achtll_ +_achtlr_ +_achtls_ +_achtlu_ +_achtlx_ +_achtr_ +_achtrb_ +_achtrc_ +_achtrd_ +_achtri_ +_achtrl_ +_achtrr_ +_achtrs_ +_achtru_ +_achtrx_ +_achts_ +_achtsb_ +_achtsc_ +_achtsd_ +_achtsi_ +_achtsl_ +_achtsr_ +_achtss_ +_achtsu_ +_achtsx_ +_achtu_ +_achtub_ +_achtuc_ +_achtud_ +_achtui_ +_achtul_ +_achtur_ +_achtus_ +_achtuu_ +_achtux_ +_achtx_ +_achtxb_ +_achtxc_ +_achtxd_ +_achtxi_ +_achtxl_ +_achtxr_ +_achtxs_ +_achtxu_ +_achtxx_ +_acjgx_ +_aclrb_ +_aclrc_ +_aclrd_ +_aclri_ +_aclrl_ +_aclrr_ +_aclrs_ +_aclrx_ +_acnvd_ +_acnvi_ +_acnvl_ +_acnvr_ +_acnvrd_ +_acnvri_ +_acnvrl_ +_acnvrr_ +_acnvrs_ +_acnvs_ +_adivd_ +_adivi_ +_adivkd_ +_adivki_ +_adivkl_ +_adivkr_ +_adivks_ +_adivkx_ +_adivl_ +_adivr_ +_adivs_ +_adivx_ +_adotd_ +_adoti_ +_adotl_ +_adotr_ +_adots_ +_adotx_ +_advzd_ +_advzi_ +_advzl_ +_advzr_ +_advzs_ +_advzx_ +_aelogd_ +_aelogr_ +_aexpd_ +_aexpi_ +_aexpkd_ +_aexpki_ +_aexpkl_ +_aexpkr_ +_aexpks_ +_aexpkx_ +_aexpl_ +_aexpr_ +_aexps_ +_aexpx_ +_afftrr_ +_afftrx_ +_afftxr_ +_afftxx_ +_agltc_ +_agltd_ +_aglti_ +_agltl_ +_agltr_ +_aglts_ +_agltx_ +_ahgmc_ +_ahgmd_ +_ahgmi_ +_ahgml_ +_ahgmr_ +_ahgms_ +_ahivc_ +_ahivd_ +_ahivi_ +_ahivl_ +_ahivr_ +_ahivs_ +_ahivx_ +_aiftrr_ +_aiftrx_ +_aiftxr_ +_aiftxx_ +_aimgd_ +_aimgi_ +_aimgl_ +_aimgr_ +_aimgs_ +_alani_ +_alanki_ +_alankl_ +_alanks_ +_alanl_ +_alans_ +_alimc_ +_alimd_ +_alimi_ +_aliml_ +_alimr_ +_alims_ +_alimx_ +_allnd_ +_allni_ +_allnl_ +_allnr_ +_allns_ +_allnx_ +_alogd_ +_alogi_ +_alogl_ +_alogr_ +_alogs_ +_alogx_ +_alori_ +_alorki_ +_alorkl_ +_alorks_ +_alorl_ +_alors_ +_alovc_ +_alovd_ +_alovi_ +_alovl_ +_alovr_ +_alovs_ +_alovx_ +_altad_ +_altai_ +_altal_ +_altar_ +_altas_ +_altax_ +_altmd_ +_altmi_ +_altml_ +_altmr_ +_altms_ +_altmx_ +_altrd_ +_altri_ +_altrl_ +_altrr_ +_altrs_ +_altrx_ +_aluid_ +_aluii_ +_aluil_ +_aluir_ +_aluis_ +_alutc_ +_alutd_ +_aluti_ +_alutl_ +_alutr_ +_aluts_ +_amagd_ +_amagi_ +_amagl_ +_amagr_ +_amags_ +_amagx_ +_amapd_ +_amapi_ +_amapl_ +_amapr_ +_amaps_ +_amaxc_ +_amaxd_ +_amaxi_ +_amaxkc_ +_amaxkd_ +_amaxki_ +_amaxkl_ +_amaxkr_ +_amaxks_ +_amaxkx_ +_amaxl_ +_amaxr_ +_amaxs_ +_amaxx_ +_amed3c_ +_amed3d_ +_amed3i_ +_amed3l_ +_amed3r_ +_amed3s_ +_amed4c_ +_amed4d_ +_amed4i_ +_amed4l_ +_amed4r_ +_amed4s_ +_amed5c_ +_amed5d_ +_amed5i_ +_amed5l_ +_amed5r_ +_amed5s_ +_amedc_ +_amedd_ +_amedi_ +_amedl_ +_amedr_ +_ameds_ +_amedx_ +_amgsd_ +_amgsi_ +_amgsl_ +_amgsr_ +_amgss_ +_amgsx_ +_aminc_ +_amind_ +_amini_ +_aminkc_ +_aminkd_ +_aminki_ +_aminkl_ +_aminkr_ +_aminks_ +_aminkx_ +_aminl_ +_aminr_ +_amins_ +_aminx_ +_amodd_ +_amodi_ +_amodkd_ +_amodki_ +_amodkl_ +_amodkr_ +_amodks_ +_amodl_ +_amodr_ +_amods_ +_amovc_ +_amovd_ +_amovi_ +_amovkc_ +_amovkd_ +_amovki_ +_amovkl_ +_amovkr_ +_amovks_ +_amovkx_ +_amovl_ +_amovr_ +_amovs_ +_amovx_ +_amuld_ +_amuli_ +_amulkd_ +_amulki_ +_amulkl_ +_amulkr_ +_amulks_ +_amulkx_ +_amull_ +_amulr_ +_amuls_ +_amulx_ +_andi_ +_andl_ +_ands_ +_anegd_ +_anegi_ +_anegl_ +_anegr_ +_anegs_ +_anegx_ +_anoti_ +_anotl_ +_anots_ +_apkxd_ +_apkxi_ +_apkxl_ +_apkxr_ +_apkxs_ +_apkxx_ +_apold_ +_apolr_ +_apowd_ +_apowi_ +_apowkd_ +_apowki_ +_apowkl_ +_apowkr_ +_apowks_ +_apowkx_ +_apowl_ +_apowr_ +_apows_ +_apowx_ +_aravd_ +_aravi_ +_aravl_ +_aravr_ +_aravs_ +_aravx_ +_arcpd_ +_arcpi_ +_arcpl_ +_arcpr_ +_arcps_ +_arcpx_ +_arczd_ +_arczi_ +_arczl_ +_arczr_ +_arczs_ +_arczx_ +_aread_ +_areadb_ +_argtd_ +_argti_ +_argtl_ +_argtr_ +_argts_ +_argtx_ +_arltd_ +_arlti_ +_arltl_ +_arltr_ +_arlts_ +_arltx_ +_aselc_ +_aseld_ +_aseli_ +_aselkc_ +_aselkd_ +_aselki_ +_aselkl_ +_aselkr_ +_aselks_ +_aselkx_ +_asell_ +_aselr_ +_asels_ +_aselx_ +_asokc_ +_asokd_ +_asoki_ +_asokl_ +_asokr_ +_asoks_ +_asokx_ +_asqrd_ +_asqri_ +_asqrl_ +_asqrr_ +_asqrs_ +_asqrx_ +_asrtc_ +_asrtd_ +_asrti_ +_asrtl_ +_asrtr_ +_asrts_ +_asrtx_ +_assqd_ +_assqi_ +_assql_ +_assqr_ +_assqs_ +_assqx_ +_asubd_ +_asubi_ +_asubkd_ +_asubki_ +_asubkl_ +_asubkr_ +_asubks_ +_asubkx_ +_asubl_ +_asubr_ +_asubs_ +_asubx_ +_asumd_ +_asumi_ +_asuml_ +_asumr_ +_asums_ +_asumx_ +_aupxd_ +_aupxi_ +_aupxl_ +_aupxr_ +_aupxs_ +_aupxx_ +_aveqc_ +_aveqd_ +_aveqi_ +_aveql_ +_aveqr_ +_aveqs_ +_aveqx_ +_await_ +_awaitb_ +_awritb_ +_awrite_ +_awsud_ +_awsui_ +_awsul_ +_awsur_ +_awsus_ +_awsux_ +_awvgd_ +_awvgi_ +_awvgl_ +_awvgr_ +_awvgs_ +_awvgx_ +_axori_ +_axorki_ +_axorkl_ +_axorks_ +_axorl_ +_axors_ +_begmem_ +_bitmov_ +_bitpak_ +_bitupk_ +_brktie_ +_bswap2_ +_bswap4_ +_bswap8_ +_btoi_ +_bytmov_ +_cctoc_ +_chdept_ +_chfeth_ +_chrlwr_ +_chrpak_ +_chrupk_ +_chrupr_ +_clccos_ +_clcenr_ +_clcfeh_ +_clcfid_ +_clcfre_ +_clcint_ +_clclit_ +_clcloe_ +_clcmak_ +_clcmd_ +_clcmdw_ +_clcnek_ +_clcpst_ +_clcscn_ +_clepst_ +_clgcur_ +_clgetb_ +_clgetc_ +_clgetd_ +_clgeti_ +_clgetl_ +_clgetr_ +_clgets_ +_clgetx_ +_clgfil_ +_clgkey_ +_clglpb_ +_clglpc_ +_clglpd_ +_clglpi_ +_clglpl_ +_clglpr_ +_clglps_ +_clglpx_ +_clglsr_ +_clgpsa_ +_clgpsb_ +_clgpsc_ +_clgpsd_ +_clgpsi_ +_clgpsl_ +_clgpsr_ +_clgpss_ +_clgpst_ +_clgpsx_ +_clgstr_ +_clgwrd_ +_clktie_ +_cllpst_ +_clopen_ +_clopst_ +_clpcls_ +_clplen_ +_clpopi_ +_clpops_ +_clpopu_ +_clppsa_ +_clppsb_ +_clppsc_ +_clppsd_ +_clppsi_ +_clppsl_ +_clppsr_ +_clppss_ +_clppst_ +_clppsx_ +_clprew_ +_clprif_ +_clpsee_ +_clpsit_ +_clpstr_ +_clputb_ +_clputc_ +_clputd_ +_clputi_ +_clputl_ +_clputr_ +_clputs_ +_clputx_ +_clreqr_ +_clscan_ +_clseti_ +_clstai_ +_cnvdae_ +_cnvtie_ +_coerce_ +_cputie_ +_ctocc_ +_ctod_ +_ctoi_ +_ctol_ +_ctor_ +_ctotok_ +_ctowrd_ +_ctox_ +_d1mach_ +_deletg_ +_diropn_ +_dtcscl_ +_dtmdee_ +_dtmdes_ +_dtmene_ +_dtmens_ +_dtoc3_ +_dtoc_ +_elogd_ +_elogr_ +_envfid_ +_envfit_ +_envfre_ +_envgeb_ +_envged_ +_envgei_ +_envger_ +_envges_ +_envinr_ +_envint_ +_envlit_ +_envmak_ +_envnet_ +_envpus_ +_envret_ +_envscn_ +_eprinf_ +_erract_ +_errcoe_ +_errget_ +_evexpr_ +_evvexr_ +_evvfre_ +_f77pak_ +_f77upk_ +_falloc_ +_fcanpb_ +_fcldir_ +_fclobr_ +_fcopy_ +_fcopyo_ +_fdebug_ +_fdevbf_ +_fdevbk_ +_fdevtx_ +_fdirne_ +_fexbuf_ +_ffa_ +_ffault_ +_ffilbf_ +_ffilsz_ +_ffldir_ +_fflsbf_ +_ffs_ +_fft842_ +_fgdev0_ +_fgdevm_ +_fgetfd_ +_fgtdir_ +_filbuf_ +_filerr_ +_filopn_ +_finfo_ +_finit_ +_fioclp_ +_fioqfh_ +_fixmem_ +_flsbuf_ +_fmaccs_ +_fmapfn_ +_fmcloe_ +_fmcopo_ +_fmcopy_ +_fmdebg_ +_fmdele_ +_fmfcdg_ +_fmfcfe_ +_fmfcit_ +_fmfcsc_ +_fmfinf_ +_fmfopn_ +_fmgetd_ +_fmiobd_ +_fmioed_ +_fmioek_ +_fmiopr_ +_fmiorr_ +_fmiosf_ +_fmiotk_ +_fmkbfs_ +_fmkcoy_ +_fmkdir_ +_fmkpbf_ +_fmlfad_ +_fmlfae_ +_fmlfat_ +_fmlfbd_ +_fmlfbe_ +_fmlfbt_ +_fmlfce_ +_fmlfcy_ +_fmlfde_ +_fmlfne_ +_fmlfon_ +_fmlfpe_ +_fmlfsi_ +_fmlfst_ +_fmlfue_ +_fmlocd_ +_fmloct_ +_fmnexe_ +_fmopen_ +_fmrebd_ +_fmrene_ +_fmretd_ +_fmseti_ +_fmstai_ +_fmsync_ +_fmterr_ +_fmtint_ +_fmtred_ +_fmtsel_ +_fmtstr_ +_fmunlk_ +_fnextn_ +_fnldir_ +_fnroot_ +_fntclb_ +_fntcls_ +_fntdir_ +_fntedt_ +_fntget_ +_fntgfb_ +_fntgfn_ +_fntleb_ +_fntmkt_ +_fntopb_ +_fntopn_ +_fntopt_ +_fntreb_ +_fntree_ +_fntrfb_ +_fnulle_ +_fopdir_ +_fopnbf_ +_fopntx_ +_fowner_ +_fpathe_ +_fpequd_ +_fpequr_ +_fpfixd_ +_fpfixr_ +_fpnonr_ +_fpnord_ +_fpnorr_ +_fpradv_ +_fprfmt_ +_fprinf_ +_fprntf_ +_fptdir_ +_fputtx_ +_freadp_ +_fredio_ +_fredir_ +_frenae_ +_frmbfs_ +_frmtmp_ +_frtnfd_ +_fsetev_ +_fsetfd_ +_fseti_ +_fsfdee_ +_fsfgee_ +_fsfopn_ +_fskdir_ +_fstati_ +_fstatl_ +_fstats_ +_fstdfe_ +_fstdir_ +_fstrfp_ +_fsvtfn_ +_fswapd_ +_fwatio_ +_fwritp_ +_fwtacc_ +_fxfacp_ +_fxfacs_ +_fxfact_ +_fxfadr_ +_fxfakb_ +_fxfakc_ +_fxfakd_ +_fxfaki_ +_fxfakr_ +_fxfalc_ +_fxfald_ +_fxfalr_ +_fxfalu_ +_fxfasr_ +_fxfbls_ +_fxfbyt_ +_fxfche_ +_fxfchm_ +_fxfchp_ +_fxfchv_ +_fxfcle_ +_fxfcll_ +_fxfcnx_ +_fxfcoj_ +_fxfcoy_ +_fxfcte_ +_fxfdae_ +_fxfdee_ +_fxfdiw_ +_fxfdur_ +_fxfenb_ +_fxfenc_ +_fxfend_ +_fxfene_ +_fxfeni_ +_fxfenl_ +_fxfenr_ +_fxfens_ +_fxfexh_ +_fxfexr_ +_fxffac_ +_fxffcr_ +_fxffiw_ +_fxffog_ +_fxffpd_ +_fxfgas_ +_fxfgeb_ +_fxfged_ +_fxfgei_ +_fxfgen_ +_fxfger_ +_fxfget_ +_fxfglm_ +_fxfgsr_ +_fxfhdt_ +_fxfhee_ +_fxfhef_ +_fxfint_ +_fxfisk_ +_fxfkse_ +_fxfksl_ +_fxfksm_ +_fxfksn_ +_fxfkss_ +_fxfkst_ +_fxfksx_ +_fxflor_ +_fxfmad_ +_fxfmar_ +_fxfmas_ +_fxfmay_ +_fxfmea_ +_fxfnul_ +_fxfopn_ +_fxfopx_ +_fxfove_ +_fxfovt_ +_fxfpaa_ +_fxfpld_ +_fxfple_ +_fxfplf_ +_fxfplo_ +_fxfplp_ +_fxfprr_ +_fxfred_ +_fxfree_ +_fxfrek_ +_fxfren_ +_fxfrep_ +_fxfrfr_ +_fxfrhr_ +_fxfsee_ +_fxfsev_ +_fxfsex_ +_fxfskn_ +_fxfstr_ +_fxftox_ +_fxfuad_ +_fxfuna_ +_fxfupd_ +_fxfupr_ +_fxfwrr_ +_fxfwrs_ +_fxfxal_ +_fxfxhd_ +_fxfxn1_ +_fxfzcl_ +_fxfzop_ +_fxfzrd_ +_fxfzst_ +_fxfzwr_ +_fxfzwt_ +_gactie_ +_gadraw_ +_gamove_ +_gargb_ +_gargc_ +_gargd_ +_gargi_ +_gargl_ +_gargr_ +_gargrd_ +_gargs_ +_gargsr_ +_gargtk_ +_gargwd_ +_gargx_ +_gascae_ +_gcancl_ +_gclear_ +_gclose_ +_gctod_ +_gctol_ +_gctox_ +_gctran_ +_gcurps_ +_gdeace_ +_gescae_ +_getci_ +_gethot_ +_getlie_ +_getlle_ +_getloe_ +_gexflr_ +_gexfls_ +_gexflt_ +_gfill_ +_gflush_ +_gframe_ +_gfrint_ +_ggcell_ +_ggcur_ +_ggetb_ +_ggeti_ +_ggetr_ +_ggets_ +_ggscae_ +_ggview_ +_ggwind_ +_gimcor_ +_gimcrr_ +_gimder_ +_gimdig_ +_gimeng_ +_gimfrg_ +_gimfrp_ +_gimgeg_ +_gimins_ +_gimiod_ +_gimioe_ +_gimlop_ +_gimqur_ +_gimrat_ +_gimreg_ +_gimrep_ +_gimres_ +_gimrex_ +_gimseg_ +_gimser_ +_gimsex_ +_gimwrp_ +_gimwrs_ +_gkical_ +_gkiclr_ +_gkicls_ +_gkides_ +_gkieof_ +_gkiese_ +_gkiexe_ +_gkifat_ +_gkifen_ +_gkiffh_ +_gkifia_ +_gkiflh_ +_gkiger_ +_gkiges_ +_gkigey_ +_gkiinl_ +_gkiint_ +_gkimfe_ +_gkiops_ +_gkiplt_ +_gkipmt_ +_gkipoe_ +_gkipor_ +_gkipuy_ +_gkiree_ +_gkirer_ +_gkires_ +_gkirey_ +_gkiser_ +_gkises_ +_gkisul_ +_gkitet_ +_gkitxt_ +_gkiwee_ +_gkiwre_ +_gkpcal_ +_gkpcle_ +_gkpclr_ +_gkpcls_ +_gkpdes_ +_gkpdup_ +_gkpese_ +_gkpfat_ +_gkpfia_ +_gkpflh_ +_gkpger_ +_gkpges_ +_gkpgey_ +_gkpgrm_ +_gkpinl_ +_gkpmfe_ +_gkpops_ +_gkpplt_ +_gkppmt_ +_gkppoe_ +_gkppor_ +_gkppst_ +_gkppuy_ +_gkpres_ +_gkpser_ +_gkpses_ +_gkptet_ +_gkptxg_ +_gkptxt_ +_gkpunn_ +_glabax_ +_glbdrd_ +_glbene_ +_glbeq_ +_glbfis_ +_glbgek_ +_glblas_ +_glblob_ +_glbmip_ +_glbple_ +_glbsep_ +_glbses_ +_glbset_ +_glbtin_ +_glbveg_ +_gline_ +_gltoc_ +_gmark_ +_gmftie_ +_gmprif_ +_gmsg_ +_gmsgb_ +_gmsgc_ +_gmsgd_ +_gmsgi_ +_gmsgl_ +_gmsgr_ +_gmsgs_ +_gmsgx_ +_gmttot_ +_gopen_ +_gopeni_ +_gpagee_ +_gpatme_ +_gpatmh_ +_gpcell_ +_gplcae_ +_gplcal_ +_gplclb_ +_gplcll_ +_gplclr_ +_gplclt_ +_gplflh_ +_gpline_ +_gploto_ +_gplotv_ +_gplret_ +_gplsee_ +_gplwci_ +_gpmark_ +_gqsort_ +_gqvery_ +_grdraw_ +_grdwcs_ +_greace_ +_greset_ +_grmove_ +_grscae_ +_gscan_ +_gscur_ +_gseti_ +_gsetr_ +_gsets_ +_gstati_ +_gstatr_ +_gstats_ +_gstrct_ +_gstrcy_ +_gstrmh_ +_gstsei_ +_gstser_ +_gsview_ +_gswind_ +_gtdise_ +_gtext_ +_gtickr_ +_gtliny_ +_gtndis_ +_gttyld_ +_gtxset_ +_gtybih_ +_gtycas_ +_gtycle_ +_gtyeny_ +_gtyexs_ +_gtyfey_ +_gtyfiy_ +_gtygeb_ +_gtygei_ +_gtyger_ +_gtyges_ +_gtyins_ +_gtyopn_ +_gtysce_ +_gumark_ +_gvline_ +_gvmark_ +_gwcsme_ +_gwrwcs_ +_i1mach_ +_idbcle_ +_idbfid_ +_idbfir_ +_idbgeg_ +_idbkwp_ +_idbned_ +_idbopn_ +_idbpug_ +_ieegmd_ +_ieegmr_ +_ieegnd_ +_ieegnr_ +_ieemad_ +_ieemar_ +_ieepad_ +_ieepar_ +_ieesmd_ +_ieesmr_ +_ieesnd_ +_ieesnr_ +_ieestd_ +_ieestr_ +_ieeupd_ +_ieeupr_ +_ieevpd_ +_ieevpr_ +_ieevud_ +_ieevur_ +_ieezsd_ +_ieezsr_ +_ikiacs_ +_ikicle_ +_ikicoy_ +_ikidee_ +_ikideg_ +_ikiext_ +_ikiged_ +_ikigen_ +_ikiger_ +_ikiint_ +_ikildr_ +_ikimke_ +_ikiopn_ +_ikiopx_ +_ikipae_ +_ikiree_ +_ikiupr_ +_ikivan_ +_imaccf_ +_imaccs_ +_imaddb_ +_imaddd_ +_imaddf_ +_imaddi_ +_imaddl_ +_imaddr_ +_imadds_ +_imaflp_ +_imalin_ +_imaplv_ +_imastr_ +_imbln1_ +_imbln2_ +_imbln3_ +_imbtrn_ +_imcfnl_ +_imcopy_ +_imcssz_ +_imctrt_ +_imdect_ +_imdele_ +_imdelf_ +_imdmap_ +_imerr_ +_imflpl_ +_imflps_ +_imflsd_ +_imflsh_ +_imflsi_ +_imflsl_ +_imflsr_ +_imflss_ +_imflsx_ +_imfluh_ +_imfnpy_ +_imfnss_ +_imgclr_ +_imgetb_ +_imgetc_ +_imgetd_ +_imgeti_ +_imgetl_ +_imgetr_ +_imgets_ +_imgfte_ +_imggsc_ +_imggsd_ +_imggsi_ +_imggsl_ +_imggsr_ +_imggss_ +_imggsx_ +_imgibf_ +_imgime_ +_imgl1d_ +_imgl1i_ +_imgl1l_ +_imgl1r_ +_imgl1s_ +_imgl1x_ +_imgl2d_ +_imgl2i_ +_imgl2l_ +_imgl2r_ +_imgl2s_ +_imgl2x_ +_imgl3d_ +_imgl3i_ +_imgl3l_ +_imgl3r_ +_imgl3s_ +_imgl3x_ +_imgnfn_ +_imgnld_ +_imgnli_ +_imgnll_ +_imgnln_ +_imgnlr_ +_imgnls_ +_imgnlx_ +_imgobf_ +_imgs1d_ +_imgs1i_ +_imgs1l_ +_imgs1r_ +_imgs1s_ +_imgs1x_ +_imgs2d_ +_imgs2i_ +_imgs2l_ +_imgs2r_ +_imgs2s_ +_imgs2x_ +_imgs3d_ +_imgs3i_ +_imgs3l_ +_imgs3r_ +_imgs3s_ +_imgs3x_ +_imgsen_ +_imgstr_ +_iminie_ +_imioff_ +_imisec_ +_imloop_ +_immaky_ +_immap_ +_immapz_ +_imnote_ +_imofnl_ +_imofns_ +_imofnu_ +_imopsf_ +_impakd_ +_impaki_ +_impakl_ +_impakr_ +_impaks_ +_impakx_ +_impare_ +_impgsd_ +_impgsi_ +_impgsl_ +_impgsr_ +_impgss_ +_impgsx_ +_impl1d_ +_impl1i_ +_impl1l_ +_impl1r_ +_impl1s_ +_impl1x_ +_impl2d_ +_impl2i_ +_impl2l_ +_impl2r_ +_impl2s_ +_impl2x_ +_impl3d_ +_impl3i_ +_impl3l_ +_impl3r_ +_impl3s_ +_impl3x_ +_impml1_ +_impml2_ +_impml3_ +_impmlr_ +_impmlv_ +_impmmo_ +_impmmp_ +_impmon_ +_impms1_ +_impms2_ +_impms3_ +_impmsr_ +_impmsv_ +_impnld_ +_impnli_ +_impnll_ +_impnln_ +_impnlr_ +_impnls_ +_impnlx_ +_imps1d_ +_imps1i_ +_imps1l_ +_imps1r_ +_imps1s_ +_imps1x_ +_imps2d_ +_imps2i_ +_imps2l_ +_imps2r_ +_imps2s_ +_imps2x_ +_imps3d_ +_imps3i_ +_imps3l_ +_imps3r_ +_imps3s_ +_imps3x_ +_impstr_ +_imputb_ +_imputd_ +_imputh_ +_imputi_ +_imputl_ +_imputr_ +_imputs_ +_imrbpx_ +_imrdpx_ +_imrene_ +_imrmbs_ +_imsamp_ +_imsetf_ +_imseti_ +_imsetr_ +_imsinb_ +_imsmpl_ +_imsmps_ +_imsslv_ +_imstai_ +_imstar_ +_imstas_ +_imtcle_ +_imtgem_ +_imtlen_ +_imtmae_ +_imtopn_ +_imtopp_ +_imtrew_ +_imtrgm_ +_imunmp_ +_imupkd_ +_imupki_ +_imupkl_ +_imupkr_ +_imupks_ +_imupkx_ +_imwbpx_ +_imwrie_ +_imwrpx_ +_intrde_ +_intree_ +_intrrt_ +_irafmn_ +_itob_ +_itoc_ +_iwcare_ +_iwcfis_ +_iwents_ +_iwfind_ +_iwgbis_ +_iwputr_ +_iwputy_ +_iwrfis_ +_iwsetp_ +_kardbf_ +_kardgd_ +_kardlp_ +_kardpl_ +_kardpr_ +_kardsf_ +_kawrbf_ +_kawrgd_ +_kawrlp_ +_kawrpl_ +_kawrpr_ +_kawrsf_ +_kawtbf_ +_kawtgd_ +_kawtlp_ +_kawtpl_ +_kawtpr_ +_kawtsf_ +_kbzard_ +_kbzawr_ +_kbzawt_ +_kbzcls_ +_kbzopn_ +_kbzstt_ +_kclcpr_ +_kcldir_ +_kcldpr_ +_kclsbf_ +_kclsgd_ +_kclslp_ +_kclspl_ +_kclssf_ +_kclstx_ +_kclsty_ +_kdvall_ +_kdvown_ +_kfacss_ +_kfaloc_ +_kfchdr_ +_kfdele_ +_kfgcwd_ +_kfinfo_ +_kflstx_ +_kflsty_ +_kfmkcp_ +_kfmkdr_ +_kfpath_ +_kfprot_ +_kfrnam_ +_kfsubd_ +_kfxdir_ +_kgettx_ +_kgetty_ +_kgfdir_ +_kicont_ +_kidece_ +_kience_ +_kienvt_ +_kierrr_ +_kiexte_ +_kifine_ +_kiflux_ +_kifman_ +_kifren_ +_kigetn_ +_kigets_ +_kignoe_ +_kiinit_ +_kiloce_ +_kimape_ +_kimapn_ +_kintpr_ +_kiopes_ +_kirece_ +_kisend_ +_kisenv_ +_kishot_ +_kixnoe_ +_kmallc_ +_knottx_ +_knotty_ +_kopcpr_ +_kopdir_ +_kopdpr_ +_kopnbf_ +_kopngd_ +_kopnlp_ +_kopnpl_ +_kopnsf_ +_kopntx_ +_kopnty_ +_koscmd_ +_kputtx_ +_kputty_ +_krealc_ +_ksared_ +_ksawat_ +_ksawre_ +_ksektx_ +_ksekty_ +_ksttbf_ +_ksttgd_ +_ksttlp_ +_ksttpl_ +_ksttpr_ +_ksttsf_ +_kstttx_ +_ksttty_ +_ktzcls_ +_ktzfls_ +_ktzget_ +_ktznot_ +_ktzopn_ +_ktzput_ +_ktzsek_ +_ktzstt_ +_kzclmt_ +_kzopmt_ +_kzrdmt_ +_kzrwmt_ +_kzstmt_ +_kzwrmt_ +_kzwtmt_ +_lexnum_ +_lnocle_ +_lnofeh_ +_lnoopn_ +_lnosae_ +_locpr_ +_locva_ +_lpopen_ +_lpzard_ +_lpzawe_ +_lpzawt_ +_lsttot_ +_ltoc_ +_m75put_ +_maideh_ +_mallo1_ +_mgdptr_ +_mgtfwa_ +_miilen_ +_miinem_ +_miipa2_ +_miipa6_ +_miipa8_ +_miipad_ +_miipak_ +_miipar_ +_miipke_ +_miirec_ +_miired_ +_miirei_ +_miirel_ +_miirer_ +_miires_ +_miiup2_ +_miiup6_ +_miiup8_ +_miiupd_ +_miiupk_ +_miiupr_ +_miiwrc_ +_miiwrd_ +_miiwri_ +_miiwrl_ +_miiwrr_ +_miiwrs_ +_miocle_ +_miogld_ +_miogli_ +_miogll_ +_mioglr_ +_miogls_ +_mioglx_ +_mioopn_ +_mioopo_ +_miopld_ +_miopli_ +_miopll_ +_mioplr_ +_miopls_ +_mioplx_ +_miosee_ +_miosei_ +_miosti_ +_msvfwa_ +_mtalle_ +_mtcap_ +_mtclen_ +_mtclre_ +_mtdeae_ +_mtdevd_ +_mtence_ +_mtfile_ +_mtfnae_ +_mtgets_ +_mtglok_ +_mtgtyn_ +_mtloce_ +_mtneeo_ +_mtopen_ +_mtpare_ +_mtposn_ +_mtpute_ +_mtreae_ +_mtrewd_ +_mtsavd_ +_mtsavs_ +_mtskid_ +_mtstas_ +_mtsync_ +_mtupde_ +_mwalld_ +_mwalls_ +_mwaxtn_ +_mwc1td_ +_mwc1tr_ +_mwc2td_ +_mwc2tr_ +_mwcloe_ +_mwcopd_ +_mwcops_ +_mwctfe_ +_mwctrd_ +_mwctrr_ +_mwfins_ +_mwflop_ +_mwgaxp_ +_mwgaxt_ +_mwgctd_ +_mwgctr_ +_mwgltd_ +_mwgltr_ +_mwgsym_ +_mwgwas_ +_mwgwsd_ +_mwgwsr_ +_mwgwtd_ +_mwgwtr_ +_mwinvd_ +_mwinvr_ +_mwload_ +_mwloam_ +_mwltrd_ +_mwltrr_ +_mwlubb_ +_mwlude_ +_mwmkid_ +_mwmkir_ +_mwmmud_ +_mwmmur_ +_mwnewm_ +_mwnewy_ +_mwopem_ +_mwopen_ +_mwrefr_ +_mwrote_ +_mwsave_ +_mwsavm_ +_mwsaxp_ +_mwscae_ +_mwsctn_ +_mwsdes_ +_mwseti_ +_mwshit_ +_mwshow_ +_mwsltd_ +_mwsltr_ +_mwssym_ +_mwstai_ +_mwswas_ +_mwswsd_ +_mwswsr_ +_mwswtd_ +_mwswte_ +_mwswtr_ +_mwtrad_ +_mwtrar_ +_mwv1td_ +_mwv1tr_ +_mwv2td_ +_mwv2tr_ +_mwvmud_ +_mwvmur_ +_mwvtrd_ +_mwvtrr_ +_ndopen_ +_noti_ +_notl_ +_nots_ +_nowhie_ +_nscan_ +_oifacs_ +_oifcle_ +_oifcoy_ +_oifdee_ +_oifgpe_ +_oifmke_ +_oifopn_ +_oifopx_ +_oifrdr_ +_oifree_ +_oiftrm_ +_oifupr_ +_oifwrr_ +_onerre_ +_onerrr_ +_onexie_ +_onexit_ +_ord1_ +_ord2_ +_ori_ +_orl_ +_ors_ +_oscmd_ +_osfnik_ +_osfnlk_ +_osfnms_ +_osfnpe_ +_osfnrk_ +_osfntt_ +_osfnuk_ +_pagefe_ +_pagefs_ +_pargb_ +_pargc_ +_pargd_ +_pargg_ +_pargi_ +_pargl_ +_pargr_ +_pargs_ +_pargsr_ +_pargx_ +_patamh_ +_patfit_ +_patgel_ +_patgse_ +_patinx_ +_patloe_ +_patmae_ +_patmah_ +_patomh_ +_patsts_ +_pggetd_ +_pggete_ +_pggetr_ +_pgpage_ +_pgpeed_ +_pgpusd_ +_pgsett_ +_placcs_ +_plallc_ +_plascp_ +_plbox_ +_plcire_ +_plcler_ +_plcloe_ +_plcome_ +_plcoms_ +_plcree_ +_pldebg_ +_pldebt_ +_plempe_ +_plempy_ +_plfacs_ +_plfcle_ +_plfcoy_ +_plfdee_ +_plfnul_ +_plfopn_ +_plfree_ +_plfupr_ +_plgete_ +_plglls_ +_plglpi_ +_plglpl_ +_plglps_ +_plglri_ +_plglrl_ +_plglrs_ +_plgsie_ +_pll2pi_ +_pll2pl_ +_pll2ps_ +_pll2ri_ +_pll2rl_ +_pll2rs_ +_pllcot_ +_pllemy_ +_plleql_ +_plline_ +_pllinl_ +_pllinp_ +_plliny_ +_plllen_ +_pllneg_ +_plload_ +_plloaf_ +_plloam_ +_plloop_ +_pllprs_ +_plnewy_ +_plopen_ +_plp2li_ +_plp2ll_ +_plp2ls_ +_plp2ri_ +_plp2rl_ +_plp2rs_ +_plpixi_ +_plpixl_ +_plpixs_ +_plplls_ +_plplpi_ +_plplpl_ +_plplps_ +_plplri_ +_plplrl_ +_plplrs_ +_plpoit_ +_plpoln_ +_plr2li_ +_plr2ll_ +_plr2ls_ +_plr2pi_ +_plr2pl_ +_plr2ps_ +_plrani_ +_plranl_ +_plrans_ +_plrcle_ +_plrefe_ +_plregp_ +_plreqi_ +_plreql_ +_plreqs_ +_plrget_ +_plrgex_ +_plrop_ +_plropn_ +_plrpri_ +_plrprl_ +_plrprs_ +_plrset_ +_plsave_ +_plsavf_ +_plsavm_ +_plsect_ +_plsecy_ +_plsete_ +_plseti_ +_plssie_ +_plsslv_ +_plstai_ +_plstel_ +_plubox_ +_plucie_ +_plupde_ +_plupon_ +_plvald_ +_pmaccs_ +_pmascp_ +_pmbox_ +_pmcire_ +_pmcler_ +_pmempy_ +_pmglls_ +_pmglpi_ +_pmglpl_ +_pmglps_ +_pmglri_ +_pmglrl_ +_pmglrs_ +_pmline_ +_pmliny_ +_pmnewk_ +_pmplls_ +_pmplpi_ +_pmplpl_ +_pmplps_ +_pmplri_ +_pmplrl_ +_pmplrs_ +_pmpoit_ +_pmpoln_ +_pmrcle_ +_pmrgex_ +_pmrop_ +_pmropn_ +_pmrset_ +_pmsect_ +_pmsecy_ +_pmsete_ +_pmseti_ +_pmstai_ +_pmstel_ +_prchdr_ +_prclcr_ +_prcldr_ +_prcloe_ +_prdone_ +_prdumn_ +_prenve_ +_prenvt_ +_prfilf_ +_prfinc_ +_prgete_ +_prgetr_ +_prkill_ +_pronic_ +_propcr_ +_propdr_ +_propen_ +_proscd_ +_protet_ +_prpsio_ +_prpsld_ +_prredr_ +_prseti_ +_prsigl_ +_prstai_ +_prupde_ +_prvret_ +_przclr_ +_pscenr_ +_pscens_ +_pschwh_ +_pscloe_ +_psdept_ +_psesct_ +_psfone_ +_psfonr_ +_psfoor_ +_psgett_ +_pshear_ +_psindt_ +_psioit_ +_psioxr_ +_pslink_ +_psnewe_ +_psopen_ +_psoutt_ +_pspage_ +_pspagk_ +_psrigy_ +_psrjps_ +_pssets_ +_pssett_ +_pssety_ +_psspft_ +_pstese_ +_pstexh_ +_pstrar_ +_pswrig_ +_pswrtk_ +_psxpos_ +_psypos_ +_putcc_ +_putci_ +_putlie_ +_qmaccs_ +_qmgetc_ +_qmscan_ +_qmscao_ +_qmsetm_ +_qmsetr_ +_qmsets_ +_qmspai_ +_qmspar_ +_qmsymb_ +_qmupds_ +_qpaccf_ +_qpaccs_ +_qpaddb_ +_qpaddc_ +_qpaddd_ +_qpaddf_ +_qpaddi_ +_qpaddl_ +_qpaddr_ +_qpadds_ +_qpaddx_ +_qpargt_ +_qpastr_ +_qpbind_ +_qpcfnl_ +_qpcloe_ +_qpclot_ +_qpcopf_ +_qpcopy_ +_qpctod_ +_qpctoi_ +_qpdele_ +_qpdelf_ +_qpdsym_ +_qpdtye_ +_qpelee_ +_qpexad_ +_qpexai_ +_qpexar_ +_qpexcd_ +_qpexce_ +_qpexci_ +_qpexcr_ +_qpexdc_ +_qpexde_ +_qpexdg_ +_qpexdr_ +_qpexee_ +_qpexfe_ +_qpexge_ +_qpexgr_ +_qpexmk_ +_qpexmr_ +_qpexon_ +_qpexpd_ +_qpexpi_ +_qpexpn_ +_qpexpr_ +_qpexps_ +_qpexpt_ +_qpexrd_ +_qpexsd_ +_qpexsi_ +_qpexsr_ +_qpfacs_ +_qpfcle_ +_qpfcos_ +_qpfcoy_ +_qpfdee_ +_qpflur_ +_qpfopn_ +_qpfopx_ +_qpfree_ +_qpfupr_ +_qpfwar_ +_qpfwfr_ +_qpfzcl_ +_qpfzop_ +_qpfzrd_ +_qpfzst_ +_qpfzwr_ +_qpfzwt_ +_qpgetb_ +_qpgetc_ +_qpgetd_ +_qpgeti_ +_qpgetk_ +_qpgetl_ +_qpgetm_ +_qpgetr_ +_qpgets_ +_qpgetx_ +_qpgmsm_ +_qpgnfn_ +_qpgpsm_ +_qpgstr_ +_qpinht_ +_qpioce_ +_qpioge_ +_qpiogr_ +_qpiogs_ +_qpiolk_ +_qpiols_ +_qpiomx_ +_qpioon_ +_qpiope_ +_qpiops_ +_qpiori_ +_qpiors_ +_qpiort_ +_qpiosc_ +_qpiose_ +_qpiosi_ +_qpiosr_ +_qpiost_ +_qpiour_ +_qpiovr_ +_qpiowt_ +_qplenf_ +_qplenl_ +_qplesd_ +_qplesi_ +_qplesr_ +_qploas_ +_qpmaxd_ +_qpmaxi_ +_qpmaxr_ +_qpmind_ +_qpmini_ +_qpminr_ +_qpmkfe_ +_qpnexk_ +_qpofnl_ +_qpofns_ +_qpofnu_ +_qpopen_ +_qpopet_ +_qppare_ +_qpparl_ +_qppcle_ +_qppopn_ +_qppstr_ +_qpputb_ +_qpputc_ +_qpputd_ +_qpputi_ +_qpputl_ +_qpputm_ +_qpputr_ +_qpputs_ +_qpputx_ +_qpquef_ +_qprawk_ +_qpread_ +_qprebd_ +_qprene_ +_qprenf_ +_qprlmd_ +_qprlmi_ +_qprlmr_ +_qpsavs_ +_qpseel_ +_qpseti_ +_qpsetr_ +_qpsizf_ +_qpstai_ +_qpstar_ +_qpsync_ +_qpungk_ +_qpwrie_ +_qpxgvd_ +_qpxgvi_ +_qpxgvl_ +_qpxgvr_ +_qpxgvs_ +_r1mach_ +_r2tr_ +_r2tx_ +_r4syn_ +_r4tr_ +_r4tx_ +_r8syn_ +_r8tr_ +_r8tx_ +_rdukey_ +_reopen_ +_resetn_ +_salloc_ +_scanc_ +_sfree_ +_shifti_ +_shiftl_ +_shifts_ +_smark_ +_sprinf_ +_sscan_ +_stallc_ +_stcloe_ +_stentr_ +_stfacs_ +_stfadr_ +_stfcle_ +_stfcos_ +_stfcoy_ +_stfcte_ +_stfdee_ +_stfgeb_ +_stfgei_ +_stfgen_ +_stfges_ +_stfget_ +_stfind_ +_stfinl_ +_stfins_ +_stfmeb_ +_stfmke_ +_stfnee_ +_stfopn_ +_stfopx_ +_stforb_ +_stfrdr_ +_stfree_ +_stfrek_ +_stfrfr_ +_stfrgb_ +_stfrne_ +_stfupr_ +_stfwfr_ +_stfwgb_ +_sthash_ +_sthead_ +_stinfo_ +_stkmkg_ +_stmark_ +_stname_ +_stnext_ +_stnsys_ +_stopen_ +_stpstr_ +_strcle_ +_strdic_ +_strefb_ +_streff_ +_streq_ +_strese_ +_strge_ +_strgee_ +_strgt_ +_strids_ +_stridx_ +_strlds_ +_strldx_ +_strle_ +_strlt_ +_strlwr_ +_strmac_ +_strmah_ +_strncp_ +_strne_ +_stropn_ +_strpak_ +_strse1_ +_strsee_ +_strseh_ +_strsrt_ +_strtbl_ +_strupk_ +_strupr_ +_stsave_ +_stsize_ +_stsque_ +_sttyco_ +_sttyet_ +_sttygg_ +_sttynm_ +_sttyse_ +_sttysm_ +_sttytt_ +_syserr_ +_sysers_ +_sysged_ +_sysges_ +_sysgsg_ +_sysid_ +_sysmte_ +_syspac_ +_syspat_ +_syspte_ +_sysret_ +_syssct_ +_tsleep_ +_ttopen_ +_ttseti_ +_ttsets_ +_ttstai_ +_ttstas_ +_ttybih_ +_ttybre_ +_ttycas_ +_ttycds_ +_ttycle_ +_ttycln_ +_ttyclr_ +_ttyctl_ +_ttydee_ +_ttydey_ +_ttyeny_ +_ttyexs_ +_ttyfey_ +_ttyfiy_ +_ttygds_ +_ttygeb_ +_ttygei_ +_ttyger_ +_ttyges_ +_ttygoo_ +_ttygpe_ +_ttygse_ +_ttyins_ +_ttyint_ +_ttylod_ +_ttyods_ +_ttyopn_ +_ttypue_ +_ttypus_ +_ttyred_ +_ttysce_ +_ttysei_ +_ttyso_ +_ttysti_ +_ttysui_ +_ttywre_ +_ungete_ +_ungeti_ +_unread_ +_urand_ +_vfnadd_ +_vfncle_ +_vfndee_ +_vfndel_ +_vfnene_ +_vfnenr_ +_vfnexr_ +_vfngen_ +_vfnise_ +_vfnman_ +_vfnmap_ +_vfnmau_ +_vfnopn_ +_vfnsqe_ +_vfntre_ +_vfnunn_ +_vfnunp_ +_vlibinit_ +_vmallc_ +_vvfncm_ +_vvfnee_ +_vvfnip_ +_vvfnis_ +_vvfnre_ +_wfaitd_ +_wfaitt_ +_wfaitv_ +_wfarcd_ +_wfarct_ +_wfarcv_ +_wfcard_ +_wfcart_ +_wfcarv_ +_wfcscd_ +_wfcsct_ +_wfcscv_ +_wfdecs_ +_wffnld_ +_wfglsd_ +_wfglst_ +_wfglsv_ +_wfgsbb_ +_wfgsbg_ +_wfgsbl_ +_wfgsce_ +_wfgscf_ +_wfgsdr_ +_wfgsel_ +_wfgson_ +_wfgsre_ +_wfinit_ +_wfmerd_ +_wfmert_ +_wfmerv_ +_wfmold_ +_wfmolt_ +_wfmolv_ +_wfmspd_ +_wfmspf_ +_wfmspi_ +_wfmspl_ +_wfmspt_ +_wfmspv_ +_wfmspy_ +_wfpard_ +_wfpart_ +_wfparv_ +_wfpcod_ +_wfpcot_ +_wfpcov_ +_wfqscd_ +_wfqsct_ +_wfqscv_ +_wfsind_ +_wfsint_ +_wfsinv_ +_wfsmph_ +_wfsmpn_ +_wfsmpt_ +_wfstgd_ +_wfstgt_ +_wfstgv_ +_wftand_ +_wftant_ +_wftanv_ +_wftnxd_ +_wftnxt_ +_wftnxv_ +_wftnxy_ +_wftscd_ +_wftsct_ +_wftscv_ +_wfzead_ +_wfzeat_ +_wfzeav_ +_wfzpxd_ +_wfzpxt_ +_wfzpxv_ +_wfzpxy_ +_xalloe_ +_xcallc_ +_xdeale_ +_xdevor_ +_xdevss_ +_xeract_ +_xerfmg_ +_xerpoi_ +_xerpop_ +_xerpsh_ +_xerpsr_ +_xerpuc_ +_xerpue_ +_xerret_ +_xerror_ +_xersel_ +_xervey_ +_xevadg_ +_xevbip_ +_xevbop_ +_xevcan_ +_xever1_ +_xever2_ +_xeverr_ +_xevfrp_ +_xevgek_ +_xevinp_ +_xevmap_ +_xevnee_ +_xevpae_ +_xevpah_ +_xevqut_ +_xevstt_ +_xevunp_ +_xfaccs_ +_xfatal_ +_xfchdr_ +_xfcloe_ +_xfdele_ +_xffluh_ +_xfgetc_ +_xfgetr_ +_xfnote_ +_xfopen_ +_xfputc_ +_xfputr_ +_xfread_ +_xfrnam_ +_xfscan_ +_xfseek_ +_xfungc_ +_xfwrie_ +_xgdevt_ +_xgtpid_ +_xgtuid_ +_xisaty_ +_xmallc_ +_xmfree_ +_xmjbuf_ +_xmktep_ +_xonerr_ +_xonext_ +_xori_ +_xorl_ +_xors_ +_xpages_ +_xprinf_ +_xqsort_ +_xrealc_ +_xsizef_ +_xstdeh_ +_xstrcp_ +_xstrct_ +_xstrcy_ +_xstrln_ +_xtoc_ +_xttyse_ +_xvvadg_ +_xvvbip_ +_xvvbop_ +_xvvcan_ +_xvvche_ +_xvver1_ +_xvver2_ +_xvverr_ +_xvvfrp_ +_xvvgek_ +_xvvinp_ +_xvvlos_ +_xvvmap_ +_xvvnee_ +_xvvnud_ +_xvvnui_ +_xvvnul_ +_xvvnur_ +_xvvnus_ +_xvvpae_ +_xvvpah_ +_xvvqut_ +_xvvstt_ +_xvvunp_ +_xwhen_ +_xxscan_ +_zardbf_ +_zardgd_ +_zardks_ +_zardlp_ +_zardmt_ +_zardnd_ +_zardnu_ +_zardpl_ +_zardpr_ +_zardps_ +_zardsf_ +_zawrbf_ +_zawrgd_ +_zawrks_ +_zawrlp_ +_zawrmt_ +_zawrnd_ +_zawrnu_ +_zawrpl_ +_zawrpr_ +_zawrps_ +_zawrsf_ +_zawset_ +_zawtbf_ +_zawtgd_ +_zawtks_ +_zawtlp_ +_zawtmt_ +_zawtnd_ +_zawtnu_ +_zawtpl_ +_zawtpr_ +_zawtps_ +_zawtsf_ +_zclcpr_ +_zcldir_ +_zcldpr_ +_zclm70_ +_zclm75_ +_zclsbf_ +_zclsgd_ +_zclsks_ +_zclslp_ +_zclsmt_ +_zclsnd_ +_zclsnu_ +_zclspl_ +_zclsps_ +_zclssf_ +_zclstt_ +_zclstx_ +_zclsty_ +_zdojmp_ +_zdvall_ +_zdvown_ +_zfacss_ +_zfaloc_ +_zfchdr_ +_zfdele_ +_zfgcwd_ +_zfinfo_ +_zflsnu_ +_zflstt_ +_zflstx_ +_zflsty_ +_zfmkcp_ +_zfmkdr_ +_zfnbrk_ +_zfpath_ +_zfprot_ +_zfrnam_ +_zfsubd_ +_zfxdir_ +_zgcmdl_ +_zgetnu_ +_zgettt_ +_zgettx_ +_zgetty_ +_zgfdir_ +_zghost_ +_zgmtco_ +_zgtime_ +_zgtpid_ +_zintpr_ +_zlocpr_ +_zlocva_ +_zmaloc_ +_zmfree_ +_znotnu_ +_znottt_ +_znottx_ +_znotty_ +_zopcpr_ +_zopdir_ +_zopdpr_ +_zopm70_ +_zopm75_ +_zopnbf_ +_zopngd_ +_zopnks_ +_zopnlp_ +_zopnmt_ +_zopnnd_ +_zopnnu_ +_zopnpl_ +_zopnsf_ +_zopntt_ +_zopntx_ +_zopnty_ +_zoscmd_ +_zpanic_ +_zputnu_ +_zputtt_ +_zputtx_ +_zputty_ +_zraloc_ +_zrdm70_ +_zrdm75_ +_zseknu_ +_zsektt_ +_zsektx_ +_zsekty_ +_zsestt_ +_zsettt_ +_zstm70_ +_zstm75_ +_zststt_ +_zsttbf_ +_zsttgd_ +_zsttks_ +_zsttlp_ +_zsttmt_ +_zsttnd_ +_zsttnu_ +_zsttpl_ +_zsttpr_ +_zsttps_ +_zsttsf_ +_zstttt_ +_zstttx_ +_zsttty_ +_zsvjmp_ +_zttgeg_ +_zttger_ +_zttloe_ +_zttloo_ +_zttlov_ +_zttpbf_ +_zttplk_ +_zttpug_ +_zttquy_ +_zttttt_ +_zttupe_ +_zwmsec_ +_zwrm70_ +_zwrm75_ +_zwtm70_ +_zwtm75_ +_zxgmes_ +_zxwhen_ +_zzclmt_ +_zzopmt_ +_zzrdii_ +_zzrdmt_ +_zzrwmt_ +_zzsetk_ +_zzstmt_ +_zzwrii_ +_zzwrmt_ +_zzwtmt_ +_zzzend_ +_fxfnoe_ +_futime_ +_kfutim_ +_zfutim_ +_dtmday_ +_dtmlte_ +_pollce_ +_pollcr_ +_pollgs_ +_pollon_ +_pollpt_ +_pollst_ +_polltt_ +_pollzo_ +_xfpoll_ +_zfpoll_ diff --git a/unix/shlib/S.nm.ssun b/unix/shlib/S.nm.ssun new file mode 100644 index 00000000..f49297b7 --- /dev/null +++ b/unix/shlib/S.nm.ssun @@ -0,0 +1,2864 @@ +aabsd_ +aabsi_ +aabsl_ +aabsr_ +aabss_ +aabsx_ +aaddd_ +aaddi_ +aaddkd_ +aaddki_ +aaddkl_ +aaddkr_ +aaddks_ +aaddkx_ +aaddl_ +aaddr_ +aadds_ +aaddx_ +aandi_ +aandki_ +aandkl_ +aandks_ +aandl_ +aands_ +aavgd_ +aavgi_ +aavgl_ +aavgr_ +aavgs_ +aavgx_ +abavd_ +abavi_ +abavl_ +abavr_ +abavs_ +abavx_ +abeqc_ +abeqd_ +abeqi_ +abeqkc_ +abeqkd_ +abeqki_ +abeqkl_ +abeqkr_ +abeqks_ +abeqkx_ +abeql_ +abeqr_ +abeqs_ +abeqx_ +abgec_ +abged_ +abgei_ +abgekc_ +abgekd_ +abgeki_ +abgekl_ +abgekr_ +abgeks_ +abgekx_ +abgel_ +abger_ +abges_ +abgex_ +abgtc_ +abgtd_ +abgti_ +abgtkc_ +abgtkd_ +abgtki_ +abgtkl_ +abgtkr_ +abgtks_ +abgtkx_ +abgtl_ +abgtr_ +abgts_ +abgtx_ +ablec_ +abled_ +ablei_ +ablekc_ +ablekd_ +ableki_ +ablekl_ +ablekr_ +ableks_ +ablekx_ +ablel_ +abler_ +ables_ +ablex_ +abltc_ +abltd_ +ablti_ +abltkc_ +abltkd_ +abltki_ +abltkl_ +abltkr_ +abltks_ +abltkx_ +abltl_ +abltr_ +ablts_ +abltx_ +abnec_ +abned_ +abnei_ +abnekc_ +abnekd_ +abneki_ +abnekl_ +abnekr_ +abneks_ +abnekx_ +abnel_ +abner_ +abnes_ +abnex_ +abori_ +aborki_ +aborkl_ +aborks_ +aborl_ +abors_ +absud_ +absui_ +absul_ +absur_ +absus_ +acht_ +achtb_ +achtbb_ +achtbc_ +achtbd_ +achtbi_ +achtbl_ +achtbr_ +achtbs_ +achtbu_ +achtbx_ +achtc_ +achtcb_ +achtcc_ +achtcd_ +achtci_ +achtcl_ +achtcr_ +achtcs_ +achtcu_ +achtcx_ +achtd_ +achtdb_ +achtdc_ +achtdd_ +achtdi_ +achtdl_ +achtdr_ +achtds_ +achtdu_ +achtdx_ +achti_ +achtib_ +achtic_ +achtid_ +achtii_ +achtil_ +achtir_ +achtis_ +achtiu_ +achtix_ +achtl_ +achtlb_ +achtlc_ +achtld_ +achtli_ +achtll_ +achtlr_ +achtls_ +achtlu_ +achtlx_ +achtr_ +achtrb_ +achtrc_ +achtrd_ +achtri_ +achtrl_ +achtrr_ +achtrs_ +achtru_ +achtrx_ +achts_ +achtsb_ +achtsc_ +achtsd_ +achtsi_ +achtsl_ +achtsr_ +achtss_ +achtsu_ +achtsx_ +achtu_ +achtub_ +achtuc_ +achtud_ +achtui_ +achtul_ +achtur_ +achtus_ +achtuu_ +achtux_ +achtx_ +achtxb_ +achtxc_ +achtxd_ +achtxi_ +achtxl_ +achtxr_ +achtxs_ +achtxu_ +achtxx_ +acjgx_ +aclrb_ +aclrc_ +aclrd_ +aclri_ +aclrl_ +aclrr_ +aclrs_ +aclrx_ +acnvd_ +acnvi_ +acnvl_ +acnvr_ +acnvrd_ +acnvri_ +acnvrl_ +acnvrr_ +acnvrs_ +acnvs_ +adivd_ +adivi_ +adivkd_ +adivki_ +adivkl_ +adivkr_ +adivks_ +adivkx_ +adivl_ +adivr_ +adivs_ +adivx_ +adotd_ +adoti_ +adotl_ +adotr_ +adots_ +adotx_ +advzd_ +advzi_ +advzl_ +advzr_ +advzs_ +advzx_ +aelogd_ +aelogr_ +aexpd_ +aexpi_ +aexpkd_ +aexpki_ +aexpkl_ +aexpkr_ +aexpks_ +aexpkx_ +aexpl_ +aexpr_ +aexps_ +aexpx_ +afftrr_ +afftrx_ +afftxr_ +afftxx_ +agltc_ +agltd_ +aglti_ +agltl_ +agltr_ +aglts_ +agltx_ +ahgmc_ +ahgmd_ +ahgmi_ +ahgml_ +ahgmr_ +ahgms_ +ahivc_ +ahivd_ +ahivi_ +ahivl_ +ahivr_ +ahivs_ +ahivx_ +aiftrr_ +aiftrx_ +aiftxr_ +aiftxx_ +aimgd_ +aimgi_ +aimgl_ +aimgr_ +aimgs_ +alani_ +alanki_ +alankl_ +alanks_ +alanl_ +alans_ +alimc_ +alimd_ +alimi_ +aliml_ +alimr_ +alims_ +alimx_ +allnd_ +allni_ +allnl_ +allnr_ +allns_ +allnx_ +alogd_ +alogi_ +alogl_ +alogr_ +alogs_ +alogx_ +alori_ +alorki_ +alorkl_ +alorks_ +alorl_ +alors_ +alovc_ +alovd_ +alovi_ +alovl_ +alovr_ +alovs_ +alovx_ +altad_ +altai_ +altal_ +altar_ +altas_ +altax_ +altmd_ +altmi_ +altml_ +altmr_ +altms_ +altmx_ +altrd_ +altri_ +altrl_ +altrr_ +altrs_ +altrx_ +aluid_ +aluii_ +aluil_ +aluir_ +aluis_ +alutc_ +alutd_ +aluti_ +alutl_ +alutr_ +aluts_ +amagd_ +amagi_ +amagl_ +amagr_ +amags_ +amagx_ +amapd_ +amapi_ +amapl_ +amapr_ +amaps_ +amaxc_ +amaxd_ +amaxi_ +amaxkc_ +amaxkd_ +amaxki_ +amaxkl_ +amaxkr_ +amaxks_ +amaxkx_ +amaxl_ +amaxr_ +amaxs_ +amaxx_ +amed3c_ +amed3d_ +amed3i_ +amed3l_ +amed3r_ +amed3s_ +amed4c_ +amed4d_ +amed4i_ +amed4l_ +amed4r_ +amed4s_ +amed5c_ +amed5d_ +amed5i_ +amed5l_ +amed5r_ +amed5s_ +amedc_ +amedd_ +amedi_ +amedl_ +amedr_ +ameds_ +amedx_ +amgsd_ +amgsi_ +amgsl_ +amgsr_ +amgss_ +amgsx_ +aminc_ +amind_ +amini_ +aminkc_ +aminkd_ +aminki_ +aminkl_ +aminkr_ +aminks_ +aminkx_ +aminl_ +aminr_ +amins_ +aminx_ +amodd_ +amodi_ +amodkd_ +amodki_ +amodkl_ +amodkr_ +amodks_ +amodl_ +amodr_ +amods_ +amovc_ +amovd_ +amovi_ +amovkc_ +amovkd_ +amovki_ +amovkl_ +amovkr_ +amovks_ +amovkx_ +amovl_ +amovr_ +amovs_ +amovx_ +amuld_ +amuli_ +amulkd_ +amulki_ +amulkl_ +amulkr_ +amulks_ +amulkx_ +amull_ +amulr_ +amuls_ +amulx_ +andi_ +andl_ +ands_ +anegd_ +anegi_ +anegl_ +anegr_ +anegs_ +anegx_ +anoti_ +anotl_ +anots_ +apkxd_ +apkxi_ +apkxl_ +apkxr_ +apkxs_ +apkxx_ +apold_ +apolr_ +apowd_ +apowi_ +apowkd_ +apowki_ +apowkl_ +apowkr_ +apowks_ +apowkx_ +apowl_ +apowr_ +apows_ +apowx_ +aravd_ +aravi_ +aravl_ +aravr_ +aravs_ +aravx_ +arcpd_ +arcpi_ +arcpl_ +arcpr_ +arcps_ +arcpx_ +arczd_ +arczi_ +arczl_ +arczr_ +arczs_ +arczx_ +aread_ +areadb_ +argtd_ +argti_ +argtl_ +argtr_ +argts_ +argtx_ +arltd_ +arlti_ +arltl_ +arltr_ +arlts_ +arltx_ +aselc_ +aseld_ +aseli_ +aselkc_ +aselkd_ +aselki_ +aselkl_ +aselkr_ +aselks_ +aselkx_ +asell_ +aselr_ +asels_ +aselx_ +asokc_ +asokd_ +asoki_ +asokl_ +asokr_ +asoks_ +asokx_ +asqrd_ +asqri_ +asqrl_ +asqrr_ +asqrs_ +asqrx_ +asrtc_ +asrtd_ +asrti_ +asrtl_ +asrtr_ +asrts_ +asrtx_ +assqd_ +assqi_ +assql_ +assqr_ +assqs_ +assqx_ +asubd_ +asubi_ +asubkd_ +asubki_ +asubkl_ +asubkr_ +asubks_ +asubkx_ +asubl_ +asubr_ +asubs_ +asubx_ +asumd_ +asumi_ +asuml_ +asumr_ +asums_ +asumx_ +aupxd_ +aupxi_ +aupxl_ +aupxr_ +aupxs_ +aupxx_ +aveqc_ +aveqd_ +aveqi_ +aveql_ +aveqr_ +aveqs_ +aveqx_ +await_ +awaitb_ +awritb_ +awrite_ +awsud_ +awsui_ +awsul_ +awsur_ +awsus_ +awsux_ +awvgd_ +awvgi_ +awvgl_ +awvgr_ +awvgs_ +awvgx_ +axori_ +axorki_ +axorkl_ +axorks_ +axorl_ +axors_ +begmem_ +bitmov_ +bitpak_ +bitupk_ +brktie_ +bswap2_ +bswap4_ +bswap8_ +btoi_ +bytmov_ +cctoc_ +chdept_ +chfeth_ +chrlwr_ +chrpak_ +chrupk_ +chrupr_ +clccos_ +clcenr_ +clcfeh_ +clcfid_ +clcfre_ +clcint_ +clclit_ +clcloe_ +clcmak_ +clcmd_ +clcmdw_ +clcnek_ +clcpst_ +clcscn_ +clepst_ +clgcur_ +clgetb_ +clgetc_ +clgetd_ +clgeti_ +clgetl_ +clgetr_ +clgets_ +clgetx_ +clgfil_ +clgkey_ +clglpb_ +clglpc_ +clglpd_ +clglpi_ +clglpl_ +clglpr_ +clglps_ +clglpx_ +clglsr_ +clgpsa_ +clgpsb_ +clgpsc_ +clgpsd_ +clgpsi_ +clgpsl_ +clgpsr_ +clgpss_ +clgpst_ +clgpsx_ +clgstr_ +clgwrd_ +clktie_ +cllpst_ +clopen_ +clopst_ +clpcls_ +clplen_ +clpopi_ +clpops_ +clpopu_ +clppsa_ +clppsb_ +clppsc_ +clppsd_ +clppsi_ +clppsl_ +clppsr_ +clppss_ +clppst_ +clppsx_ +clprew_ +clprif_ +clpsee_ +clpsit_ +clpstr_ +clputb_ +clputc_ +clputd_ +clputi_ +clputl_ +clputr_ +clputs_ +clputx_ +clreqr_ +clscan_ +clseti_ +clstai_ +cnvdae_ +cnvtie_ +coerce_ +cputie_ +ctocc_ +ctod_ +ctoi_ +ctol_ +ctor_ +ctotok_ +ctowrd_ +ctox_ +d1mach_ +deletg_ +diropn_ +dtcscl_ +dtmdee_ +dtmdes_ +dtmene_ +dtmens_ +dtoc3_ +dtoc_ +elogd_ +elogr_ +envfid_ +envfit_ +envfre_ +envgeb_ +envged_ +envgei_ +envger_ +envges_ +envinr_ +envint_ +envlit_ +envmak_ +envnet_ +envpus_ +envret_ +envscn_ +eprinf_ +erract_ +errcoe_ +errget_ +evexpr_ +evvexr_ +evvfre_ +f77pak_ +f77upk_ +falloc_ +fcanpb_ +fcldir_ +fclobr_ +fcopy_ +fcopyo_ +fdebug_ +fdevbf_ +fdevbk_ +fdevtx_ +fdirne_ +fexbuf_ +ffa_ +ffault_ +ffilbf_ +ffilsz_ +ffldir_ +fflsbf_ +ffs_ +fft842_ +fgdev0_ +fgdevm_ +fgetfd_ +fgtdir_ +filbuf_ +filerr_ +filopn_ +finfo_ +finit_ +fioclp_ +fioqfh_ +fixmem_ +flsbuf_ +fmaccs_ +fmapfn_ +fmcloe_ +fmcopo_ +fmcopy_ +fmdebg_ +fmdele_ +fmfcdg_ +fmfcfe_ +fmfcit_ +fmfcsc_ +fmfinf_ +fmfopn_ +fmgetd_ +fmiobd_ +fmioed_ +fmioek_ +fmiopr_ +fmiorr_ +fmiosf_ +fmiotk_ +fmkbfs_ +fmkcoy_ +fmkdir_ +fmkpbf_ +fmlfad_ +fmlfae_ +fmlfat_ +fmlfbd_ +fmlfbe_ +fmlfbt_ +fmlfce_ +fmlfcy_ +fmlfde_ +fmlfne_ +fmlfon_ +fmlfpe_ +fmlfsi_ +fmlfst_ +fmlfue_ +fmlocd_ +fmloct_ +fmnexe_ +fmopen_ +fmrebd_ +fmrene_ +fmretd_ +fmseti_ +fmstai_ +fmsync_ +fmterr_ +fmtint_ +fmtred_ +fmtsel_ +fmtstr_ +fmunlk_ +fnextn_ +fnldir_ +fnroot_ +fntclb_ +fntcls_ +fntdir_ +fntedt_ +fntget_ +fntgfb_ +fntgfn_ +fntleb_ +fntmkt_ +fntopb_ +fntopn_ +fntopt_ +fntreb_ +fntree_ +fntrfb_ +fnulle_ +fopdir_ +fopnbf_ +fopntx_ +fowner_ +fpathe_ +fpequd_ +fpequr_ +fpfixd_ +fpfixr_ +fpnonr_ +fpnord_ +fpnorr_ +fpradv_ +fprfmt_ +fprinf_ +fprntf_ +fptdir_ +fputtx_ +freadp_ +fredio_ +fredir_ +frenae_ +frmbfs_ +frmtmp_ +frtnfd_ +fsetev_ +fsetfd_ +fseti_ +fsfdee_ +fsfgee_ +fsfopn_ +fskdir_ +fstati_ +fstatl_ +fstats_ +fstdfe_ +fstdir_ +fstrfp_ +fsvtfn_ +fswapd_ +fwatio_ +fwritp_ +fwtacc_ +fxfacp_ +fxfacs_ +fxfact_ +fxfadr_ +fxfakb_ +fxfakc_ +fxfakd_ +fxfaki_ +fxfakr_ +fxfalc_ +fxfald_ +fxfalr_ +fxfalu_ +fxfasr_ +fxfbls_ +fxfbyt_ +fxfche_ +fxfchm_ +fxfchp_ +fxfchv_ +fxfcle_ +fxfcll_ +fxfcnx_ +fxfcoj_ +fxfcoy_ +fxfcte_ +fxfdae_ +fxfdee_ +fxfdiw_ +fxfdur_ +fxfenb_ +fxfenc_ +fxfend_ +fxfene_ +fxfeni_ +fxfenl_ +fxfenr_ +fxfens_ +fxfexh_ +fxfexr_ +fxffac_ +fxffcr_ +fxffiw_ +fxffog_ +fxffpd_ +fxfgas_ +fxfgeb_ +fxfged_ +fxfgei_ +fxfgen_ +fxfger_ +fxfget_ +fxfglm_ +fxfgsr_ +fxfhdt_ +fxfhee_ +fxfhef_ +fxfint_ +fxfisk_ +fxfkse_ +fxfksl_ +fxfksm_ +fxfksn_ +fxfkss_ +fxfkst_ +fxfksx_ +fxflor_ +fxfmad_ +fxfmar_ +fxfmas_ +fxfmay_ +fxfmea_ +fxfnul_ +fxfopn_ +fxfopx_ +fxfove_ +fxfovt_ +fxfpaa_ +fxfpld_ +fxfple_ +fxfplf_ +fxfplo_ +fxfplp_ +fxfprr_ +fxfred_ +fxfree_ +fxfrek_ +fxfren_ +fxfrep_ +fxfrfr_ +fxfrhr_ +fxfsee_ +fxfsev_ +fxfsex_ +fxfskn_ +fxfstr_ +fxftox_ +fxfuad_ +fxfuna_ +fxfupd_ +fxfupr_ +fxfwrr_ +fxfwrs_ +fxfxal_ +fxfxhd_ +fxfxn1_ +fxfzcl_ +fxfzop_ +fxfzrd_ +fxfzst_ +fxfzwr_ +fxfzwt_ +gactie_ +gadraw_ +gamove_ +gargb_ +gargc_ +gargd_ +gargi_ +gargl_ +gargr_ +gargrd_ +gargs_ +gargsr_ +gargtk_ +gargwd_ +gargx_ +gascae_ +gcancl_ +gclear_ +gclose_ +gctod_ +gctol_ +gctox_ +gctran_ +gcurps_ +gdeace_ +gescae_ +getci_ +gethot_ +getlie_ +getlle_ +getloe_ +gexflr_ +gexfls_ +gexflt_ +gfill_ +gflush_ +gframe_ +gfrint_ +ggcell_ +ggcur_ +ggetb_ +ggeti_ +ggetr_ +ggets_ +ggscae_ +ggview_ +ggwind_ +gimcor_ +gimcrr_ +gimder_ +gimdig_ +gimeng_ +gimfrg_ +gimfrp_ +gimgeg_ +gimins_ +gimiod_ +gimioe_ +gimlop_ +gimqur_ +gimrat_ +gimreg_ +gimrep_ +gimres_ +gimrex_ +gimseg_ +gimser_ +gimsex_ +gimwrp_ +gimwrs_ +gkical_ +gkiclr_ +gkicls_ +gkides_ +gkieof_ +gkiese_ +gkiexe_ +gkifat_ +gkifen_ +gkiffh_ +gkifia_ +gkiflh_ +gkiger_ +gkiges_ +gkigey_ +gkiinl_ +gkiint_ +gkimfe_ +gkiops_ +gkiplt_ +gkipmt_ +gkipoe_ +gkipor_ +gkipuy_ +gkiree_ +gkirer_ +gkires_ +gkirey_ +gkiser_ +gkises_ +gkisul_ +gkitet_ +gkitxt_ +gkiwee_ +gkiwre_ +gkpcal_ +gkpcle_ +gkpclr_ +gkpcls_ +gkpdes_ +gkpdup_ +gkpese_ +gkpfat_ +gkpfia_ +gkpflh_ +gkpger_ +gkpges_ +gkpgey_ +gkpgrm_ +gkpinl_ +gkpmfe_ +gkpops_ +gkpplt_ +gkppmt_ +gkppoe_ +gkppor_ +gkppst_ +gkppuy_ +gkpres_ +gkpser_ +gkpses_ +gkptet_ +gkptxg_ +gkptxt_ +gkpunn_ +glabax_ +glbdrd_ +glbene_ +glbeq_ +glbfis_ +glbgek_ +glblas_ +glblob_ +glbmip_ +glbple_ +glbsep_ +glbses_ +glbset_ +glbtin_ +glbveg_ +gline_ +gltoc_ +gmark_ +gmftie_ +gmprif_ +gmsg_ +gmsgb_ +gmsgc_ +gmsgd_ +gmsgi_ +gmsgl_ +gmsgr_ +gmsgs_ +gmsgx_ +gmttot_ +gopen_ +gopeni_ +gpagee_ +gpatme_ +gpatmh_ +gpcell_ +gplcae_ +gplcal_ +gplclb_ +gplcll_ +gplclr_ +gplclt_ +gplflh_ +gpline_ +gploto_ +gplotv_ +gplret_ +gplsee_ +gplwci_ +gpmark_ +gqsort_ +gqvery_ +grdraw_ +grdwcs_ +greace_ +greset_ +grmove_ +grscae_ +gscan_ +gscur_ +gseti_ +gsetr_ +gsets_ +gstati_ +gstatr_ +gstats_ +gstrct_ +gstrcy_ +gstrmh_ +gstsei_ +gstser_ +gsview_ +gswind_ +gtdise_ +gtext_ +gtickr_ +gtliny_ +gtndis_ +gttyld_ +gtxset_ +gtybih_ +gtycas_ +gtycle_ +gtyeny_ +gtyexs_ +gtyfey_ +gtyfiy_ +gtygeb_ +gtygei_ +gtyger_ +gtyges_ +gtyins_ +gtyopn_ +gtysce_ +gumark_ +gvline_ +gvmark_ +gwcsme_ +gwrwcs_ +i1mach_ +idbcle_ +idbfid_ +idbfir_ +idbgeg_ +idbkwp_ +idbned_ +idbopn_ +idbpug_ +ieegmd_ +ieegmr_ +ieegnd_ +ieegnr_ +ieemad_ +ieemar_ +ieepad_ +ieepar_ +ieesmd_ +ieesmr_ +ieesnd_ +ieesnr_ +ieestd_ +ieestr_ +ieeupd_ +ieeupr_ +ieevpd_ +ieevpr_ +ieevud_ +ieevur_ +ieezsd_ +ieezsr_ +ikiacs_ +ikicle_ +ikicoy_ +ikidee_ +ikideg_ +ikiext_ +ikiged_ +ikigen_ +ikiger_ +ikiint_ +ikildr_ +ikimke_ +ikiopn_ +ikiopx_ +ikipae_ +ikiree_ +ikiupr_ +ikivan_ +imaccf_ +imaccs_ +imaddb_ +imaddd_ +imaddf_ +imaddi_ +imaddl_ +imaddr_ +imadds_ +imaflp_ +imalin_ +imaplv_ +imastr_ +imbln1_ +imbln2_ +imbln3_ +imbtrn_ +imcfnl_ +imcopy_ +imcssz_ +imctrt_ +imdect_ +imdele_ +imdelf_ +imdmap_ +imerr_ +imflpl_ +imflps_ +imflsd_ +imflsh_ +imflsi_ +imflsl_ +imflsr_ +imflss_ +imflsx_ +imfluh_ +imfnpy_ +imfnss_ +imgclr_ +imgetb_ +imgetc_ +imgetd_ +imgeti_ +imgetl_ +imgetr_ +imgets_ +imgfte_ +imggsc_ +imggsd_ +imggsi_ +imggsl_ +imggsr_ +imggss_ +imggsx_ +imgibf_ +imgime_ +imgl1d_ +imgl1i_ +imgl1l_ +imgl1r_ +imgl1s_ +imgl1x_ +imgl2d_ +imgl2i_ +imgl2l_ +imgl2r_ +imgl2s_ +imgl2x_ +imgl3d_ +imgl3i_ +imgl3l_ +imgl3r_ +imgl3s_ +imgl3x_ +imgnfn_ +imgnld_ +imgnli_ +imgnll_ +imgnln_ +imgnlr_ +imgnls_ +imgnlx_ +imgobf_ +imgs1d_ +imgs1i_ +imgs1l_ +imgs1r_ +imgs1s_ +imgs1x_ +imgs2d_ +imgs2i_ +imgs2l_ +imgs2r_ +imgs2s_ +imgs2x_ +imgs3d_ +imgs3i_ +imgs3l_ +imgs3r_ +imgs3s_ +imgs3x_ +imgsen_ +imgstr_ +iminie_ +imioff_ +imisec_ +imloop_ +immaky_ +immap_ +immapz_ +imnote_ +imofnl_ +imofns_ +imofnu_ +imopsf_ +impakd_ +impaki_ +impakl_ +impakr_ +impaks_ +impakx_ +impare_ +impgsd_ +impgsi_ +impgsl_ +impgsr_ +impgss_ +impgsx_ +impl1d_ +impl1i_ +impl1l_ +impl1r_ +impl1s_ +impl1x_ +impl2d_ +impl2i_ +impl2l_ +impl2r_ +impl2s_ +impl2x_ +impl3d_ +impl3i_ +impl3l_ +impl3r_ +impl3s_ +impl3x_ +impml1_ +impml2_ +impml3_ +impmlr_ +impmlv_ +impmmo_ +impmmp_ +impmon_ +impms1_ +impms2_ +impms3_ +impmsr_ +impmsv_ +impnld_ +impnli_ +impnll_ +impnln_ +impnlr_ +impnls_ +impnlx_ +imps1d_ +imps1i_ +imps1l_ +imps1r_ +imps1s_ +imps1x_ +imps2d_ +imps2i_ +imps2l_ +imps2r_ +imps2s_ +imps2x_ +imps3d_ +imps3i_ +imps3l_ +imps3r_ +imps3s_ +imps3x_ +impstr_ +imputb_ +imputd_ +imputh_ +imputi_ +imputl_ +imputr_ +imputs_ +imrbpx_ +imrdpx_ +imrene_ +imrmbs_ +imsamp_ +imsetf_ +imseti_ +imsetr_ +imsinb_ +imsmpl_ +imsmps_ +imsslv_ +imstai_ +imstar_ +imstas_ +imtcle_ +imtgem_ +imtlen_ +imtmae_ +imtopn_ +imtopp_ +imtrew_ +imtrgm_ +imunmp_ +imupkd_ +imupki_ +imupkl_ +imupkr_ +imupks_ +imupkx_ +imwbpx_ +imwrie_ +imwrpx_ +intrde_ +intree_ +intrrt_ +irafmn_ +itob_ +itoc_ +iwcare_ +iwcfis_ +iwents_ +iwfind_ +iwgbis_ +iwputr_ +iwputy_ +iwrfis_ +iwsetp_ +kardbf_ +kardgd_ +kardlp_ +kardpl_ +kardpr_ +kardsf_ +kawrbf_ +kawrgd_ +kawrlp_ +kawrpl_ +kawrpr_ +kawrsf_ +kawtbf_ +kawtgd_ +kawtlp_ +kawtpl_ +kawtpr_ +kawtsf_ +kbzard_ +kbzawr_ +kbzawt_ +kbzcls_ +kbzopn_ +kbzstt_ +kclcpr_ +kcldir_ +kcldpr_ +kclsbf_ +kclsgd_ +kclslp_ +kclspl_ +kclssf_ +kclstx_ +kclsty_ +kdvall_ +kdvown_ +kfacss_ +kfaloc_ +kfchdr_ +kfdele_ +kfgcwd_ +kfinfo_ +kflstx_ +kflsty_ +kfmkcp_ +kfmkdr_ +kfpath_ +kfprot_ +kfrnam_ +kfsubd_ +kfxdir_ +kgettx_ +kgetty_ +kgfdir_ +kicont_ +kidece_ +kience_ +kienvt_ +kierrr_ +kiexte_ +kifine_ +kiflux_ +kifman_ +kifren_ +kigetn_ +kigets_ +kignoe_ +kiinit_ +kiloce_ +kimape_ +kimapn_ +kintpr_ +kiopes_ +kirece_ +kisend_ +kisenv_ +kishot_ +kixnoe_ +kmallc_ +knottx_ +knotty_ +kopcpr_ +kopdir_ +kopdpr_ +kopnbf_ +kopngd_ +kopnlp_ +kopnpl_ +kopnsf_ +kopntx_ +kopnty_ +koscmd_ +kputtx_ +kputty_ +krealc_ +ksared_ +ksawat_ +ksawre_ +ksektx_ +ksekty_ +ksttbf_ +ksttgd_ +ksttlp_ +ksttpl_ +ksttpr_ +ksttsf_ +kstttx_ +ksttty_ +ktzcls_ +ktzfls_ +ktzget_ +ktznot_ +ktzopn_ +ktzput_ +ktzsek_ +ktzstt_ +kzclmt_ +kzopmt_ +kzrdmt_ +kzrwmt_ +kzstmt_ +kzwrmt_ +kzwtmt_ +lexnum_ +lnocle_ +lnofeh_ +lnoopn_ +lnosae_ +locpr_ +locva_ +lpopen_ +lpzard_ +lpzawe_ +lpzawt_ +lsttot_ +ltoc_ +m75put_ +maideh_ +mallo1_ +mgdptr_ +mgtfwa_ +miilen_ +miinem_ +miipa2_ +miipa6_ +miipa8_ +miipad_ +miipak_ +miipar_ +miipke_ +miirec_ +miired_ +miirei_ +miirel_ +miirer_ +miires_ +miiup2_ +miiup6_ +miiup8_ +miiupd_ +miiupk_ +miiupr_ +miiwrc_ +miiwrd_ +miiwri_ +miiwrl_ +miiwrr_ +miiwrs_ +miocle_ +miogld_ +miogli_ +miogll_ +mioglr_ +miogls_ +mioglx_ +mioopn_ +mioopo_ +miopld_ +miopli_ +miopll_ +mioplr_ +miopls_ +mioplx_ +miosee_ +miosei_ +miosti_ +msvfwa_ +mtalle_ +mtcap_ +mtclen_ +mtclre_ +mtdeae_ +mtdevd_ +mtence_ +mtfile_ +mtfnae_ +mtgets_ +mtglok_ +mtgtyn_ +mtloce_ +mtneeo_ +mtopen_ +mtpare_ +mtposn_ +mtpute_ +mtreae_ +mtrewd_ +mtsavd_ +mtsavs_ +mtskid_ +mtstas_ +mtsync_ +mtupde_ +mwalld_ +mwalls_ +mwaxtn_ +mwc1td_ +mwc1tr_ +mwc2td_ +mwc2tr_ +mwcloe_ +mwcopd_ +mwcops_ +mwctfe_ +mwctrd_ +mwctrr_ +mwfins_ +mwflop_ +mwgaxp_ +mwgaxt_ +mwgctd_ +mwgctr_ +mwgltd_ +mwgltr_ +mwgsym_ +mwgwas_ +mwgwsd_ +mwgwsr_ +mwgwtd_ +mwgwtr_ +mwinvd_ +mwinvr_ +mwload_ +mwloam_ +mwltrd_ +mwltrr_ +mwlubb_ +mwlude_ +mwmkid_ +mwmkir_ +mwmmud_ +mwmmur_ +mwnewm_ +mwnewy_ +mwopem_ +mwopen_ +mwrefr_ +mwrote_ +mwsave_ +mwsavm_ +mwsaxp_ +mwscae_ +mwsctn_ +mwsdes_ +mwseti_ +mwshit_ +mwshow_ +mwsltd_ +mwsltr_ +mwssym_ +mwstai_ +mwswas_ +mwswsd_ +mwswsr_ +mwswtd_ +mwswte_ +mwswtr_ +mwtrad_ +mwtrar_ +mwv1td_ +mwv1tr_ +mwv2td_ +mwv2tr_ +mwvmud_ +mwvmur_ +mwvtrd_ +mwvtrr_ +ndopen_ +noti_ +notl_ +nots_ +nowhie_ +nscan_ +oifacs_ +oifcle_ +oifcoy_ +oifdee_ +oifgpe_ +oifmke_ +oifopn_ +oifopx_ +oifrdr_ +oifree_ +oiftrm_ +oifupr_ +oifwrr_ +onerre_ +onerrr_ +onexie_ +onexit_ +ord1_ +ord2_ +ori_ +orl_ +ors_ +oscmd_ +osfnik_ +osfnlk_ +osfnms_ +osfnpe_ +osfnrk_ +osfntt_ +osfnuk_ +pagefe_ +pagefs_ +pargb_ +pargc_ +pargd_ +pargg_ +pargi_ +pargl_ +pargr_ +pargs_ +pargsr_ +pargx_ +patamh_ +patfit_ +patgel_ +patgse_ +patinx_ +patloe_ +patmae_ +patmah_ +patomh_ +patsts_ +pggetd_ +pggete_ +pggetr_ +pgpage_ +pgpeed_ +pgpusd_ +pgsett_ +placcs_ +plallc_ +plascp_ +plbox_ +plcire_ +plcler_ +plcloe_ +plcome_ +plcoms_ +plcree_ +pldebg_ +pldebt_ +plempe_ +plempy_ +plfacs_ +plfcle_ +plfcoy_ +plfdee_ +plfnul_ +plfopn_ +plfree_ +plfupr_ +plgete_ +plglls_ +plglpi_ +plglpl_ +plglps_ +plglri_ +plglrl_ +plglrs_ +plgsie_ +pll2pi_ +pll2pl_ +pll2ps_ +pll2ri_ +pll2rl_ +pll2rs_ +pllcot_ +pllemy_ +plleql_ +plline_ +pllinl_ +pllinp_ +plliny_ +plllen_ +pllneg_ +plload_ +plloaf_ +plloam_ +plloop_ +pllprs_ +plnewy_ +plopen_ +plp2li_ +plp2ll_ +plp2ls_ +plp2ri_ +plp2rl_ +plp2rs_ +plpixi_ +plpixl_ +plpixs_ +plplls_ +plplpi_ +plplpl_ +plplps_ +plplri_ +plplrl_ +plplrs_ +plpoit_ +plpoln_ +plr2li_ +plr2ll_ +plr2ls_ +plr2pi_ +plr2pl_ +plr2ps_ +plrani_ +plranl_ +plrans_ +plrcle_ +plrefe_ +plregp_ +plreqi_ +plreql_ +plreqs_ +plrget_ +plrgex_ +plrop_ +plropn_ +plrpri_ +plrprl_ +plrprs_ +plrset_ +plsave_ +plsavf_ +plsavm_ +plsect_ +plsecy_ +plsete_ +plseti_ +plssie_ +plsslv_ +plstai_ +plstel_ +plubox_ +plucie_ +plupde_ +plupon_ +plvald_ +pmaccs_ +pmascp_ +pmbox_ +pmcire_ +pmcler_ +pmempy_ +pmglls_ +pmglpi_ +pmglpl_ +pmglps_ +pmglri_ +pmglrl_ +pmglrs_ +pmline_ +pmliny_ +pmnewk_ +pmplls_ +pmplpi_ +pmplpl_ +pmplps_ +pmplri_ +pmplrl_ +pmplrs_ +pmpoit_ +pmpoln_ +pmrcle_ +pmrgex_ +pmrop_ +pmropn_ +pmrset_ +pmsect_ +pmsecy_ +pmsete_ +pmseti_ +pmstai_ +pmstel_ +prchdr_ +prclcr_ +prcldr_ +prcloe_ +prdone_ +prdumn_ +prenve_ +prenvt_ +prfilf_ +prfinc_ +prgete_ +prgetr_ +prkill_ +pronic_ +propcr_ +propdr_ +propen_ +proscd_ +protet_ +prpsio_ +prpsld_ +prredr_ +prseti_ +prsigl_ +prstai_ +prupde_ +prvret_ +przclr_ +pscenr_ +pscens_ +pschwh_ +pscloe_ +psdept_ +psesct_ +psfone_ +psfonr_ +psfoor_ +psgett_ +pshear_ +psindt_ +psioit_ +psioxr_ +pslink_ +psnewe_ +psopen_ +psoutt_ +pspage_ +pspagk_ +psrigy_ +psrjps_ +pssets_ +pssett_ +pssety_ +psspft_ +pstese_ +pstexh_ +pstrar_ +pswrig_ +pswrtk_ +psxpos_ +psypos_ +putcc_ +putci_ +putlie_ +qmaccs_ +qmgetc_ +qmscan_ +qmscao_ +qmsetm_ +qmsetr_ +qmsets_ +qmspai_ +qmspar_ +qmsymb_ +qmupds_ +qpaccf_ +qpaccs_ +qpaddb_ +qpaddc_ +qpaddd_ +qpaddf_ +qpaddi_ +qpaddl_ +qpaddr_ +qpadds_ +qpaddx_ +qpargt_ +qpastr_ +qpbind_ +qpcfnl_ +qpcloe_ +qpclot_ +qpcopf_ +qpcopy_ +qpctod_ +qpctoi_ +qpdele_ +qpdelf_ +qpdsym_ +qpdtye_ +qpelee_ +qpexad_ +qpexai_ +qpexar_ +qpexcd_ +qpexce_ +qpexci_ +qpexcr_ +qpexdc_ +qpexde_ +qpexdg_ +qpexdr_ +qpexee_ +qpexfe_ +qpexge_ +qpexgr_ +qpexmk_ +qpexmr_ +qpexon_ +qpexpd_ +qpexpi_ +qpexpn_ +qpexpr_ +qpexps_ +qpexpt_ +qpexrd_ +qpexsd_ +qpexsi_ +qpexsr_ +qpfacs_ +qpfcle_ +qpfcos_ +qpfcoy_ +qpfdee_ +qpflur_ +qpfopn_ +qpfopx_ +qpfree_ +qpfupr_ +qpfwar_ +qpfwfr_ +qpfzcl_ +qpfzop_ +qpfzrd_ +qpfzst_ +qpfzwr_ +qpfzwt_ +qpgetb_ +qpgetc_ +qpgetd_ +qpgeti_ +qpgetk_ +qpgetl_ +qpgetm_ +qpgetr_ +qpgets_ +qpgetx_ +qpgmsm_ +qpgnfn_ +qpgpsm_ +qpgstr_ +qpinht_ +qpioce_ +qpioge_ +qpiogr_ +qpiogs_ +qpiolk_ +qpiols_ +qpiomx_ +qpioon_ +qpiope_ +qpiops_ +qpiori_ +qpiors_ +qpiort_ +qpiosc_ +qpiose_ +qpiosi_ +qpiosr_ +qpiost_ +qpiour_ +qpiovr_ +qpiowt_ +qplenf_ +qplenl_ +qplesd_ +qplesi_ +qplesr_ +qploas_ +qpmaxd_ +qpmaxi_ +qpmaxr_ +qpmind_ +qpmini_ +qpminr_ +qpmkfe_ +qpnexk_ +qpofnl_ +qpofns_ +qpofnu_ +qpopen_ +qpopet_ +qppare_ +qpparl_ +qppcle_ +qppopn_ +qppstr_ +qpputb_ +qpputc_ +qpputd_ +qpputi_ +qpputl_ +qpputm_ +qpputr_ +qpputs_ +qpputx_ +qpquef_ +qprawk_ +qpread_ +qprebd_ +qprene_ +qprenf_ +qprlmd_ +qprlmi_ +qprlmr_ +qpsavs_ +qpseel_ +qpseti_ +qpsetr_ +qpsizf_ +qpstai_ +qpstar_ +qpsync_ +qpungk_ +qpwrie_ +qpxgvd_ +qpxgvi_ +qpxgvl_ +qpxgvr_ +qpxgvs_ +r1mach_ +r2tr_ +r2tx_ +r4syn_ +r4tr_ +r4tx_ +r8syn_ +r8tr_ +r8tx_ +rdukey_ +reopen_ +resetn_ +salloc_ +scanc_ +sfree_ +shifti_ +shiftl_ +shifts_ +smark_ +sprinf_ +sscan_ +stallc_ +stcloe_ +stentr_ +stfacs_ +stfadr_ +stfcle_ +stfcos_ +stfcoy_ +stfcte_ +stfdee_ +stfgeb_ +stfgei_ +stfgen_ +stfges_ +stfget_ +stfind_ +stfinl_ +stfins_ +stfmeb_ +stfmke_ +stfnee_ +stfopn_ +stfopx_ +stforb_ +stfrdr_ +stfree_ +stfrek_ +stfrfr_ +stfrgb_ +stfrne_ +stfupr_ +stfwfr_ +stfwgb_ +sthash_ +sthead_ +stinfo_ +stkmkg_ +stmark_ +stname_ +stnext_ +stnsys_ +stopen_ +stpstr_ +strcle_ +strdic_ +strefb_ +streff_ +streq_ +strese_ +strge_ +strgee_ +strgt_ +strids_ +stridx_ +strlds_ +strldx_ +strle_ +strlt_ +strlwr_ +strmac_ +strmah_ +strncp_ +strne_ +stropn_ +strpak_ +strse1_ +strsee_ +strseh_ +strsrt_ +strtbl_ +strupk_ +strupr_ +stsave_ +stsize_ +stsque_ +sttyco_ +sttyet_ +sttygg_ +sttynm_ +sttyse_ +sttysm_ +sttytt_ +syserr_ +sysers_ +sysged_ +sysges_ +sysgsg_ +sysid_ +sysmte_ +syspac_ +syspat_ +syspte_ +sysret_ +syssct_ +tsleep_ +ttopen_ +ttseti_ +ttsets_ +ttstai_ +ttstas_ +ttybih_ +ttybre_ +ttycas_ +ttycds_ +ttycle_ +ttycln_ +ttyclr_ +ttyctl_ +ttydee_ +ttydey_ +ttyeny_ +ttyexs_ +ttyfey_ +ttyfiy_ +ttygds_ +ttygeb_ +ttygei_ +ttyger_ +ttyges_ +ttygoo_ +ttygpe_ +ttygse_ +ttyins_ +ttyint_ +ttylod_ +ttyods_ +ttyopn_ +ttypue_ +ttypus_ +ttyred_ +ttysce_ +ttysei_ +ttyso_ +ttysti_ +ttysui_ +ttywre_ +ungete_ +ungeti_ +unread_ +urand_ +vfnadd_ +vfncle_ +vfndee_ +vfndel_ +vfnene_ +vfnenr_ +vfnexr_ +vfngen_ +vfnise_ +vfnman_ +vfnmap_ +vfnmau_ +vfnopn_ +vfnsqe_ +vfntre_ +vfnunn_ +vfnunp_ +vlibinit_ +vmallc_ +vvfncm_ +vvfnee_ +vvfnip_ +vvfnis_ +vvfnre_ +wfaitd_ +wfaitt_ +wfaitv_ +wfarcd_ +wfarct_ +wfarcv_ +wfcard_ +wfcart_ +wfcarv_ +wfcscd_ +wfcsct_ +wfcscv_ +wfdecs_ +wffnld_ +wfglsd_ +wfglst_ +wfglsv_ +wfgsbb_ +wfgsbg_ +wfgsbl_ +wfgsce_ +wfgscf_ +wfgsdr_ +wfgsel_ +wfgson_ +wfgsre_ +wfinit_ +wfmerd_ +wfmert_ +wfmerv_ +wfmold_ +wfmolt_ +wfmolv_ +wfmspd_ +wfmspf_ +wfmspi_ +wfmspl_ +wfmspt_ +wfmspv_ +wfmspy_ +wfpard_ +wfpart_ +wfparv_ +wfpcod_ +wfpcot_ +wfpcov_ +wfqscd_ +wfqsct_ +wfqscv_ +wfsind_ +wfsint_ +wfsinv_ +wfsmph_ +wfsmpn_ +wfsmpt_ +wfstgd_ +wfstgt_ +wfstgv_ +wftand_ +wftant_ +wftanv_ +wftnxd_ +wftnxt_ +wftnxv_ +wftnxy_ +wftscd_ +wftsct_ +wftscv_ +wfzead_ +wfzeat_ +wfzeav_ +wfzpxd_ +wfzpxt_ +wfzpxv_ +wfzpxy_ +xalloe_ +xcallc_ +xdeale_ +xdevor_ +xdevss_ +xeract_ +xerfmg_ +xerpoi_ +xerpop_ +xerpsh_ +xerpsr_ +xerpuc_ +xerpue_ +xerret_ +xerror_ +xersel_ +xervey_ +xevadg_ +xevbip_ +xevbop_ +xevcan_ +xever1_ +xever2_ +xeverr_ +xevfrp_ +xevgek_ +xevinp_ +xevmap_ +xevnee_ +xevpae_ +xevpah_ +xevqut_ +xevstt_ +xevunp_ +xfaccs_ +xfatal_ +xfchdr_ +xfcloe_ +xfdele_ +xffluh_ +xfgetc_ +xfgetr_ +xfnote_ +xfopen_ +xfputc_ +xfputr_ +xfread_ +xfrnam_ +xfscan_ +xfseek_ +xfungc_ +xfwrie_ +xgdevt_ +xgtpid_ +xgtuid_ +xisaty_ +xmallc_ +xmfree_ +xmjbuf_ +xmktep_ +xonerr_ +xonext_ +xori_ +xorl_ +xors_ +xpages_ +xprinf_ +xqsort_ +xrealc_ +xsizef_ +xstdeh_ +xstrcp_ +xstrct_ +xstrcy_ +xstrln_ +xtoc_ +xttyse_ +xvvadg_ +xvvbip_ +xvvbop_ +xvvcan_ +xvvche_ +xvver1_ +xvver2_ +xvverr_ +xvvfrp_ +xvvgek_ +xvvinp_ +xvvlos_ +xvvmap_ +xvvnee_ +xvvnud_ +xvvnui_ +xvvnul_ +xvvnur_ +xvvnus_ +xvvpae_ +xvvpah_ +xvvqut_ +xvvstt_ +xvvunp_ +xwhen_ +xxscan_ +zardbf_ +zardgd_ +zardks_ +zardlp_ +zardmt_ +zardnd_ +zardnu_ +zardpl_ +zardpr_ +zardps_ +zardsf_ +zawrbf_ +zawrgd_ +zawrks_ +zawrlp_ +zawrmt_ +zawrnd_ +zawrnu_ +zawrpl_ +zawrpr_ +zawrps_ +zawrsf_ +zawset_ +zawtbf_ +zawtgd_ +zawtks_ +zawtlp_ +zawtmt_ +zawtnd_ +zawtnu_ +zawtpl_ +zawtpr_ +zawtps_ +zawtsf_ +zclcpr_ +zcldir_ +zcldpr_ +zclm70_ +zclm75_ +zclsbf_ +zclsgd_ +zclsks_ +zclslp_ +zclsmt_ +zclsnd_ +zclsnu_ +zclspl_ +zclsps_ +zclssf_ +zclstt_ +zclstx_ +zclsty_ +zdojmp_ +zdvall_ +zdvown_ +zfacss_ +zfaloc_ +zfchdr_ +zfdele_ +zfgcwd_ +zfinfo_ +zflsnu_ +zflstt_ +zflstx_ +zflsty_ +zfmkcp_ +zfmkdr_ +zfnbrk_ +zfpath_ +zfprot_ +zfrnam_ +zfsubd_ +zfxdir_ +zgcmdl_ +zgetnu_ +zgettt_ +zgettx_ +zgetty_ +zgfdir_ +zghost_ +zgmtco_ +zgtime_ +zgtpid_ +zintpr_ +zlocpr_ +zlocva_ +zmaloc_ +zmfree_ +znotnu_ +znottt_ +znottx_ +znotty_ +zopcpr_ +zopdir_ +zopdpr_ +zopm70_ +zopm75_ +zopnbf_ +zopngd_ +zopnks_ +zopnlp_ +zopnmt_ +zopnnd_ +zopnnu_ +zopnpl_ +zopnsf_ +zopntt_ +zopntx_ +zopnty_ +zoscmd_ +zpanic_ +zputnu_ +zputtt_ +zputtx_ +zputty_ +zraloc_ +zrdm70_ +zrdm75_ +zseknu_ +zsektt_ +zsektx_ +zsekty_ +zsestt_ +zsettt_ +zstm70_ +zstm75_ +zststt_ +zsttbf_ +zsttgd_ +zsttks_ +zsttlp_ +zsttmt_ +zsttnd_ +zsttnu_ +zsttpl_ +zsttpr_ +zsttps_ +zsttsf_ +zstttt_ +zstttx_ +zsttty_ +zttgeg_ +zttger_ +zttloe_ +zttloo_ +zttlov_ +zttpbf_ +zttplk_ +zttpug_ +zttquy_ +zttttt_ +zttupe_ +zwmsec_ +zwrm70_ +zwrm75_ +zwtm70_ +zwtm75_ +zxgmes_ +zxwhen_ +zzclmt_ +zzopmt_ +zzrdii_ +zzrdmt_ +zzrwmt_ +zzsetk_ +zzstmt_ +zzwrii_ +zzwrmt_ +zzwtmt_ +zzzend_ +fxfnoe_ +futime_ +kfutim_ +zfutim_ +dtmday_ +dtmlte_ +xfpoll_ +pollce_ +pollcr_ +pollgs_ +pollon_ +pollpt_ +pollst_ +polltt_ +pollzo_ +zfpoll_ diff --git a/unix/shlib/S.s b/unix/shlib/S.s new file mode 100644 index 00000000..43158418 --- /dev/null +++ b/unix/shlib/S.s @@ -0,0 +1,2890 @@ + .seg "data" + .global sh_debug +sh_debug: + .long 0 + .seg "text" + .global ushlib_ +ushlib_: + .long 12 + .long 0x10000000 + .long 0x10026000 + .long 0x10031320 + .long 0 + .long 2864 + .long 5 + .long 8 + .seg "text" + .common mem_,8 + mem_ = 0 + .common fiocom_,0x24660 + fiocom_ = ( 0x10000078 ) + .common xercom_,0x810 + xercom_ = ( 0x100246d8 ) + .global vshlib_ + vshlib_ = ( 0x10026000 ) + .global aabsd_; aabsd_ = 0x10026020 + .global aabsi_; aabsi_ = 0x10026030 + .global aabsl_; aabsl_ = 0x10026040 + .global aabsr_; aabsr_ = 0x10026050 + .global aabss_; aabss_ = 0x10026060 + .global aabsx_; aabsx_ = 0x10026070 + .global aaddd_; aaddd_ = 0x10026080 + .global aaddi_; aaddi_ = 0x10026090 + .global aaddkd_; aaddkd_ = 0x100260a0 + .global aaddki_; aaddki_ = 0x100260b0 + .global aaddkl_; aaddkl_ = 0x100260c0 + .global aaddkr_; aaddkr_ = 0x100260d0 + .global aaddks_; aaddks_ = 0x100260e0 + .global aaddkx_; aaddkx_ = 0x100260f0 + .global aaddl_; aaddl_ = 0x10026100 + .global aaddr_; aaddr_ = 0x10026110 + .global aadds_; aadds_ = 0x10026120 + .global aaddx_; aaddx_ = 0x10026130 + .global aandi_; aandi_ = 0x10026140 + .global aandki_; aandki_ = 0x10026150 + .global aandkl_; aandkl_ = 0x10026160 + .global aandks_; aandks_ = 0x10026170 + .global aandl_; aandl_ = 0x10026180 + .global aands_; aands_ = 0x10026190 + .global aavgd_; aavgd_ = 0x100261a0 + .global aavgi_; aavgi_ = 0x100261b0 + .global aavgl_; aavgl_ = 0x100261c0 + .global aavgr_; aavgr_ = 0x100261d0 + .global aavgs_; aavgs_ = 0x100261e0 + .global aavgx_; aavgx_ = 0x100261f0 + .global abavd_; abavd_ = 0x10026200 + .global abavi_; abavi_ = 0x10026210 + .global abavl_; abavl_ = 0x10026220 + .global abavr_; abavr_ = 0x10026230 + .global abavs_; abavs_ = 0x10026240 + .global abavx_; abavx_ = 0x10026250 + .global abeqc_; abeqc_ = 0x10026260 + .global abeqd_; abeqd_ = 0x10026270 + .global abeqi_; abeqi_ = 0x10026280 + .global abeqkc_; abeqkc_ = 0x10026290 + .global abeqkd_; abeqkd_ = 0x100262a0 + .global abeqki_; abeqki_ = 0x100262b0 + .global abeqkl_; abeqkl_ = 0x100262c0 + .global abeqkr_; abeqkr_ = 0x100262d0 + .global abeqks_; abeqks_ = 0x100262e0 + .global abeqkx_; abeqkx_ = 0x100262f0 + .global abeql_; abeql_ = 0x10026300 + .global abeqr_; abeqr_ = 0x10026310 + .global abeqs_; abeqs_ = 0x10026320 + .global abeqx_; abeqx_ = 0x10026330 + .global abgec_; abgec_ = 0x10026340 + .global abged_; abged_ = 0x10026350 + .global abgei_; abgei_ = 0x10026360 + .global abgekc_; abgekc_ = 0x10026370 + .global abgekd_; abgekd_ = 0x10026380 + .global abgeki_; abgeki_ = 0x10026390 + .global abgekl_; abgekl_ = 0x100263a0 + .global abgekr_; abgekr_ = 0x100263b0 + .global abgeks_; abgeks_ = 0x100263c0 + .global abgekx_; abgekx_ = 0x100263d0 + .global abgel_; abgel_ = 0x100263e0 + .global abger_; abger_ = 0x100263f0 + .global abges_; abges_ = 0x10026400 + .global abgex_; abgex_ = 0x10026410 + .global abgtc_; abgtc_ = 0x10026420 + .global abgtd_; abgtd_ = 0x10026430 + .global abgti_; abgti_ = 0x10026440 + .global abgtkc_; abgtkc_ = 0x10026450 + .global abgtkd_; abgtkd_ = 0x10026460 + .global abgtki_; abgtki_ = 0x10026470 + .global abgtkl_; abgtkl_ = 0x10026480 + .global abgtkr_; abgtkr_ = 0x10026490 + .global abgtks_; abgtks_ = 0x100264a0 + .global abgtkx_; abgtkx_ = 0x100264b0 + .global abgtl_; abgtl_ = 0x100264c0 + .global abgtr_; abgtr_ = 0x100264d0 + .global abgts_; abgts_ = 0x100264e0 + .global abgtx_; abgtx_ = 0x100264f0 + .global ablec_; ablec_ = 0x10026500 + .global abled_; abled_ = 0x10026510 + .global ablei_; ablei_ = 0x10026520 + .global ablekc_; ablekc_ = 0x10026530 + .global ablekd_; ablekd_ = 0x10026540 + .global ableki_; ableki_ = 0x10026550 + .global ablekl_; ablekl_ = 0x10026560 + .global ablekr_; ablekr_ = 0x10026570 + .global ableks_; ableks_ = 0x10026580 + .global ablekx_; ablekx_ = 0x10026590 + .global ablel_; ablel_ = 0x100265a0 + .global abler_; abler_ = 0x100265b0 + .global ables_; ables_ = 0x100265c0 + .global ablex_; ablex_ = 0x100265d0 + .global abltc_; abltc_ = 0x100265e0 + .global abltd_; abltd_ = 0x100265f0 + .global ablti_; ablti_ = 0x10026600 + .global abltkc_; abltkc_ = 0x10026610 + .global abltkd_; abltkd_ = 0x10026620 + .global abltki_; abltki_ = 0x10026630 + .global abltkl_; abltkl_ = 0x10026640 + .global abltkr_; abltkr_ = 0x10026650 + .global abltks_; abltks_ = 0x10026660 + .global abltkx_; abltkx_ = 0x10026670 + .global abltl_; abltl_ = 0x10026680 + .global abltr_; abltr_ = 0x10026690 + .global ablts_; ablts_ = 0x100266a0 + .global abltx_; abltx_ = 0x100266b0 + .global abnec_; abnec_ = 0x100266c0 + .global abned_; abned_ = 0x100266d0 + .global abnei_; abnei_ = 0x100266e0 + .global abnekc_; abnekc_ = 0x100266f0 + .global abnekd_; abnekd_ = 0x10026700 + .global abneki_; abneki_ = 0x10026710 + .global abnekl_; abnekl_ = 0x10026720 + .global abnekr_; abnekr_ = 0x10026730 + .global abneks_; abneks_ = 0x10026740 + .global abnekx_; abnekx_ = 0x10026750 + .global abnel_; abnel_ = 0x10026760 + .global abner_; abner_ = 0x10026770 + .global abnes_; abnes_ = 0x10026780 + .global abnex_; abnex_ = 0x10026790 + .global abori_; abori_ = 0x100267a0 + .global aborki_; aborki_ = 0x100267b0 + .global aborkl_; aborkl_ = 0x100267c0 + .global aborks_; aborks_ = 0x100267d0 + .global aborl_; aborl_ = 0x100267e0 + .global abors_; abors_ = 0x100267f0 + .global absud_; absud_ = 0x10026800 + .global absui_; absui_ = 0x10026810 + .global absul_; absul_ = 0x10026820 + .global absur_; absur_ = 0x10026830 + .global absus_; absus_ = 0x10026840 + .global acht_; acht_ = 0x10026850 + .global achtb_; achtb_ = 0x10026860 + .global achtbb_; achtbb_ = 0x10026870 + .global achtbc_; achtbc_ = 0x10026880 + .global achtbd_; achtbd_ = 0x10026890 + .global achtbi_; achtbi_ = 0x100268a0 + .global achtbl_; achtbl_ = 0x100268b0 + .global achtbr_; achtbr_ = 0x100268c0 + .global achtbs_; achtbs_ = 0x100268d0 + .global achtbu_; achtbu_ = 0x100268e0 + .global achtbx_; achtbx_ = 0x100268f0 + .global achtc_; achtc_ = 0x10026900 + .global achtcb_; achtcb_ = 0x10026910 + .global achtcc_; achtcc_ = 0x10026920 + .global achtcd_; achtcd_ = 0x10026930 + .global achtci_; achtci_ = 0x10026940 + .global achtcl_; achtcl_ = 0x10026950 + .global achtcr_; achtcr_ = 0x10026960 + .global achtcs_; achtcs_ = 0x10026970 + .global achtcu_; achtcu_ = 0x10026980 + .global achtcx_; achtcx_ = 0x10026990 + .global achtd_; achtd_ = 0x100269a0 + .global achtdb_; achtdb_ = 0x100269b0 + .global achtdc_; achtdc_ = 0x100269c0 + .global achtdd_; achtdd_ = 0x100269d0 + .global achtdi_; achtdi_ = 0x100269e0 + .global achtdl_; achtdl_ = 0x100269f0 + .global achtdr_; achtdr_ = 0x10026a00 + .global achtds_; achtds_ = 0x10026a10 + .global achtdu_; achtdu_ = 0x10026a20 + .global achtdx_; achtdx_ = 0x10026a30 + .global achti_; achti_ = 0x10026a40 + .global achtib_; achtib_ = 0x10026a50 + .global achtic_; achtic_ = 0x10026a60 + .global achtid_; achtid_ = 0x10026a70 + .global achtii_; achtii_ = 0x10026a80 + .global achtil_; achtil_ = 0x10026a90 + .global achtir_; achtir_ = 0x10026aa0 + .global achtis_; achtis_ = 0x10026ab0 + .global achtiu_; achtiu_ = 0x10026ac0 + .global achtix_; achtix_ = 0x10026ad0 + .global achtl_; achtl_ = 0x10026ae0 + .global achtlb_; achtlb_ = 0x10026af0 + .global achtlc_; achtlc_ = 0x10026b00 + .global achtld_; achtld_ = 0x10026b10 + .global achtli_; achtli_ = 0x10026b20 + .global achtll_; achtll_ = 0x10026b30 + .global achtlr_; achtlr_ = 0x10026b40 + .global achtls_; achtls_ = 0x10026b50 + .global achtlu_; achtlu_ = 0x10026b60 + .global achtlx_; achtlx_ = 0x10026b70 + .global achtr_; achtr_ = 0x10026b80 + .global achtrb_; achtrb_ = 0x10026b90 + .global achtrc_; achtrc_ = 0x10026ba0 + .global achtrd_; achtrd_ = 0x10026bb0 + .global achtri_; achtri_ = 0x10026bc0 + .global achtrl_; achtrl_ = 0x10026bd0 + .global achtrr_; achtrr_ = 0x10026be0 + .global achtrs_; achtrs_ = 0x10026bf0 + .global achtru_; achtru_ = 0x10026c00 + .global achtrx_; achtrx_ = 0x10026c10 + .global achts_; achts_ = 0x10026c20 + .global achtsb_; achtsb_ = 0x10026c30 + .global achtsc_; achtsc_ = 0x10026c40 + .global achtsd_; achtsd_ = 0x10026c50 + .global achtsi_; achtsi_ = 0x10026c60 + .global achtsl_; achtsl_ = 0x10026c70 + .global achtsr_; achtsr_ = 0x10026c80 + .global achtss_; achtss_ = 0x10026c90 + .global achtsu_; achtsu_ = 0x10026ca0 + .global achtsx_; achtsx_ = 0x10026cb0 + .global achtu_; achtu_ = 0x10026cc0 + .global achtub_; achtub_ = 0x10026cd0 + .global achtuc_; achtuc_ = 0x10026ce0 + .global achtud_; achtud_ = 0x10026cf0 + .global achtui_; achtui_ = 0x10026d00 + .global achtul_; achtul_ = 0x10026d10 + .global achtur_; achtur_ = 0x10026d20 + .global achtus_; achtus_ = 0x10026d30 + .global achtuu_; achtuu_ = 0x10026d40 + .global achtux_; achtux_ = 0x10026d50 + .global achtx_; achtx_ = 0x10026d60 + .global achtxb_; achtxb_ = 0x10026d70 + .global achtxc_; achtxc_ = 0x10026d80 + .global achtxd_; achtxd_ = 0x10026d90 + .global achtxi_; achtxi_ = 0x10026da0 + .global achtxl_; achtxl_ = 0x10026db0 + .global achtxr_; achtxr_ = 0x10026dc0 + .global achtxs_; achtxs_ = 0x10026dd0 + .global achtxu_; achtxu_ = 0x10026de0 + .global achtxx_; achtxx_ = 0x10026df0 + .global acjgx_; acjgx_ = 0x10026e00 + .global aclrb_; aclrb_ = 0x10026e10 + .global aclrc_; aclrc_ = 0x10026e20 + .global aclrd_; aclrd_ = 0x10026e30 + .global aclri_; aclri_ = 0x10026e40 + .global aclrl_; aclrl_ = 0x10026e50 + .global aclrr_; aclrr_ = 0x10026e60 + .global aclrs_; aclrs_ = 0x10026e70 + .global aclrx_; aclrx_ = 0x10026e80 + .global acnvd_; acnvd_ = 0x10026e90 + .global acnvi_; acnvi_ = 0x10026ea0 + .global acnvl_; acnvl_ = 0x10026eb0 + .global acnvr_; acnvr_ = 0x10026ec0 + .global acnvrd_; acnvrd_ = 0x10026ed0 + .global acnvri_; acnvri_ = 0x10026ee0 + .global acnvrl_; acnvrl_ = 0x10026ef0 + .global acnvrr_; acnvrr_ = 0x10026f00 + .global acnvrs_; acnvrs_ = 0x10026f10 + .global acnvs_; acnvs_ = 0x10026f20 + .global adivd_; adivd_ = 0x10026f30 + .global adivi_; adivi_ = 0x10026f40 + .global adivkd_; adivkd_ = 0x10026f50 + .global adivki_; adivki_ = 0x10026f60 + .global adivkl_; adivkl_ = 0x10026f70 + .global adivkr_; adivkr_ = 0x10026f80 + .global adivks_; adivks_ = 0x10026f90 + .global adivkx_; adivkx_ = 0x10026fa0 + .global adivl_; adivl_ = 0x10026fb0 + .global adivr_; adivr_ = 0x10026fc0 + .global adivs_; adivs_ = 0x10026fd0 + .global adivx_; adivx_ = 0x10026fe0 + .global adotd_; adotd_ = 0x10026ff0 + .global adoti_; adoti_ = 0x10027000 + .global adotl_; adotl_ = 0x10027010 + .global adotr_; adotr_ = 0x10027020 + .global adots_; adots_ = 0x10027030 + .global adotx_; adotx_ = 0x10027040 + .global advzd_; advzd_ = 0x10027050 + .global advzi_; advzi_ = 0x10027060 + .global advzl_; advzl_ = 0x10027070 + .global advzr_; advzr_ = 0x10027080 + .global advzs_; advzs_ = 0x10027090 + .global advzx_; advzx_ = 0x100270a0 + .global aelogd_; aelogd_ = 0x100270b0 + .global aelogr_; aelogr_ = 0x100270c0 + .global aexpd_; aexpd_ = 0x100270d0 + .global aexpi_; aexpi_ = 0x100270e0 + .global aexpkd_; aexpkd_ = 0x100270f0 + .global aexpki_; aexpki_ = 0x10027100 + .global aexpkl_; aexpkl_ = 0x10027110 + .global aexpkr_; aexpkr_ = 0x10027120 + .global aexpks_; aexpks_ = 0x10027130 + .global aexpkx_; aexpkx_ = 0x10027140 + .global aexpl_; aexpl_ = 0x10027150 + .global aexpr_; aexpr_ = 0x10027160 + .global aexps_; aexps_ = 0x10027170 + .global aexpx_; aexpx_ = 0x10027180 + .global afftrr_; afftrr_ = 0x10027190 + .global afftrx_; afftrx_ = 0x100271a0 + .global afftxr_; afftxr_ = 0x100271b0 + .global afftxx_; afftxx_ = 0x100271c0 + .global agltc_; agltc_ = 0x100271d0 + .global agltd_; agltd_ = 0x100271e0 + .global aglti_; aglti_ = 0x100271f0 + .global agltl_; agltl_ = 0x10027200 + .global agltr_; agltr_ = 0x10027210 + .global aglts_; aglts_ = 0x10027220 + .global agltx_; agltx_ = 0x10027230 + .global ahgmc_; ahgmc_ = 0x10027240 + .global ahgmd_; ahgmd_ = 0x10027250 + .global ahgmi_; ahgmi_ = 0x10027260 + .global ahgml_; ahgml_ = 0x10027270 + .global ahgmr_; ahgmr_ = 0x10027280 + .global ahgms_; ahgms_ = 0x10027290 + .global ahivc_; ahivc_ = 0x100272a0 + .global ahivd_; ahivd_ = 0x100272b0 + .global ahivi_; ahivi_ = 0x100272c0 + .global ahivl_; ahivl_ = 0x100272d0 + .global ahivr_; ahivr_ = 0x100272e0 + .global ahivs_; ahivs_ = 0x100272f0 + .global ahivx_; ahivx_ = 0x10027300 + .global aiftrr_; aiftrr_ = 0x10027310 + .global aiftrx_; aiftrx_ = 0x10027320 + .global aiftxr_; aiftxr_ = 0x10027330 + .global aiftxx_; aiftxx_ = 0x10027340 + .global aimgd_; aimgd_ = 0x10027350 + .global aimgi_; aimgi_ = 0x10027360 + .global aimgl_; aimgl_ = 0x10027370 + .global aimgr_; aimgr_ = 0x10027380 + .global aimgs_; aimgs_ = 0x10027390 + .global alani_; alani_ = 0x100273a0 + .global alanki_; alanki_ = 0x100273b0 + .global alankl_; alankl_ = 0x100273c0 + .global alanks_; alanks_ = 0x100273d0 + .global alanl_; alanl_ = 0x100273e0 + .global alans_; alans_ = 0x100273f0 + .global alimc_; alimc_ = 0x10027400 + .global alimd_; alimd_ = 0x10027410 + .global alimi_; alimi_ = 0x10027420 + .global aliml_; aliml_ = 0x10027430 + .global alimr_; alimr_ = 0x10027440 + .global alims_; alims_ = 0x10027450 + .global alimx_; alimx_ = 0x10027460 + .global allnd_; allnd_ = 0x10027470 + .global allni_; allni_ = 0x10027480 + .global allnl_; allnl_ = 0x10027490 + .global allnr_; allnr_ = 0x100274a0 + .global allns_; allns_ = 0x100274b0 + .global allnx_; allnx_ = 0x100274c0 + .global alogd_; alogd_ = 0x100274d0 + .global alogi_; alogi_ = 0x100274e0 + .global alogl_; alogl_ = 0x100274f0 + .global alogr_; alogr_ = 0x10027500 + .global alogs_; alogs_ = 0x10027510 + .global alogx_; alogx_ = 0x10027520 + .global alori_; alori_ = 0x10027530 + .global alorki_; alorki_ = 0x10027540 + .global alorkl_; alorkl_ = 0x10027550 + .global alorks_; alorks_ = 0x10027560 + .global alorl_; alorl_ = 0x10027570 + .global alors_; alors_ = 0x10027580 + .global alovc_; alovc_ = 0x10027590 + .global alovd_; alovd_ = 0x100275a0 + .global alovi_; alovi_ = 0x100275b0 + .global alovl_; alovl_ = 0x100275c0 + .global alovr_; alovr_ = 0x100275d0 + .global alovs_; alovs_ = 0x100275e0 + .global alovx_; alovx_ = 0x100275f0 + .global altad_; altad_ = 0x10027600 + .global altai_; altai_ = 0x10027610 + .global altal_; altal_ = 0x10027620 + .global altar_; altar_ = 0x10027630 + .global altas_; altas_ = 0x10027640 + .global altax_; altax_ = 0x10027650 + .global altmd_; altmd_ = 0x10027660 + .global altmi_; altmi_ = 0x10027670 + .global altml_; altml_ = 0x10027680 + .global altmr_; altmr_ = 0x10027690 + .global altms_; altms_ = 0x100276a0 + .global altmx_; altmx_ = 0x100276b0 + .global altrd_; altrd_ = 0x100276c0 + .global altri_; altri_ = 0x100276d0 + .global altrl_; altrl_ = 0x100276e0 + .global altrr_; altrr_ = 0x100276f0 + .global altrs_; altrs_ = 0x10027700 + .global altrx_; altrx_ = 0x10027710 + .global aluid_; aluid_ = 0x10027720 + .global aluii_; aluii_ = 0x10027730 + .global aluil_; aluil_ = 0x10027740 + .global aluir_; aluir_ = 0x10027750 + .global aluis_; aluis_ = 0x10027760 + .global alutc_; alutc_ = 0x10027770 + .global alutd_; alutd_ = 0x10027780 + .global aluti_; aluti_ = 0x10027790 + .global alutl_; alutl_ = 0x100277a0 + .global alutr_; alutr_ = 0x100277b0 + .global aluts_; aluts_ = 0x100277c0 + .global amagd_; amagd_ = 0x100277d0 + .global amagi_; amagi_ = 0x100277e0 + .global amagl_; amagl_ = 0x100277f0 + .global amagr_; amagr_ = 0x10027800 + .global amags_; amags_ = 0x10027810 + .global amagx_; amagx_ = 0x10027820 + .global amapd_; amapd_ = 0x10027830 + .global amapi_; amapi_ = 0x10027840 + .global amapl_; amapl_ = 0x10027850 + .global amapr_; amapr_ = 0x10027860 + .global amaps_; amaps_ = 0x10027870 + .global amaxc_; amaxc_ = 0x10027880 + .global amaxd_; amaxd_ = 0x10027890 + .global amaxi_; amaxi_ = 0x100278a0 + .global amaxkc_; amaxkc_ = 0x100278b0 + .global amaxkd_; amaxkd_ = 0x100278c0 + .global amaxki_; amaxki_ = 0x100278d0 + .global amaxkl_; amaxkl_ = 0x100278e0 + .global amaxkr_; amaxkr_ = 0x100278f0 + .global amaxks_; amaxks_ = 0x10027900 + .global amaxkx_; amaxkx_ = 0x10027910 + .global amaxl_; amaxl_ = 0x10027920 + .global amaxr_; amaxr_ = 0x10027930 + .global amaxs_; amaxs_ = 0x10027940 + .global amaxx_; amaxx_ = 0x10027950 + .global amed3c_; amed3c_ = 0x10027960 + .global amed3d_; amed3d_ = 0x10027970 + .global amed3i_; amed3i_ = 0x10027980 + .global amed3l_; amed3l_ = 0x10027990 + .global amed3r_; amed3r_ = 0x100279a0 + .global amed3s_; amed3s_ = 0x100279b0 + .global amed4c_; amed4c_ = 0x100279c0 + .global amed4d_; amed4d_ = 0x100279d0 + .global amed4i_; amed4i_ = 0x100279e0 + .global amed4l_; amed4l_ = 0x100279f0 + .global amed4r_; amed4r_ = 0x10027a00 + .global amed4s_; amed4s_ = 0x10027a10 + .global amed5c_; amed5c_ = 0x10027a20 + .global amed5d_; amed5d_ = 0x10027a30 + .global amed5i_; amed5i_ = 0x10027a40 + .global amed5l_; amed5l_ = 0x10027a50 + .global amed5r_; amed5r_ = 0x10027a60 + .global amed5s_; amed5s_ = 0x10027a70 + .global amedc_; amedc_ = 0x10027a80 + .global amedd_; amedd_ = 0x10027a90 + .global amedi_; amedi_ = 0x10027aa0 + .global amedl_; amedl_ = 0x10027ab0 + .global amedr_; amedr_ = 0x10027ac0 + .global ameds_; ameds_ = 0x10027ad0 + .global amedx_; amedx_ = 0x10027ae0 + .global amgsd_; amgsd_ = 0x10027af0 + .global amgsi_; amgsi_ = 0x10027b00 + .global amgsl_; amgsl_ = 0x10027b10 + .global amgsr_; amgsr_ = 0x10027b20 + .global amgss_; amgss_ = 0x10027b30 + .global amgsx_; amgsx_ = 0x10027b40 + .global aminc_; aminc_ = 0x10027b50 + .global amind_; amind_ = 0x10027b60 + .global amini_; amini_ = 0x10027b70 + .global aminkc_; aminkc_ = 0x10027b80 + .global aminkd_; aminkd_ = 0x10027b90 + .global aminki_; aminki_ = 0x10027ba0 + .global aminkl_; aminkl_ = 0x10027bb0 + .global aminkr_; aminkr_ = 0x10027bc0 + .global aminks_; aminks_ = 0x10027bd0 + .global aminkx_; aminkx_ = 0x10027be0 + .global aminl_; aminl_ = 0x10027bf0 + .global aminr_; aminr_ = 0x10027c00 + .global amins_; amins_ = 0x10027c10 + .global aminx_; aminx_ = 0x10027c20 + .global amodd_; amodd_ = 0x10027c30 + .global amodi_; amodi_ = 0x10027c40 + .global amodkd_; amodkd_ = 0x10027c50 + .global amodki_; amodki_ = 0x10027c60 + .global amodkl_; amodkl_ = 0x10027c70 + .global amodkr_; amodkr_ = 0x10027c80 + .global amodks_; amodks_ = 0x10027c90 + .global amodl_; amodl_ = 0x10027ca0 + .global amodr_; amodr_ = 0x10027cb0 + .global amods_; amods_ = 0x10027cc0 + .global amovc_; amovc_ = 0x10027cd0 + .global amovd_; amovd_ = 0x10027ce0 + .global amovi_; amovi_ = 0x10027cf0 + .global amovkc_; amovkc_ = 0x10027d00 + .global amovkd_; amovkd_ = 0x10027d10 + .global amovki_; amovki_ = 0x10027d20 + .global amovkl_; amovkl_ = 0x10027d30 + .global amovkr_; amovkr_ = 0x10027d40 + .global amovks_; amovks_ = 0x10027d50 + .global amovkx_; amovkx_ = 0x10027d60 + .global amovl_; amovl_ = 0x10027d70 + .global amovr_; amovr_ = 0x10027d80 + .global amovs_; amovs_ = 0x10027d90 + .global amovx_; amovx_ = 0x10027da0 + .global amuld_; amuld_ = 0x10027db0 + .global amuli_; amuli_ = 0x10027dc0 + .global amulkd_; amulkd_ = 0x10027dd0 + .global amulki_; amulki_ = 0x10027de0 + .global amulkl_; amulkl_ = 0x10027df0 + .global amulkr_; amulkr_ = 0x10027e00 + .global amulks_; amulks_ = 0x10027e10 + .global amulkx_; amulkx_ = 0x10027e20 + .global amull_; amull_ = 0x10027e30 + .global amulr_; amulr_ = 0x10027e40 + .global amuls_; amuls_ = 0x10027e50 + .global amulx_; amulx_ = 0x10027e60 + .global andi_; andi_ = 0x10027e70 + .global andl_; andl_ = 0x10027e80 + .global ands_; ands_ = 0x10027e90 + .global anegd_; anegd_ = 0x10027ea0 + .global anegi_; anegi_ = 0x10027eb0 + .global anegl_; anegl_ = 0x10027ec0 + .global anegr_; anegr_ = 0x10027ed0 + .global anegs_; anegs_ = 0x10027ee0 + .global anegx_; anegx_ = 0x10027ef0 + .global anoti_; anoti_ = 0x10027f00 + .global anotl_; anotl_ = 0x10027f10 + .global anots_; anots_ = 0x10027f20 + .global apkxd_; apkxd_ = 0x10027f30 + .global apkxi_; apkxi_ = 0x10027f40 + .global apkxl_; apkxl_ = 0x10027f50 + .global apkxr_; apkxr_ = 0x10027f60 + .global apkxs_; apkxs_ = 0x10027f70 + .global apkxx_; apkxx_ = 0x10027f80 + .global apold_; apold_ = 0x10027f90 + .global apolr_; apolr_ = 0x10027fa0 + .global apowd_; apowd_ = 0x10027fb0 + .global apowi_; apowi_ = 0x10027fc0 + .global apowkd_; apowkd_ = 0x10027fd0 + .global apowki_; apowki_ = 0x10027fe0 + .global apowkl_; apowkl_ = 0x10027ff0 + .global apowkr_; apowkr_ = 0x10028000 + .global apowks_; apowks_ = 0x10028010 + .global apowkx_; apowkx_ = 0x10028020 + .global apowl_; apowl_ = 0x10028030 + .global apowr_; apowr_ = 0x10028040 + .global apows_; apows_ = 0x10028050 + .global apowx_; apowx_ = 0x10028060 + .global aravd_; aravd_ = 0x10028070 + .global aravi_; aravi_ = 0x10028080 + .global aravl_; aravl_ = 0x10028090 + .global aravr_; aravr_ = 0x100280a0 + .global aravs_; aravs_ = 0x100280b0 + .global aravx_; aravx_ = 0x100280c0 + .global arcpd_; arcpd_ = 0x100280d0 + .global arcpi_; arcpi_ = 0x100280e0 + .global arcpl_; arcpl_ = 0x100280f0 + .global arcpr_; arcpr_ = 0x10028100 + .global arcps_; arcps_ = 0x10028110 + .global arcpx_; arcpx_ = 0x10028120 + .global arczd_; arczd_ = 0x10028130 + .global arczi_; arczi_ = 0x10028140 + .global arczl_; arczl_ = 0x10028150 + .global arczr_; arczr_ = 0x10028160 + .global arczs_; arczs_ = 0x10028170 + .global arczx_; arczx_ = 0x10028180 + .global aread_; aread_ = 0x10028190 + .global areadb_; areadb_ = 0x100281a0 + .global argtd_; argtd_ = 0x100281b0 + .global argti_; argti_ = 0x100281c0 + .global argtl_; argtl_ = 0x100281d0 + .global argtr_; argtr_ = 0x100281e0 + .global argts_; argts_ = 0x100281f0 + .global argtx_; argtx_ = 0x10028200 + .global arltd_; arltd_ = 0x10028210 + .global arlti_; arlti_ = 0x10028220 + .global arltl_; arltl_ = 0x10028230 + .global arltr_; arltr_ = 0x10028240 + .global arlts_; arlts_ = 0x10028250 + .global arltx_; arltx_ = 0x10028260 + .global aselc_; aselc_ = 0x10028270 + .global aseld_; aseld_ = 0x10028280 + .global aseli_; aseli_ = 0x10028290 + .global aselkc_; aselkc_ = 0x100282a0 + .global aselkd_; aselkd_ = 0x100282b0 + .global aselki_; aselki_ = 0x100282c0 + .global aselkl_; aselkl_ = 0x100282d0 + .global aselkr_; aselkr_ = 0x100282e0 + .global aselks_; aselks_ = 0x100282f0 + .global aselkx_; aselkx_ = 0x10028300 + .global asell_; asell_ = 0x10028310 + .global aselr_; aselr_ = 0x10028320 + .global asels_; asels_ = 0x10028330 + .global aselx_; aselx_ = 0x10028340 + .global asokc_; asokc_ = 0x10028350 + .global asokd_; asokd_ = 0x10028360 + .global asoki_; asoki_ = 0x10028370 + .global asokl_; asokl_ = 0x10028380 + .global asokr_; asokr_ = 0x10028390 + .global asoks_; asoks_ = 0x100283a0 + .global asokx_; asokx_ = 0x100283b0 + .global asqrd_; asqrd_ = 0x100283c0 + .global asqri_; asqri_ = 0x100283d0 + .global asqrl_; asqrl_ = 0x100283e0 + .global asqrr_; asqrr_ = 0x100283f0 + .global asqrs_; asqrs_ = 0x10028400 + .global asqrx_; asqrx_ = 0x10028410 + .global asrtc_; asrtc_ = 0x10028420 + .global asrtd_; asrtd_ = 0x10028430 + .global asrti_; asrti_ = 0x10028440 + .global asrtl_; asrtl_ = 0x10028450 + .global asrtr_; asrtr_ = 0x10028460 + .global asrts_; asrts_ = 0x10028470 + .global asrtx_; asrtx_ = 0x10028480 + .global assqd_; assqd_ = 0x10028490 + .global assqi_; assqi_ = 0x100284a0 + .global assql_; assql_ = 0x100284b0 + .global assqr_; assqr_ = 0x100284c0 + .global assqs_; assqs_ = 0x100284d0 + .global assqx_; assqx_ = 0x100284e0 + .global asubd_; asubd_ = 0x100284f0 + .global asubi_; asubi_ = 0x10028500 + .global asubkd_; asubkd_ = 0x10028510 + .global asubki_; asubki_ = 0x10028520 + .global asubkl_; asubkl_ = 0x10028530 + .global asubkr_; asubkr_ = 0x10028540 + .global asubks_; asubks_ = 0x10028550 + .global asubkx_; asubkx_ = 0x10028560 + .global asubl_; asubl_ = 0x10028570 + .global asubr_; asubr_ = 0x10028580 + .global asubs_; asubs_ = 0x10028590 + .global asubx_; asubx_ = 0x100285a0 + .global asumd_; asumd_ = 0x100285b0 + .global asumi_; asumi_ = 0x100285c0 + .global asuml_; asuml_ = 0x100285d0 + .global asumr_; asumr_ = 0x100285e0 + .global asums_; asums_ = 0x100285f0 + .global asumx_; asumx_ = 0x10028600 + .global aupxd_; aupxd_ = 0x10028610 + .global aupxi_; aupxi_ = 0x10028620 + .global aupxl_; aupxl_ = 0x10028630 + .global aupxr_; aupxr_ = 0x10028640 + .global aupxs_; aupxs_ = 0x10028650 + .global aupxx_; aupxx_ = 0x10028660 + .global aveqc_; aveqc_ = 0x10028670 + .global aveqd_; aveqd_ = 0x10028680 + .global aveqi_; aveqi_ = 0x10028690 + .global aveql_; aveql_ = 0x100286a0 + .global aveqr_; aveqr_ = 0x100286b0 + .global aveqs_; aveqs_ = 0x100286c0 + .global aveqx_; aveqx_ = 0x100286d0 + .global await_; await_ = 0x100286e0 + .global awaitb_; awaitb_ = 0x100286f0 + .global awritb_; awritb_ = 0x10028700 + .global awrite_; awrite_ = 0x10028710 + .global awsud_; awsud_ = 0x10028720 + .global awsui_; awsui_ = 0x10028730 + .global awsul_; awsul_ = 0x10028740 + .global awsur_; awsur_ = 0x10028750 + .global awsus_; awsus_ = 0x10028760 + .global awsux_; awsux_ = 0x10028770 + .global awvgd_; awvgd_ = 0x10028780 + .global awvgi_; awvgi_ = 0x10028790 + .global awvgl_; awvgl_ = 0x100287a0 + .global awvgr_; awvgr_ = 0x100287b0 + .global awvgs_; awvgs_ = 0x100287c0 + .global awvgx_; awvgx_ = 0x100287d0 + .global axori_; axori_ = 0x100287e0 + .global axorki_; axorki_ = 0x100287f0 + .global axorkl_; axorkl_ = 0x10028800 + .global axorks_; axorks_ = 0x10028810 + .global axorl_; axorl_ = 0x10028820 + .global axors_; axors_ = 0x10028830 + .global begmem_; begmem_ = 0x10028840 + .global bitmov_; bitmov_ = 0x10028850 + .global bitpak_; bitpak_ = 0x10028860 + .global bitupk_; bitupk_ = 0x10028870 + .global brktie_; brktie_ = 0x10028880 + .global bswap2_; bswap2_ = 0x10028890 + .global bswap4_; bswap4_ = 0x100288a0 + .global bswap8_; bswap8_ = 0x100288b0 + .global btoi_; btoi_ = 0x100288c0 + .global bytmov_; bytmov_ = 0x100288d0 + .global cctoc_; cctoc_ = 0x100288e0 + .global chdept_; chdept_ = 0x100288f0 + .global chfeth_; chfeth_ = 0x10028900 + .global chrlwr_; chrlwr_ = 0x10028910 + .global chrpak_; chrpak_ = 0x10028920 + .global chrupk_; chrupk_ = 0x10028930 + .global chrupr_; chrupr_ = 0x10028940 + .global clccos_; clccos_ = 0x10028950 + .global clcenr_; clcenr_ = 0x10028960 + .global clcfeh_; clcfeh_ = 0x10028970 + .global clcfid_; clcfid_ = 0x10028980 + .global clcfre_; clcfre_ = 0x10028990 + .global clcint_; clcint_ = 0x100289a0 + .global clclit_; clclit_ = 0x100289b0 + .global clcloe_; clcloe_ = 0x100289c0 + .global clcmak_; clcmak_ = 0x100289d0 + .global clcmd_; clcmd_ = 0x100289e0 + .global clcmdw_; clcmdw_ = 0x100289f0 + .global clcnek_; clcnek_ = 0x10028a00 + .global clcpst_; clcpst_ = 0x10028a10 + .global clcscn_; clcscn_ = 0x10028a20 + .global clepst_; clepst_ = 0x10028a30 + .global clgcur_; clgcur_ = 0x10028a40 + .global clgetb_; clgetb_ = 0x10028a50 + .global clgetc_; clgetc_ = 0x10028a60 + .global clgetd_; clgetd_ = 0x10028a70 + .global clgeti_; clgeti_ = 0x10028a80 + .global clgetl_; clgetl_ = 0x10028a90 + .global clgetr_; clgetr_ = 0x10028aa0 + .global clgets_; clgets_ = 0x10028ab0 + .global clgetx_; clgetx_ = 0x10028ac0 + .global clgfil_; clgfil_ = 0x10028ad0 + .global clgkey_; clgkey_ = 0x10028ae0 + .global clglpb_; clglpb_ = 0x10028af0 + .global clglpc_; clglpc_ = 0x10028b00 + .global clglpd_; clglpd_ = 0x10028b10 + .global clglpi_; clglpi_ = 0x10028b20 + .global clglpl_; clglpl_ = 0x10028b30 + .global clglpr_; clglpr_ = 0x10028b40 + .global clglps_; clglps_ = 0x10028b50 + .global clglpx_; clglpx_ = 0x10028b60 + .global clglsr_; clglsr_ = 0x10028b70 + .global clgpsa_; clgpsa_ = 0x10028b80 + .global clgpsb_; clgpsb_ = 0x10028b90 + .global clgpsc_; clgpsc_ = 0x10028ba0 + .global clgpsd_; clgpsd_ = 0x10028bb0 + .global clgpsi_; clgpsi_ = 0x10028bc0 + .global clgpsl_; clgpsl_ = 0x10028bd0 + .global clgpsr_; clgpsr_ = 0x10028be0 + .global clgpss_; clgpss_ = 0x10028bf0 + .global clgpst_; clgpst_ = 0x10028c00 + .global clgpsx_; clgpsx_ = 0x10028c10 + .global clgstr_; clgstr_ = 0x10028c20 + .global clgwrd_; clgwrd_ = 0x10028c30 + .global clktie_; clktie_ = 0x10028c40 + .global cllpst_; cllpst_ = 0x10028c50 + .global clopen_; clopen_ = 0x10028c60 + .global clopst_; clopst_ = 0x10028c70 + .global clpcls_; clpcls_ = 0x10028c80 + .global clplen_; clplen_ = 0x10028c90 + .global clpopi_; clpopi_ = 0x10028ca0 + .global clpops_; clpops_ = 0x10028cb0 + .global clpopu_; clpopu_ = 0x10028cc0 + .global clppsa_; clppsa_ = 0x10028cd0 + .global clppsb_; clppsb_ = 0x10028ce0 + .global clppsc_; clppsc_ = 0x10028cf0 + .global clppsd_; clppsd_ = 0x10028d00 + .global clppsi_; clppsi_ = 0x10028d10 + .global clppsl_; clppsl_ = 0x10028d20 + .global clppsr_; clppsr_ = 0x10028d30 + .global clppss_; clppss_ = 0x10028d40 + .global clppst_; clppst_ = 0x10028d50 + .global clppsx_; clppsx_ = 0x10028d60 + .global clprew_; clprew_ = 0x10028d70 + .global clprif_; clprif_ = 0x10028d80 + .global clpsee_; clpsee_ = 0x10028d90 + .global clpsit_; clpsit_ = 0x10028da0 + .global clpstr_; clpstr_ = 0x10028db0 + .global clputb_; clputb_ = 0x10028dc0 + .global clputc_; clputc_ = 0x10028dd0 + .global clputd_; clputd_ = 0x10028de0 + .global clputi_; clputi_ = 0x10028df0 + .global clputl_; clputl_ = 0x10028e00 + .global clputr_; clputr_ = 0x10028e10 + .global clputs_; clputs_ = 0x10028e20 + .global clputx_; clputx_ = 0x10028e30 + .global clreqr_; clreqr_ = 0x10028e40 + .global clscan_; clscan_ = 0x10028e50 + .global clseti_; clseti_ = 0x10028e60 + .global clstai_; clstai_ = 0x10028e70 + .global cnvdae_; cnvdae_ = 0x10028e80 + .global cnvtie_; cnvtie_ = 0x10028e90 + .global coerce_; coerce_ = 0x10028ea0 + .global cputie_; cputie_ = 0x10028eb0 + .global ctocc_; ctocc_ = 0x10028ec0 + .global ctod_; ctod_ = 0x10028ed0 + .global ctoi_; ctoi_ = 0x10028ee0 + .global ctol_; ctol_ = 0x10028ef0 + .global ctor_; ctor_ = 0x10028f00 + .global ctotok_; ctotok_ = 0x10028f10 + .global ctowrd_; ctowrd_ = 0x10028f20 + .global ctox_; ctox_ = 0x10028f30 + .global d1mach_; d1mach_ = 0x10028f40 + .global deletg_; deletg_ = 0x10028f50 + .global diropn_; diropn_ = 0x10028f60 + .global dtcscl_; dtcscl_ = 0x10028f70 + .global dtmdee_; dtmdee_ = 0x10028f80 + .global dtmdes_; dtmdes_ = 0x10028f90 + .global dtmene_; dtmene_ = 0x10028fa0 + .global dtmens_; dtmens_ = 0x10028fb0 + .global dtoc3_; dtoc3_ = 0x10028fc0 + .global dtoc_; dtoc_ = 0x10028fd0 + .global elogd_; elogd_ = 0x10028fe0 + .global elogr_; elogr_ = 0x10028ff0 + .global envfid_; envfid_ = 0x10029000 + .global envfit_; envfit_ = 0x10029010 + .global envfre_; envfre_ = 0x10029020 + .global envgeb_; envgeb_ = 0x10029030 + .global envged_; envged_ = 0x10029040 + .global envgei_; envgei_ = 0x10029050 + .global envger_; envger_ = 0x10029060 + .global envges_; envges_ = 0x10029070 + .global envinr_; envinr_ = 0x10029080 + .global envint_; envint_ = 0x10029090 + .global envlit_; envlit_ = 0x100290a0 + .global envmak_; envmak_ = 0x100290b0 + .global envnet_; envnet_ = 0x100290c0 + .global envpus_; envpus_ = 0x100290d0 + .global envret_; envret_ = 0x100290e0 + .global envscn_; envscn_ = 0x100290f0 + .global eprinf_; eprinf_ = 0x10029100 + .global erract_; erract_ = 0x10029110 + .global errcoe_; errcoe_ = 0x10029120 + .global errget_; errget_ = 0x10029130 + .global evexpr_; evexpr_ = 0x10029140 + .global evvexr_; evvexr_ = 0x10029150 + .global evvfre_; evvfre_ = 0x10029160 + .global f77pak_; f77pak_ = 0x10029170 + .global f77upk_; f77upk_ = 0x10029180 + .global falloc_; falloc_ = 0x10029190 + .global fcanpb_; fcanpb_ = 0x100291a0 + .global fcldir_; fcldir_ = 0x100291b0 + .global fclobr_; fclobr_ = 0x100291c0 + .global fcopy_; fcopy_ = 0x100291d0 + .global fcopyo_; fcopyo_ = 0x100291e0 + .global fdebug_; fdebug_ = 0x100291f0 + .global fdevbf_; fdevbf_ = 0x10029200 + .global fdevbk_; fdevbk_ = 0x10029210 + .global fdevtx_; fdevtx_ = 0x10029220 + .global fdirne_; fdirne_ = 0x10029230 + .global fexbuf_; fexbuf_ = 0x10029240 + .global ffa_; ffa_ = 0x10029250 + .global ffault_; ffault_ = 0x10029260 + .global ffilbf_; ffilbf_ = 0x10029270 + .global ffilsz_; ffilsz_ = 0x10029280 + .global ffldir_; ffldir_ = 0x10029290 + .global fflsbf_; fflsbf_ = 0x100292a0 + .global ffs_; ffs_ = 0x100292b0 + .global fft842_; fft842_ = 0x100292c0 + .global fgdev0_; fgdev0_ = 0x100292d0 + .global fgdevm_; fgdevm_ = 0x100292e0 + .global fgetfd_; fgetfd_ = 0x100292f0 + .global fgtdir_; fgtdir_ = 0x10029300 + .global filbuf_; filbuf_ = 0x10029310 + .global filerr_; filerr_ = 0x10029320 + .global filopn_; filopn_ = 0x10029330 + .global finfo_; finfo_ = 0x10029340 + .global finit_; finit_ = 0x10029350 + .global fioclp_; fioclp_ = 0x10029360 + .global fioqfh_; fioqfh_ = 0x10029370 + .global fixmem_; fixmem_ = 0x10029380 + .global flsbuf_; flsbuf_ = 0x10029390 + .global fmaccs_; fmaccs_ = 0x100293a0 + .global fmapfn_; fmapfn_ = 0x100293b0 + .global fmcloe_; fmcloe_ = 0x100293c0 + .global fmcopo_; fmcopo_ = 0x100293d0 + .global fmcopy_; fmcopy_ = 0x100293e0 + .global fmdebg_; fmdebg_ = 0x100293f0 + .global fmdele_; fmdele_ = 0x10029400 + .global fmfcdg_; fmfcdg_ = 0x10029410 + .global fmfcfe_; fmfcfe_ = 0x10029420 + .global fmfcit_; fmfcit_ = 0x10029430 + .global fmfcsc_; fmfcsc_ = 0x10029440 + .global fmfinf_; fmfinf_ = 0x10029450 + .global fmfopn_; fmfopn_ = 0x10029460 + .global fmgetd_; fmgetd_ = 0x10029470 + .global fmiobd_; fmiobd_ = 0x10029480 + .global fmioed_; fmioed_ = 0x10029490 + .global fmioek_; fmioek_ = 0x100294a0 + .global fmiopr_; fmiopr_ = 0x100294b0 + .global fmiorr_; fmiorr_ = 0x100294c0 + .global fmiosf_; fmiosf_ = 0x100294d0 + .global fmiotk_; fmiotk_ = 0x100294e0 + .global fmkbfs_; fmkbfs_ = 0x100294f0 + .global fmkcoy_; fmkcoy_ = 0x10029500 + .global fmkdir_; fmkdir_ = 0x10029510 + .global fmkpbf_; fmkpbf_ = 0x10029520 + .global fmlfad_; fmlfad_ = 0x10029530 + .global fmlfae_; fmlfae_ = 0x10029540 + .global fmlfat_; fmlfat_ = 0x10029550 + .global fmlfbd_; fmlfbd_ = 0x10029560 + .global fmlfbe_; fmlfbe_ = 0x10029570 + .global fmlfbt_; fmlfbt_ = 0x10029580 + .global fmlfce_; fmlfce_ = 0x10029590 + .global fmlfcy_; fmlfcy_ = 0x100295a0 + .global fmlfde_; fmlfde_ = 0x100295b0 + .global fmlfne_; fmlfne_ = 0x100295c0 + .global fmlfon_; fmlfon_ = 0x100295d0 + .global fmlfpe_; fmlfpe_ = 0x100295e0 + .global fmlfsi_; fmlfsi_ = 0x100295f0 + .global fmlfst_; fmlfst_ = 0x10029600 + .global fmlfue_; fmlfue_ = 0x10029610 + .global fmlocd_; fmlocd_ = 0x10029620 + .global fmloct_; fmloct_ = 0x10029630 + .global fmnexe_; fmnexe_ = 0x10029640 + .global fmopen_; fmopen_ = 0x10029650 + .global fmrebd_; fmrebd_ = 0x10029660 + .global fmrene_; fmrene_ = 0x10029670 + .global fmretd_; fmretd_ = 0x10029680 + .global fmseti_; fmseti_ = 0x10029690 + .global fmstai_; fmstai_ = 0x100296a0 + .global fmsync_; fmsync_ = 0x100296b0 + .global fmterr_; fmterr_ = 0x100296c0 + .global fmtint_; fmtint_ = 0x100296d0 + .global fmtred_; fmtred_ = 0x100296e0 + .global fmtsel_; fmtsel_ = 0x100296f0 + .global fmtstr_; fmtstr_ = 0x10029700 + .global fmunlk_; fmunlk_ = 0x10029710 + .global fnextn_; fnextn_ = 0x10029720 + .global fnldir_; fnldir_ = 0x10029730 + .global fnroot_; fnroot_ = 0x10029740 + .global fntclb_; fntclb_ = 0x10029750 + .global fntcls_; fntcls_ = 0x10029760 + .global fntdir_; fntdir_ = 0x10029770 + .global fntedt_; fntedt_ = 0x10029780 + .global fntget_; fntget_ = 0x10029790 + .global fntgfb_; fntgfb_ = 0x100297a0 + .global fntgfn_; fntgfn_ = 0x100297b0 + .global fntleb_; fntleb_ = 0x100297c0 + .global fntmkt_; fntmkt_ = 0x100297d0 + .global fntopb_; fntopb_ = 0x100297e0 + .global fntopn_; fntopn_ = 0x100297f0 + .global fntopt_; fntopt_ = 0x10029800 + .global fntreb_; fntreb_ = 0x10029810 + .global fntree_; fntree_ = 0x10029820 + .global fntrfb_; fntrfb_ = 0x10029830 + .global fnulle_; fnulle_ = 0x10029840 + .global fopdir_; fopdir_ = 0x10029850 + .global fopnbf_; fopnbf_ = 0x10029860 + .global fopntx_; fopntx_ = 0x10029870 + .global fowner_; fowner_ = 0x10029880 + .global fpathe_; fpathe_ = 0x10029890 + .global fpequd_; fpequd_ = 0x100298a0 + .global fpequr_; fpequr_ = 0x100298b0 + .global fpfixd_; fpfixd_ = 0x100298c0 + .global fpfixr_; fpfixr_ = 0x100298d0 + .global fpnonr_; fpnonr_ = 0x100298e0 + .global fpnord_; fpnord_ = 0x100298f0 + .global fpnorr_; fpnorr_ = 0x10029900 + .global fpradv_; fpradv_ = 0x10029910 + .global fprfmt_; fprfmt_ = 0x10029920 + .global fprinf_; fprinf_ = 0x10029930 + .global fprntf_; fprntf_ = 0x10029940 + .global fptdir_; fptdir_ = 0x10029950 + .global fputtx_; fputtx_ = 0x10029960 + .global freadp_; freadp_ = 0x10029970 + .global fredio_; fredio_ = 0x10029980 + .global fredir_; fredir_ = 0x10029990 + .global frenae_; frenae_ = 0x100299a0 + .global frmbfs_; frmbfs_ = 0x100299b0 + .global frmtmp_; frmtmp_ = 0x100299c0 + .global frtnfd_; frtnfd_ = 0x100299d0 + .global fsetev_; fsetev_ = 0x100299e0 + .global fsetfd_; fsetfd_ = 0x100299f0 + .global fseti_; fseti_ = 0x10029a00 + .global fsfdee_; fsfdee_ = 0x10029a10 + .global fsfgee_; fsfgee_ = 0x10029a20 + .global fsfopn_; fsfopn_ = 0x10029a30 + .global fskdir_; fskdir_ = 0x10029a40 + .global fstati_; fstati_ = 0x10029a50 + .global fstatl_; fstatl_ = 0x10029a60 + .global fstats_; fstats_ = 0x10029a70 + .global fstdfe_; fstdfe_ = 0x10029a80 + .global fstdir_; fstdir_ = 0x10029a90 + .global fstrfp_; fstrfp_ = 0x10029aa0 + .global fsvtfn_; fsvtfn_ = 0x10029ab0 + .global fswapd_; fswapd_ = 0x10029ac0 + .global fwatio_; fwatio_ = 0x10029ad0 + .global fwritp_; fwritp_ = 0x10029ae0 + .global fwtacc_; fwtacc_ = 0x10029af0 + .global fxfacp_; fxfacp_ = 0x10029b00 + .global fxfacs_; fxfacs_ = 0x10029b10 + .global fxfact_; fxfact_ = 0x10029b20 + .global fxfadr_; fxfadr_ = 0x10029b30 + .global fxfakb_; fxfakb_ = 0x10029b40 + .global fxfakc_; fxfakc_ = 0x10029b50 + .global fxfakd_; fxfakd_ = 0x10029b60 + .global fxfaki_; fxfaki_ = 0x10029b70 + .global fxfakr_; fxfakr_ = 0x10029b80 + .global fxfalc_; fxfalc_ = 0x10029b90 + .global fxfald_; fxfald_ = 0x10029ba0 + .global fxfalr_; fxfalr_ = 0x10029bb0 + .global fxfalu_; fxfalu_ = 0x10029bc0 + .global fxfasr_; fxfasr_ = 0x10029bd0 + .global fxfbls_; fxfbls_ = 0x10029be0 + .global fxfbyt_; fxfbyt_ = 0x10029bf0 + .global fxfche_; fxfche_ = 0x10029c00 + .global fxfchm_; fxfchm_ = 0x10029c10 + .global fxfchp_; fxfchp_ = 0x10029c20 + .global fxfchv_; fxfchv_ = 0x10029c30 + .global fxfcle_; fxfcle_ = 0x10029c40 + .global fxfcll_; fxfcll_ = 0x10029c50 + .global fxfcnx_; fxfcnx_ = 0x10029c60 + .global fxfcoj_; fxfcoj_ = 0x10029c70 + .global fxfcoy_; fxfcoy_ = 0x10029c80 + .global fxfcte_; fxfcte_ = 0x10029c90 + .global fxfdae_; fxfdae_ = 0x10029ca0 + .global fxfdee_; fxfdee_ = 0x10029cb0 + .global fxfdiw_; fxfdiw_ = 0x10029cc0 + .global fxfdur_; fxfdur_ = 0x10029cd0 + .global fxfenb_; fxfenb_ = 0x10029ce0 + .global fxfenc_; fxfenc_ = 0x10029cf0 + .global fxfend_; fxfend_ = 0x10029d00 + .global fxfene_; fxfene_ = 0x10029d10 + .global fxfeni_; fxfeni_ = 0x10029d20 + .global fxfenl_; fxfenl_ = 0x10029d30 + .global fxfenr_; fxfenr_ = 0x10029d40 + .global fxfens_; fxfens_ = 0x10029d50 + .global fxfexh_; fxfexh_ = 0x10029d60 + .global fxfexr_; fxfexr_ = 0x10029d70 + .global fxffac_; fxffac_ = 0x10029d80 + .global fxffcr_; fxffcr_ = 0x10029d90 + .global fxffiw_; fxffiw_ = 0x10029da0 + .global fxffog_; fxffog_ = 0x10029db0 + .global fxffpd_; fxffpd_ = 0x10029dc0 + .global fxfgas_; fxfgas_ = 0x10029dd0 + .global fxfgeb_; fxfgeb_ = 0x10029de0 + .global fxfged_; fxfged_ = 0x10029df0 + .global fxfgei_; fxfgei_ = 0x10029e00 + .global fxfgen_; fxfgen_ = 0x10029e10 + .global fxfger_; fxfger_ = 0x10029e20 + .global fxfget_; fxfget_ = 0x10029e30 + .global fxfglm_; fxfglm_ = 0x10029e40 + .global fxfgsr_; fxfgsr_ = 0x10029e50 + .global fxfhdt_; fxfhdt_ = 0x10029e60 + .global fxfhee_; fxfhee_ = 0x10029e70 + .global fxfhef_; fxfhef_ = 0x10029e80 + .global fxfint_; fxfint_ = 0x10029e90 + .global fxfisk_; fxfisk_ = 0x10029ea0 + .global fxfkse_; fxfkse_ = 0x10029eb0 + .global fxfksl_; fxfksl_ = 0x10029ec0 + .global fxfksm_; fxfksm_ = 0x10029ed0 + .global fxfksn_; fxfksn_ = 0x10029ee0 + .global fxfkss_; fxfkss_ = 0x10029ef0 + .global fxfkst_; fxfkst_ = 0x10029f00 + .global fxfksx_; fxfksx_ = 0x10029f10 + .global fxflor_; fxflor_ = 0x10029f20 + .global fxfmad_; fxfmad_ = 0x10029f30 + .global fxfmar_; fxfmar_ = 0x10029f40 + .global fxfmas_; fxfmas_ = 0x10029f50 + .global fxfmay_; fxfmay_ = 0x10029f60 + .global fxfmea_; fxfmea_ = 0x10029f70 + .global fxfnul_; fxfnul_ = 0x10029f80 + .global fxfopn_; fxfopn_ = 0x10029f90 + .global fxfopx_; fxfopx_ = 0x10029fa0 + .global fxfove_; fxfove_ = 0x10029fb0 + .global fxfovt_; fxfovt_ = 0x10029fc0 + .global fxfpaa_; fxfpaa_ = 0x10029fd0 + .global fxfpld_; fxfpld_ = 0x10029fe0 + .global fxfple_; fxfple_ = 0x10029ff0 + .global fxfplf_; fxfplf_ = 0x1002a000 + .global fxfplo_; fxfplo_ = 0x1002a010 + .global fxfplp_; fxfplp_ = 0x1002a020 + .global fxfprr_; fxfprr_ = 0x1002a030 + .global fxfred_; fxfred_ = 0x1002a040 + .global fxfree_; fxfree_ = 0x1002a050 + .global fxfrek_; fxfrek_ = 0x1002a060 + .global fxfren_; fxfren_ = 0x1002a070 + .global fxfrep_; fxfrep_ = 0x1002a080 + .global fxfrfr_; fxfrfr_ = 0x1002a090 + .global fxfrhr_; fxfrhr_ = 0x1002a0a0 + .global fxfsee_; fxfsee_ = 0x1002a0b0 + .global fxfsev_; fxfsev_ = 0x1002a0c0 + .global fxfsex_; fxfsex_ = 0x1002a0d0 + .global fxfskn_; fxfskn_ = 0x1002a0e0 + .global fxfstr_; fxfstr_ = 0x1002a0f0 + .global fxftox_; fxftox_ = 0x1002a100 + .global fxfuad_; fxfuad_ = 0x1002a110 + .global fxfuna_; fxfuna_ = 0x1002a120 + .global fxfupd_; fxfupd_ = 0x1002a130 + .global fxfupr_; fxfupr_ = 0x1002a140 + .global fxfwrr_; fxfwrr_ = 0x1002a150 + .global fxfwrs_; fxfwrs_ = 0x1002a160 + .global fxfxal_; fxfxal_ = 0x1002a170 + .global fxfxhd_; fxfxhd_ = 0x1002a180 + .global fxfxn1_; fxfxn1_ = 0x1002a190 + .global fxfzcl_; fxfzcl_ = 0x1002a1a0 + .global fxfzop_; fxfzop_ = 0x1002a1b0 + .global fxfzrd_; fxfzrd_ = 0x1002a1c0 + .global fxfzst_; fxfzst_ = 0x1002a1d0 + .global fxfzwr_; fxfzwr_ = 0x1002a1e0 + .global fxfzwt_; fxfzwt_ = 0x1002a1f0 + .global gactie_; gactie_ = 0x1002a200 + .global gadraw_; gadraw_ = 0x1002a210 + .global gamove_; gamove_ = 0x1002a220 + .global gargb_; gargb_ = 0x1002a230 + .global gargc_; gargc_ = 0x1002a240 + .global gargd_; gargd_ = 0x1002a250 + .global gargi_; gargi_ = 0x1002a260 + .global gargl_; gargl_ = 0x1002a270 + .global gargr_; gargr_ = 0x1002a280 + .global gargrd_; gargrd_ = 0x1002a290 + .global gargs_; gargs_ = 0x1002a2a0 + .global gargsr_; gargsr_ = 0x1002a2b0 + .global gargtk_; gargtk_ = 0x1002a2c0 + .global gargwd_; gargwd_ = 0x1002a2d0 + .global gargx_; gargx_ = 0x1002a2e0 + .global gascae_; gascae_ = 0x1002a2f0 + .global gcancl_; gcancl_ = 0x1002a300 + .global gclear_; gclear_ = 0x1002a310 + .global gclose_; gclose_ = 0x1002a320 + .global gctod_; gctod_ = 0x1002a330 + .global gctol_; gctol_ = 0x1002a340 + .global gctox_; gctox_ = 0x1002a350 + .global gctran_; gctran_ = 0x1002a360 + .global gcurps_; gcurps_ = 0x1002a370 + .global gdeace_; gdeace_ = 0x1002a380 + .global gescae_; gescae_ = 0x1002a390 + .global getci_; getci_ = 0x1002a3a0 + .global gethot_; gethot_ = 0x1002a3b0 + .global getlie_; getlie_ = 0x1002a3c0 + .global getlle_; getlle_ = 0x1002a3d0 + .global getloe_; getloe_ = 0x1002a3e0 + .global gexflr_; gexflr_ = 0x1002a3f0 + .global gexfls_; gexfls_ = 0x1002a400 + .global gexflt_; gexflt_ = 0x1002a410 + .global gfill_; gfill_ = 0x1002a420 + .global gflush_; gflush_ = 0x1002a430 + .global gframe_; gframe_ = 0x1002a440 + .global gfrint_; gfrint_ = 0x1002a450 + .global ggcell_; ggcell_ = 0x1002a460 + .global ggcur_; ggcur_ = 0x1002a470 + .global ggetb_; ggetb_ = 0x1002a480 + .global ggeti_; ggeti_ = 0x1002a490 + .global ggetr_; ggetr_ = 0x1002a4a0 + .global ggets_; ggets_ = 0x1002a4b0 + .global ggscae_; ggscae_ = 0x1002a4c0 + .global ggview_; ggview_ = 0x1002a4d0 + .global ggwind_; ggwind_ = 0x1002a4e0 + .global gimcor_; gimcor_ = 0x1002a4f0 + .global gimcrr_; gimcrr_ = 0x1002a500 + .global gimder_; gimder_ = 0x1002a510 + .global gimdig_; gimdig_ = 0x1002a520 + .global gimeng_; gimeng_ = 0x1002a530 + .global gimfrg_; gimfrg_ = 0x1002a540 + .global gimfrp_; gimfrp_ = 0x1002a550 + .global gimgeg_; gimgeg_ = 0x1002a560 + .global gimins_; gimins_ = 0x1002a570 + .global gimiod_; gimiod_ = 0x1002a580 + .global gimioe_; gimioe_ = 0x1002a590 + .global gimlop_; gimlop_ = 0x1002a5a0 + .global gimqur_; gimqur_ = 0x1002a5b0 + .global gimrat_; gimrat_ = 0x1002a5c0 + .global gimreg_; gimreg_ = 0x1002a5d0 + .global gimrep_; gimrep_ = 0x1002a5e0 + .global gimres_; gimres_ = 0x1002a5f0 + .global gimrex_; gimrex_ = 0x1002a600 + .global gimseg_; gimseg_ = 0x1002a610 + .global gimser_; gimser_ = 0x1002a620 + .global gimsex_; gimsex_ = 0x1002a630 + .global gimwrp_; gimwrp_ = 0x1002a640 + .global gimwrs_; gimwrs_ = 0x1002a650 + .global gkical_; gkical_ = 0x1002a660 + .global gkiclr_; gkiclr_ = 0x1002a670 + .global gkicls_; gkicls_ = 0x1002a680 + .global gkides_; gkides_ = 0x1002a690 + .global gkieof_; gkieof_ = 0x1002a6a0 + .global gkiese_; gkiese_ = 0x1002a6b0 + .global gkiexe_; gkiexe_ = 0x1002a6c0 + .global gkifat_; gkifat_ = 0x1002a6d0 + .global gkifen_; gkifen_ = 0x1002a6e0 + .global gkiffh_; gkiffh_ = 0x1002a6f0 + .global gkifia_; gkifia_ = 0x1002a700 + .global gkiflh_; gkiflh_ = 0x1002a710 + .global gkiger_; gkiger_ = 0x1002a720 + .global gkiges_; gkiges_ = 0x1002a730 + .global gkigey_; gkigey_ = 0x1002a740 + .global gkiinl_; gkiinl_ = 0x1002a750 + .global gkiint_; gkiint_ = 0x1002a760 + .global gkimfe_; gkimfe_ = 0x1002a770 + .global gkiops_; gkiops_ = 0x1002a780 + .global gkiplt_; gkiplt_ = 0x1002a790 + .global gkipmt_; gkipmt_ = 0x1002a7a0 + .global gkipoe_; gkipoe_ = 0x1002a7b0 + .global gkipor_; gkipor_ = 0x1002a7c0 + .global gkipuy_; gkipuy_ = 0x1002a7d0 + .global gkiree_; gkiree_ = 0x1002a7e0 + .global gkirer_; gkirer_ = 0x1002a7f0 + .global gkires_; gkires_ = 0x1002a800 + .global gkirey_; gkirey_ = 0x1002a810 + .global gkiser_; gkiser_ = 0x1002a820 + .global gkises_; gkises_ = 0x1002a830 + .global gkisul_; gkisul_ = 0x1002a840 + .global gkitet_; gkitet_ = 0x1002a850 + .global gkitxt_; gkitxt_ = 0x1002a860 + .global gkiwee_; gkiwee_ = 0x1002a870 + .global gkiwre_; gkiwre_ = 0x1002a880 + .global gkpcal_; gkpcal_ = 0x1002a890 + .global gkpcle_; gkpcle_ = 0x1002a8a0 + .global gkpclr_; gkpclr_ = 0x1002a8b0 + .global gkpcls_; gkpcls_ = 0x1002a8c0 + .global gkpdes_; gkpdes_ = 0x1002a8d0 + .global gkpdup_; gkpdup_ = 0x1002a8e0 + .global gkpese_; gkpese_ = 0x1002a8f0 + .global gkpfat_; gkpfat_ = 0x1002a900 + .global gkpfia_; gkpfia_ = 0x1002a910 + .global gkpflh_; gkpflh_ = 0x1002a920 + .global gkpger_; gkpger_ = 0x1002a930 + .global gkpges_; gkpges_ = 0x1002a940 + .global gkpgey_; gkpgey_ = 0x1002a950 + .global gkpgrm_; gkpgrm_ = 0x1002a960 + .global gkpinl_; gkpinl_ = 0x1002a970 + .global gkpmfe_; gkpmfe_ = 0x1002a980 + .global gkpops_; gkpops_ = 0x1002a990 + .global gkpplt_; gkpplt_ = 0x1002a9a0 + .global gkppmt_; gkppmt_ = 0x1002a9b0 + .global gkppoe_; gkppoe_ = 0x1002a9c0 + .global gkppor_; gkppor_ = 0x1002a9d0 + .global gkppst_; gkppst_ = 0x1002a9e0 + .global gkppuy_; gkppuy_ = 0x1002a9f0 + .global gkpres_; gkpres_ = 0x1002aa00 + .global gkpser_; gkpser_ = 0x1002aa10 + .global gkpses_; gkpses_ = 0x1002aa20 + .global gkptet_; gkptet_ = 0x1002aa30 + .global gkptxg_; gkptxg_ = 0x1002aa40 + .global gkptxt_; gkptxt_ = 0x1002aa50 + .global gkpunn_; gkpunn_ = 0x1002aa60 + .global glabax_; glabax_ = 0x1002aa70 + .global glbdrd_; glbdrd_ = 0x1002aa80 + .global glbene_; glbene_ = 0x1002aa90 + .global glbeq_; glbeq_ = 0x1002aaa0 + .global glbfis_; glbfis_ = 0x1002aab0 + .global glbgek_; glbgek_ = 0x1002aac0 + .global glblas_; glblas_ = 0x1002aad0 + .global glblob_; glblob_ = 0x1002aae0 + .global glbmip_; glbmip_ = 0x1002aaf0 + .global glbple_; glbple_ = 0x1002ab00 + .global glbsep_; glbsep_ = 0x1002ab10 + .global glbses_; glbses_ = 0x1002ab20 + .global glbset_; glbset_ = 0x1002ab30 + .global glbtin_; glbtin_ = 0x1002ab40 + .global glbveg_; glbveg_ = 0x1002ab50 + .global gline_; gline_ = 0x1002ab60 + .global gltoc_; gltoc_ = 0x1002ab70 + .global gmark_; gmark_ = 0x1002ab80 + .global gmftie_; gmftie_ = 0x1002ab90 + .global gmprif_; gmprif_ = 0x1002aba0 + .global gmsg_; gmsg_ = 0x1002abb0 + .global gmsgb_; gmsgb_ = 0x1002abc0 + .global gmsgc_; gmsgc_ = 0x1002abd0 + .global gmsgd_; gmsgd_ = 0x1002abe0 + .global gmsgi_; gmsgi_ = 0x1002abf0 + .global gmsgl_; gmsgl_ = 0x1002ac00 + .global gmsgr_; gmsgr_ = 0x1002ac10 + .global gmsgs_; gmsgs_ = 0x1002ac20 + .global gmsgx_; gmsgx_ = 0x1002ac30 + .global gmttot_; gmttot_ = 0x1002ac40 + .global gopen_; gopen_ = 0x1002ac50 + .global gopeni_; gopeni_ = 0x1002ac60 + .global gpagee_; gpagee_ = 0x1002ac70 + .global gpatme_; gpatme_ = 0x1002ac80 + .global gpatmh_; gpatmh_ = 0x1002ac90 + .global gpcell_; gpcell_ = 0x1002aca0 + .global gplcae_; gplcae_ = 0x1002acb0 + .global gplcal_; gplcal_ = 0x1002acc0 + .global gplclb_; gplclb_ = 0x1002acd0 + .global gplcll_; gplcll_ = 0x1002ace0 + .global gplclr_; gplclr_ = 0x1002acf0 + .global gplclt_; gplclt_ = 0x1002ad00 + .global gplflh_; gplflh_ = 0x1002ad10 + .global gpline_; gpline_ = 0x1002ad20 + .global gploto_; gploto_ = 0x1002ad30 + .global gplotv_; gplotv_ = 0x1002ad40 + .global gplret_; gplret_ = 0x1002ad50 + .global gplsee_; gplsee_ = 0x1002ad60 + .global gplwci_; gplwci_ = 0x1002ad70 + .global gpmark_; gpmark_ = 0x1002ad80 + .global gqsort_; gqsort_ = 0x1002ad90 + .global gqvery_; gqvery_ = 0x1002ada0 + .global grdraw_; grdraw_ = 0x1002adb0 + .global grdwcs_; grdwcs_ = 0x1002adc0 + .global greace_; greace_ = 0x1002add0 + .global greset_; greset_ = 0x1002ade0 + .global grmove_; grmove_ = 0x1002adf0 + .global grscae_; grscae_ = 0x1002ae00 + .global gscan_; gscan_ = 0x1002ae10 + .global gscur_; gscur_ = 0x1002ae20 + .global gseti_; gseti_ = 0x1002ae30 + .global gsetr_; gsetr_ = 0x1002ae40 + .global gsets_; gsets_ = 0x1002ae50 + .global gstati_; gstati_ = 0x1002ae60 + .global gstatr_; gstatr_ = 0x1002ae70 + .global gstats_; gstats_ = 0x1002ae80 + .global gstrct_; gstrct_ = 0x1002ae90 + .global gstrcy_; gstrcy_ = 0x1002aea0 + .global gstrmh_; gstrmh_ = 0x1002aeb0 + .global gstsei_; gstsei_ = 0x1002aec0 + .global gstser_; gstser_ = 0x1002aed0 + .global gsview_; gsview_ = 0x1002aee0 + .global gswind_; gswind_ = 0x1002aef0 + .global gtdise_; gtdise_ = 0x1002af00 + .global gtext_; gtext_ = 0x1002af10 + .global gtickr_; gtickr_ = 0x1002af20 + .global gtliny_; gtliny_ = 0x1002af30 + .global gtndis_; gtndis_ = 0x1002af40 + .global gttyld_; gttyld_ = 0x1002af50 + .global gtxset_; gtxset_ = 0x1002af60 + .global gtybih_; gtybih_ = 0x1002af70 + .global gtycas_; gtycas_ = 0x1002af80 + .global gtycle_; gtycle_ = 0x1002af90 + .global gtyeny_; gtyeny_ = 0x1002afa0 + .global gtyexs_; gtyexs_ = 0x1002afb0 + .global gtyfey_; gtyfey_ = 0x1002afc0 + .global gtyfiy_; gtyfiy_ = 0x1002afd0 + .global gtygeb_; gtygeb_ = 0x1002afe0 + .global gtygei_; gtygei_ = 0x1002aff0 + .global gtyger_; gtyger_ = 0x1002b000 + .global gtyges_; gtyges_ = 0x1002b010 + .global gtyins_; gtyins_ = 0x1002b020 + .global gtyopn_; gtyopn_ = 0x1002b030 + .global gtysce_; gtysce_ = 0x1002b040 + .global gumark_; gumark_ = 0x1002b050 + .global gvline_; gvline_ = 0x1002b060 + .global gvmark_; gvmark_ = 0x1002b070 + .global gwcsme_; gwcsme_ = 0x1002b080 + .global gwrwcs_; gwrwcs_ = 0x1002b090 + .global i1mach_; i1mach_ = 0x1002b0a0 + .global idbcle_; idbcle_ = 0x1002b0b0 + .global idbfid_; idbfid_ = 0x1002b0c0 + .global idbfir_; idbfir_ = 0x1002b0d0 + .global idbgeg_; idbgeg_ = 0x1002b0e0 + .global idbkwp_; idbkwp_ = 0x1002b0f0 + .global idbned_; idbned_ = 0x1002b100 + .global idbopn_; idbopn_ = 0x1002b110 + .global idbpug_; idbpug_ = 0x1002b120 + .global ieegmd_; ieegmd_ = 0x1002b130 + .global ieegmr_; ieegmr_ = 0x1002b140 + .global ieegnd_; ieegnd_ = 0x1002b150 + .global ieegnr_; ieegnr_ = 0x1002b160 + .global ieemad_; ieemad_ = 0x1002b170 + .global ieemar_; ieemar_ = 0x1002b180 + .global ieepad_; ieepad_ = 0x1002b190 + .global ieepar_; ieepar_ = 0x1002b1a0 + .global ieesmd_; ieesmd_ = 0x1002b1b0 + .global ieesmr_; ieesmr_ = 0x1002b1c0 + .global ieesnd_; ieesnd_ = 0x1002b1d0 + .global ieesnr_; ieesnr_ = 0x1002b1e0 + .global ieestd_; ieestd_ = 0x1002b1f0 + .global ieestr_; ieestr_ = 0x1002b200 + .global ieeupd_; ieeupd_ = 0x1002b210 + .global ieeupr_; ieeupr_ = 0x1002b220 + .global ieevpd_; ieevpd_ = 0x1002b230 + .global ieevpr_; ieevpr_ = 0x1002b240 + .global ieevud_; ieevud_ = 0x1002b250 + .global ieevur_; ieevur_ = 0x1002b260 + .global ieezsd_; ieezsd_ = 0x1002b270 + .global ieezsr_; ieezsr_ = 0x1002b280 + .global ikiacs_; ikiacs_ = 0x1002b290 + .global ikicle_; ikicle_ = 0x1002b2a0 + .global ikicoy_; ikicoy_ = 0x1002b2b0 + .global ikidee_; ikidee_ = 0x1002b2c0 + .global ikideg_; ikideg_ = 0x1002b2d0 + .global ikiext_; ikiext_ = 0x1002b2e0 + .global ikiged_; ikiged_ = 0x1002b2f0 + .global ikigen_; ikigen_ = 0x1002b300 + .global ikiger_; ikiger_ = 0x1002b310 + .global ikiint_; ikiint_ = 0x1002b320 + .global ikildr_; ikildr_ = 0x1002b330 + .global ikimke_; ikimke_ = 0x1002b340 + .global ikiopn_; ikiopn_ = 0x1002b350 + .global ikiopx_; ikiopx_ = 0x1002b360 + .global ikipae_; ikipae_ = 0x1002b370 + .global ikiree_; ikiree_ = 0x1002b380 + .global ikiupr_; ikiupr_ = 0x1002b390 + .global ikivan_; ikivan_ = 0x1002b3a0 + .global imaccf_; imaccf_ = 0x1002b3b0 + .global imaccs_; imaccs_ = 0x1002b3c0 + .global imaddb_; imaddb_ = 0x1002b3d0 + .global imaddd_; imaddd_ = 0x1002b3e0 + .global imaddf_; imaddf_ = 0x1002b3f0 + .global imaddi_; imaddi_ = 0x1002b400 + .global imaddl_; imaddl_ = 0x1002b410 + .global imaddr_; imaddr_ = 0x1002b420 + .global imadds_; imadds_ = 0x1002b430 + .global imaflp_; imaflp_ = 0x1002b440 + .global imalin_; imalin_ = 0x1002b450 + .global imaplv_; imaplv_ = 0x1002b460 + .global imastr_; imastr_ = 0x1002b470 + .global imbln1_; imbln1_ = 0x1002b480 + .global imbln2_; imbln2_ = 0x1002b490 + .global imbln3_; imbln3_ = 0x1002b4a0 + .global imbtrn_; imbtrn_ = 0x1002b4b0 + .global imcfnl_; imcfnl_ = 0x1002b4c0 + .global imcopy_; imcopy_ = 0x1002b4d0 + .global imcssz_; imcssz_ = 0x1002b4e0 + .global imctrt_; imctrt_ = 0x1002b4f0 + .global imdect_; imdect_ = 0x1002b500 + .global imdele_; imdele_ = 0x1002b510 + .global imdelf_; imdelf_ = 0x1002b520 + .global imdmap_; imdmap_ = 0x1002b530 + .global imerr_; imerr_ = 0x1002b540 + .global imflpl_; imflpl_ = 0x1002b550 + .global imflps_; imflps_ = 0x1002b560 + .global imflsd_; imflsd_ = 0x1002b570 + .global imflsh_; imflsh_ = 0x1002b580 + .global imflsi_; imflsi_ = 0x1002b590 + .global imflsl_; imflsl_ = 0x1002b5a0 + .global imflsr_; imflsr_ = 0x1002b5b0 + .global imflss_; imflss_ = 0x1002b5c0 + .global imflsx_; imflsx_ = 0x1002b5d0 + .global imfluh_; imfluh_ = 0x1002b5e0 + .global imfnpy_; imfnpy_ = 0x1002b5f0 + .global imfnss_; imfnss_ = 0x1002b600 + .global imgclr_; imgclr_ = 0x1002b610 + .global imgetb_; imgetb_ = 0x1002b620 + .global imgetc_; imgetc_ = 0x1002b630 + .global imgetd_; imgetd_ = 0x1002b640 + .global imgeti_; imgeti_ = 0x1002b650 + .global imgetl_; imgetl_ = 0x1002b660 + .global imgetr_; imgetr_ = 0x1002b670 + .global imgets_; imgets_ = 0x1002b680 + .global imgfte_; imgfte_ = 0x1002b690 + .global imggsc_; imggsc_ = 0x1002b6a0 + .global imggsd_; imggsd_ = 0x1002b6b0 + .global imggsi_; imggsi_ = 0x1002b6c0 + .global imggsl_; imggsl_ = 0x1002b6d0 + .global imggsr_; imggsr_ = 0x1002b6e0 + .global imggss_; imggss_ = 0x1002b6f0 + .global imggsx_; imggsx_ = 0x1002b700 + .global imgibf_; imgibf_ = 0x1002b710 + .global imgime_; imgime_ = 0x1002b720 + .global imgl1d_; imgl1d_ = 0x1002b730 + .global imgl1i_; imgl1i_ = 0x1002b740 + .global imgl1l_; imgl1l_ = 0x1002b750 + .global imgl1r_; imgl1r_ = 0x1002b760 + .global imgl1s_; imgl1s_ = 0x1002b770 + .global imgl1x_; imgl1x_ = 0x1002b780 + .global imgl2d_; imgl2d_ = 0x1002b790 + .global imgl2i_; imgl2i_ = 0x1002b7a0 + .global imgl2l_; imgl2l_ = 0x1002b7b0 + .global imgl2r_; imgl2r_ = 0x1002b7c0 + .global imgl2s_; imgl2s_ = 0x1002b7d0 + .global imgl2x_; imgl2x_ = 0x1002b7e0 + .global imgl3d_; imgl3d_ = 0x1002b7f0 + .global imgl3i_; imgl3i_ = 0x1002b800 + .global imgl3l_; imgl3l_ = 0x1002b810 + .global imgl3r_; imgl3r_ = 0x1002b820 + .global imgl3s_; imgl3s_ = 0x1002b830 + .global imgl3x_; imgl3x_ = 0x1002b840 + .global imgnfn_; imgnfn_ = 0x1002b850 + .global imgnld_; imgnld_ = 0x1002b860 + .global imgnli_; imgnli_ = 0x1002b870 + .global imgnll_; imgnll_ = 0x1002b880 + .global imgnln_; imgnln_ = 0x1002b890 + .global imgnlr_; imgnlr_ = 0x1002b8a0 + .global imgnls_; imgnls_ = 0x1002b8b0 + .global imgnlx_; imgnlx_ = 0x1002b8c0 + .global imgobf_; imgobf_ = 0x1002b8d0 + .global imgs1d_; imgs1d_ = 0x1002b8e0 + .global imgs1i_; imgs1i_ = 0x1002b8f0 + .global imgs1l_; imgs1l_ = 0x1002b900 + .global imgs1r_; imgs1r_ = 0x1002b910 + .global imgs1s_; imgs1s_ = 0x1002b920 + .global imgs1x_; imgs1x_ = 0x1002b930 + .global imgs2d_; imgs2d_ = 0x1002b940 + .global imgs2i_; imgs2i_ = 0x1002b950 + .global imgs2l_; imgs2l_ = 0x1002b960 + .global imgs2r_; imgs2r_ = 0x1002b970 + .global imgs2s_; imgs2s_ = 0x1002b980 + .global imgs2x_; imgs2x_ = 0x1002b990 + .global imgs3d_; imgs3d_ = 0x1002b9a0 + .global imgs3i_; imgs3i_ = 0x1002b9b0 + .global imgs3l_; imgs3l_ = 0x1002b9c0 + .global imgs3r_; imgs3r_ = 0x1002b9d0 + .global imgs3s_; imgs3s_ = 0x1002b9e0 + .global imgs3x_; imgs3x_ = 0x1002b9f0 + .global imgsen_; imgsen_ = 0x1002ba00 + .global imgstr_; imgstr_ = 0x1002ba10 + .global iminie_; iminie_ = 0x1002ba20 + .global imioff_; imioff_ = 0x1002ba30 + .global imisec_; imisec_ = 0x1002ba40 + .global imloop_; imloop_ = 0x1002ba50 + .global immaky_; immaky_ = 0x1002ba60 + .global immap_; immap_ = 0x1002ba70 + .global immapz_; immapz_ = 0x1002ba80 + .global imnote_; imnote_ = 0x1002ba90 + .global imofnl_; imofnl_ = 0x1002baa0 + .global imofns_; imofns_ = 0x1002bab0 + .global imofnu_; imofnu_ = 0x1002bac0 + .global imopsf_; imopsf_ = 0x1002bad0 + .global impakd_; impakd_ = 0x1002bae0 + .global impaki_; impaki_ = 0x1002baf0 + .global impakl_; impakl_ = 0x1002bb00 + .global impakr_; impakr_ = 0x1002bb10 + .global impaks_; impaks_ = 0x1002bb20 + .global impakx_; impakx_ = 0x1002bb30 + .global impare_; impare_ = 0x1002bb40 + .global impgsd_; impgsd_ = 0x1002bb50 + .global impgsi_; impgsi_ = 0x1002bb60 + .global impgsl_; impgsl_ = 0x1002bb70 + .global impgsr_; impgsr_ = 0x1002bb80 + .global impgss_; impgss_ = 0x1002bb90 + .global impgsx_; impgsx_ = 0x1002bba0 + .global impl1d_; impl1d_ = 0x1002bbb0 + .global impl1i_; impl1i_ = 0x1002bbc0 + .global impl1l_; impl1l_ = 0x1002bbd0 + .global impl1r_; impl1r_ = 0x1002bbe0 + .global impl1s_; impl1s_ = 0x1002bbf0 + .global impl1x_; impl1x_ = 0x1002bc00 + .global impl2d_; impl2d_ = 0x1002bc10 + .global impl2i_; impl2i_ = 0x1002bc20 + .global impl2l_; impl2l_ = 0x1002bc30 + .global impl2r_; impl2r_ = 0x1002bc40 + .global impl2s_; impl2s_ = 0x1002bc50 + .global impl2x_; impl2x_ = 0x1002bc60 + .global impl3d_; impl3d_ = 0x1002bc70 + .global impl3i_; impl3i_ = 0x1002bc80 + .global impl3l_; impl3l_ = 0x1002bc90 + .global impl3r_; impl3r_ = 0x1002bca0 + .global impl3s_; impl3s_ = 0x1002bcb0 + .global impl3x_; impl3x_ = 0x1002bcc0 + .global impml1_; impml1_ = 0x1002bcd0 + .global impml2_; impml2_ = 0x1002bce0 + .global impml3_; impml3_ = 0x1002bcf0 + .global impmlr_; impmlr_ = 0x1002bd00 + .global impmlv_; impmlv_ = 0x1002bd10 + .global impmmo_; impmmo_ = 0x1002bd20 + .global impmmp_; impmmp_ = 0x1002bd30 + .global impmon_; impmon_ = 0x1002bd40 + .global impms1_; impms1_ = 0x1002bd50 + .global impms2_; impms2_ = 0x1002bd60 + .global impms3_; impms3_ = 0x1002bd70 + .global impmsr_; impmsr_ = 0x1002bd80 + .global impmsv_; impmsv_ = 0x1002bd90 + .global impnld_; impnld_ = 0x1002bda0 + .global impnli_; impnli_ = 0x1002bdb0 + .global impnll_; impnll_ = 0x1002bdc0 + .global impnln_; impnln_ = 0x1002bdd0 + .global impnlr_; impnlr_ = 0x1002bde0 + .global impnls_; impnls_ = 0x1002bdf0 + .global impnlx_; impnlx_ = 0x1002be00 + .global imps1d_; imps1d_ = 0x1002be10 + .global imps1i_; imps1i_ = 0x1002be20 + .global imps1l_; imps1l_ = 0x1002be30 + .global imps1r_; imps1r_ = 0x1002be40 + .global imps1s_; imps1s_ = 0x1002be50 + .global imps1x_; imps1x_ = 0x1002be60 + .global imps2d_; imps2d_ = 0x1002be70 + .global imps2i_; imps2i_ = 0x1002be80 + .global imps2l_; imps2l_ = 0x1002be90 + .global imps2r_; imps2r_ = 0x1002bea0 + .global imps2s_; imps2s_ = 0x1002beb0 + .global imps2x_; imps2x_ = 0x1002bec0 + .global imps3d_; imps3d_ = 0x1002bed0 + .global imps3i_; imps3i_ = 0x1002bee0 + .global imps3l_; imps3l_ = 0x1002bef0 + .global imps3r_; imps3r_ = 0x1002bf00 + .global imps3s_; imps3s_ = 0x1002bf10 + .global imps3x_; imps3x_ = 0x1002bf20 + .global impstr_; impstr_ = 0x1002bf30 + .global imputb_; imputb_ = 0x1002bf40 + .global imputd_; imputd_ = 0x1002bf50 + .global imputh_; imputh_ = 0x1002bf60 + .global imputi_; imputi_ = 0x1002bf70 + .global imputl_; imputl_ = 0x1002bf80 + .global imputr_; imputr_ = 0x1002bf90 + .global imputs_; imputs_ = 0x1002bfa0 + .global imrbpx_; imrbpx_ = 0x1002bfb0 + .global imrdpx_; imrdpx_ = 0x1002bfc0 + .global imrene_; imrene_ = 0x1002bfd0 + .global imrmbs_; imrmbs_ = 0x1002bfe0 + .global imsamp_; imsamp_ = 0x1002bff0 + .global imsetf_; imsetf_ = 0x1002c000 + .global imseti_; imseti_ = 0x1002c010 + .global imsetr_; imsetr_ = 0x1002c020 + .global imsinb_; imsinb_ = 0x1002c030 + .global imsmpl_; imsmpl_ = 0x1002c040 + .global imsmps_; imsmps_ = 0x1002c050 + .global imsslv_; imsslv_ = 0x1002c060 + .global imstai_; imstai_ = 0x1002c070 + .global imstar_; imstar_ = 0x1002c080 + .global imstas_; imstas_ = 0x1002c090 + .global imtcle_; imtcle_ = 0x1002c0a0 + .global imtgem_; imtgem_ = 0x1002c0b0 + .global imtlen_; imtlen_ = 0x1002c0c0 + .global imtmae_; imtmae_ = 0x1002c0d0 + .global imtopn_; imtopn_ = 0x1002c0e0 + .global imtopp_; imtopp_ = 0x1002c0f0 + .global imtrew_; imtrew_ = 0x1002c100 + .global imtrgm_; imtrgm_ = 0x1002c110 + .global imunmp_; imunmp_ = 0x1002c120 + .global imupkd_; imupkd_ = 0x1002c130 + .global imupki_; imupki_ = 0x1002c140 + .global imupkl_; imupkl_ = 0x1002c150 + .global imupkr_; imupkr_ = 0x1002c160 + .global imupks_; imupks_ = 0x1002c170 + .global imupkx_; imupkx_ = 0x1002c180 + .global imwbpx_; imwbpx_ = 0x1002c190 + .global imwrie_; imwrie_ = 0x1002c1a0 + .global imwrpx_; imwrpx_ = 0x1002c1b0 + .global intrde_; intrde_ = 0x1002c1c0 + .global intree_; intree_ = 0x1002c1d0 + .global intrrt_; intrrt_ = 0x1002c1e0 + .global irafmn_; irafmn_ = 0x1002c1f0 + .global itob_; itob_ = 0x1002c200 + .global itoc_; itoc_ = 0x1002c210 + .global iwcare_; iwcare_ = 0x1002c220 + .global iwcfis_; iwcfis_ = 0x1002c230 + .global iwents_; iwents_ = 0x1002c240 + .global iwfind_; iwfind_ = 0x1002c250 + .global iwgbis_; iwgbis_ = 0x1002c260 + .global iwputr_; iwputr_ = 0x1002c270 + .global iwputy_; iwputy_ = 0x1002c280 + .global iwrfis_; iwrfis_ = 0x1002c290 + .global iwsetp_; iwsetp_ = 0x1002c2a0 + .global kardbf_; kardbf_ = 0x1002c2b0 + .global kardgd_; kardgd_ = 0x1002c2c0 + .global kardlp_; kardlp_ = 0x1002c2d0 + .global kardpl_; kardpl_ = 0x1002c2e0 + .global kardpr_; kardpr_ = 0x1002c2f0 + .global kardsf_; kardsf_ = 0x1002c300 + .global kawrbf_; kawrbf_ = 0x1002c310 + .global kawrgd_; kawrgd_ = 0x1002c320 + .global kawrlp_; kawrlp_ = 0x1002c330 + .global kawrpl_; kawrpl_ = 0x1002c340 + .global kawrpr_; kawrpr_ = 0x1002c350 + .global kawrsf_; kawrsf_ = 0x1002c360 + .global kawtbf_; kawtbf_ = 0x1002c370 + .global kawtgd_; kawtgd_ = 0x1002c380 + .global kawtlp_; kawtlp_ = 0x1002c390 + .global kawtpl_; kawtpl_ = 0x1002c3a0 + .global kawtpr_; kawtpr_ = 0x1002c3b0 + .global kawtsf_; kawtsf_ = 0x1002c3c0 + .global kbzard_; kbzard_ = 0x1002c3d0 + .global kbzawr_; kbzawr_ = 0x1002c3e0 + .global kbzawt_; kbzawt_ = 0x1002c3f0 + .global kbzcls_; kbzcls_ = 0x1002c400 + .global kbzopn_; kbzopn_ = 0x1002c410 + .global kbzstt_; kbzstt_ = 0x1002c420 + .global kclcpr_; kclcpr_ = 0x1002c430 + .global kcldir_; kcldir_ = 0x1002c440 + .global kcldpr_; kcldpr_ = 0x1002c450 + .global kclsbf_; kclsbf_ = 0x1002c460 + .global kclsgd_; kclsgd_ = 0x1002c470 + .global kclslp_; kclslp_ = 0x1002c480 + .global kclspl_; kclspl_ = 0x1002c490 + .global kclssf_; kclssf_ = 0x1002c4a0 + .global kclstx_; kclstx_ = 0x1002c4b0 + .global kclsty_; kclsty_ = 0x1002c4c0 + .global kdvall_; kdvall_ = 0x1002c4d0 + .global kdvown_; kdvown_ = 0x1002c4e0 + .global kfacss_; kfacss_ = 0x1002c4f0 + .global kfaloc_; kfaloc_ = 0x1002c500 + .global kfchdr_; kfchdr_ = 0x1002c510 + .global kfdele_; kfdele_ = 0x1002c520 + .global kfgcwd_; kfgcwd_ = 0x1002c530 + .global kfinfo_; kfinfo_ = 0x1002c540 + .global kflstx_; kflstx_ = 0x1002c550 + .global kflsty_; kflsty_ = 0x1002c560 + .global kfmkcp_; kfmkcp_ = 0x1002c570 + .global kfmkdr_; kfmkdr_ = 0x1002c580 + .global kfpath_; kfpath_ = 0x1002c590 + .global kfprot_; kfprot_ = 0x1002c5a0 + .global kfrnam_; kfrnam_ = 0x1002c5b0 + .global kfsubd_; kfsubd_ = 0x1002c5c0 + .global kfxdir_; kfxdir_ = 0x1002c5d0 + .global kgettx_; kgettx_ = 0x1002c5e0 + .global kgetty_; kgetty_ = 0x1002c5f0 + .global kgfdir_; kgfdir_ = 0x1002c600 + .global kicont_; kicont_ = 0x1002c610 + .global kidece_; kidece_ = 0x1002c620 + .global kience_; kience_ = 0x1002c630 + .global kienvt_; kienvt_ = 0x1002c640 + .global kierrr_; kierrr_ = 0x1002c650 + .global kiexte_; kiexte_ = 0x1002c660 + .global kifine_; kifine_ = 0x1002c670 + .global kiflux_; kiflux_ = 0x1002c680 + .global kifman_; kifman_ = 0x1002c690 + .global kifren_; kifren_ = 0x1002c6a0 + .global kigetn_; kigetn_ = 0x1002c6b0 + .global kigets_; kigets_ = 0x1002c6c0 + .global kignoe_; kignoe_ = 0x1002c6d0 + .global kiinit_; kiinit_ = 0x1002c6e0 + .global kiloce_; kiloce_ = 0x1002c6f0 + .global kimape_; kimape_ = 0x1002c700 + .global kimapn_; kimapn_ = 0x1002c710 + .global kintpr_; kintpr_ = 0x1002c720 + .global kiopes_; kiopes_ = 0x1002c730 + .global kirece_; kirece_ = 0x1002c740 + .global kisend_; kisend_ = 0x1002c750 + .global kisenv_; kisenv_ = 0x1002c760 + .global kishot_; kishot_ = 0x1002c770 + .global kixnoe_; kixnoe_ = 0x1002c780 + .global kmallc_; kmallc_ = 0x1002c790 + .global knottx_; knottx_ = 0x1002c7a0 + .global knotty_; knotty_ = 0x1002c7b0 + .global kopcpr_; kopcpr_ = 0x1002c7c0 + .global kopdir_; kopdir_ = 0x1002c7d0 + .global kopdpr_; kopdpr_ = 0x1002c7e0 + .global kopnbf_; kopnbf_ = 0x1002c7f0 + .global kopngd_; kopngd_ = 0x1002c800 + .global kopnlp_; kopnlp_ = 0x1002c810 + .global kopnpl_; kopnpl_ = 0x1002c820 + .global kopnsf_; kopnsf_ = 0x1002c830 + .global kopntx_; kopntx_ = 0x1002c840 + .global kopnty_; kopnty_ = 0x1002c850 + .global koscmd_; koscmd_ = 0x1002c860 + .global kputtx_; kputtx_ = 0x1002c870 + .global kputty_; kputty_ = 0x1002c880 + .global krealc_; krealc_ = 0x1002c890 + .global ksared_; ksared_ = 0x1002c8a0 + .global ksawat_; ksawat_ = 0x1002c8b0 + .global ksawre_; ksawre_ = 0x1002c8c0 + .global ksektx_; ksektx_ = 0x1002c8d0 + .global ksekty_; ksekty_ = 0x1002c8e0 + .global ksttbf_; ksttbf_ = 0x1002c8f0 + .global ksttgd_; ksttgd_ = 0x1002c900 + .global ksttlp_; ksttlp_ = 0x1002c910 + .global ksttpl_; ksttpl_ = 0x1002c920 + .global ksttpr_; ksttpr_ = 0x1002c930 + .global ksttsf_; ksttsf_ = 0x1002c940 + .global kstttx_; kstttx_ = 0x1002c950 + .global ksttty_; ksttty_ = 0x1002c960 + .global ktzcls_; ktzcls_ = 0x1002c970 + .global ktzfls_; ktzfls_ = 0x1002c980 + .global ktzget_; ktzget_ = 0x1002c990 + .global ktznot_; ktznot_ = 0x1002c9a0 + .global ktzopn_; ktzopn_ = 0x1002c9b0 + .global ktzput_; ktzput_ = 0x1002c9c0 + .global ktzsek_; ktzsek_ = 0x1002c9d0 + .global ktzstt_; ktzstt_ = 0x1002c9e0 + .global kzclmt_; kzclmt_ = 0x1002c9f0 + .global kzopmt_; kzopmt_ = 0x1002ca00 + .global kzrdmt_; kzrdmt_ = 0x1002ca10 + .global kzrwmt_; kzrwmt_ = 0x1002ca20 + .global kzstmt_; kzstmt_ = 0x1002ca30 + .global kzwrmt_; kzwrmt_ = 0x1002ca40 + .global kzwtmt_; kzwtmt_ = 0x1002ca50 + .global lexnum_; lexnum_ = 0x1002ca60 + .global lnocle_; lnocle_ = 0x1002ca70 + .global lnofeh_; lnofeh_ = 0x1002ca80 + .global lnoopn_; lnoopn_ = 0x1002ca90 + .global lnosae_; lnosae_ = 0x1002caa0 + .global locpr_; locpr_ = 0x1002cab0 + .global locva_; locva_ = 0x1002cac0 + .global lpopen_; lpopen_ = 0x1002cad0 + .global lpzard_; lpzard_ = 0x1002cae0 + .global lpzawe_; lpzawe_ = 0x1002caf0 + .global lpzawt_; lpzawt_ = 0x1002cb00 + .global lsttot_; lsttot_ = 0x1002cb10 + .global ltoc_; ltoc_ = 0x1002cb20 + .global m75put_; m75put_ = 0x1002cb30 + .global maideh_; maideh_ = 0x1002cb40 + .global mallo1_; mallo1_ = 0x1002cb50 + .global mgdptr_; mgdptr_ = 0x1002cb60 + .global mgtfwa_; mgtfwa_ = 0x1002cb70 + .global miilen_; miilen_ = 0x1002cb80 + .global miinem_; miinem_ = 0x1002cb90 + .global miipa2_; miipa2_ = 0x1002cba0 + .global miipa6_; miipa6_ = 0x1002cbb0 + .global miipa8_; miipa8_ = 0x1002cbc0 + .global miipad_; miipad_ = 0x1002cbd0 + .global miipak_; miipak_ = 0x1002cbe0 + .global miipar_; miipar_ = 0x1002cbf0 + .global miipke_; miipke_ = 0x1002cc00 + .global miirec_; miirec_ = 0x1002cc10 + .global miired_; miired_ = 0x1002cc20 + .global miirei_; miirei_ = 0x1002cc30 + .global miirel_; miirel_ = 0x1002cc40 + .global miirer_; miirer_ = 0x1002cc50 + .global miires_; miires_ = 0x1002cc60 + .global miiup2_; miiup2_ = 0x1002cc70 + .global miiup6_; miiup6_ = 0x1002cc80 + .global miiup8_; miiup8_ = 0x1002cc90 + .global miiupd_; miiupd_ = 0x1002cca0 + .global miiupk_; miiupk_ = 0x1002ccb0 + .global miiupr_; miiupr_ = 0x1002ccc0 + .global miiwrc_; miiwrc_ = 0x1002ccd0 + .global miiwrd_; miiwrd_ = 0x1002cce0 + .global miiwri_; miiwri_ = 0x1002ccf0 + .global miiwrl_; miiwrl_ = 0x1002cd00 + .global miiwrr_; miiwrr_ = 0x1002cd10 + .global miiwrs_; miiwrs_ = 0x1002cd20 + .global miocle_; miocle_ = 0x1002cd30 + .global miogld_; miogld_ = 0x1002cd40 + .global miogli_; miogli_ = 0x1002cd50 + .global miogll_; miogll_ = 0x1002cd60 + .global mioglr_; mioglr_ = 0x1002cd70 + .global miogls_; miogls_ = 0x1002cd80 + .global mioglx_; mioglx_ = 0x1002cd90 + .global mioopn_; mioopn_ = 0x1002cda0 + .global mioopo_; mioopo_ = 0x1002cdb0 + .global miopld_; miopld_ = 0x1002cdc0 + .global miopli_; miopli_ = 0x1002cdd0 + .global miopll_; miopll_ = 0x1002cde0 + .global mioplr_; mioplr_ = 0x1002cdf0 + .global miopls_; miopls_ = 0x1002ce00 + .global mioplx_; mioplx_ = 0x1002ce10 + .global miosee_; miosee_ = 0x1002ce20 + .global miosei_; miosei_ = 0x1002ce30 + .global miosti_; miosti_ = 0x1002ce40 + .global msvfwa_; msvfwa_ = 0x1002ce50 + .global mtalle_; mtalle_ = 0x1002ce60 + .global mtcap_; mtcap_ = 0x1002ce70 + .global mtclen_; mtclen_ = 0x1002ce80 + .global mtclre_; mtclre_ = 0x1002ce90 + .global mtdeae_; mtdeae_ = 0x1002cea0 + .global mtdevd_; mtdevd_ = 0x1002ceb0 + .global mtence_; mtence_ = 0x1002cec0 + .global mtfile_; mtfile_ = 0x1002ced0 + .global mtfnae_; mtfnae_ = 0x1002cee0 + .global mtgets_; mtgets_ = 0x1002cef0 + .global mtglok_; mtglok_ = 0x1002cf00 + .global mtgtyn_; mtgtyn_ = 0x1002cf10 + .global mtloce_; mtloce_ = 0x1002cf20 + .global mtneeo_; mtneeo_ = 0x1002cf30 + .global mtopen_; mtopen_ = 0x1002cf40 + .global mtpare_; mtpare_ = 0x1002cf50 + .global mtposn_; mtposn_ = 0x1002cf60 + .global mtpute_; mtpute_ = 0x1002cf70 + .global mtreae_; mtreae_ = 0x1002cf80 + .global mtrewd_; mtrewd_ = 0x1002cf90 + .global mtsavd_; mtsavd_ = 0x1002cfa0 + .global mtsavs_; mtsavs_ = 0x1002cfb0 + .global mtskid_; mtskid_ = 0x1002cfc0 + .global mtstas_; mtstas_ = 0x1002cfd0 + .global mtsync_; mtsync_ = 0x1002cfe0 + .global mtupde_; mtupde_ = 0x1002cff0 + .global mwalld_; mwalld_ = 0x1002d000 + .global mwalls_; mwalls_ = 0x1002d010 + .global mwaxtn_; mwaxtn_ = 0x1002d020 + .global mwc1td_; mwc1td_ = 0x1002d030 + .global mwc1tr_; mwc1tr_ = 0x1002d040 + .global mwc2td_; mwc2td_ = 0x1002d050 + .global mwc2tr_; mwc2tr_ = 0x1002d060 + .global mwcloe_; mwcloe_ = 0x1002d070 + .global mwcopd_; mwcopd_ = 0x1002d080 + .global mwcops_; mwcops_ = 0x1002d090 + .global mwctfe_; mwctfe_ = 0x1002d0a0 + .global mwctrd_; mwctrd_ = 0x1002d0b0 + .global mwctrr_; mwctrr_ = 0x1002d0c0 + .global mwfins_; mwfins_ = 0x1002d0d0 + .global mwflop_; mwflop_ = 0x1002d0e0 + .global mwgaxp_; mwgaxp_ = 0x1002d0f0 + .global mwgaxt_; mwgaxt_ = 0x1002d100 + .global mwgctd_; mwgctd_ = 0x1002d110 + .global mwgctr_; mwgctr_ = 0x1002d120 + .global mwgltd_; mwgltd_ = 0x1002d130 + .global mwgltr_; mwgltr_ = 0x1002d140 + .global mwgsym_; mwgsym_ = 0x1002d150 + .global mwgwas_; mwgwas_ = 0x1002d160 + .global mwgwsd_; mwgwsd_ = 0x1002d170 + .global mwgwsr_; mwgwsr_ = 0x1002d180 + .global mwgwtd_; mwgwtd_ = 0x1002d190 + .global mwgwtr_; mwgwtr_ = 0x1002d1a0 + .global mwinvd_; mwinvd_ = 0x1002d1b0 + .global mwinvr_; mwinvr_ = 0x1002d1c0 + .global mwload_; mwload_ = 0x1002d1d0 + .global mwloam_; mwloam_ = 0x1002d1e0 + .global mwltrd_; mwltrd_ = 0x1002d1f0 + .global mwltrr_; mwltrr_ = 0x1002d200 + .global mwlubb_; mwlubb_ = 0x1002d210 + .global mwlude_; mwlude_ = 0x1002d220 + .global mwmkid_; mwmkid_ = 0x1002d230 + .global mwmkir_; mwmkir_ = 0x1002d240 + .global mwmmud_; mwmmud_ = 0x1002d250 + .global mwmmur_; mwmmur_ = 0x1002d260 + .global mwnewm_; mwnewm_ = 0x1002d270 + .global mwnewy_; mwnewy_ = 0x1002d280 + .global mwopem_; mwopem_ = 0x1002d290 + .global mwopen_; mwopen_ = 0x1002d2a0 + .global mwrefr_; mwrefr_ = 0x1002d2b0 + .global mwrote_; mwrote_ = 0x1002d2c0 + .global mwsave_; mwsave_ = 0x1002d2d0 + .global mwsavm_; mwsavm_ = 0x1002d2e0 + .global mwsaxp_; mwsaxp_ = 0x1002d2f0 + .global mwscae_; mwscae_ = 0x1002d300 + .global mwsctn_; mwsctn_ = 0x1002d310 + .global mwsdes_; mwsdes_ = 0x1002d320 + .global mwseti_; mwseti_ = 0x1002d330 + .global mwshit_; mwshit_ = 0x1002d340 + .global mwshow_; mwshow_ = 0x1002d350 + .global mwsltd_; mwsltd_ = 0x1002d360 + .global mwsltr_; mwsltr_ = 0x1002d370 + .global mwssym_; mwssym_ = 0x1002d380 + .global mwstai_; mwstai_ = 0x1002d390 + .global mwswas_; mwswas_ = 0x1002d3a0 + .global mwswsd_; mwswsd_ = 0x1002d3b0 + .global mwswsr_; mwswsr_ = 0x1002d3c0 + .global mwswtd_; mwswtd_ = 0x1002d3d0 + .global mwswte_; mwswte_ = 0x1002d3e0 + .global mwswtr_; mwswtr_ = 0x1002d3f0 + .global mwtrad_; mwtrad_ = 0x1002d400 + .global mwtrar_; mwtrar_ = 0x1002d410 + .global mwv1td_; mwv1td_ = 0x1002d420 + .global mwv1tr_; mwv1tr_ = 0x1002d430 + .global mwv2td_; mwv2td_ = 0x1002d440 + .global mwv2tr_; mwv2tr_ = 0x1002d450 + .global mwvmud_; mwvmud_ = 0x1002d460 + .global mwvmur_; mwvmur_ = 0x1002d470 + .global mwvtrd_; mwvtrd_ = 0x1002d480 + .global mwvtrr_; mwvtrr_ = 0x1002d490 + .global ndopen_; ndopen_ = 0x1002d4a0 + .global noti_; noti_ = 0x1002d4b0 + .global notl_; notl_ = 0x1002d4c0 + .global nots_; nots_ = 0x1002d4d0 + .global nowhie_; nowhie_ = 0x1002d4e0 + .global nscan_; nscan_ = 0x1002d4f0 + .global oifacs_; oifacs_ = 0x1002d500 + .global oifcle_; oifcle_ = 0x1002d510 + .global oifcoy_; oifcoy_ = 0x1002d520 + .global oifdee_; oifdee_ = 0x1002d530 + .global oifgpe_; oifgpe_ = 0x1002d540 + .global oifmke_; oifmke_ = 0x1002d550 + .global oifopn_; oifopn_ = 0x1002d560 + .global oifopx_; oifopx_ = 0x1002d570 + .global oifrdr_; oifrdr_ = 0x1002d580 + .global oifree_; oifree_ = 0x1002d590 + .global oiftrm_; oiftrm_ = 0x1002d5a0 + .global oifupr_; oifupr_ = 0x1002d5b0 + .global oifwrr_; oifwrr_ = 0x1002d5c0 + .global onerre_; onerre_ = 0x1002d5d0 + .global onerrr_; onerrr_ = 0x1002d5e0 + .global onexie_; onexie_ = 0x1002d5f0 + .global onexit_; onexit_ = 0x1002d600 + .global ord1_; ord1_ = 0x1002d610 + .global ord2_; ord2_ = 0x1002d620 + .global ori_; ori_ = 0x1002d630 + .global orl_; orl_ = 0x1002d640 + .global ors_; ors_ = 0x1002d650 + .global oscmd_; oscmd_ = 0x1002d660 + .global osfnik_; osfnik_ = 0x1002d670 + .global osfnlk_; osfnlk_ = 0x1002d680 + .global osfnms_; osfnms_ = 0x1002d690 + .global osfnpe_; osfnpe_ = 0x1002d6a0 + .global osfnrk_; osfnrk_ = 0x1002d6b0 + .global osfntt_; osfntt_ = 0x1002d6c0 + .global osfnuk_; osfnuk_ = 0x1002d6d0 + .global pagefe_; pagefe_ = 0x1002d6e0 + .global pagefs_; pagefs_ = 0x1002d6f0 + .global pargb_; pargb_ = 0x1002d700 + .global pargc_; pargc_ = 0x1002d710 + .global pargd_; pargd_ = 0x1002d720 + .global pargg_; pargg_ = 0x1002d730 + .global pargi_; pargi_ = 0x1002d740 + .global pargl_; pargl_ = 0x1002d750 + .global pargr_; pargr_ = 0x1002d760 + .global pargs_; pargs_ = 0x1002d770 + .global pargsr_; pargsr_ = 0x1002d780 + .global pargx_; pargx_ = 0x1002d790 + .global patamh_; patamh_ = 0x1002d7a0 + .global patfit_; patfit_ = 0x1002d7b0 + .global patgel_; patgel_ = 0x1002d7c0 + .global patgse_; patgse_ = 0x1002d7d0 + .global patinx_; patinx_ = 0x1002d7e0 + .global patloe_; patloe_ = 0x1002d7f0 + .global patmae_; patmae_ = 0x1002d800 + .global patmah_; patmah_ = 0x1002d810 + .global patomh_; patomh_ = 0x1002d820 + .global patsts_; patsts_ = 0x1002d830 + .global pggetd_; pggetd_ = 0x1002d840 + .global pggete_; pggete_ = 0x1002d850 + .global pggetr_; pggetr_ = 0x1002d860 + .global pgpage_; pgpage_ = 0x1002d870 + .global pgpeed_; pgpeed_ = 0x1002d880 + .global pgpusd_; pgpusd_ = 0x1002d890 + .global pgsett_; pgsett_ = 0x1002d8a0 + .global placcs_; placcs_ = 0x1002d8b0 + .global plallc_; plallc_ = 0x1002d8c0 + .global plascp_; plascp_ = 0x1002d8d0 + .global plbox_; plbox_ = 0x1002d8e0 + .global plcire_; plcire_ = 0x1002d8f0 + .global plcler_; plcler_ = 0x1002d900 + .global plcloe_; plcloe_ = 0x1002d910 + .global plcome_; plcome_ = 0x1002d920 + .global plcoms_; plcoms_ = 0x1002d930 + .global plcree_; plcree_ = 0x1002d940 + .global pldebg_; pldebg_ = 0x1002d950 + .global pldebt_; pldebt_ = 0x1002d960 + .global plempe_; plempe_ = 0x1002d970 + .global plempy_; plempy_ = 0x1002d980 + .global plfacs_; plfacs_ = 0x1002d990 + .global plfcle_; plfcle_ = 0x1002d9a0 + .global plfcoy_; plfcoy_ = 0x1002d9b0 + .global plfdee_; plfdee_ = 0x1002d9c0 + .global plfnul_; plfnul_ = 0x1002d9d0 + .global plfopn_; plfopn_ = 0x1002d9e0 + .global plfree_; plfree_ = 0x1002d9f0 + .global plfupr_; plfupr_ = 0x1002da00 + .global plgete_; plgete_ = 0x1002da10 + .global plglls_; plglls_ = 0x1002da20 + .global plglpi_; plglpi_ = 0x1002da30 + .global plglpl_; plglpl_ = 0x1002da40 + .global plglps_; plglps_ = 0x1002da50 + .global plglri_; plglri_ = 0x1002da60 + .global plglrl_; plglrl_ = 0x1002da70 + .global plglrs_; plglrs_ = 0x1002da80 + .global plgsie_; plgsie_ = 0x1002da90 + .global pll2pi_; pll2pi_ = 0x1002daa0 + .global pll2pl_; pll2pl_ = 0x1002dab0 + .global pll2ps_; pll2ps_ = 0x1002dac0 + .global pll2ri_; pll2ri_ = 0x1002dad0 + .global pll2rl_; pll2rl_ = 0x1002dae0 + .global pll2rs_; pll2rs_ = 0x1002daf0 + .global pllcot_; pllcot_ = 0x1002db00 + .global pllemy_; pllemy_ = 0x1002db10 + .global plleql_; plleql_ = 0x1002db20 + .global plline_; plline_ = 0x1002db30 + .global pllinl_; pllinl_ = 0x1002db40 + .global pllinp_; pllinp_ = 0x1002db50 + .global plliny_; plliny_ = 0x1002db60 + .global plllen_; plllen_ = 0x1002db70 + .global pllneg_; pllneg_ = 0x1002db80 + .global plload_; plload_ = 0x1002db90 + .global plloaf_; plloaf_ = 0x1002dba0 + .global plloam_; plloam_ = 0x1002dbb0 + .global plloop_; plloop_ = 0x1002dbc0 + .global pllprs_; pllprs_ = 0x1002dbd0 + .global plnewy_; plnewy_ = 0x1002dbe0 + .global plopen_; plopen_ = 0x1002dbf0 + .global plp2li_; plp2li_ = 0x1002dc00 + .global plp2ll_; plp2ll_ = 0x1002dc10 + .global plp2ls_; plp2ls_ = 0x1002dc20 + .global plp2ri_; plp2ri_ = 0x1002dc30 + .global plp2rl_; plp2rl_ = 0x1002dc40 + .global plp2rs_; plp2rs_ = 0x1002dc50 + .global plpixi_; plpixi_ = 0x1002dc60 + .global plpixl_; plpixl_ = 0x1002dc70 + .global plpixs_; plpixs_ = 0x1002dc80 + .global plplls_; plplls_ = 0x1002dc90 + .global plplpi_; plplpi_ = 0x1002dca0 + .global plplpl_; plplpl_ = 0x1002dcb0 + .global plplps_; plplps_ = 0x1002dcc0 + .global plplri_; plplri_ = 0x1002dcd0 + .global plplrl_; plplrl_ = 0x1002dce0 + .global plplrs_; plplrs_ = 0x1002dcf0 + .global plpoit_; plpoit_ = 0x1002dd00 + .global plpoln_; plpoln_ = 0x1002dd10 + .global plr2li_; plr2li_ = 0x1002dd20 + .global plr2ll_; plr2ll_ = 0x1002dd30 + .global plr2ls_; plr2ls_ = 0x1002dd40 + .global plr2pi_; plr2pi_ = 0x1002dd50 + .global plr2pl_; plr2pl_ = 0x1002dd60 + .global plr2ps_; plr2ps_ = 0x1002dd70 + .global plrani_; plrani_ = 0x1002dd80 + .global plranl_; plranl_ = 0x1002dd90 + .global plrans_; plrans_ = 0x1002dda0 + .global plrcle_; plrcle_ = 0x1002ddb0 + .global plrefe_; plrefe_ = 0x1002ddc0 + .global plregp_; plregp_ = 0x1002ddd0 + .global plreqi_; plreqi_ = 0x1002dde0 + .global plreql_; plreql_ = 0x1002ddf0 + .global plreqs_; plreqs_ = 0x1002de00 + .global plrget_; plrget_ = 0x1002de10 + .global plrgex_; plrgex_ = 0x1002de20 + .global plrop_; plrop_ = 0x1002de30 + .global plropn_; plropn_ = 0x1002de40 + .global plrpri_; plrpri_ = 0x1002de50 + .global plrprl_; plrprl_ = 0x1002de60 + .global plrprs_; plrprs_ = 0x1002de70 + .global plrset_; plrset_ = 0x1002de80 + .global plsave_; plsave_ = 0x1002de90 + .global plsavf_; plsavf_ = 0x1002dea0 + .global plsavm_; plsavm_ = 0x1002deb0 + .global plsect_; plsect_ = 0x1002dec0 + .global plsecy_; plsecy_ = 0x1002ded0 + .global plsete_; plsete_ = 0x1002dee0 + .global plseti_; plseti_ = 0x1002def0 + .global plssie_; plssie_ = 0x1002df00 + .global plsslv_; plsslv_ = 0x1002df10 + .global plstai_; plstai_ = 0x1002df20 + .global plstel_; plstel_ = 0x1002df30 + .global plubox_; plubox_ = 0x1002df40 + .global plucie_; plucie_ = 0x1002df50 + .global plupde_; plupde_ = 0x1002df60 + .global plupon_; plupon_ = 0x1002df70 + .global plvald_; plvald_ = 0x1002df80 + .global pmaccs_; pmaccs_ = 0x1002df90 + .global pmascp_; pmascp_ = 0x1002dfa0 + .global pmbox_; pmbox_ = 0x1002dfb0 + .global pmcire_; pmcire_ = 0x1002dfc0 + .global pmcler_; pmcler_ = 0x1002dfd0 + .global pmempy_; pmempy_ = 0x1002dfe0 + .global pmglls_; pmglls_ = 0x1002dff0 + .global pmglpi_; pmglpi_ = 0x1002e000 + .global pmglpl_; pmglpl_ = 0x1002e010 + .global pmglps_; pmglps_ = 0x1002e020 + .global pmglri_; pmglri_ = 0x1002e030 + .global pmglrl_; pmglrl_ = 0x1002e040 + .global pmglrs_; pmglrs_ = 0x1002e050 + .global pmline_; pmline_ = 0x1002e060 + .global pmliny_; pmliny_ = 0x1002e070 + .global pmnewk_; pmnewk_ = 0x1002e080 + .global pmplls_; pmplls_ = 0x1002e090 + .global pmplpi_; pmplpi_ = 0x1002e0a0 + .global pmplpl_; pmplpl_ = 0x1002e0b0 + .global pmplps_; pmplps_ = 0x1002e0c0 + .global pmplri_; pmplri_ = 0x1002e0d0 + .global pmplrl_; pmplrl_ = 0x1002e0e0 + .global pmplrs_; pmplrs_ = 0x1002e0f0 + .global pmpoit_; pmpoit_ = 0x1002e100 + .global pmpoln_; pmpoln_ = 0x1002e110 + .global pmrcle_; pmrcle_ = 0x1002e120 + .global pmrgex_; pmrgex_ = 0x1002e130 + .global pmrop_; pmrop_ = 0x1002e140 + .global pmropn_; pmropn_ = 0x1002e150 + .global pmrset_; pmrset_ = 0x1002e160 + .global pmsect_; pmsect_ = 0x1002e170 + .global pmsecy_; pmsecy_ = 0x1002e180 + .global pmsete_; pmsete_ = 0x1002e190 + .global pmseti_; pmseti_ = 0x1002e1a0 + .global pmstai_; pmstai_ = 0x1002e1b0 + .global pmstel_; pmstel_ = 0x1002e1c0 + .global prchdr_; prchdr_ = 0x1002e1d0 + .global prclcr_; prclcr_ = 0x1002e1e0 + .global prcldr_; prcldr_ = 0x1002e1f0 + .global prcloe_; prcloe_ = 0x1002e200 + .global prdone_; prdone_ = 0x1002e210 + .global prdumn_; prdumn_ = 0x1002e220 + .global prenve_; prenve_ = 0x1002e230 + .global prenvt_; prenvt_ = 0x1002e240 + .global prfilf_; prfilf_ = 0x1002e250 + .global prfinc_; prfinc_ = 0x1002e260 + .global prgete_; prgete_ = 0x1002e270 + .global prgetr_; prgetr_ = 0x1002e280 + .global prkill_; prkill_ = 0x1002e290 + .global pronic_; pronic_ = 0x1002e2a0 + .global propcr_; propcr_ = 0x1002e2b0 + .global propdr_; propdr_ = 0x1002e2c0 + .global propen_; propen_ = 0x1002e2d0 + .global proscd_; proscd_ = 0x1002e2e0 + .global protet_; protet_ = 0x1002e2f0 + .global prpsio_; prpsio_ = 0x1002e300 + .global prpsld_; prpsld_ = 0x1002e310 + .global prredr_; prredr_ = 0x1002e320 + .global prseti_; prseti_ = 0x1002e330 + .global prsigl_; prsigl_ = 0x1002e340 + .global prstai_; prstai_ = 0x1002e350 + .global prupde_; prupde_ = 0x1002e360 + .global prvret_; prvret_ = 0x1002e370 + .global przclr_; przclr_ = 0x1002e380 + .global pscenr_; pscenr_ = 0x1002e390 + .global pscens_; pscens_ = 0x1002e3a0 + .global pschwh_; pschwh_ = 0x1002e3b0 + .global pscloe_; pscloe_ = 0x1002e3c0 + .global psdept_; psdept_ = 0x1002e3d0 + .global psesct_; psesct_ = 0x1002e3e0 + .global psfone_; psfone_ = 0x1002e3f0 + .global psfonr_; psfonr_ = 0x1002e400 + .global psfoor_; psfoor_ = 0x1002e410 + .global psgett_; psgett_ = 0x1002e420 + .global pshear_; pshear_ = 0x1002e430 + .global psindt_; psindt_ = 0x1002e440 + .global psioit_; psioit_ = 0x1002e450 + .global psioxr_; psioxr_ = 0x1002e460 + .global pslink_; pslink_ = 0x1002e470 + .global psnewe_; psnewe_ = 0x1002e480 + .global psopen_; psopen_ = 0x1002e490 + .global psoutt_; psoutt_ = 0x1002e4a0 + .global pspage_; pspage_ = 0x1002e4b0 + .global pspagk_; pspagk_ = 0x1002e4c0 + .global psrigy_; psrigy_ = 0x1002e4d0 + .global psrjps_; psrjps_ = 0x1002e4e0 + .global pssets_; pssets_ = 0x1002e4f0 + .global pssett_; pssett_ = 0x1002e500 + .global pssety_; pssety_ = 0x1002e510 + .global psspft_; psspft_ = 0x1002e520 + .global pstese_; pstese_ = 0x1002e530 + .global pstexh_; pstexh_ = 0x1002e540 + .global pstrar_; pstrar_ = 0x1002e550 + .global pswrig_; pswrig_ = 0x1002e560 + .global pswrtk_; pswrtk_ = 0x1002e570 + .global psxpos_; psxpos_ = 0x1002e580 + .global psypos_; psypos_ = 0x1002e590 + .global putcc_; putcc_ = 0x1002e5a0 + .global putci_; putci_ = 0x1002e5b0 + .global putlie_; putlie_ = 0x1002e5c0 + .global qmaccs_; qmaccs_ = 0x1002e5d0 + .global qmgetc_; qmgetc_ = 0x1002e5e0 + .global qmscan_; qmscan_ = 0x1002e5f0 + .global qmscao_; qmscao_ = 0x1002e600 + .global qmsetm_; qmsetm_ = 0x1002e610 + .global qmsetr_; qmsetr_ = 0x1002e620 + .global qmsets_; qmsets_ = 0x1002e630 + .global qmspai_; qmspai_ = 0x1002e640 + .global qmspar_; qmspar_ = 0x1002e650 + .global qmsymb_; qmsymb_ = 0x1002e660 + .global qmupds_; qmupds_ = 0x1002e670 + .global qpaccf_; qpaccf_ = 0x1002e680 + .global qpaccs_; qpaccs_ = 0x1002e690 + .global qpaddb_; qpaddb_ = 0x1002e6a0 + .global qpaddc_; qpaddc_ = 0x1002e6b0 + .global qpaddd_; qpaddd_ = 0x1002e6c0 + .global qpaddf_; qpaddf_ = 0x1002e6d0 + .global qpaddi_; qpaddi_ = 0x1002e6e0 + .global qpaddl_; qpaddl_ = 0x1002e6f0 + .global qpaddr_; qpaddr_ = 0x1002e700 + .global qpadds_; qpadds_ = 0x1002e710 + .global qpaddx_; qpaddx_ = 0x1002e720 + .global qpargt_; qpargt_ = 0x1002e730 + .global qpastr_; qpastr_ = 0x1002e740 + .global qpbind_; qpbind_ = 0x1002e750 + .global qpcfnl_; qpcfnl_ = 0x1002e760 + .global qpcloe_; qpcloe_ = 0x1002e770 + .global qpclot_; qpclot_ = 0x1002e780 + .global qpcopf_; qpcopf_ = 0x1002e790 + .global qpcopy_; qpcopy_ = 0x1002e7a0 + .global qpctod_; qpctod_ = 0x1002e7b0 + .global qpctoi_; qpctoi_ = 0x1002e7c0 + .global qpdele_; qpdele_ = 0x1002e7d0 + .global qpdelf_; qpdelf_ = 0x1002e7e0 + .global qpdsym_; qpdsym_ = 0x1002e7f0 + .global qpdtye_; qpdtye_ = 0x1002e800 + .global qpelee_; qpelee_ = 0x1002e810 + .global qpexad_; qpexad_ = 0x1002e820 + .global qpexai_; qpexai_ = 0x1002e830 + .global qpexar_; qpexar_ = 0x1002e840 + .global qpexcd_; qpexcd_ = 0x1002e850 + .global qpexce_; qpexce_ = 0x1002e860 + .global qpexci_; qpexci_ = 0x1002e870 + .global qpexcr_; qpexcr_ = 0x1002e880 + .global qpexdc_; qpexdc_ = 0x1002e890 + .global qpexde_; qpexde_ = 0x1002e8a0 + .global qpexdg_; qpexdg_ = 0x1002e8b0 + .global qpexdr_; qpexdr_ = 0x1002e8c0 + .global qpexee_; qpexee_ = 0x1002e8d0 + .global qpexfe_; qpexfe_ = 0x1002e8e0 + .global qpexge_; qpexge_ = 0x1002e8f0 + .global qpexgr_; qpexgr_ = 0x1002e900 + .global qpexmk_; qpexmk_ = 0x1002e910 + .global qpexmr_; qpexmr_ = 0x1002e920 + .global qpexon_; qpexon_ = 0x1002e930 + .global qpexpd_; qpexpd_ = 0x1002e940 + .global qpexpi_; qpexpi_ = 0x1002e950 + .global qpexpn_; qpexpn_ = 0x1002e960 + .global qpexpr_; qpexpr_ = 0x1002e970 + .global qpexps_; qpexps_ = 0x1002e980 + .global qpexpt_; qpexpt_ = 0x1002e990 + .global qpexrd_; qpexrd_ = 0x1002e9a0 + .global qpexsd_; qpexsd_ = 0x1002e9b0 + .global qpexsi_; qpexsi_ = 0x1002e9c0 + .global qpexsr_; qpexsr_ = 0x1002e9d0 + .global qpfacs_; qpfacs_ = 0x1002e9e0 + .global qpfcle_; qpfcle_ = 0x1002e9f0 + .global qpfcos_; qpfcos_ = 0x1002ea00 + .global qpfcoy_; qpfcoy_ = 0x1002ea10 + .global qpfdee_; qpfdee_ = 0x1002ea20 + .global qpflur_; qpflur_ = 0x1002ea30 + .global qpfopn_; qpfopn_ = 0x1002ea40 + .global qpfopx_; qpfopx_ = 0x1002ea50 + .global qpfree_; qpfree_ = 0x1002ea60 + .global qpfupr_; qpfupr_ = 0x1002ea70 + .global qpfwar_; qpfwar_ = 0x1002ea80 + .global qpfwfr_; qpfwfr_ = 0x1002ea90 + .global qpfzcl_; qpfzcl_ = 0x1002eaa0 + .global qpfzop_; qpfzop_ = 0x1002eab0 + .global qpfzrd_; qpfzrd_ = 0x1002eac0 + .global qpfzst_; qpfzst_ = 0x1002ead0 + .global qpfzwr_; qpfzwr_ = 0x1002eae0 + .global qpfzwt_; qpfzwt_ = 0x1002eaf0 + .global qpgetb_; qpgetb_ = 0x1002eb00 + .global qpgetc_; qpgetc_ = 0x1002eb10 + .global qpgetd_; qpgetd_ = 0x1002eb20 + .global qpgeti_; qpgeti_ = 0x1002eb30 + .global qpgetk_; qpgetk_ = 0x1002eb40 + .global qpgetl_; qpgetl_ = 0x1002eb50 + .global qpgetm_; qpgetm_ = 0x1002eb60 + .global qpgetr_; qpgetr_ = 0x1002eb70 + .global qpgets_; qpgets_ = 0x1002eb80 + .global qpgetx_; qpgetx_ = 0x1002eb90 + .global qpgmsm_; qpgmsm_ = 0x1002eba0 + .global qpgnfn_; qpgnfn_ = 0x1002ebb0 + .global qpgpsm_; qpgpsm_ = 0x1002ebc0 + .global qpgstr_; qpgstr_ = 0x1002ebd0 + .global qpinht_; qpinht_ = 0x1002ebe0 + .global qpioce_; qpioce_ = 0x1002ebf0 + .global qpioge_; qpioge_ = 0x1002ec00 + .global qpiogr_; qpiogr_ = 0x1002ec10 + .global qpiogs_; qpiogs_ = 0x1002ec20 + .global qpiolk_; qpiolk_ = 0x1002ec30 + .global qpiols_; qpiols_ = 0x1002ec40 + .global qpiomx_; qpiomx_ = 0x1002ec50 + .global qpioon_; qpioon_ = 0x1002ec60 + .global qpiope_; qpiope_ = 0x1002ec70 + .global qpiops_; qpiops_ = 0x1002ec80 + .global qpiori_; qpiori_ = 0x1002ec90 + .global qpiors_; qpiors_ = 0x1002eca0 + .global qpiort_; qpiort_ = 0x1002ecb0 + .global qpiosc_; qpiosc_ = 0x1002ecc0 + .global qpiose_; qpiose_ = 0x1002ecd0 + .global qpiosi_; qpiosi_ = 0x1002ece0 + .global qpiosr_; qpiosr_ = 0x1002ecf0 + .global qpiost_; qpiost_ = 0x1002ed00 + .global qpiour_; qpiour_ = 0x1002ed10 + .global qpiovr_; qpiovr_ = 0x1002ed20 + .global qpiowt_; qpiowt_ = 0x1002ed30 + .global qplenf_; qplenf_ = 0x1002ed40 + .global qplenl_; qplenl_ = 0x1002ed50 + .global qplesd_; qplesd_ = 0x1002ed60 + .global qplesi_; qplesi_ = 0x1002ed70 + .global qplesr_; qplesr_ = 0x1002ed80 + .global qploas_; qploas_ = 0x1002ed90 + .global qpmaxd_; qpmaxd_ = 0x1002eda0 + .global qpmaxi_; qpmaxi_ = 0x1002edb0 + .global qpmaxr_; qpmaxr_ = 0x1002edc0 + .global qpmind_; qpmind_ = 0x1002edd0 + .global qpmini_; qpmini_ = 0x1002ede0 + .global qpminr_; qpminr_ = 0x1002edf0 + .global qpmkfe_; qpmkfe_ = 0x1002ee00 + .global qpnexk_; qpnexk_ = 0x1002ee10 + .global qpofnl_; qpofnl_ = 0x1002ee20 + .global qpofns_; qpofns_ = 0x1002ee30 + .global qpofnu_; qpofnu_ = 0x1002ee40 + .global qpopen_; qpopen_ = 0x1002ee50 + .global qpopet_; qpopet_ = 0x1002ee60 + .global qppare_; qppare_ = 0x1002ee70 + .global qpparl_; qpparl_ = 0x1002ee80 + .global qppcle_; qppcle_ = 0x1002ee90 + .global qppopn_; qppopn_ = 0x1002eea0 + .global qppstr_; qppstr_ = 0x1002eeb0 + .global qpputb_; qpputb_ = 0x1002eec0 + .global qpputc_; qpputc_ = 0x1002eed0 + .global qpputd_; qpputd_ = 0x1002eee0 + .global qpputi_; qpputi_ = 0x1002eef0 + .global qpputl_; qpputl_ = 0x1002ef00 + .global qpputm_; qpputm_ = 0x1002ef10 + .global qpputr_; qpputr_ = 0x1002ef20 + .global qpputs_; qpputs_ = 0x1002ef30 + .global qpputx_; qpputx_ = 0x1002ef40 + .global qpquef_; qpquef_ = 0x1002ef50 + .global qprawk_; qprawk_ = 0x1002ef60 + .global qpread_; qpread_ = 0x1002ef70 + .global qprebd_; qprebd_ = 0x1002ef80 + .global qprene_; qprene_ = 0x1002ef90 + .global qprenf_; qprenf_ = 0x1002efa0 + .global qprlmd_; qprlmd_ = 0x1002efb0 + .global qprlmi_; qprlmi_ = 0x1002efc0 + .global qprlmr_; qprlmr_ = 0x1002efd0 + .global qpsavs_; qpsavs_ = 0x1002efe0 + .global qpseel_; qpseel_ = 0x1002eff0 + .global qpseti_; qpseti_ = 0x1002f000 + .global qpsetr_; qpsetr_ = 0x1002f010 + .global qpsizf_; qpsizf_ = 0x1002f020 + .global qpstai_; qpstai_ = 0x1002f030 + .global qpstar_; qpstar_ = 0x1002f040 + .global qpsync_; qpsync_ = 0x1002f050 + .global qpungk_; qpungk_ = 0x1002f060 + .global qpwrie_; qpwrie_ = 0x1002f070 + .global qpxgvd_; qpxgvd_ = 0x1002f080 + .global qpxgvi_; qpxgvi_ = 0x1002f090 + .global qpxgvl_; qpxgvl_ = 0x1002f0a0 + .global qpxgvr_; qpxgvr_ = 0x1002f0b0 + .global qpxgvs_; qpxgvs_ = 0x1002f0c0 + .global r1mach_; r1mach_ = 0x1002f0d0 + .global r2tr_; r2tr_ = 0x1002f0e0 + .global r2tx_; r2tx_ = 0x1002f0f0 + .global r4syn_; r4syn_ = 0x1002f100 + .global r4tr_; r4tr_ = 0x1002f110 + .global r4tx_; r4tx_ = 0x1002f120 + .global r8syn_; r8syn_ = 0x1002f130 + .global r8tr_; r8tr_ = 0x1002f140 + .global r8tx_; r8tx_ = 0x1002f150 + .global rdukey_; rdukey_ = 0x1002f160 + .global reopen_; reopen_ = 0x1002f170 + .global resetn_; resetn_ = 0x1002f180 + .global salloc_; salloc_ = 0x1002f190 + .global scanc_; scanc_ = 0x1002f1a0 + .global sfree_; sfree_ = 0x1002f1b0 + .global shifti_; shifti_ = 0x1002f1c0 + .global shiftl_; shiftl_ = 0x1002f1d0 + .global shifts_; shifts_ = 0x1002f1e0 + .global smark_; smark_ = 0x1002f1f0 + .global sprinf_; sprinf_ = 0x1002f200 + .global sscan_; sscan_ = 0x1002f210 + .global stallc_; stallc_ = 0x1002f220 + .global stcloe_; stcloe_ = 0x1002f230 + .global stentr_; stentr_ = 0x1002f240 + .global stfacs_; stfacs_ = 0x1002f250 + .global stfadr_; stfadr_ = 0x1002f260 + .global stfcle_; stfcle_ = 0x1002f270 + .global stfcos_; stfcos_ = 0x1002f280 + .global stfcoy_; stfcoy_ = 0x1002f290 + .global stfcte_; stfcte_ = 0x1002f2a0 + .global stfdee_; stfdee_ = 0x1002f2b0 + .global stfgeb_; stfgeb_ = 0x1002f2c0 + .global stfgei_; stfgei_ = 0x1002f2d0 + .global stfgen_; stfgen_ = 0x1002f2e0 + .global stfges_; stfges_ = 0x1002f2f0 + .global stfget_; stfget_ = 0x1002f300 + .global stfind_; stfind_ = 0x1002f310 + .global stfinl_; stfinl_ = 0x1002f320 + .global stfins_; stfins_ = 0x1002f330 + .global stfmeb_; stfmeb_ = 0x1002f340 + .global stfmke_; stfmke_ = 0x1002f350 + .global stfnee_; stfnee_ = 0x1002f360 + .global stfopn_; stfopn_ = 0x1002f370 + .global stfopx_; stfopx_ = 0x1002f380 + .global stforb_; stforb_ = 0x1002f390 + .global stfrdr_; stfrdr_ = 0x1002f3a0 + .global stfree_; stfree_ = 0x1002f3b0 + .global stfrek_; stfrek_ = 0x1002f3c0 + .global stfrfr_; stfrfr_ = 0x1002f3d0 + .global stfrgb_; stfrgb_ = 0x1002f3e0 + .global stfrne_; stfrne_ = 0x1002f3f0 + .global stfupr_; stfupr_ = 0x1002f400 + .global stfwfr_; stfwfr_ = 0x1002f410 + .global stfwgb_; stfwgb_ = 0x1002f420 + .global sthash_; sthash_ = 0x1002f430 + .global sthead_; sthead_ = 0x1002f440 + .global stinfo_; stinfo_ = 0x1002f450 + .global stkmkg_; stkmkg_ = 0x1002f460 + .global stmark_; stmark_ = 0x1002f470 + .global stname_; stname_ = 0x1002f480 + .global stnext_; stnext_ = 0x1002f490 + .global stnsys_; stnsys_ = 0x1002f4a0 + .global stopen_; stopen_ = 0x1002f4b0 + .global stpstr_; stpstr_ = 0x1002f4c0 + .global strcle_; strcle_ = 0x1002f4d0 + .global strdic_; strdic_ = 0x1002f4e0 + .global strefb_; strefb_ = 0x1002f4f0 + .global streff_; streff_ = 0x1002f500 + .global streq_; streq_ = 0x1002f510 + .global strese_; strese_ = 0x1002f520 + .global strge_; strge_ = 0x1002f530 + .global strgee_; strgee_ = 0x1002f540 + .global strgt_; strgt_ = 0x1002f550 + .global strids_; strids_ = 0x1002f560 + .global stridx_; stridx_ = 0x1002f570 + .global strlds_; strlds_ = 0x1002f580 + .global strldx_; strldx_ = 0x1002f590 + .global strle_; strle_ = 0x1002f5a0 + .global strlt_; strlt_ = 0x1002f5b0 + .global strlwr_; strlwr_ = 0x1002f5c0 + .global strmac_; strmac_ = 0x1002f5d0 + .global strmah_; strmah_ = 0x1002f5e0 + .global strncp_; strncp_ = 0x1002f5f0 + .global strne_; strne_ = 0x1002f600 + .global stropn_; stropn_ = 0x1002f610 + .global strpak_; strpak_ = 0x1002f620 + .global strse1_; strse1_ = 0x1002f630 + .global strsee_; strsee_ = 0x1002f640 + .global strseh_; strseh_ = 0x1002f650 + .global strsrt_; strsrt_ = 0x1002f660 + .global strtbl_; strtbl_ = 0x1002f670 + .global strupk_; strupk_ = 0x1002f680 + .global strupr_; strupr_ = 0x1002f690 + .global stsave_; stsave_ = 0x1002f6a0 + .global stsize_; stsize_ = 0x1002f6b0 + .global stsque_; stsque_ = 0x1002f6c0 + .global sttyco_; sttyco_ = 0x1002f6d0 + .global sttyet_; sttyet_ = 0x1002f6e0 + .global sttygg_; sttygg_ = 0x1002f6f0 + .global sttynm_; sttynm_ = 0x1002f700 + .global sttyse_; sttyse_ = 0x1002f710 + .global sttysm_; sttysm_ = 0x1002f720 + .global sttytt_; sttytt_ = 0x1002f730 + .global syserr_; syserr_ = 0x1002f740 + .global sysers_; sysers_ = 0x1002f750 + .global sysged_; sysged_ = 0x1002f760 + .global sysges_; sysges_ = 0x1002f770 + .global sysgsg_; sysgsg_ = 0x1002f780 + .global sysid_; sysid_ = 0x1002f790 + .global sysmte_; sysmte_ = 0x1002f7a0 + .global syspac_; syspac_ = 0x1002f7b0 + .global syspat_; syspat_ = 0x1002f7c0 + .global syspte_; syspte_ = 0x1002f7d0 + .global sysret_; sysret_ = 0x1002f7e0 + .global syssct_; syssct_ = 0x1002f7f0 + .global tsleep_; tsleep_ = 0x1002f800 + .global ttopen_; ttopen_ = 0x1002f810 + .global ttseti_; ttseti_ = 0x1002f820 + .global ttsets_; ttsets_ = 0x1002f830 + .global ttstai_; ttstai_ = 0x1002f840 + .global ttstas_; ttstas_ = 0x1002f850 + .global ttybih_; ttybih_ = 0x1002f860 + .global ttybre_; ttybre_ = 0x1002f870 + .global ttycas_; ttycas_ = 0x1002f880 + .global ttycds_; ttycds_ = 0x1002f890 + .global ttycle_; ttycle_ = 0x1002f8a0 + .global ttycln_; ttycln_ = 0x1002f8b0 + .global ttyclr_; ttyclr_ = 0x1002f8c0 + .global ttyctl_; ttyctl_ = 0x1002f8d0 + .global ttydee_; ttydee_ = 0x1002f8e0 + .global ttydey_; ttydey_ = 0x1002f8f0 + .global ttyeny_; ttyeny_ = 0x1002f900 + .global ttyexs_; ttyexs_ = 0x1002f910 + .global ttyfey_; ttyfey_ = 0x1002f920 + .global ttyfiy_; ttyfiy_ = 0x1002f930 + .global ttygds_; ttygds_ = 0x1002f940 + .global ttygeb_; ttygeb_ = 0x1002f950 + .global ttygei_; ttygei_ = 0x1002f960 + .global ttyger_; ttyger_ = 0x1002f970 + .global ttyges_; ttyges_ = 0x1002f980 + .global ttygoo_; ttygoo_ = 0x1002f990 + .global ttygpe_; ttygpe_ = 0x1002f9a0 + .global ttygse_; ttygse_ = 0x1002f9b0 + .global ttyins_; ttyins_ = 0x1002f9c0 + .global ttyint_; ttyint_ = 0x1002f9d0 + .global ttylod_; ttylod_ = 0x1002f9e0 + .global ttyods_; ttyods_ = 0x1002f9f0 + .global ttyopn_; ttyopn_ = 0x1002fa00 + .global ttypue_; ttypue_ = 0x1002fa10 + .global ttypus_; ttypus_ = 0x1002fa20 + .global ttyred_; ttyred_ = 0x1002fa30 + .global ttysce_; ttysce_ = 0x1002fa40 + .global ttysei_; ttysei_ = 0x1002fa50 + .global ttyso_; ttyso_ = 0x1002fa60 + .global ttysti_; ttysti_ = 0x1002fa70 + .global ttysui_; ttysui_ = 0x1002fa80 + .global ttywre_; ttywre_ = 0x1002fa90 + .global ungete_; ungete_ = 0x1002faa0 + .global ungeti_; ungeti_ = 0x1002fab0 + .global unread_; unread_ = 0x1002fac0 + .global urand_; urand_ = 0x1002fad0 + .global vfnadd_; vfnadd_ = 0x1002fae0 + .global vfncle_; vfncle_ = 0x1002faf0 + .global vfndee_; vfndee_ = 0x1002fb00 + .global vfndel_; vfndel_ = 0x1002fb10 + .global vfnene_; vfnene_ = 0x1002fb20 + .global vfnenr_; vfnenr_ = 0x1002fb30 + .global vfnexr_; vfnexr_ = 0x1002fb40 + .global vfngen_; vfngen_ = 0x1002fb50 + .global vfnise_; vfnise_ = 0x1002fb60 + .global vfnman_; vfnman_ = 0x1002fb70 + .global vfnmap_; vfnmap_ = 0x1002fb80 + .global vfnmau_; vfnmau_ = 0x1002fb90 + .global vfnopn_; vfnopn_ = 0x1002fba0 + .global vfnsqe_; vfnsqe_ = 0x1002fbb0 + .global vfntre_; vfntre_ = 0x1002fbc0 + .global vfnunn_; vfnunn_ = 0x1002fbd0 + .global vfnunp_; vfnunp_ = 0x1002fbe0 + .global vlibinit_; vlibinit_ = 0x1002fbf0 + .global vmallc_; vmallc_ = 0x1002fc00 + .global vvfncm_; vvfncm_ = 0x1002fc10 + .global vvfnee_; vvfnee_ = 0x1002fc20 + .global vvfnip_; vvfnip_ = 0x1002fc30 + .global vvfnis_; vvfnis_ = 0x1002fc40 + .global vvfnre_; vvfnre_ = 0x1002fc50 + .global wfaitd_; wfaitd_ = 0x1002fc60 + .global wfaitt_; wfaitt_ = 0x1002fc70 + .global wfaitv_; wfaitv_ = 0x1002fc80 + .global wfarcd_; wfarcd_ = 0x1002fc90 + .global wfarct_; wfarct_ = 0x1002fca0 + .global wfarcv_; wfarcv_ = 0x1002fcb0 + .global wfcard_; wfcard_ = 0x1002fcc0 + .global wfcart_; wfcart_ = 0x1002fcd0 + .global wfcarv_; wfcarv_ = 0x1002fce0 + .global wfcscd_; wfcscd_ = 0x1002fcf0 + .global wfcsct_; wfcsct_ = 0x1002fd00 + .global wfcscv_; wfcscv_ = 0x1002fd10 + .global wfdecs_; wfdecs_ = 0x1002fd20 + .global wffnld_; wffnld_ = 0x1002fd30 + .global wfglsd_; wfglsd_ = 0x1002fd40 + .global wfglst_; wfglst_ = 0x1002fd50 + .global wfglsv_; wfglsv_ = 0x1002fd60 + .global wfgsbb_; wfgsbb_ = 0x1002fd70 + .global wfgsbg_; wfgsbg_ = 0x1002fd80 + .global wfgsbl_; wfgsbl_ = 0x1002fd90 + .global wfgsce_; wfgsce_ = 0x1002fda0 + .global wfgscf_; wfgscf_ = 0x1002fdb0 + .global wfgsdr_; wfgsdr_ = 0x1002fdc0 + .global wfgsel_; wfgsel_ = 0x1002fdd0 + .global wfgson_; wfgson_ = 0x1002fde0 + .global wfgsre_; wfgsre_ = 0x1002fdf0 + .global wfinit_; wfinit_ = 0x1002fe00 + .global wfmerd_; wfmerd_ = 0x1002fe10 + .global wfmert_; wfmert_ = 0x1002fe20 + .global wfmerv_; wfmerv_ = 0x1002fe30 + .global wfmold_; wfmold_ = 0x1002fe40 + .global wfmolt_; wfmolt_ = 0x1002fe50 + .global wfmolv_; wfmolv_ = 0x1002fe60 + .global wfmspd_; wfmspd_ = 0x1002fe70 + .global wfmspf_; wfmspf_ = 0x1002fe80 + .global wfmspi_; wfmspi_ = 0x1002fe90 + .global wfmspl_; wfmspl_ = 0x1002fea0 + .global wfmspt_; wfmspt_ = 0x1002feb0 + .global wfmspv_; wfmspv_ = 0x1002fec0 + .global wfmspy_; wfmspy_ = 0x1002fed0 + .global wfpard_; wfpard_ = 0x1002fee0 + .global wfpart_; wfpart_ = 0x1002fef0 + .global wfparv_; wfparv_ = 0x1002ff00 + .global wfpcod_; wfpcod_ = 0x1002ff10 + .global wfpcot_; wfpcot_ = 0x1002ff20 + .global wfpcov_; wfpcov_ = 0x1002ff30 + .global wfqscd_; wfqscd_ = 0x1002ff40 + .global wfqsct_; wfqsct_ = 0x1002ff50 + .global wfqscv_; wfqscv_ = 0x1002ff60 + .global wfsind_; wfsind_ = 0x1002ff70 + .global wfsint_; wfsint_ = 0x1002ff80 + .global wfsinv_; wfsinv_ = 0x1002ff90 + .global wfsmph_; wfsmph_ = 0x1002ffa0 + .global wfsmpn_; wfsmpn_ = 0x1002ffb0 + .global wfsmpt_; wfsmpt_ = 0x1002ffc0 + .global wfstgd_; wfstgd_ = 0x1002ffd0 + .global wfstgt_; wfstgt_ = 0x1002ffe0 + .global wfstgv_; wfstgv_ = 0x1002fff0 + .global wftand_; wftand_ = 0x10030000 + .global wftant_; wftant_ = 0x10030010 + .global wftanv_; wftanv_ = 0x10030020 + .global wftnxd_; wftnxd_ = 0x10030030 + .global wftnxt_; wftnxt_ = 0x10030040 + .global wftnxv_; wftnxv_ = 0x10030050 + .global wftnxy_; wftnxy_ = 0x10030060 + .global wftscd_; wftscd_ = 0x10030070 + .global wftsct_; wftsct_ = 0x10030080 + .global wftscv_; wftscv_ = 0x10030090 + .global wfzead_; wfzead_ = 0x100300a0 + .global wfzeat_; wfzeat_ = 0x100300b0 + .global wfzeav_; wfzeav_ = 0x100300c0 + .global wfzpxd_; wfzpxd_ = 0x100300d0 + .global wfzpxt_; wfzpxt_ = 0x100300e0 + .global wfzpxv_; wfzpxv_ = 0x100300f0 + .global wfzpxy_; wfzpxy_ = 0x10030100 + .global xalloe_; xalloe_ = 0x10030110 + .global xcallc_; xcallc_ = 0x10030120 + .global xdeale_; xdeale_ = 0x10030130 + .global xdevor_; xdevor_ = 0x10030140 + .global xdevss_; xdevss_ = 0x10030150 + .global xeract_; xeract_ = 0x10030160 + .global xerfmg_; xerfmg_ = 0x10030170 + .global xerpoi_; xerpoi_ = 0x10030180 + .global xerpop_; xerpop_ = 0x10030190 + .global xerpsh_; xerpsh_ = 0x100301a0 + .global xerpsr_; xerpsr_ = 0x100301b0 + .global xerpuc_; xerpuc_ = 0x100301c0 + .global xerpue_; xerpue_ = 0x100301d0 + .global xerret_; xerret_ = 0x100301e0 + .global xerror_; xerror_ = 0x100301f0 + .global xersel_; xersel_ = 0x10030200 + .global xervey_; xervey_ = 0x10030210 + .global xevadg_; xevadg_ = 0x10030220 + .global xevbip_; xevbip_ = 0x10030230 + .global xevbop_; xevbop_ = 0x10030240 + .global xevcan_; xevcan_ = 0x10030250 + .global xever1_; xever1_ = 0x10030260 + .global xever2_; xever2_ = 0x10030270 + .global xeverr_; xeverr_ = 0x10030280 + .global xevfrp_; xevfrp_ = 0x10030290 + .global xevgek_; xevgek_ = 0x100302a0 + .global xevinp_; xevinp_ = 0x100302b0 + .global xevmap_; xevmap_ = 0x100302c0 + .global xevnee_; xevnee_ = 0x100302d0 + .global xevpae_; xevpae_ = 0x100302e0 + .global xevpah_; xevpah_ = 0x100302f0 + .global xevqut_; xevqut_ = 0x10030300 + .global xevstt_; xevstt_ = 0x10030310 + .global xevunp_; xevunp_ = 0x10030320 + .global xfaccs_; xfaccs_ = 0x10030330 + .global xfatal_; xfatal_ = 0x10030340 + .global xfchdr_; xfchdr_ = 0x10030350 + .global xfcloe_; xfcloe_ = 0x10030360 + .global xfdele_; xfdele_ = 0x10030370 + .global xffluh_; xffluh_ = 0x10030380 + .global xfgetc_; xfgetc_ = 0x10030390 + .global xfgetr_; xfgetr_ = 0x100303a0 + .global xfnote_; xfnote_ = 0x100303b0 + .global xfopen_; xfopen_ = 0x100303c0 + .global xfputc_; xfputc_ = 0x100303d0 + .global xfputr_; xfputr_ = 0x100303e0 + .global xfread_; xfread_ = 0x100303f0 + .global xfrnam_; xfrnam_ = 0x10030400 + .global xfscan_; xfscan_ = 0x10030410 + .global xfseek_; xfseek_ = 0x10030420 + .global xfungc_; xfungc_ = 0x10030430 + .global xfwrie_; xfwrie_ = 0x10030440 + .global xgdevt_; xgdevt_ = 0x10030450 + .global xgtpid_; xgtpid_ = 0x10030460 + .global xgtuid_; xgtuid_ = 0x10030470 + .global xisaty_; xisaty_ = 0x10030480 + .global xmallc_; xmallc_ = 0x10030490 + .global xmfree_; xmfree_ = 0x100304a0 + .global xmjbuf_; xmjbuf_ = 0x100304b0 + .global xmktep_; xmktep_ = 0x100304c0 + .global xonerr_; xonerr_ = 0x100304d0 + .global xonext_; xonext_ = 0x100304e0 + .global xori_; xori_ = 0x100304f0 + .global xorl_; xorl_ = 0x10030500 + .global xors_; xors_ = 0x10030510 + .global xpages_; xpages_ = 0x10030520 + .global xprinf_; xprinf_ = 0x10030530 + .global xqsort_; xqsort_ = 0x10030540 + .global xrealc_; xrealc_ = 0x10030550 + .global xsizef_; xsizef_ = 0x10030560 + .global xstdeh_; xstdeh_ = 0x10030570 + .global xstrcp_; xstrcp_ = 0x10030580 + .global xstrct_; xstrct_ = 0x10030590 + .global xstrcy_; xstrcy_ = 0x100305a0 + .global xstrln_; xstrln_ = 0x100305b0 + .global xtoc_; xtoc_ = 0x100305c0 + .global xttyse_; xttyse_ = 0x100305d0 + .global xvvadg_; xvvadg_ = 0x100305e0 + .global xvvbip_; xvvbip_ = 0x100305f0 + .global xvvbop_; xvvbop_ = 0x10030600 + .global xvvcan_; xvvcan_ = 0x10030610 + .global xvvche_; xvvche_ = 0x10030620 + .global xvver1_; xvver1_ = 0x10030630 + .global xvver2_; xvver2_ = 0x10030640 + .global xvverr_; xvverr_ = 0x10030650 + .global xvvfrp_; xvvfrp_ = 0x10030660 + .global xvvgek_; xvvgek_ = 0x10030670 + .global xvvinp_; xvvinp_ = 0x10030680 + .global xvvlos_; xvvlos_ = 0x10030690 + .global xvvmap_; xvvmap_ = 0x100306a0 + .global xvvnee_; xvvnee_ = 0x100306b0 + .global xvvnud_; xvvnud_ = 0x100306c0 + .global xvvnui_; xvvnui_ = 0x100306d0 + .global xvvnul_; xvvnul_ = 0x100306e0 + .global xvvnur_; xvvnur_ = 0x100306f0 + .global xvvnus_; xvvnus_ = 0x10030700 + .global xvvpae_; xvvpae_ = 0x10030710 + .global xvvpah_; xvvpah_ = 0x10030720 + .global xvvqut_; xvvqut_ = 0x10030730 + .global xvvstt_; xvvstt_ = 0x10030740 + .global xvvunp_; xvvunp_ = 0x10030750 + .global xwhen_; xwhen_ = 0x10030760 + .global xxscan_; xxscan_ = 0x10030770 + .global zardbf_; zardbf_ = 0x10030780 + .global zardgd_; zardgd_ = 0x10030790 + .global zardks_; zardks_ = 0x100307a0 + .global zardlp_; zardlp_ = 0x100307b0 + .global zardmt_; zardmt_ = 0x100307c0 + .global zardnd_; zardnd_ = 0x100307d0 + .global zardnu_; zardnu_ = 0x100307e0 + .global zardpl_; zardpl_ = 0x100307f0 + .global zardpr_; zardpr_ = 0x10030800 + .global zardps_; zardps_ = 0x10030810 + .global zardsf_; zardsf_ = 0x10030820 + .global zawrbf_; zawrbf_ = 0x10030830 + .global zawrgd_; zawrgd_ = 0x10030840 + .global zawrks_; zawrks_ = 0x10030850 + .global zawrlp_; zawrlp_ = 0x10030860 + .global zawrmt_; zawrmt_ = 0x10030870 + .global zawrnd_; zawrnd_ = 0x10030880 + .global zawrnu_; zawrnu_ = 0x10030890 + .global zawrpl_; zawrpl_ = 0x100308a0 + .global zawrpr_; zawrpr_ = 0x100308b0 + .global zawrps_; zawrps_ = 0x100308c0 + .global zawrsf_; zawrsf_ = 0x100308d0 + .global zawset_; zawset_ = 0x100308e0 + .global zawtbf_; zawtbf_ = 0x100308f0 + .global zawtgd_; zawtgd_ = 0x10030900 + .global zawtks_; zawtks_ = 0x10030910 + .global zawtlp_; zawtlp_ = 0x10030920 + .global zawtmt_; zawtmt_ = 0x10030930 + .global zawtnd_; zawtnd_ = 0x10030940 + .global zawtnu_; zawtnu_ = 0x10030950 + .global zawtpl_; zawtpl_ = 0x10030960 + .global zawtpr_; zawtpr_ = 0x10030970 + .global zawtps_; zawtps_ = 0x10030980 + .global zawtsf_; zawtsf_ = 0x10030990 + .global zclcpr_; zclcpr_ = 0x100309a0 + .global zcldir_; zcldir_ = 0x100309b0 + .global zcldpr_; zcldpr_ = 0x100309c0 + .global zclm70_; zclm70_ = 0x100309d0 + .global zclm75_; zclm75_ = 0x100309e0 + .global zclsbf_; zclsbf_ = 0x100309f0 + .global zclsgd_; zclsgd_ = 0x10030a00 + .global zclsks_; zclsks_ = 0x10030a10 + .global zclslp_; zclslp_ = 0x10030a20 + .global zclsmt_; zclsmt_ = 0x10030a30 + .global zclsnd_; zclsnd_ = 0x10030a40 + .global zclsnu_; zclsnu_ = 0x10030a50 + .global zclspl_; zclspl_ = 0x10030a60 + .global zclsps_; zclsps_ = 0x10030a70 + .global zclssf_; zclssf_ = 0x10030a80 + .global zclstt_; zclstt_ = 0x10030a90 + .global zclstx_; zclstx_ = 0x10030aa0 + .global zclsty_; zclsty_ = 0x10030ab0 + .global zdojmp_; zdojmp_ = 0x10030ac0 + .global zdvall_; zdvall_ = 0x10030ad0 + .global zdvown_; zdvown_ = 0x10030ae0 + .global zfacss_; zfacss_ = 0x10030af0 + .global zfaloc_; zfaloc_ = 0x10030b00 + .global zfchdr_; zfchdr_ = 0x10030b10 + .global zfdele_; zfdele_ = 0x10030b20 + .global zfgcwd_; zfgcwd_ = 0x10030b30 + .global zfinfo_; zfinfo_ = 0x10030b40 + .global zflsnu_; zflsnu_ = 0x10030b50 + .global zflstt_; zflstt_ = 0x10030b60 + .global zflstx_; zflstx_ = 0x10030b70 + .global zflsty_; zflsty_ = 0x10030b80 + .global zfmkcp_; zfmkcp_ = 0x10030b90 + .global zfmkdr_; zfmkdr_ = 0x10030ba0 + .global zfnbrk_; zfnbrk_ = 0x10030bb0 + .global zfpath_; zfpath_ = 0x10030bc0 + .global zfprot_; zfprot_ = 0x10030bd0 + .global zfrnam_; zfrnam_ = 0x10030be0 + .global zfsubd_; zfsubd_ = 0x10030bf0 + .global zfxdir_; zfxdir_ = 0x10030c00 + .global zgcmdl_; zgcmdl_ = 0x10030c10 + .global zgetnu_; zgetnu_ = 0x10030c20 + .global zgettt_; zgettt_ = 0x10030c30 + .global zgettx_; zgettx_ = 0x10030c40 + .global zgetty_; zgetty_ = 0x10030c50 + .global zgfdir_; zgfdir_ = 0x10030c60 + .global zghost_; zghost_ = 0x10030c70 + .global zgmtco_; zgmtco_ = 0x10030c80 + .global zgtime_; zgtime_ = 0x10030c90 + .global zgtpid_; zgtpid_ = 0x10030ca0 + .global zintpr_; zintpr_ = 0x10030cb0 + .global zlocpr_; zlocpr_ = 0x10030cc0 + .global zlocva_; zlocva_ = 0x10030cd0 + .global zmaloc_; zmaloc_ = 0x10030ce0 + .global zmfree_; zmfree_ = 0x10030cf0 + .global znotnu_; znotnu_ = 0x10030d00 + .global znottt_; znottt_ = 0x10030d10 + .global znottx_; znottx_ = 0x10030d20 + .global znotty_; znotty_ = 0x10030d30 + .global zopcpr_; zopcpr_ = 0x10030d40 + .global zopdir_; zopdir_ = 0x10030d50 + .global zopdpr_; zopdpr_ = 0x10030d60 + .global zopm70_; zopm70_ = 0x10030d70 + .global zopm75_; zopm75_ = 0x10030d80 + .global zopnbf_; zopnbf_ = 0x10030d90 + .global zopngd_; zopngd_ = 0x10030da0 + .global zopnks_; zopnks_ = 0x10030db0 + .global zopnlp_; zopnlp_ = 0x10030dc0 + .global zopnmt_; zopnmt_ = 0x10030dd0 + .global zopnnd_; zopnnd_ = 0x10030de0 + .global zopnnu_; zopnnu_ = 0x10030df0 + .global zopnpl_; zopnpl_ = 0x10030e00 + .global zopnsf_; zopnsf_ = 0x10030e10 + .global zopntt_; zopntt_ = 0x10030e20 + .global zopntx_; zopntx_ = 0x10030e30 + .global zopnty_; zopnty_ = 0x10030e40 + .global zoscmd_; zoscmd_ = 0x10030e50 + .global zpanic_; zpanic_ = 0x10030e60 + .global zputnu_; zputnu_ = 0x10030e70 + .global zputtt_; zputtt_ = 0x10030e80 + .global zputtx_; zputtx_ = 0x10030e90 + .global zputty_; zputty_ = 0x10030ea0 + .global zraloc_; zraloc_ = 0x10030eb0 + .global zrdm70_; zrdm70_ = 0x10030ec0 + .global zrdm75_; zrdm75_ = 0x10030ed0 + .global zseknu_; zseknu_ = 0x10030ee0 + .global zsektt_; zsektt_ = 0x10030ef0 + .global zsektx_; zsektx_ = 0x10030f00 + .global zsekty_; zsekty_ = 0x10030f10 + .global zsestt_; zsestt_ = 0x10030f20 + .global zsettt_; zsettt_ = 0x10030f30 + .global zstm70_; zstm70_ = 0x10030f40 + .global zstm75_; zstm75_ = 0x10030f50 + .global zststt_; zststt_ = 0x10030f60 + .global zsttbf_; zsttbf_ = 0x10030f70 + .global zsttgd_; zsttgd_ = 0x10030f80 + .global zsttks_; zsttks_ = 0x10030f90 + .global zsttlp_; zsttlp_ = 0x10030fa0 + .global zsttmt_; zsttmt_ = 0x10030fb0 + .global zsttnd_; zsttnd_ = 0x10030fc0 + .global zsttnu_; zsttnu_ = 0x10030fd0 + .global zsttpl_; zsttpl_ = 0x10030fe0 + .global zsttpr_; zsttpr_ = 0x10030ff0 + .global zsttps_; zsttps_ = 0x10031000 + .global zsttsf_; zsttsf_ = 0x10031010 + .global zstttt_; zstttt_ = 0x10031020 + .global zstttx_; zstttx_ = 0x10031030 + .global zsttty_; zsttty_ = 0x10031040 + .global zttgeg_; zttgeg_ = 0x10031050 + .global zttger_; zttger_ = 0x10031060 + .global zttloe_; zttloe_ = 0x10031070 + .global zttloo_; zttloo_ = 0x10031080 + .global zttlov_; zttlov_ = 0x10031090 + .global zttpbf_; zttpbf_ = 0x100310a0 + .global zttplk_; zttplk_ = 0x100310b0 + .global zttpug_; zttpug_ = 0x100310c0 + .global zttquy_; zttquy_ = 0x100310d0 + .global zttttt_; zttttt_ = 0x100310e0 + .global zttupe_; zttupe_ = 0x100310f0 + .global zwmsec_; zwmsec_ = 0x10031100 + .global zwrm70_; zwrm70_ = 0x10031110 + .global zwrm75_; zwrm75_ = 0x10031120 + .global zwtm70_; zwtm70_ = 0x10031130 + .global zwtm75_; zwtm75_ = 0x10031140 + .global zxgmes_; zxgmes_ = 0x10031150 + .global zxwhen_; zxwhen_ = 0x10031160 + .global zzclmt_; zzclmt_ = 0x10031170 + .global zzopmt_; zzopmt_ = 0x10031180 + .global zzrdii_; zzrdii_ = 0x10031190 + .global zzrdmt_; zzrdmt_ = 0x100311a0 + .global zzrwmt_; zzrwmt_ = 0x100311b0 + .global zzsetk_; zzsetk_ = 0x100311c0 + .global zzstmt_; zzstmt_ = 0x100311d0 + .global zzwrii_; zzwrii_ = 0x100311e0 + .global zzwrmt_; zzwrmt_ = 0x100311f0 + .global zzwtmt_; zzwtmt_ = 0x10031200 + .global zzzend_; zzzend_ = 0x10031210 + .global fxfnoe_; fxfnoe_ = 0x10031220 + .global futime_; futime_ = 0x10031230 + .global kfutim_; kfutim_ = 0x10031240 + .global zfutim_; zfutim_ = 0x10031250 + .global dtmday_; dtmday_ = 0x10031260 + .global dtmlte_; dtmlte_ = 0x10031270 + .global poll_; poll_ = 0x10031280 + .global pollce_; pollce_ = 0x10031290 + .global pollcr_; pollcr_ = 0x100312a0 + .global pollgs_; pollgs_ = 0x100312b0 + .global pollon_; pollon_ = 0x100312c0 + .global pollpt_; pollpt_ = 0x100312d0 + .global pollst_; pollst_ = 0x100312e0 + .global polltt_; polltt_ = 0x100312f0 + .global pollzo_; pollzo_ = 0x10031300 + .global zfpoll_; zfpoll_ = 0x10031310 + .global vshend_ +vshend_: diff --git a/unix/shlib/S.ver.f68881 b/unix/shlib/S.ver.f68881 new file mode 100644 index 00000000..7f8f011e --- /dev/null +++ b/unix/shlib/S.ver.f68881 @@ -0,0 +1 @@ +7 diff --git a/unix/shlib/S.ver.ffpa b/unix/shlib/S.ver.ffpa new file mode 100644 index 00000000..7f8f011e --- /dev/null +++ b/unix/shlib/S.ver.ffpa @@ -0,0 +1 @@ +7 diff --git a/unix/shlib/S.ver.generic b/unix/shlib/S.ver.generic new file mode 100644 index 00000000..d00491fd --- /dev/null +++ b/unix/shlib/S.ver.generic @@ -0,0 +1 @@ +1 diff --git a/unix/shlib/S.ver.i386 b/unix/shlib/S.ver.i386 new file mode 100644 index 00000000..7ed6ff82 --- /dev/null +++ b/unix/shlib/S.ver.i386 @@ -0,0 +1 @@ +5 diff --git a/unix/shlib/S.ver.pg b/unix/shlib/S.ver.pg new file mode 100644 index 00000000..0cfbf088 --- /dev/null +++ b/unix/shlib/S.ver.pg @@ -0,0 +1 @@ +2 diff --git a/unix/shlib/S.ver.sparc b/unix/shlib/S.ver.sparc new file mode 100644 index 00000000..45a4fb75 --- /dev/null +++ b/unix/shlib/S.ver.sparc @@ -0,0 +1 @@ +8 diff --git a/unix/shlib/S.ver.ssun b/unix/shlib/S.ver.ssun new file mode 100644 index 00000000..48082f72 --- /dev/null +++ b/unix/shlib/S.ver.ssun @@ -0,0 +1 @@ +12 diff --git a/unix/shlib/Slib.c b/unix/shlib/Slib.c new file mode 100644 index 00000000..40e21968 --- /dev/null +++ b/unix/shlib/Slib.c @@ -0,0 +1,85 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* + * SLIB.C -- Support routines for the shared library. + */ + +extern unsigned vshlib_[]; +extern char *((*environ)[]); +extern char *Malloc(), *Realloc(), *Free(); + +main() +{ + /* Malloc etc. are produced by the MEDIT task - see mkshlib.csh. */ + vlibinit_ (environ, Malloc, Realloc, Free); + + /* Do something useful when S.e is called as a task. */ + printf ("Sun/IRAF Shared Library, version %d, %d symbols\n", + vshlib_[0], vshlib_[5]); + printf ("base=%x, etext=%x, edata=%x, end=%x, size=%dKb\n", + vshlib_[1], vshlib_[2], vshlib_[3], vshlib_[4], + (vshlib_[4] - vshlib_[1]) / 1000); +} + + +/* Back link to selected procedures and global variables in the client so + * that the shared library code can call routines executing in the runtime + * context of the client image. (Not intended to be portable). + */ +#define I_malloc 0 +#define I_realloc 1 +#define I_free 2 +#define I_len 3 + +#ifdef SOLARIS +#define I_dlopen 4 +#define I_dlclose 5 +#define I_dlsym 6 +#define I_dlerror 7 +#endif + +typedef int (*PFI)(); +static PFI fcn[I_len]; + +malloc (nb) { return (fcn[I_malloc](nb)); } +realloc (bp,nb) { return (fcn[I_realloc](bp,nb)); } +free (bp) { return (fcn[I_free](bp)); } + +#ifdef SOLARIS +void *dlopen (const char *pathname, int mode) + { return ((void *)fcn[I_dlopen] (pathname, mode)); } +int dlclose (void *handle) + { return ((int)fcn[I_dlclose] (handle)); } +void *dlsym (void *handle, const char *name) + { return ((void *)fcn[I_dlsym] (handle, name)); } +char *dlerror (void) + { return ((char *)fcn[I_dlerror]()); } + +vlibinit_ (u_environ, u_malloc, u_realloc, u_free, + u_dlopen, u_dlclose, u_dlsym, u_dlerror) +char *((*u_environ)[]); +PFI u_malloc, u_realloc, u_free; +PFI u_dlopen, u_dlclose, u_dlsym, u_dlerror; +{ + environ = u_environ; + fcn[I_malloc] = u_malloc; + fcn[I_realloc] = u_realloc; + fcn[I_free] = u_free; + fcn[I_dlopen] = u_dlopen; + fcn[I_dlclose] = u_dlclose; + fcn[I_dlsym] = u_dlsym; + fcn[I_dlerror] = u_dlerror; +} +#else + +vlibinit_ (u_environ, u_malloc, u_realloc, u_free) +char *((*u_environ)[]); +PFI u_malloc, u_realloc, u_free; +{ + environ = u_environ; + fcn[I_malloc] = u_malloc; + fcn[I_realloc] = u_realloc; + fcn[I_free] = u_free; +} +#endif diff --git a/unix/shlib/V.s b/unix/shlib/V.s new file mode 100644 index 00000000..62436960 --- /dev/null +++ b/unix/shlib/V.s @@ -0,0 +1,2886 @@ + .seg "text" + .common mem_,8 + mem_ = 0 + .common fiocom_,0x24660 +fiocom_: + .skip 0x24660 + .common xercom_,0x810 +xercom_: + .skip 0x810 + .skip ( 0x26000 - 0x78 - 0x24e70 ) + .global vshlib_ +vshlib_: + .long 12 + .long 0x10000000 + .long _etext + .long _edata + .long _end + .long 2864 + .long 5 + .long 8 + set aabsd_, %g1; jmp %g1; nop + set aabsi_, %g1; jmp %g1; nop + set aabsl_, %g1; jmp %g1; nop + set aabsr_, %g1; jmp %g1; nop + set aabss_, %g1; jmp %g1; nop + set aabsx_, %g1; jmp %g1; nop + set aaddd_, %g1; jmp %g1; nop + set aaddi_, %g1; jmp %g1; nop + set aaddkd_, %g1; jmp %g1; nop + set aaddki_, %g1; jmp %g1; nop + set aaddkl_, %g1; jmp %g1; nop + set aaddkr_, %g1; jmp %g1; nop + set aaddks_, %g1; jmp %g1; nop + set aaddkx_, %g1; jmp %g1; nop + set aaddl_, %g1; jmp %g1; nop + set aaddr_, %g1; jmp %g1; nop + set aadds_, %g1; jmp %g1; nop + set aaddx_, %g1; jmp %g1; nop + set aandi_, %g1; jmp %g1; nop + set aandki_, %g1; jmp %g1; nop + set aandkl_, %g1; jmp %g1; nop + set aandks_, %g1; jmp %g1; nop + set aandl_, %g1; jmp %g1; nop + set aands_, %g1; jmp %g1; nop + set aavgd_, %g1; jmp %g1; nop + set aavgi_, %g1; jmp %g1; nop + set aavgl_, %g1; jmp %g1; nop + set aavgr_, %g1; jmp %g1; nop + set aavgs_, %g1; jmp %g1; nop + set aavgx_, %g1; jmp %g1; nop + set abavd_, %g1; jmp %g1; nop + set abavi_, %g1; jmp %g1; nop + set abavl_, %g1; jmp %g1; nop + set abavr_, %g1; jmp %g1; nop + set abavs_, %g1; jmp %g1; nop + set abavx_, %g1; jmp %g1; nop + set abeqc_, %g1; jmp %g1; nop + set abeqd_, %g1; jmp %g1; nop + set abeqi_, %g1; jmp %g1; nop + set abeqkc_, %g1; jmp %g1; nop + set abeqkd_, %g1; jmp %g1; nop + set abeqki_, %g1; jmp %g1; nop + set abeqkl_, %g1; jmp %g1; nop + set abeqkr_, %g1; jmp %g1; nop + set abeqks_, %g1; jmp %g1; nop + set abeqkx_, %g1; jmp %g1; nop + set abeql_, %g1; jmp %g1; nop + set abeqr_, %g1; jmp %g1; nop + set abeqs_, %g1; jmp %g1; nop + set abeqx_, %g1; jmp %g1; nop + set abgec_, %g1; jmp %g1; nop + set abged_, %g1; jmp %g1; nop + set abgei_, %g1; jmp %g1; nop + set abgekc_, %g1; jmp %g1; nop + set abgekd_, %g1; jmp %g1; nop + set abgeki_, %g1; jmp %g1; nop + set abgekl_, %g1; jmp %g1; nop + set abgekr_, %g1; jmp %g1; nop + set abgeks_, %g1; jmp %g1; nop + set abgekx_, %g1; jmp %g1; nop + set abgel_, %g1; jmp %g1; nop + set abger_, %g1; jmp %g1; nop + set abges_, %g1; jmp %g1; nop + set abgex_, %g1; jmp %g1; nop + set abgtc_, %g1; jmp %g1; nop + set abgtd_, %g1; jmp %g1; nop + set abgti_, %g1; jmp %g1; nop + set abgtkc_, %g1; jmp %g1; nop + set abgtkd_, %g1; jmp %g1; nop + set abgtki_, %g1; jmp %g1; nop + set abgtkl_, %g1; jmp %g1; nop + set abgtkr_, %g1; jmp %g1; nop + set abgtks_, %g1; jmp %g1; nop + set abgtkx_, %g1; jmp %g1; nop + set abgtl_, %g1; jmp %g1; nop + set abgtr_, %g1; jmp %g1; nop + set abgts_, %g1; jmp %g1; nop + set abgtx_, %g1; jmp %g1; nop + set ablec_, %g1; jmp %g1; nop + set abled_, %g1; jmp %g1; nop + set ablei_, %g1; jmp %g1; nop + set ablekc_, %g1; jmp %g1; nop + set ablekd_, %g1; jmp %g1; nop + set ableki_, %g1; jmp %g1; nop + set ablekl_, %g1; jmp %g1; nop + set ablekr_, %g1; jmp %g1; nop + set ableks_, %g1; jmp %g1; nop + set ablekx_, %g1; jmp %g1; nop + set ablel_, %g1; jmp %g1; nop + set abler_, %g1; jmp %g1; nop + set ables_, %g1; jmp %g1; nop + set ablex_, %g1; jmp %g1; nop + set abltc_, %g1; jmp %g1; nop + set abltd_, %g1; jmp %g1; nop + set ablti_, %g1; jmp %g1; nop + set abltkc_, %g1; jmp %g1; nop + set abltkd_, %g1; jmp %g1; nop + set abltki_, %g1; jmp %g1; nop + set abltkl_, %g1; jmp %g1; nop + set abltkr_, %g1; jmp %g1; nop + set abltks_, %g1; jmp %g1; nop + set abltkx_, %g1; jmp %g1; nop + set abltl_, %g1; jmp %g1; nop + set abltr_, %g1; jmp %g1; nop + set ablts_, %g1; jmp %g1; nop + set abltx_, %g1; jmp %g1; nop + set abnec_, %g1; jmp %g1; nop + set abned_, %g1; jmp %g1; nop + set abnei_, %g1; jmp %g1; nop + set abnekc_, %g1; jmp %g1; nop + set abnekd_, %g1; jmp %g1; nop + set abneki_, %g1; jmp %g1; nop + set abnekl_, %g1; jmp %g1; nop + set abnekr_, %g1; jmp %g1; nop + set abneks_, %g1; jmp %g1; nop + set abnekx_, %g1; jmp %g1; nop + set abnel_, %g1; jmp %g1; nop + set abner_, %g1; jmp %g1; nop + set abnes_, %g1; jmp %g1; nop + set abnex_, %g1; jmp %g1; nop + set abori_, %g1; jmp %g1; nop + set aborki_, %g1; jmp %g1; nop + set aborkl_, %g1; jmp %g1; nop + set aborks_, %g1; jmp %g1; nop + set aborl_, %g1; jmp %g1; nop + set abors_, %g1; jmp %g1; nop + set absud_, %g1; jmp %g1; nop + set absui_, %g1; jmp %g1; nop + set absul_, %g1; jmp %g1; nop + set absur_, %g1; jmp %g1; nop + set absus_, %g1; jmp %g1; nop + set acht_, %g1; jmp %g1; nop + set achtb_, %g1; jmp %g1; nop + set achtbb_, %g1; jmp %g1; nop + set achtbc_, %g1; jmp %g1; nop + set achtbd_, %g1; jmp %g1; nop + set achtbi_, %g1; jmp %g1; nop + set achtbl_, %g1; jmp %g1; nop + set achtbr_, %g1; jmp %g1; nop + set achtbs_, %g1; jmp %g1; nop + set achtbu_, %g1; jmp %g1; nop + set achtbx_, %g1; jmp %g1; nop + set achtc_, %g1; jmp %g1; nop + set achtcb_, %g1; jmp %g1; nop + set achtcc_, %g1; jmp %g1; nop + set achtcd_, %g1; jmp %g1; nop + set achtci_, %g1; jmp %g1; nop + set achtcl_, %g1; jmp %g1; nop + set achtcr_, %g1; jmp %g1; nop + set achtcs_, %g1; jmp %g1; nop + set achtcu_, %g1; jmp %g1; nop + set achtcx_, %g1; jmp %g1; nop + set achtd_, %g1; jmp %g1; nop + set achtdb_, %g1; jmp %g1; nop + set achtdc_, %g1; jmp %g1; nop + set achtdd_, %g1; jmp %g1; nop + set achtdi_, %g1; jmp %g1; nop + set achtdl_, %g1; jmp %g1; nop + set achtdr_, %g1; jmp %g1; nop + set achtds_, %g1; jmp %g1; nop + set achtdu_, %g1; jmp %g1; nop + set achtdx_, %g1; jmp %g1; nop + set achti_, %g1; jmp %g1; nop + set achtib_, %g1; jmp %g1; nop + set achtic_, %g1; jmp %g1; nop + set achtid_, %g1; jmp %g1; nop + set achtii_, %g1; jmp %g1; nop + set achtil_, %g1; jmp %g1; nop + set achtir_, %g1; jmp %g1; nop + set achtis_, %g1; jmp %g1; nop + set achtiu_, %g1; jmp %g1; nop + set achtix_, %g1; jmp %g1; nop + set achtl_, %g1; jmp %g1; nop + set achtlb_, %g1; jmp %g1; nop + set achtlc_, %g1; jmp %g1; nop + set achtld_, %g1; jmp %g1; nop + set achtli_, %g1; jmp %g1; nop + set achtll_, %g1; jmp %g1; nop + set achtlr_, %g1; jmp %g1; nop + set achtls_, %g1; jmp %g1; nop + set achtlu_, %g1; jmp %g1; nop + set achtlx_, %g1; jmp %g1; nop + set achtr_, %g1; jmp %g1; nop + set achtrb_, %g1; jmp %g1; nop + set achtrc_, %g1; jmp %g1; nop + set achtrd_, %g1; jmp %g1; nop + set achtri_, %g1; jmp %g1; nop + set achtrl_, %g1; jmp %g1; nop + set achtrr_, %g1; jmp %g1; nop + set achtrs_, %g1; jmp %g1; nop + set achtru_, %g1; jmp %g1; nop + set achtrx_, %g1; jmp %g1; nop + set achts_, %g1; jmp %g1; nop + set achtsb_, %g1; jmp %g1; nop + set achtsc_, %g1; jmp %g1; nop + set achtsd_, %g1; jmp %g1; nop + set achtsi_, %g1; jmp %g1; nop + set achtsl_, %g1; jmp %g1; nop + set achtsr_, %g1; jmp %g1; nop + set achtss_, %g1; jmp %g1; nop + set achtsu_, %g1; jmp %g1; nop + set achtsx_, %g1; jmp %g1; nop + set achtu_, %g1; jmp %g1; nop + set achtub_, %g1; jmp %g1; nop + set achtuc_, %g1; jmp %g1; nop + set achtud_, %g1; jmp %g1; nop + set achtui_, %g1; jmp %g1; nop + set achtul_, %g1; jmp %g1; nop + set achtur_, %g1; jmp %g1; nop + set achtus_, %g1; jmp %g1; nop + set achtuu_, %g1; jmp %g1; nop + set achtux_, %g1; jmp %g1; nop + set achtx_, %g1; jmp %g1; nop + set achtxb_, %g1; jmp %g1; nop + set achtxc_, %g1; jmp %g1; nop + set achtxd_, %g1; jmp %g1; nop + set achtxi_, %g1; jmp %g1; nop + set achtxl_, %g1; jmp %g1; nop + set achtxr_, %g1; jmp %g1; nop + set achtxs_, %g1; jmp %g1; nop + set achtxu_, %g1; jmp %g1; nop + set achtxx_, %g1; jmp %g1; nop + set acjgx_, %g1; jmp %g1; nop + set aclrb_, %g1; jmp %g1; nop + set aclrc_, %g1; jmp %g1; nop + set aclrd_, %g1; jmp %g1; nop + set aclri_, %g1; jmp %g1; nop + set aclrl_, %g1; jmp %g1; nop + set aclrr_, %g1; jmp %g1; nop + set aclrs_, %g1; jmp %g1; nop + set aclrx_, %g1; jmp %g1; nop + set acnvd_, %g1; jmp %g1; nop + set acnvi_, %g1; jmp %g1; nop + set acnvl_, %g1; jmp %g1; nop + set acnvr_, %g1; jmp %g1; nop + set acnvrd_, %g1; jmp %g1; nop + set acnvri_, %g1; jmp %g1; nop + set acnvrl_, %g1; jmp %g1; nop + set acnvrr_, %g1; jmp %g1; nop + set acnvrs_, %g1; jmp %g1; nop + set acnvs_, %g1; jmp %g1; nop + set adivd_, %g1; jmp %g1; nop + set adivi_, %g1; jmp %g1; nop + set adivkd_, %g1; jmp %g1; nop + set adivki_, %g1; jmp %g1; nop + set adivkl_, %g1; jmp %g1; nop + set adivkr_, %g1; jmp %g1; nop + set adivks_, %g1; jmp %g1; nop + set adivkx_, %g1; jmp %g1; nop + set adivl_, %g1; jmp %g1; nop + set adivr_, %g1; jmp %g1; nop + set adivs_, %g1; jmp %g1; nop + set adivx_, %g1; jmp %g1; nop + set adotd_, %g1; jmp %g1; nop + set adoti_, %g1; jmp %g1; nop + set adotl_, %g1; jmp %g1; nop + set adotr_, %g1; jmp %g1; nop + set adots_, %g1; jmp %g1; nop + set adotx_, %g1; jmp %g1; nop + set advzd_, %g1; jmp %g1; nop + set advzi_, %g1; jmp %g1; nop + set advzl_, %g1; jmp %g1; nop + set advzr_, %g1; jmp %g1; nop + set advzs_, %g1; jmp %g1; nop + set advzx_, %g1; jmp %g1; nop + set aelogd_, %g1; jmp %g1; nop + set aelogr_, %g1; jmp %g1; nop + set aexpd_, %g1; jmp %g1; nop + set aexpi_, %g1; jmp %g1; nop + set aexpkd_, %g1; jmp %g1; nop + set aexpki_, %g1; jmp %g1; nop + set aexpkl_, %g1; jmp %g1; nop + set aexpkr_, %g1; jmp %g1; nop + set aexpks_, %g1; jmp %g1; nop + set aexpkx_, %g1; jmp %g1; nop + set aexpl_, %g1; jmp %g1; nop + set aexpr_, %g1; jmp %g1; nop + set aexps_, %g1; jmp %g1; nop + set aexpx_, %g1; jmp %g1; nop + set afftrr_, %g1; jmp %g1; nop + set afftrx_, %g1; jmp %g1; nop + set afftxr_, %g1; jmp %g1; nop + set afftxx_, %g1; jmp %g1; nop + set agltc_, %g1; jmp %g1; nop + set agltd_, %g1; jmp %g1; nop + set aglti_, %g1; jmp %g1; nop + set agltl_, %g1; jmp %g1; nop + set agltr_, %g1; jmp %g1; nop + set aglts_, %g1; jmp %g1; nop + set agltx_, %g1; jmp %g1; nop + set ahgmc_, %g1; jmp %g1; nop + set ahgmd_, %g1; jmp %g1; nop + set ahgmi_, %g1; jmp %g1; nop + set ahgml_, %g1; jmp %g1; nop + set ahgmr_, %g1; jmp %g1; nop + set ahgms_, %g1; jmp %g1; nop + set ahivc_, %g1; jmp %g1; nop + set ahivd_, %g1; jmp %g1; nop + set ahivi_, %g1; jmp %g1; nop + set ahivl_, %g1; jmp %g1; nop + set ahivr_, %g1; jmp %g1; nop + set ahivs_, %g1; jmp %g1; nop + set ahivx_, %g1; jmp %g1; nop + set aiftrr_, %g1; jmp %g1; nop + set aiftrx_, %g1; jmp %g1; nop + set aiftxr_, %g1; jmp %g1; nop + set aiftxx_, %g1; jmp %g1; nop + set aimgd_, %g1; jmp %g1; nop + set aimgi_, %g1; jmp %g1; nop + set aimgl_, %g1; jmp %g1; nop + set aimgr_, %g1; jmp %g1; nop + set aimgs_, %g1; jmp %g1; nop + set alani_, %g1; jmp %g1; nop + set alanki_, %g1; jmp %g1; nop + set alankl_, %g1; jmp %g1; nop + set alanks_, %g1; jmp %g1; nop + set alanl_, %g1; jmp %g1; nop + set alans_, %g1; jmp %g1; nop + set alimc_, %g1; jmp %g1; nop + set alimd_, %g1; jmp %g1; nop + set alimi_, %g1; jmp %g1; nop + set aliml_, %g1; jmp %g1; nop + set alimr_, %g1; jmp %g1; nop + set alims_, %g1; jmp %g1; nop + set alimx_, %g1; jmp %g1; nop + set allnd_, %g1; jmp %g1; nop + set allni_, %g1; jmp %g1; nop + set allnl_, %g1; jmp %g1; nop + set allnr_, %g1; jmp %g1; nop + set allns_, %g1; jmp %g1; nop + set allnx_, %g1; jmp %g1; nop + set alogd_, %g1; jmp %g1; nop + set alogi_, %g1; jmp %g1; nop + set alogl_, %g1; jmp %g1; nop + set alogr_, %g1; jmp %g1; nop + set alogs_, %g1; jmp %g1; nop + set alogx_, %g1; jmp %g1; nop + set alori_, %g1; jmp %g1; nop + set alorki_, %g1; jmp %g1; nop + set alorkl_, %g1; jmp %g1; nop + set alorks_, %g1; jmp %g1; nop + set alorl_, %g1; jmp %g1; nop + set alors_, %g1; jmp %g1; nop + set alovc_, %g1; jmp %g1; nop + set alovd_, %g1; jmp %g1; nop + set alovi_, %g1; jmp %g1; nop + set alovl_, %g1; jmp %g1; nop + set alovr_, %g1; jmp %g1; nop + set alovs_, %g1; jmp %g1; nop + set alovx_, %g1; jmp %g1; nop + set altad_, %g1; jmp %g1; nop + set altai_, %g1; jmp %g1; nop + set altal_, %g1; jmp %g1; nop + set altar_, %g1; jmp %g1; nop + set altas_, %g1; jmp %g1; nop + set altax_, %g1; jmp %g1; nop + set altmd_, %g1; jmp %g1; nop + set altmi_, %g1; jmp %g1; nop + set altml_, %g1; jmp %g1; nop + set altmr_, %g1; jmp %g1; nop + set altms_, %g1; jmp %g1; nop + set altmx_, %g1; jmp %g1; nop + set altrd_, %g1; jmp %g1; nop + set altri_, %g1; jmp %g1; nop + set altrl_, %g1; jmp %g1; nop + set altrr_, %g1; jmp %g1; nop + set altrs_, %g1; jmp %g1; nop + set altrx_, %g1; jmp %g1; nop + set aluid_, %g1; jmp %g1; nop + set aluii_, %g1; jmp %g1; nop + set aluil_, %g1; jmp %g1; nop + set aluir_, %g1; jmp %g1; nop + set aluis_, %g1; jmp %g1; nop + set alutc_, %g1; jmp %g1; nop + set alutd_, %g1; jmp %g1; nop + set aluti_, %g1; jmp %g1; nop + set alutl_, %g1; jmp %g1; nop + set alutr_, %g1; jmp %g1; nop + set aluts_, %g1; jmp %g1; nop + set amagd_, %g1; jmp %g1; nop + set amagi_, %g1; jmp %g1; nop + set amagl_, %g1; jmp %g1; nop + set amagr_, %g1; jmp %g1; nop + set amags_, %g1; jmp %g1; nop + set amagx_, %g1; jmp %g1; nop + set amapd_, %g1; jmp %g1; nop + set amapi_, %g1; jmp %g1; nop + set amapl_, %g1; jmp %g1; nop + set amapr_, %g1; jmp %g1; nop + set amaps_, %g1; jmp %g1; nop + set amaxc_, %g1; jmp %g1; nop + set amaxd_, %g1; jmp %g1; nop + set amaxi_, %g1; jmp %g1; nop + set amaxkc_, %g1; jmp %g1; nop + set amaxkd_, %g1; jmp %g1; nop + set amaxki_, %g1; jmp %g1; nop + set amaxkl_, %g1; jmp %g1; nop + set amaxkr_, %g1; jmp %g1; nop + set amaxks_, %g1; jmp %g1; nop + set amaxkx_, %g1; jmp %g1; nop + set amaxl_, %g1; jmp %g1; nop + set amaxr_, %g1; jmp %g1; nop + set amaxs_, %g1; jmp %g1; nop + set amaxx_, %g1; jmp %g1; nop + set amed3c_, %g1; jmp %g1; nop + set amed3d_, %g1; jmp %g1; nop + set amed3i_, %g1; jmp %g1; nop + set amed3l_, %g1; jmp %g1; nop + set amed3r_, %g1; jmp %g1; nop + set amed3s_, %g1; jmp %g1; nop + set amed4c_, %g1; jmp %g1; nop + set amed4d_, %g1; jmp %g1; nop + set amed4i_, %g1; jmp %g1; nop + set amed4l_, %g1; jmp %g1; nop + set amed4r_, %g1; jmp %g1; nop + set amed4s_, %g1; jmp %g1; nop + set amed5c_, %g1; jmp %g1; nop + set amed5d_, %g1; jmp %g1; nop + set amed5i_, %g1; jmp %g1; nop + set amed5l_, %g1; jmp %g1; nop + set amed5r_, %g1; jmp %g1; nop + set amed5s_, %g1; jmp %g1; nop + set amedc_, %g1; jmp %g1; nop + set amedd_, %g1; jmp %g1; nop + set amedi_, %g1; jmp %g1; nop + set amedl_, %g1; jmp %g1; nop + set amedr_, %g1; jmp %g1; nop + set ameds_, %g1; jmp %g1; nop + set amedx_, %g1; jmp %g1; nop + set amgsd_, %g1; jmp %g1; nop + set amgsi_, %g1; jmp %g1; nop + set amgsl_, %g1; jmp %g1; nop + set amgsr_, %g1; jmp %g1; nop + set amgss_, %g1; jmp %g1; nop + set amgsx_, %g1; jmp %g1; nop + set aminc_, %g1; jmp %g1; nop + set amind_, %g1; jmp %g1; nop + set amini_, %g1; jmp %g1; nop + set aminkc_, %g1; jmp %g1; nop + set aminkd_, %g1; jmp %g1; nop + set aminki_, %g1; jmp %g1; nop + set aminkl_, %g1; jmp %g1; nop + set aminkr_, %g1; jmp %g1; nop + set aminks_, %g1; jmp %g1; nop + set aminkx_, %g1; jmp %g1; nop + set aminl_, %g1; jmp %g1; nop + set aminr_, %g1; jmp %g1; nop + set amins_, %g1; jmp %g1; nop + set aminx_, %g1; jmp %g1; nop + set amodd_, %g1; jmp %g1; nop + set amodi_, %g1; jmp %g1; nop + set amodkd_, %g1; jmp %g1; nop + set amodki_, %g1; jmp %g1; nop + set amodkl_, %g1; jmp %g1; nop + set amodkr_, %g1; jmp %g1; nop + set amodks_, %g1; jmp %g1; nop + set amodl_, %g1; jmp %g1; nop + set amodr_, %g1; jmp %g1; nop + set amods_, %g1; jmp %g1; nop + set amovc_, %g1; jmp %g1; nop + set amovd_, %g1; jmp %g1; nop + set amovi_, %g1; jmp %g1; nop + set amovkc_, %g1; jmp %g1; nop + set amovkd_, %g1; jmp %g1; nop + set amovki_, %g1; jmp %g1; nop + set amovkl_, %g1; jmp %g1; nop + set amovkr_, %g1; jmp %g1; nop + set amovks_, %g1; jmp %g1; nop + set amovkx_, %g1; jmp %g1; nop + set amovl_, %g1; jmp %g1; nop + set amovr_, %g1; jmp %g1; nop + set amovs_, %g1; jmp %g1; nop + set amovx_, %g1; jmp %g1; nop + set amuld_, %g1; jmp %g1; nop + set amuli_, %g1; jmp %g1; nop + set amulkd_, %g1; jmp %g1; nop + set amulki_, %g1; jmp %g1; nop + set amulkl_, %g1; jmp %g1; nop + set amulkr_, %g1; jmp %g1; nop + set amulks_, %g1; jmp %g1; nop + set amulkx_, %g1; jmp %g1; nop + set amull_, %g1; jmp %g1; nop + set amulr_, %g1; jmp %g1; nop + set amuls_, %g1; jmp %g1; nop + set amulx_, %g1; jmp %g1; nop + set andi_, %g1; jmp %g1; nop + set andl_, %g1; jmp %g1; nop + set ands_, %g1; jmp %g1; nop + set anegd_, %g1; jmp %g1; nop + set anegi_, %g1; jmp %g1; nop + set anegl_, %g1; jmp %g1; nop + set anegr_, %g1; jmp %g1; nop + set anegs_, %g1; jmp %g1; nop + set anegx_, %g1; jmp %g1; nop + set anoti_, %g1; jmp %g1; nop + set anotl_, %g1; jmp %g1; nop + set anots_, %g1; jmp %g1; nop + set apkxd_, %g1; jmp %g1; nop + set apkxi_, %g1; jmp %g1; nop + set apkxl_, %g1; jmp %g1; nop + set apkxr_, %g1; jmp %g1; nop + set apkxs_, %g1; jmp %g1; nop + set apkxx_, %g1; jmp %g1; nop + set apold_, %g1; jmp %g1; nop + set apolr_, %g1; jmp %g1; nop + set apowd_, %g1; jmp %g1; nop + set apowi_, %g1; jmp %g1; nop + set apowkd_, %g1; jmp %g1; nop + set apowki_, %g1; jmp %g1; nop + set apowkl_, %g1; jmp %g1; nop + set apowkr_, %g1; jmp %g1; nop + set apowks_, %g1; jmp %g1; nop + set apowkx_, %g1; jmp %g1; nop + set apowl_, %g1; jmp %g1; nop + set apowr_, %g1; jmp %g1; nop + set apows_, %g1; jmp %g1; nop + set apowx_, %g1; jmp %g1; nop + set aravd_, %g1; jmp %g1; nop + set aravi_, %g1; jmp %g1; nop + set aravl_, %g1; jmp %g1; nop + set aravr_, %g1; jmp %g1; nop + set aravs_, %g1; jmp %g1; nop + set aravx_, %g1; jmp %g1; nop + set arcpd_, %g1; jmp %g1; nop + set arcpi_, %g1; jmp %g1; nop + set arcpl_, %g1; jmp %g1; nop + set arcpr_, %g1; jmp %g1; nop + set arcps_, %g1; jmp %g1; nop + set arcpx_, %g1; jmp %g1; nop + set arczd_, %g1; jmp %g1; nop + set arczi_, %g1; jmp %g1; nop + set arczl_, %g1; jmp %g1; nop + set arczr_, %g1; jmp %g1; nop + set arczs_, %g1; jmp %g1; nop + set arczx_, %g1; jmp %g1; nop + set aread_, %g1; jmp %g1; nop + set areadb_, %g1; jmp %g1; nop + set argtd_, %g1; jmp %g1; nop + set argti_, %g1; jmp %g1; nop + set argtl_, %g1; jmp %g1; nop + set argtr_, %g1; jmp %g1; nop + set argts_, %g1; jmp %g1; nop + set argtx_, %g1; jmp %g1; nop + set arltd_, %g1; jmp %g1; nop + set arlti_, %g1; jmp %g1; nop + set arltl_, %g1; jmp %g1; nop + set arltr_, %g1; jmp %g1; nop + set arlts_, %g1; jmp %g1; nop + set arltx_, %g1; jmp %g1; nop + set aselc_, %g1; jmp %g1; nop + set aseld_, %g1; jmp %g1; nop + set aseli_, %g1; jmp %g1; nop + set aselkc_, %g1; jmp %g1; nop + set aselkd_, %g1; jmp %g1; nop + set aselki_, %g1; jmp %g1; nop + set aselkl_, %g1; jmp %g1; nop + set aselkr_, %g1; jmp %g1; nop + set aselks_, %g1; jmp %g1; nop + set aselkx_, %g1; jmp %g1; nop + set asell_, %g1; jmp %g1; nop + set aselr_, %g1; jmp %g1; nop + set asels_, %g1; jmp %g1; nop + set aselx_, %g1; jmp %g1; nop + set asokc_, %g1; jmp %g1; nop + set asokd_, %g1; jmp %g1; nop + set asoki_, %g1; jmp %g1; nop + set asokl_, %g1; jmp %g1; nop + set asokr_, %g1; jmp %g1; nop + set asoks_, %g1; jmp %g1; nop + set asokx_, %g1; jmp %g1; nop + set asqrd_, %g1; jmp %g1; nop + set asqri_, %g1; jmp %g1; nop + set asqrl_, %g1; jmp %g1; nop + set asqrr_, %g1; jmp %g1; nop + set asqrs_, %g1; jmp %g1; nop + set asqrx_, %g1; jmp %g1; nop + set asrtc_, %g1; jmp %g1; nop + set asrtd_, %g1; jmp %g1; nop + set asrti_, %g1; jmp %g1; nop + set asrtl_, %g1; jmp %g1; nop + set asrtr_, %g1; jmp %g1; nop + set asrts_, %g1; jmp %g1; nop + set asrtx_, %g1; jmp %g1; nop + set assqd_, %g1; jmp %g1; nop + set assqi_, %g1; jmp %g1; nop + set assql_, %g1; jmp %g1; nop + set assqr_, %g1; jmp %g1; nop + set assqs_, %g1; jmp %g1; nop + set assqx_, %g1; jmp %g1; nop + set asubd_, %g1; jmp %g1; nop + set asubi_, %g1; jmp %g1; nop + set asubkd_, %g1; jmp %g1; nop + set asubki_, %g1; jmp %g1; nop + set asubkl_, %g1; jmp %g1; nop + set asubkr_, %g1; jmp %g1; nop + set asubks_, %g1; jmp %g1; nop + set asubkx_, %g1; jmp %g1; nop + set asubl_, %g1; jmp %g1; nop + set asubr_, %g1; jmp %g1; nop + set asubs_, %g1; jmp %g1; nop + set asubx_, %g1; jmp %g1; nop + set asumd_, %g1; jmp %g1; nop + set asumi_, %g1; jmp %g1; nop + set asuml_, %g1; jmp %g1; nop + set asumr_, %g1; jmp %g1; nop + set asums_, %g1; jmp %g1; nop + set asumx_, %g1; jmp %g1; nop + set aupxd_, %g1; jmp %g1; nop + set aupxi_, %g1; jmp %g1; nop + set aupxl_, %g1; jmp %g1; nop + set aupxr_, %g1; jmp %g1; nop + set aupxs_, %g1; jmp %g1; nop + set aupxx_, %g1; jmp %g1; nop + set aveqc_, %g1; jmp %g1; nop + set aveqd_, %g1; jmp %g1; nop + set aveqi_, %g1; jmp %g1; nop + set aveql_, %g1; jmp %g1; nop + set aveqr_, %g1; jmp %g1; nop + set aveqs_, %g1; jmp %g1; nop + set aveqx_, %g1; jmp %g1; nop + set await_, %g1; jmp %g1; nop + set awaitb_, %g1; jmp %g1; nop + set awritb_, %g1; jmp %g1; nop + set awrite_, %g1; jmp %g1; nop + set awsud_, %g1; jmp %g1; nop + set awsui_, %g1; jmp %g1; nop + set awsul_, %g1; jmp %g1; nop + set awsur_, %g1; jmp %g1; nop + set awsus_, %g1; jmp %g1; nop + set awsux_, %g1; jmp %g1; nop + set awvgd_, %g1; jmp %g1; nop + set awvgi_, %g1; jmp %g1; nop + set awvgl_, %g1; jmp %g1; nop + set awvgr_, %g1; jmp %g1; nop + set awvgs_, %g1; jmp %g1; nop + set awvgx_, %g1; jmp %g1; nop + set axori_, %g1; jmp %g1; nop + set axorki_, %g1; jmp %g1; nop + set axorkl_, %g1; jmp %g1; nop + set axorks_, %g1; jmp %g1; nop + set axorl_, %g1; jmp %g1; nop + set axors_, %g1; jmp %g1; nop + set begmem_, %g1; jmp %g1; nop + set bitmov_, %g1; jmp %g1; nop + set bitpak_, %g1; jmp %g1; nop + set bitupk_, %g1; jmp %g1; nop + set brktie_, %g1; jmp %g1; nop + set bswap2_, %g1; jmp %g1; nop + set bswap4_, %g1; jmp %g1; nop + set bswap8_, %g1; jmp %g1; nop + set btoi_, %g1; jmp %g1; nop + set bytmov_, %g1; jmp %g1; nop + set cctoc_, %g1; jmp %g1; nop + set chdept_, %g1; jmp %g1; nop + set chfeth_, %g1; jmp %g1; nop + set chrlwr_, %g1; jmp %g1; nop + set chrpak_, %g1; jmp %g1; nop + set chrupk_, %g1; jmp %g1; nop + set chrupr_, %g1; jmp %g1; nop + set clccos_, %g1; jmp %g1; nop + set clcenr_, %g1; jmp %g1; nop + set clcfeh_, %g1; jmp %g1; nop + set clcfid_, %g1; jmp %g1; nop + set clcfre_, %g1; jmp %g1; nop + set clcint_, %g1; jmp %g1; nop + set clclit_, %g1; jmp %g1; nop + set clcloe_, %g1; jmp %g1; nop + set clcmak_, %g1; jmp %g1; nop + set clcmd_, %g1; jmp %g1; nop + set clcmdw_, %g1; jmp %g1; nop + set clcnek_, %g1; jmp %g1; nop + set clcpst_, %g1; jmp %g1; nop + set clcscn_, %g1; jmp %g1; nop + set clepst_, %g1; jmp %g1; nop + set clgcur_, %g1; jmp %g1; nop + set clgetb_, %g1; jmp %g1; nop + set clgetc_, %g1; jmp %g1; nop + set clgetd_, %g1; jmp %g1; nop + set clgeti_, %g1; jmp %g1; nop + set clgetl_, %g1; jmp %g1; nop + set clgetr_, %g1; jmp %g1; nop + set clgets_, %g1; jmp %g1; nop + set clgetx_, %g1; jmp %g1; nop + set clgfil_, %g1; jmp %g1; nop + set clgkey_, %g1; jmp %g1; nop + set clglpb_, %g1; jmp %g1; nop + set clglpc_, %g1; jmp %g1; nop + set clglpd_, %g1; jmp %g1; nop + set clglpi_, %g1; jmp %g1; nop + set clglpl_, %g1; jmp %g1; nop + set clglpr_, %g1; jmp %g1; nop + set clglps_, %g1; jmp %g1; nop + set clglpx_, %g1; jmp %g1; nop + set clglsr_, %g1; jmp %g1; nop + set clgpsa_, %g1; jmp %g1; nop + set clgpsb_, %g1; jmp %g1; nop + set clgpsc_, %g1; jmp %g1; nop + set clgpsd_, %g1; jmp %g1; nop + set clgpsi_, %g1; jmp %g1; nop + set clgpsl_, %g1; jmp %g1; nop + set clgpsr_, %g1; jmp %g1; nop + set clgpss_, %g1; jmp %g1; nop + set clgpst_, %g1; jmp %g1; nop + set clgpsx_, %g1; jmp %g1; nop + set clgstr_, %g1; jmp %g1; nop + set clgwrd_, %g1; jmp %g1; nop + set clktie_, %g1; jmp %g1; nop + set cllpst_, %g1; jmp %g1; nop + set clopen_, %g1; jmp %g1; nop + set clopst_, %g1; jmp %g1; nop + set clpcls_, %g1; jmp %g1; nop + set clplen_, %g1; jmp %g1; nop + set clpopi_, %g1; jmp %g1; nop + set clpops_, %g1; jmp %g1; nop + set clpopu_, %g1; jmp %g1; nop + set clppsa_, %g1; jmp %g1; nop + set clppsb_, %g1; jmp %g1; nop + set clppsc_, %g1; jmp %g1; nop + set clppsd_, %g1; jmp %g1; nop + set clppsi_, %g1; jmp %g1; nop + set clppsl_, %g1; jmp %g1; nop + set clppsr_, %g1; jmp %g1; nop + set clppss_, %g1; jmp %g1; nop + set clppst_, %g1; jmp %g1; nop + set clppsx_, %g1; jmp %g1; nop + set clprew_, %g1; jmp %g1; nop + set clprif_, %g1; jmp %g1; nop + set clpsee_, %g1; jmp %g1; nop + set clpsit_, %g1; jmp %g1; nop + set clpstr_, %g1; jmp %g1; nop + set clputb_, %g1; jmp %g1; nop + set clputc_, %g1; jmp %g1; nop + set clputd_, %g1; jmp %g1; nop + set clputi_, %g1; jmp %g1; nop + set clputl_, %g1; jmp %g1; nop + set clputr_, %g1; jmp %g1; nop + set clputs_, %g1; jmp %g1; nop + set clputx_, %g1; jmp %g1; nop + set clreqr_, %g1; jmp %g1; nop + set clscan_, %g1; jmp %g1; nop + set clseti_, %g1; jmp %g1; nop + set clstai_, %g1; jmp %g1; nop + set cnvdae_, %g1; jmp %g1; nop + set cnvtie_, %g1; jmp %g1; nop + set coerce_, %g1; jmp %g1; nop + set cputie_, %g1; jmp %g1; nop + set ctocc_, %g1; jmp %g1; nop + set ctod_, %g1; jmp %g1; nop + set ctoi_, %g1; jmp %g1; nop + set ctol_, %g1; jmp %g1; nop + set ctor_, %g1; jmp %g1; nop + set ctotok_, %g1; jmp %g1; nop + set ctowrd_, %g1; jmp %g1; nop + set ctox_, %g1; jmp %g1; nop + set d1mach_, %g1; jmp %g1; nop + set deletg_, %g1; jmp %g1; nop + set diropn_, %g1; jmp %g1; nop + set dtcscl_, %g1; jmp %g1; nop + set dtmdee_, %g1; jmp %g1; nop + set dtmdes_, %g1; jmp %g1; nop + set dtmene_, %g1; jmp %g1; nop + set dtmens_, %g1; jmp %g1; nop + set dtoc3_, %g1; jmp %g1; nop + set dtoc_, %g1; jmp %g1; nop + set elogd_, %g1; jmp %g1; nop + set elogr_, %g1; jmp %g1; nop + set envfid_, %g1; jmp %g1; nop + set envfit_, %g1; jmp %g1; nop + set envfre_, %g1; jmp %g1; nop + set envgeb_, %g1; jmp %g1; nop + set envged_, %g1; jmp %g1; nop + set envgei_, %g1; jmp %g1; nop + set envger_, %g1; jmp %g1; nop + set envges_, %g1; jmp %g1; nop + set envinr_, %g1; jmp %g1; nop + set envint_, %g1; jmp %g1; nop + set envlit_, %g1; jmp %g1; nop + set envmak_, %g1; jmp %g1; nop + set envnet_, %g1; jmp %g1; nop + set envpus_, %g1; jmp %g1; nop + set envret_, %g1; jmp %g1; nop + set envscn_, %g1; jmp %g1; nop + set eprinf_, %g1; jmp %g1; nop + set erract_, %g1; jmp %g1; nop + set errcoe_, %g1; jmp %g1; nop + set errget_, %g1; jmp %g1; nop + set evexpr_, %g1; jmp %g1; nop + set evvexr_, %g1; jmp %g1; nop + set evvfre_, %g1; jmp %g1; nop + set f77pak_, %g1; jmp %g1; nop + set f77upk_, %g1; jmp %g1; nop + set falloc_, %g1; jmp %g1; nop + set fcanpb_, %g1; jmp %g1; nop + set fcldir_, %g1; jmp %g1; nop + set fclobr_, %g1; jmp %g1; nop + set fcopy_, %g1; jmp %g1; nop + set fcopyo_, %g1; jmp %g1; nop + set fdebug_, %g1; jmp %g1; nop + set fdevbf_, %g1; jmp %g1; nop + set fdevbk_, %g1; jmp %g1; nop + set fdevtx_, %g1; jmp %g1; nop + set fdirne_, %g1; jmp %g1; nop + set fexbuf_, %g1; jmp %g1; nop + set ffa_, %g1; jmp %g1; nop + set ffault_, %g1; jmp %g1; nop + set ffilbf_, %g1; jmp %g1; nop + set ffilsz_, %g1; jmp %g1; nop + set ffldir_, %g1; jmp %g1; nop + set fflsbf_, %g1; jmp %g1; nop + set ffs_, %g1; jmp %g1; nop + set fft842_, %g1; jmp %g1; nop + set fgdev0_, %g1; jmp %g1; nop + set fgdevm_, %g1; jmp %g1; nop + set fgetfd_, %g1; jmp %g1; nop + set fgtdir_, %g1; jmp %g1; nop + set filbuf_, %g1; jmp %g1; nop + set filerr_, %g1; jmp %g1; nop + set filopn_, %g1; jmp %g1; nop + set finfo_, %g1; jmp %g1; nop + set finit_, %g1; jmp %g1; nop + set fioclp_, %g1; jmp %g1; nop + set fioqfh_, %g1; jmp %g1; nop + set fixmem_, %g1; jmp %g1; nop + set flsbuf_, %g1; jmp %g1; nop + set fmaccs_, %g1; jmp %g1; nop + set fmapfn_, %g1; jmp %g1; nop + set fmcloe_, %g1; jmp %g1; nop + set fmcopo_, %g1; jmp %g1; nop + set fmcopy_, %g1; jmp %g1; nop + set fmdebg_, %g1; jmp %g1; nop + set fmdele_, %g1; jmp %g1; nop + set fmfcdg_, %g1; jmp %g1; nop + set fmfcfe_, %g1; jmp %g1; nop + set fmfcit_, %g1; jmp %g1; nop + set fmfcsc_, %g1; jmp %g1; nop + set fmfinf_, %g1; jmp %g1; nop + set fmfopn_, %g1; jmp %g1; nop + set fmgetd_, %g1; jmp %g1; nop + set fmiobd_, %g1; jmp %g1; nop + set fmioed_, %g1; jmp %g1; nop + set fmioek_, %g1; jmp %g1; nop + set fmiopr_, %g1; jmp %g1; nop + set fmiorr_, %g1; jmp %g1; nop + set fmiosf_, %g1; jmp %g1; nop + set fmiotk_, %g1; jmp %g1; nop + set fmkbfs_, %g1; jmp %g1; nop + set fmkcoy_, %g1; jmp %g1; nop + set fmkdir_, %g1; jmp %g1; nop + set fmkpbf_, %g1; jmp %g1; nop + set fmlfad_, %g1; jmp %g1; nop + set fmlfae_, %g1; jmp %g1; nop + set fmlfat_, %g1; jmp %g1; nop + set fmlfbd_, %g1; jmp %g1; nop + set fmlfbe_, %g1; jmp %g1; nop + set fmlfbt_, %g1; jmp %g1; nop + set fmlfce_, %g1; jmp %g1; nop + set fmlfcy_, %g1; jmp %g1; nop + set fmlfde_, %g1; jmp %g1; nop + set fmlfne_, %g1; jmp %g1; nop + set fmlfon_, %g1; jmp %g1; nop + set fmlfpe_, %g1; jmp %g1; nop + set fmlfsi_, %g1; jmp %g1; nop + set fmlfst_, %g1; jmp %g1; nop + set fmlfue_, %g1; jmp %g1; nop + set fmlocd_, %g1; jmp %g1; nop + set fmloct_, %g1; jmp %g1; nop + set fmnexe_, %g1; jmp %g1; nop + set fmopen_, %g1; jmp %g1; nop + set fmrebd_, %g1; jmp %g1; nop + set fmrene_, %g1; jmp %g1; nop + set fmretd_, %g1; jmp %g1; nop + set fmseti_, %g1; jmp %g1; nop + set fmstai_, %g1; jmp %g1; nop + set fmsync_, %g1; jmp %g1; nop + set fmterr_, %g1; jmp %g1; nop + set fmtint_, %g1; jmp %g1; nop + set fmtred_, %g1; jmp %g1; nop + set fmtsel_, %g1; jmp %g1; nop + set fmtstr_, %g1; jmp %g1; nop + set fmunlk_, %g1; jmp %g1; nop + set fnextn_, %g1; jmp %g1; nop + set fnldir_, %g1; jmp %g1; nop + set fnroot_, %g1; jmp %g1; nop + set fntclb_, %g1; jmp %g1; nop + set fntcls_, %g1; jmp %g1; nop + set fntdir_, %g1; jmp %g1; nop + set fntedt_, %g1; jmp %g1; nop + set fntget_, %g1; jmp %g1; nop + set fntgfb_, %g1; jmp %g1; nop + set fntgfn_, %g1; jmp %g1; nop + set fntleb_, %g1; jmp %g1; nop + set fntmkt_, %g1; jmp %g1; nop + set fntopb_, %g1; jmp %g1; nop + set fntopn_, %g1; jmp %g1; nop + set fntopt_, %g1; jmp %g1; nop + set fntreb_, %g1; jmp %g1; nop + set fntree_, %g1; jmp %g1; nop + set fntrfb_, %g1; jmp %g1; nop + set fnulle_, %g1; jmp %g1; nop + set fopdir_, %g1; jmp %g1; nop + set fopnbf_, %g1; jmp %g1; nop + set fopntx_, %g1; jmp %g1; nop + set fowner_, %g1; jmp %g1; nop + set fpathe_, %g1; jmp %g1; nop + set fpequd_, %g1; jmp %g1; nop + set fpequr_, %g1; jmp %g1; nop + set fpfixd_, %g1; jmp %g1; nop + set fpfixr_, %g1; jmp %g1; nop + set fpnonr_, %g1; jmp %g1; nop + set fpnord_, %g1; jmp %g1; nop + set fpnorr_, %g1; jmp %g1; nop + set fpradv_, %g1; jmp %g1; nop + set fprfmt_, %g1; jmp %g1; nop + set fprinf_, %g1; jmp %g1; nop + set fprntf_, %g1; jmp %g1; nop + set fptdir_, %g1; jmp %g1; nop + set fputtx_, %g1; jmp %g1; nop + set freadp_, %g1; jmp %g1; nop + set fredio_, %g1; jmp %g1; nop + set fredir_, %g1; jmp %g1; nop + set frenae_, %g1; jmp %g1; nop + set frmbfs_, %g1; jmp %g1; nop + set frmtmp_, %g1; jmp %g1; nop + set frtnfd_, %g1; jmp %g1; nop + set fsetev_, %g1; jmp %g1; nop + set fsetfd_, %g1; jmp %g1; nop + set fseti_, %g1; jmp %g1; nop + set fsfdee_, %g1; jmp %g1; nop + set fsfgee_, %g1; jmp %g1; nop + set fsfopn_, %g1; jmp %g1; nop + set fskdir_, %g1; jmp %g1; nop + set fstati_, %g1; jmp %g1; nop + set fstatl_, %g1; jmp %g1; nop + set fstats_, %g1; jmp %g1; nop + set fstdfe_, %g1; jmp %g1; nop + set fstdir_, %g1; jmp %g1; nop + set fstrfp_, %g1; jmp %g1; nop + set fsvtfn_, %g1; jmp %g1; nop + set fswapd_, %g1; jmp %g1; nop + set fwatio_, %g1; jmp %g1; nop + set fwritp_, %g1; jmp %g1; nop + set fwtacc_, %g1; jmp %g1; nop + set fxfacp_, %g1; jmp %g1; nop + set fxfacs_, %g1; jmp %g1; nop + set fxfact_, %g1; jmp %g1; nop + set fxfadr_, %g1; jmp %g1; nop + set fxfakb_, %g1; jmp %g1; nop + set fxfakc_, %g1; jmp %g1; nop + set fxfakd_, %g1; jmp %g1; nop + set fxfaki_, %g1; jmp %g1; nop + set fxfakr_, %g1; jmp %g1; nop + set fxfalc_, %g1; jmp %g1; nop + set fxfald_, %g1; jmp %g1; nop + set fxfalr_, %g1; jmp %g1; nop + set fxfalu_, %g1; jmp %g1; nop + set fxfasr_, %g1; jmp %g1; nop + set fxfbls_, %g1; jmp %g1; nop + set fxfbyt_, %g1; jmp %g1; nop + set fxfche_, %g1; jmp %g1; nop + set fxfchm_, %g1; jmp %g1; nop + set fxfchp_, %g1; jmp %g1; nop + set fxfchv_, %g1; jmp %g1; nop + set fxfcle_, %g1; jmp %g1; nop + set fxfcll_, %g1; jmp %g1; nop + set fxfcnx_, %g1; jmp %g1; nop + set fxfcoj_, %g1; jmp %g1; nop + set fxfcoy_, %g1; jmp %g1; nop + set fxfcte_, %g1; jmp %g1; nop + set fxfdae_, %g1; jmp %g1; nop + set fxfdee_, %g1; jmp %g1; nop + set fxfdiw_, %g1; jmp %g1; nop + set fxfdur_, %g1; jmp %g1; nop + set fxfenb_, %g1; jmp %g1; nop + set fxfenc_, %g1; jmp %g1; nop + set fxfend_, %g1; jmp %g1; nop + set fxfene_, %g1; jmp %g1; nop + set fxfeni_, %g1; jmp %g1; nop + set fxfenl_, %g1; jmp %g1; nop + set fxfenr_, %g1; jmp %g1; nop + set fxfens_, %g1; jmp %g1; nop + set fxfexh_, %g1; jmp %g1; nop + set fxfexr_, %g1; jmp %g1; nop + set fxffac_, %g1; jmp %g1; nop + set fxffcr_, %g1; jmp %g1; nop + set fxffiw_, %g1; jmp %g1; nop + set fxffog_, %g1; jmp %g1; nop + set fxffpd_, %g1; jmp %g1; nop + set fxfgas_, %g1; jmp %g1; nop + set fxfgeb_, %g1; jmp %g1; nop + set fxfged_, %g1; jmp %g1; nop + set fxfgei_, %g1; jmp %g1; nop + set fxfgen_, %g1; jmp %g1; nop + set fxfger_, %g1; jmp %g1; nop + set fxfget_, %g1; jmp %g1; nop + set fxfglm_, %g1; jmp %g1; nop + set fxfgsr_, %g1; jmp %g1; nop + set fxfhdt_, %g1; jmp %g1; nop + set fxfhee_, %g1; jmp %g1; nop + set fxfhef_, %g1; jmp %g1; nop + set fxfint_, %g1; jmp %g1; nop + set fxfisk_, %g1; jmp %g1; nop + set fxfkse_, %g1; jmp %g1; nop + set fxfksl_, %g1; jmp %g1; nop + set fxfksm_, %g1; jmp %g1; nop + set fxfksn_, %g1; jmp %g1; nop + set fxfkss_, %g1; jmp %g1; nop + set fxfkst_, %g1; jmp %g1; nop + set fxfksx_, %g1; jmp %g1; nop + set fxflor_, %g1; jmp %g1; nop + set fxfmad_, %g1; jmp %g1; nop + set fxfmar_, %g1; jmp %g1; nop + set fxfmas_, %g1; jmp %g1; nop + set fxfmay_, %g1; jmp %g1; nop + set fxfmea_, %g1; jmp %g1; nop + set fxfnul_, %g1; jmp %g1; nop + set fxfopn_, %g1; jmp %g1; nop + set fxfopx_, %g1; jmp %g1; nop + set fxfove_, %g1; jmp %g1; nop + set fxfovt_, %g1; jmp %g1; nop + set fxfpaa_, %g1; jmp %g1; nop + set fxfpld_, %g1; jmp %g1; nop + set fxfple_, %g1; jmp %g1; nop + set fxfplf_, %g1; jmp %g1; nop + set fxfplo_, %g1; jmp %g1; nop + set fxfplp_, %g1; jmp %g1; nop + set fxfprr_, %g1; jmp %g1; nop + set fxfred_, %g1; jmp %g1; nop + set fxfree_, %g1; jmp %g1; nop + set fxfrek_, %g1; jmp %g1; nop + set fxfren_, %g1; jmp %g1; nop + set fxfrep_, %g1; jmp %g1; nop + set fxfrfr_, %g1; jmp %g1; nop + set fxfrhr_, %g1; jmp %g1; nop + set fxfsee_, %g1; jmp %g1; nop + set fxfsev_, %g1; jmp %g1; nop + set fxfsex_, %g1; jmp %g1; nop + set fxfskn_, %g1; jmp %g1; nop + set fxfstr_, %g1; jmp %g1; nop + set fxftox_, %g1; jmp %g1; nop + set fxfuad_, %g1; jmp %g1; nop + set fxfuna_, %g1; jmp %g1; nop + set fxfupd_, %g1; jmp %g1; nop + set fxfupr_, %g1; jmp %g1; nop + set fxfwrr_, %g1; jmp %g1; nop + set fxfwrs_, %g1; jmp %g1; nop + set fxfxal_, %g1; jmp %g1; nop + set fxfxhd_, %g1; jmp %g1; nop + set fxfxn1_, %g1; jmp %g1; nop + set fxfzcl_, %g1; jmp %g1; nop + set fxfzop_, %g1; jmp %g1; nop + set fxfzrd_, %g1; jmp %g1; nop + set fxfzst_, %g1; jmp %g1; nop + set fxfzwr_, %g1; jmp %g1; nop + set fxfzwt_, %g1; jmp %g1; nop + set gactie_, %g1; jmp %g1; nop + set gadraw_, %g1; jmp %g1; nop + set gamove_, %g1; jmp %g1; nop + set gargb_, %g1; jmp %g1; nop + set gargc_, %g1; jmp %g1; nop + set gargd_, %g1; jmp %g1; nop + set gargi_, %g1; jmp %g1; nop + set gargl_, %g1; jmp %g1; nop + set gargr_, %g1; jmp %g1; nop + set gargrd_, %g1; jmp %g1; nop + set gargs_, %g1; jmp %g1; nop + set gargsr_, %g1; jmp %g1; nop + set gargtk_, %g1; jmp %g1; nop + set gargwd_, %g1; jmp %g1; nop + set gargx_, %g1; jmp %g1; nop + set gascae_, %g1; jmp %g1; nop + set gcancl_, %g1; jmp %g1; nop + set gclear_, %g1; jmp %g1; nop + set gclose_, %g1; jmp %g1; nop + set gctod_, %g1; jmp %g1; nop + set gctol_, %g1; jmp %g1; nop + set gctox_, %g1; jmp %g1; nop + set gctran_, %g1; jmp %g1; nop + set gcurps_, %g1; jmp %g1; nop + set gdeace_, %g1; jmp %g1; nop + set gescae_, %g1; jmp %g1; nop + set getci_, %g1; jmp %g1; nop + set gethot_, %g1; jmp %g1; nop + set getlie_, %g1; jmp %g1; nop + set getlle_, %g1; jmp %g1; nop + set getloe_, %g1; jmp %g1; nop + set gexflr_, %g1; jmp %g1; nop + set gexfls_, %g1; jmp %g1; nop + set gexflt_, %g1; jmp %g1; nop + set gfill_, %g1; jmp %g1; nop + set gflush_, %g1; jmp %g1; nop + set gframe_, %g1; jmp %g1; nop + set gfrint_, %g1; jmp %g1; nop + set ggcell_, %g1; jmp %g1; nop + set ggcur_, %g1; jmp %g1; nop + set ggetb_, %g1; jmp %g1; nop + set ggeti_, %g1; jmp %g1; nop + set ggetr_, %g1; jmp %g1; nop + set ggets_, %g1; jmp %g1; nop + set ggscae_, %g1; jmp %g1; nop + set ggview_, %g1; jmp %g1; nop + set ggwind_, %g1; jmp %g1; nop + set gimcor_, %g1; jmp %g1; nop + set gimcrr_, %g1; jmp %g1; nop + set gimder_, %g1; jmp %g1; nop + set gimdig_, %g1; jmp %g1; nop + set gimeng_, %g1; jmp %g1; nop + set gimfrg_, %g1; jmp %g1; nop + set gimfrp_, %g1; jmp %g1; nop + set gimgeg_, %g1; jmp %g1; nop + set gimins_, %g1; jmp %g1; nop + set gimiod_, %g1; jmp %g1; nop + set gimioe_, %g1; jmp %g1; nop + set gimlop_, %g1; jmp %g1; nop + set gimqur_, %g1; jmp %g1; nop + set gimrat_, %g1; jmp %g1; nop + set gimreg_, %g1; jmp %g1; nop + set gimrep_, %g1; jmp %g1; nop + set gimres_, %g1; jmp %g1; nop + set gimrex_, %g1; jmp %g1; nop + set gimseg_, %g1; jmp %g1; nop + set gimser_, %g1; jmp %g1; nop + set gimsex_, %g1; jmp %g1; nop + set gimwrp_, %g1; jmp %g1; nop + set gimwrs_, %g1; jmp %g1; nop + set gkical_, %g1; jmp %g1; nop + set gkiclr_, %g1; jmp %g1; nop + set gkicls_, %g1; jmp %g1; nop + set gkides_, %g1; jmp %g1; nop + set gkieof_, %g1; jmp %g1; nop + set gkiese_, %g1; jmp %g1; nop + set gkiexe_, %g1; jmp %g1; nop + set gkifat_, %g1; jmp %g1; nop + set gkifen_, %g1; jmp %g1; nop + set gkiffh_, %g1; jmp %g1; nop + set gkifia_, %g1; jmp %g1; nop + set gkiflh_, %g1; jmp %g1; nop + set gkiger_, %g1; jmp %g1; nop + set gkiges_, %g1; jmp %g1; nop + set gkigey_, %g1; jmp %g1; nop + set gkiinl_, %g1; jmp %g1; nop + set gkiint_, %g1; jmp %g1; nop + set gkimfe_, %g1; jmp %g1; nop + set gkiops_, %g1; jmp %g1; nop + set gkiplt_, %g1; jmp %g1; nop + set gkipmt_, %g1; jmp %g1; nop + set gkipoe_, %g1; jmp %g1; nop + set gkipor_, %g1; jmp %g1; nop + set gkipuy_, %g1; jmp %g1; nop + set gkiree_, %g1; jmp %g1; nop + set gkirer_, %g1; jmp %g1; nop + set gkires_, %g1; jmp %g1; nop + set gkirey_, %g1; jmp %g1; nop + set gkiser_, %g1; jmp %g1; nop + set gkises_, %g1; jmp %g1; nop + set gkisul_, %g1; jmp %g1; nop + set gkitet_, %g1; jmp %g1; nop + set gkitxt_, %g1; jmp %g1; nop + set gkiwee_, %g1; jmp %g1; nop + set gkiwre_, %g1; jmp %g1; nop + set gkpcal_, %g1; jmp %g1; nop + set gkpcle_, %g1; jmp %g1; nop + set gkpclr_, %g1; jmp %g1; nop + set gkpcls_, %g1; jmp %g1; nop + set gkpdes_, %g1; jmp %g1; nop + set gkpdup_, %g1; jmp %g1; nop + set gkpese_, %g1; jmp %g1; nop + set gkpfat_, %g1; jmp %g1; nop + set gkpfia_, %g1; jmp %g1; nop + set gkpflh_, %g1; jmp %g1; nop + set gkpger_, %g1; jmp %g1; nop + set gkpges_, %g1; jmp %g1; nop + set gkpgey_, %g1; jmp %g1; nop + set gkpgrm_, %g1; jmp %g1; nop + set gkpinl_, %g1; jmp %g1; nop + set gkpmfe_, %g1; jmp %g1; nop + set gkpops_, %g1; jmp %g1; nop + set gkpplt_, %g1; jmp %g1; nop + set gkppmt_, %g1; jmp %g1; nop + set gkppoe_, %g1; jmp %g1; nop + set gkppor_, %g1; jmp %g1; nop + set gkppst_, %g1; jmp %g1; nop + set gkppuy_, %g1; jmp %g1; nop + set gkpres_, %g1; jmp %g1; nop + set gkpser_, %g1; jmp %g1; nop + set gkpses_, %g1; jmp %g1; nop + set gkptet_, %g1; jmp %g1; nop + set gkptxg_, %g1; jmp %g1; nop + set gkptxt_, %g1; jmp %g1; nop + set gkpunn_, %g1; jmp %g1; nop + set glabax_, %g1; jmp %g1; nop + set glbdrd_, %g1; jmp %g1; nop + set glbene_, %g1; jmp %g1; nop + set glbeq_, %g1; jmp %g1; nop + set glbfis_, %g1; jmp %g1; nop + set glbgek_, %g1; jmp %g1; nop + set glblas_, %g1; jmp %g1; nop + set glblob_, %g1; jmp %g1; nop + set glbmip_, %g1; jmp %g1; nop + set glbple_, %g1; jmp %g1; nop + set glbsep_, %g1; jmp %g1; nop + set glbses_, %g1; jmp %g1; nop + set glbset_, %g1; jmp %g1; nop + set glbtin_, %g1; jmp %g1; nop + set glbveg_, %g1; jmp %g1; nop + set gline_, %g1; jmp %g1; nop + set gltoc_, %g1; jmp %g1; nop + set gmark_, %g1; jmp %g1; nop + set gmftie_, %g1; jmp %g1; nop + set gmprif_, %g1; jmp %g1; nop + set gmsg_, %g1; jmp %g1; nop + set gmsgb_, %g1; jmp %g1; nop + set gmsgc_, %g1; jmp %g1; nop + set gmsgd_, %g1; jmp %g1; nop + set gmsgi_, %g1; jmp %g1; nop + set gmsgl_, %g1; jmp %g1; nop + set gmsgr_, %g1; jmp %g1; nop + set gmsgs_, %g1; jmp %g1; nop + set gmsgx_, %g1; jmp %g1; nop + set gmttot_, %g1; jmp %g1; nop + set gopen_, %g1; jmp %g1; nop + set gopeni_, %g1; jmp %g1; nop + set gpagee_, %g1; jmp %g1; nop + set gpatme_, %g1; jmp %g1; nop + set gpatmh_, %g1; jmp %g1; nop + set gpcell_, %g1; jmp %g1; nop + set gplcae_, %g1; jmp %g1; nop + set gplcal_, %g1; jmp %g1; nop + set gplclb_, %g1; jmp %g1; nop + set gplcll_, %g1; jmp %g1; nop + set gplclr_, %g1; jmp %g1; nop + set gplclt_, %g1; jmp %g1; nop + set gplflh_, %g1; jmp %g1; nop + set gpline_, %g1; jmp %g1; nop + set gploto_, %g1; jmp %g1; nop + set gplotv_, %g1; jmp %g1; nop + set gplret_, %g1; jmp %g1; nop + set gplsee_, %g1; jmp %g1; nop + set gplwci_, %g1; jmp %g1; nop + set gpmark_, %g1; jmp %g1; nop + set gqsort_, %g1; jmp %g1; nop + set gqvery_, %g1; jmp %g1; nop + set grdraw_, %g1; jmp %g1; nop + set grdwcs_, %g1; jmp %g1; nop + set greace_, %g1; jmp %g1; nop + set greset_, %g1; jmp %g1; nop + set grmove_, %g1; jmp %g1; nop + set grscae_, %g1; jmp %g1; nop + set gscan_, %g1; jmp %g1; nop + set gscur_, %g1; jmp %g1; nop + set gseti_, %g1; jmp %g1; nop + set gsetr_, %g1; jmp %g1; nop + set gsets_, %g1; jmp %g1; nop + set gstati_, %g1; jmp %g1; nop + set gstatr_, %g1; jmp %g1; nop + set gstats_, %g1; jmp %g1; nop + set gstrct_, %g1; jmp %g1; nop + set gstrcy_, %g1; jmp %g1; nop + set gstrmh_, %g1; jmp %g1; nop + set gstsei_, %g1; jmp %g1; nop + set gstser_, %g1; jmp %g1; nop + set gsview_, %g1; jmp %g1; nop + set gswind_, %g1; jmp %g1; nop + set gtdise_, %g1; jmp %g1; nop + set gtext_, %g1; jmp %g1; nop + set gtickr_, %g1; jmp %g1; nop + set gtliny_, %g1; jmp %g1; nop + set gtndis_, %g1; jmp %g1; nop + set gttyld_, %g1; jmp %g1; nop + set gtxset_, %g1; jmp %g1; nop + set gtybih_, %g1; jmp %g1; nop + set gtycas_, %g1; jmp %g1; nop + set gtycle_, %g1; jmp %g1; nop + set gtyeny_, %g1; jmp %g1; nop + set gtyexs_, %g1; jmp %g1; nop + set gtyfey_, %g1; jmp %g1; nop + set gtyfiy_, %g1; jmp %g1; nop + set gtygeb_, %g1; jmp %g1; nop + set gtygei_, %g1; jmp %g1; nop + set gtyger_, %g1; jmp %g1; nop + set gtyges_, %g1; jmp %g1; nop + set gtyins_, %g1; jmp %g1; nop + set gtyopn_, %g1; jmp %g1; nop + set gtysce_, %g1; jmp %g1; nop + set gumark_, %g1; jmp %g1; nop + set gvline_, %g1; jmp %g1; nop + set gvmark_, %g1; jmp %g1; nop + set gwcsme_, %g1; jmp %g1; nop + set gwrwcs_, %g1; jmp %g1; nop + set i1mach_, %g1; jmp %g1; nop + set idbcle_, %g1; jmp %g1; nop + set idbfid_, %g1; jmp %g1; nop + set idbfir_, %g1; jmp %g1; nop + set idbgeg_, %g1; jmp %g1; nop + set idbkwp_, %g1; jmp %g1; nop + set idbned_, %g1; jmp %g1; nop + set idbopn_, %g1; jmp %g1; nop + set idbpug_, %g1; jmp %g1; nop + set ieegmd_, %g1; jmp %g1; nop + set ieegmr_, %g1; jmp %g1; nop + set ieegnd_, %g1; jmp %g1; nop + set ieegnr_, %g1; jmp %g1; nop + set ieemad_, %g1; jmp %g1; nop + set ieemar_, %g1; jmp %g1; nop + set ieepad_, %g1; jmp %g1; nop + set ieepar_, %g1; jmp %g1; nop + set ieesmd_, %g1; jmp %g1; nop + set ieesmr_, %g1; jmp %g1; nop + set ieesnd_, %g1; jmp %g1; nop + set ieesnr_, %g1; jmp %g1; nop + set ieestd_, %g1; jmp %g1; nop + set ieestr_, %g1; jmp %g1; nop + set ieeupd_, %g1; jmp %g1; nop + set ieeupr_, %g1; jmp %g1; nop + set ieevpd_, %g1; jmp %g1; nop + set ieevpr_, %g1; jmp %g1; nop + set ieevud_, %g1; jmp %g1; nop + set ieevur_, %g1; jmp %g1; nop + set ieezsd_, %g1; jmp %g1; nop + set ieezsr_, %g1; jmp %g1; nop + set ikiacs_, %g1; jmp %g1; nop + set ikicle_, %g1; jmp %g1; nop + set ikicoy_, %g1; jmp %g1; nop + set ikidee_, %g1; jmp %g1; nop + set ikideg_, %g1; jmp %g1; nop + set ikiext_, %g1; jmp %g1; nop + set ikiged_, %g1; jmp %g1; nop + set ikigen_, %g1; jmp %g1; nop + set ikiger_, %g1; jmp %g1; nop + set ikiint_, %g1; jmp %g1; nop + set ikildr_, %g1; jmp %g1; nop + set ikimke_, %g1; jmp %g1; nop + set ikiopn_, %g1; jmp %g1; nop + set ikiopx_, %g1; jmp %g1; nop + set ikipae_, %g1; jmp %g1; nop + set ikiree_, %g1; jmp %g1; nop + set ikiupr_, %g1; jmp %g1; nop + set ikivan_, %g1; jmp %g1; nop + set imaccf_, %g1; jmp %g1; nop + set imaccs_, %g1; jmp %g1; nop + set imaddb_, %g1; jmp %g1; nop + set imaddd_, %g1; jmp %g1; nop + set imaddf_, %g1; jmp %g1; nop + set imaddi_, %g1; jmp %g1; nop + set imaddl_, %g1; jmp %g1; nop + set imaddr_, %g1; jmp %g1; nop + set imadds_, %g1; jmp %g1; nop + set imaflp_, %g1; jmp %g1; nop + set imalin_, %g1; jmp %g1; nop + set imaplv_, %g1; jmp %g1; nop + set imastr_, %g1; jmp %g1; nop + set imbln1_, %g1; jmp %g1; nop + set imbln2_, %g1; jmp %g1; nop + set imbln3_, %g1; jmp %g1; nop + set imbtrn_, %g1; jmp %g1; nop + set imcfnl_, %g1; jmp %g1; nop + set imcopy_, %g1; jmp %g1; nop + set imcssz_, %g1; jmp %g1; nop + set imctrt_, %g1; jmp %g1; nop + set imdect_, %g1; jmp %g1; nop + set imdele_, %g1; jmp %g1; nop + set imdelf_, %g1; jmp %g1; nop + set imdmap_, %g1; jmp %g1; nop + set imerr_, %g1; jmp %g1; nop + set imflpl_, %g1; jmp %g1; nop + set imflps_, %g1; jmp %g1; nop + set imflsd_, %g1; jmp %g1; nop + set imflsh_, %g1; jmp %g1; nop + set imflsi_, %g1; jmp %g1; nop + set imflsl_, %g1; jmp %g1; nop + set imflsr_, %g1; jmp %g1; nop + set imflss_, %g1; jmp %g1; nop + set imflsx_, %g1; jmp %g1; nop + set imfluh_, %g1; jmp %g1; nop + set imfnpy_, %g1; jmp %g1; nop + set imfnss_, %g1; jmp %g1; nop + set imgclr_, %g1; jmp %g1; nop + set imgetb_, %g1; jmp %g1; nop + set imgetc_, %g1; jmp %g1; nop + set imgetd_, %g1; jmp %g1; nop + set imgeti_, %g1; jmp %g1; nop + set imgetl_, %g1; jmp %g1; nop + set imgetr_, %g1; jmp %g1; nop + set imgets_, %g1; jmp %g1; nop + set imgfte_, %g1; jmp %g1; nop + set imggsc_, %g1; jmp %g1; nop + set imggsd_, %g1; jmp %g1; nop + set imggsi_, %g1; jmp %g1; nop + set imggsl_, %g1; jmp %g1; nop + set imggsr_, %g1; jmp %g1; nop + set imggss_, %g1; jmp %g1; nop + set imggsx_, %g1; jmp %g1; nop + set imgibf_, %g1; jmp %g1; nop + set imgime_, %g1; jmp %g1; nop + set imgl1d_, %g1; jmp %g1; nop + set imgl1i_, %g1; jmp %g1; nop + set imgl1l_, %g1; jmp %g1; nop + set imgl1r_, %g1; jmp %g1; nop + set imgl1s_, %g1; jmp %g1; nop + set imgl1x_, %g1; jmp %g1; nop + set imgl2d_, %g1; jmp %g1; nop + set imgl2i_, %g1; jmp %g1; nop + set imgl2l_, %g1; jmp %g1; nop + set imgl2r_, %g1; jmp %g1; nop + set imgl2s_, %g1; jmp %g1; nop + set imgl2x_, %g1; jmp %g1; nop + set imgl3d_, %g1; jmp %g1; nop + set imgl3i_, %g1; jmp %g1; nop + set imgl3l_, %g1; jmp %g1; nop + set imgl3r_, %g1; jmp %g1; nop + set imgl3s_, %g1; jmp %g1; nop + set imgl3x_, %g1; jmp %g1; nop + set imgnfn_, %g1; jmp %g1; nop + set imgnld_, %g1; jmp %g1; nop + set imgnli_, %g1; jmp %g1; nop + set imgnll_, %g1; jmp %g1; nop + set imgnln_, %g1; jmp %g1; nop + set imgnlr_, %g1; jmp %g1; nop + set imgnls_, %g1; jmp %g1; nop + set imgnlx_, %g1; jmp %g1; nop + set imgobf_, %g1; jmp %g1; nop + set imgs1d_, %g1; jmp %g1; nop + set imgs1i_, %g1; jmp %g1; nop + set imgs1l_, %g1; jmp %g1; nop + set imgs1r_, %g1; jmp %g1; nop + set imgs1s_, %g1; jmp %g1; nop + set imgs1x_, %g1; jmp %g1; nop + set imgs2d_, %g1; jmp %g1; nop + set imgs2i_, %g1; jmp %g1; nop + set imgs2l_, %g1; jmp %g1; nop + set imgs2r_, %g1; jmp %g1; nop + set imgs2s_, %g1; jmp %g1; nop + set imgs2x_, %g1; jmp %g1; nop + set imgs3d_, %g1; jmp %g1; nop + set imgs3i_, %g1; jmp %g1; nop + set imgs3l_, %g1; jmp %g1; nop + set imgs3r_, %g1; jmp %g1; nop + set imgs3s_, %g1; jmp %g1; nop + set imgs3x_, %g1; jmp %g1; nop + set imgsen_, %g1; jmp %g1; nop + set imgstr_, %g1; jmp %g1; nop + set iminie_, %g1; jmp %g1; nop + set imioff_, %g1; jmp %g1; nop + set imisec_, %g1; jmp %g1; nop + set imloop_, %g1; jmp %g1; nop + set immaky_, %g1; jmp %g1; nop + set immap_, %g1; jmp %g1; nop + set immapz_, %g1; jmp %g1; nop + set imnote_, %g1; jmp %g1; nop + set imofnl_, %g1; jmp %g1; nop + set imofns_, %g1; jmp %g1; nop + set imofnu_, %g1; jmp %g1; nop + set imopsf_, %g1; jmp %g1; nop + set impakd_, %g1; jmp %g1; nop + set impaki_, %g1; jmp %g1; nop + set impakl_, %g1; jmp %g1; nop + set impakr_, %g1; jmp %g1; nop + set impaks_, %g1; jmp %g1; nop + set impakx_, %g1; jmp %g1; nop + set impare_, %g1; jmp %g1; nop + set impgsd_, %g1; jmp %g1; nop + set impgsi_, %g1; jmp %g1; nop + set impgsl_, %g1; jmp %g1; nop + set impgsr_, %g1; jmp %g1; nop + set impgss_, %g1; jmp %g1; nop + set impgsx_, %g1; jmp %g1; nop + set impl1d_, %g1; jmp %g1; nop + set impl1i_, %g1; jmp %g1; nop + set impl1l_, %g1; jmp %g1; nop + set impl1r_, %g1; jmp %g1; nop + set impl1s_, %g1; jmp %g1; nop + set impl1x_, %g1; jmp %g1; nop + set impl2d_, %g1; jmp %g1; nop + set impl2i_, %g1; jmp %g1; nop + set impl2l_, %g1; jmp %g1; nop + set impl2r_, %g1; jmp %g1; nop + set impl2s_, %g1; jmp %g1; nop + set impl2x_, %g1; jmp %g1; nop + set impl3d_, %g1; jmp %g1; nop + set impl3i_, %g1; jmp %g1; nop + set impl3l_, %g1; jmp %g1; nop + set impl3r_, %g1; jmp %g1; nop + set impl3s_, %g1; jmp %g1; nop + set impl3x_, %g1; jmp %g1; nop + set impml1_, %g1; jmp %g1; nop + set impml2_, %g1; jmp %g1; nop + set impml3_, %g1; jmp %g1; nop + set impmlr_, %g1; jmp %g1; nop + set impmlv_, %g1; jmp %g1; nop + set impmmo_, %g1; jmp %g1; nop + set impmmp_, %g1; jmp %g1; nop + set impmon_, %g1; jmp %g1; nop + set impms1_, %g1; jmp %g1; nop + set impms2_, %g1; jmp %g1; nop + set impms3_, %g1; jmp %g1; nop + set impmsr_, %g1; jmp %g1; nop + set impmsv_, %g1; jmp %g1; nop + set impnld_, %g1; jmp %g1; nop + set impnli_, %g1; jmp %g1; nop + set impnll_, %g1; jmp %g1; nop + set impnln_, %g1; jmp %g1; nop + set impnlr_, %g1; jmp %g1; nop + set impnls_, %g1; jmp %g1; nop + set impnlx_, %g1; jmp %g1; nop + set imps1d_, %g1; jmp %g1; nop + set imps1i_, %g1; jmp %g1; nop + set imps1l_, %g1; jmp %g1; nop + set imps1r_, %g1; jmp %g1; nop + set imps1s_, %g1; jmp %g1; nop + set imps1x_, %g1; jmp %g1; nop + set imps2d_, %g1; jmp %g1; nop + set imps2i_, %g1; jmp %g1; nop + set imps2l_, %g1; jmp %g1; nop + set imps2r_, %g1; jmp %g1; nop + set imps2s_, %g1; jmp %g1; nop + set imps2x_, %g1; jmp %g1; nop + set imps3d_, %g1; jmp %g1; nop + set imps3i_, %g1; jmp %g1; nop + set imps3l_, %g1; jmp %g1; nop + set imps3r_, %g1; jmp %g1; nop + set imps3s_, %g1; jmp %g1; nop + set imps3x_, %g1; jmp %g1; nop + set impstr_, %g1; jmp %g1; nop + set imputb_, %g1; jmp %g1; nop + set imputd_, %g1; jmp %g1; nop + set imputh_, %g1; jmp %g1; nop + set imputi_, %g1; jmp %g1; nop + set imputl_, %g1; jmp %g1; nop + set imputr_, %g1; jmp %g1; nop + set imputs_, %g1; jmp %g1; nop + set imrbpx_, %g1; jmp %g1; nop + set imrdpx_, %g1; jmp %g1; nop + set imrene_, %g1; jmp %g1; nop + set imrmbs_, %g1; jmp %g1; nop + set imsamp_, %g1; jmp %g1; nop + set imsetf_, %g1; jmp %g1; nop + set imseti_, %g1; jmp %g1; nop + set imsetr_, %g1; jmp %g1; nop + set imsinb_, %g1; jmp %g1; nop + set imsmpl_, %g1; jmp %g1; nop + set imsmps_, %g1; jmp %g1; nop + set imsslv_, %g1; jmp %g1; nop + set imstai_, %g1; jmp %g1; nop + set imstar_, %g1; jmp %g1; nop + set imstas_, %g1; jmp %g1; nop + set imtcle_, %g1; jmp %g1; nop + set imtgem_, %g1; jmp %g1; nop + set imtlen_, %g1; jmp %g1; nop + set imtmae_, %g1; jmp %g1; nop + set imtopn_, %g1; jmp %g1; nop + set imtopp_, %g1; jmp %g1; nop + set imtrew_, %g1; jmp %g1; nop + set imtrgm_, %g1; jmp %g1; nop + set imunmp_, %g1; jmp %g1; nop + set imupkd_, %g1; jmp %g1; nop + set imupki_, %g1; jmp %g1; nop + set imupkl_, %g1; jmp %g1; nop + set imupkr_, %g1; jmp %g1; nop + set imupks_, %g1; jmp %g1; nop + set imupkx_, %g1; jmp %g1; nop + set imwbpx_, %g1; jmp %g1; nop + set imwrie_, %g1; jmp %g1; nop + set imwrpx_, %g1; jmp %g1; nop + set intrde_, %g1; jmp %g1; nop + set intree_, %g1; jmp %g1; nop + set intrrt_, %g1; jmp %g1; nop + set irafmn_, %g1; jmp %g1; nop + set itob_, %g1; jmp %g1; nop + set itoc_, %g1; jmp %g1; nop + set iwcare_, %g1; jmp %g1; nop + set iwcfis_, %g1; jmp %g1; nop + set iwents_, %g1; jmp %g1; nop + set iwfind_, %g1; jmp %g1; nop + set iwgbis_, %g1; jmp %g1; nop + set iwputr_, %g1; jmp %g1; nop + set iwputy_, %g1; jmp %g1; nop + set iwrfis_, %g1; jmp %g1; nop + set iwsetp_, %g1; jmp %g1; nop + set kardbf_, %g1; jmp %g1; nop + set kardgd_, %g1; jmp %g1; nop + set kardlp_, %g1; jmp %g1; nop + set kardpl_, %g1; jmp %g1; nop + set kardpr_, %g1; jmp %g1; nop + set kardsf_, %g1; jmp %g1; nop + set kawrbf_, %g1; jmp %g1; nop + set kawrgd_, %g1; jmp %g1; nop + set kawrlp_, %g1; jmp %g1; nop + set kawrpl_, %g1; jmp %g1; nop + set kawrpr_, %g1; jmp %g1; nop + set kawrsf_, %g1; jmp %g1; nop + set kawtbf_, %g1; jmp %g1; nop + set kawtgd_, %g1; jmp %g1; nop + set kawtlp_, %g1; jmp %g1; nop + set kawtpl_, %g1; jmp %g1; nop + set kawtpr_, %g1; jmp %g1; nop + set kawtsf_, %g1; jmp %g1; nop + set kbzard_, %g1; jmp %g1; nop + set kbzawr_, %g1; jmp %g1; nop + set kbzawt_, %g1; jmp %g1; nop + set kbzcls_, %g1; jmp %g1; nop + set kbzopn_, %g1; jmp %g1; nop + set kbzstt_, %g1; jmp %g1; nop + set kclcpr_, %g1; jmp %g1; nop + set kcldir_, %g1; jmp %g1; nop + set kcldpr_, %g1; jmp %g1; nop + set kclsbf_, %g1; jmp %g1; nop + set kclsgd_, %g1; jmp %g1; nop + set kclslp_, %g1; jmp %g1; nop + set kclspl_, %g1; jmp %g1; nop + set kclssf_, %g1; jmp %g1; nop + set kclstx_, %g1; jmp %g1; nop + set kclsty_, %g1; jmp %g1; nop + set kdvall_, %g1; jmp %g1; nop + set kdvown_, %g1; jmp %g1; nop + set kfacss_, %g1; jmp %g1; nop + set kfaloc_, %g1; jmp %g1; nop + set kfchdr_, %g1; jmp %g1; nop + set kfdele_, %g1; jmp %g1; nop + set kfgcwd_, %g1; jmp %g1; nop + set kfinfo_, %g1; jmp %g1; nop + set kflstx_, %g1; jmp %g1; nop + set kflsty_, %g1; jmp %g1; nop + set kfmkcp_, %g1; jmp %g1; nop + set kfmkdr_, %g1; jmp %g1; nop + set kfpath_, %g1; jmp %g1; nop + set kfprot_, %g1; jmp %g1; nop + set kfrnam_, %g1; jmp %g1; nop + set kfsubd_, %g1; jmp %g1; nop + set kfxdir_, %g1; jmp %g1; nop + set kgettx_, %g1; jmp %g1; nop + set kgetty_, %g1; jmp %g1; nop + set kgfdir_, %g1; jmp %g1; nop + set kicont_, %g1; jmp %g1; nop + set kidece_, %g1; jmp %g1; nop + set kience_, %g1; jmp %g1; nop + set kienvt_, %g1; jmp %g1; nop + set kierrr_, %g1; jmp %g1; nop + set kiexte_, %g1; jmp %g1; nop + set kifine_, %g1; jmp %g1; nop + set kiflux_, %g1; jmp %g1; nop + set kifman_, %g1; jmp %g1; nop + set kifren_, %g1; jmp %g1; nop + set kigetn_, %g1; jmp %g1; nop + set kigets_, %g1; jmp %g1; nop + set kignoe_, %g1; jmp %g1; nop + set kiinit_, %g1; jmp %g1; nop + set kiloce_, %g1; jmp %g1; nop + set kimape_, %g1; jmp %g1; nop + set kimapn_, %g1; jmp %g1; nop + set kintpr_, %g1; jmp %g1; nop + set kiopes_, %g1; jmp %g1; nop + set kirece_, %g1; jmp %g1; nop + set kisend_, %g1; jmp %g1; nop + set kisenv_, %g1; jmp %g1; nop + set kishot_, %g1; jmp %g1; nop + set kixnoe_, %g1; jmp %g1; nop + set kmallc_, %g1; jmp %g1; nop + set knottx_, %g1; jmp %g1; nop + set knotty_, %g1; jmp %g1; nop + set kopcpr_, %g1; jmp %g1; nop + set kopdir_, %g1; jmp %g1; nop + set kopdpr_, %g1; jmp %g1; nop + set kopnbf_, %g1; jmp %g1; nop + set kopngd_, %g1; jmp %g1; nop + set kopnlp_, %g1; jmp %g1; nop + set kopnpl_, %g1; jmp %g1; nop + set kopnsf_, %g1; jmp %g1; nop + set kopntx_, %g1; jmp %g1; nop + set kopnty_, %g1; jmp %g1; nop + set koscmd_, %g1; jmp %g1; nop + set kputtx_, %g1; jmp %g1; nop + set kputty_, %g1; jmp %g1; nop + set krealc_, %g1; jmp %g1; nop + set ksared_, %g1; jmp %g1; nop + set ksawat_, %g1; jmp %g1; nop + set ksawre_, %g1; jmp %g1; nop + set ksektx_, %g1; jmp %g1; nop + set ksekty_, %g1; jmp %g1; nop + set ksttbf_, %g1; jmp %g1; nop + set ksttgd_, %g1; jmp %g1; nop + set ksttlp_, %g1; jmp %g1; nop + set ksttpl_, %g1; jmp %g1; nop + set ksttpr_, %g1; jmp %g1; nop + set ksttsf_, %g1; jmp %g1; nop + set kstttx_, %g1; jmp %g1; nop + set ksttty_, %g1; jmp %g1; nop + set ktzcls_, %g1; jmp %g1; nop + set ktzfls_, %g1; jmp %g1; nop + set ktzget_, %g1; jmp %g1; nop + set ktznot_, %g1; jmp %g1; nop + set ktzopn_, %g1; jmp %g1; nop + set ktzput_, %g1; jmp %g1; nop + set ktzsek_, %g1; jmp %g1; nop + set ktzstt_, %g1; jmp %g1; nop + set kzclmt_, %g1; jmp %g1; nop + set kzopmt_, %g1; jmp %g1; nop + set kzrdmt_, %g1; jmp %g1; nop + set kzrwmt_, %g1; jmp %g1; nop + set kzstmt_, %g1; jmp %g1; nop + set kzwrmt_, %g1; jmp %g1; nop + set kzwtmt_, %g1; jmp %g1; nop + set lexnum_, %g1; jmp %g1; nop + set lnocle_, %g1; jmp %g1; nop + set lnofeh_, %g1; jmp %g1; nop + set lnoopn_, %g1; jmp %g1; nop + set lnosae_, %g1; jmp %g1; nop + set locpr_, %g1; jmp %g1; nop + set locva_, %g1; jmp %g1; nop + set lpopen_, %g1; jmp %g1; nop + set lpzard_, %g1; jmp %g1; nop + set lpzawe_, %g1; jmp %g1; nop + set lpzawt_, %g1; jmp %g1; nop + set lsttot_, %g1; jmp %g1; nop + set ltoc_, %g1; jmp %g1; nop + set m75put_, %g1; jmp %g1; nop + set maideh_, %g1; jmp %g1; nop + set mallo1_, %g1; jmp %g1; nop + set mgdptr_, %g1; jmp %g1; nop + set mgtfwa_, %g1; jmp %g1; nop + set miilen_, %g1; jmp %g1; nop + set miinem_, %g1; jmp %g1; nop + set miipa2_, %g1; jmp %g1; nop + set miipa6_, %g1; jmp %g1; nop + set miipa8_, %g1; jmp %g1; nop + set miipad_, %g1; jmp %g1; nop + set miipak_, %g1; jmp %g1; nop + set miipar_, %g1; jmp %g1; nop + set miipke_, %g1; jmp %g1; nop + set miirec_, %g1; jmp %g1; nop + set miired_, %g1; jmp %g1; nop + set miirei_, %g1; jmp %g1; nop + set miirel_, %g1; jmp %g1; nop + set miirer_, %g1; jmp %g1; nop + set miires_, %g1; jmp %g1; nop + set miiup2_, %g1; jmp %g1; nop + set miiup6_, %g1; jmp %g1; nop + set miiup8_, %g1; jmp %g1; nop + set miiupd_, %g1; jmp %g1; nop + set miiupk_, %g1; jmp %g1; nop + set miiupr_, %g1; jmp %g1; nop + set miiwrc_, %g1; jmp %g1; nop + set miiwrd_, %g1; jmp %g1; nop + set miiwri_, %g1; jmp %g1; nop + set miiwrl_, %g1; jmp %g1; nop + set miiwrr_, %g1; jmp %g1; nop + set miiwrs_, %g1; jmp %g1; nop + set miocle_, %g1; jmp %g1; nop + set miogld_, %g1; jmp %g1; nop + set miogli_, %g1; jmp %g1; nop + set miogll_, %g1; jmp %g1; nop + set mioglr_, %g1; jmp %g1; nop + set miogls_, %g1; jmp %g1; nop + set mioglx_, %g1; jmp %g1; nop + set mioopn_, %g1; jmp %g1; nop + set mioopo_, %g1; jmp %g1; nop + set miopld_, %g1; jmp %g1; nop + set miopli_, %g1; jmp %g1; nop + set miopll_, %g1; jmp %g1; nop + set mioplr_, %g1; jmp %g1; nop + set miopls_, %g1; jmp %g1; nop + set mioplx_, %g1; jmp %g1; nop + set miosee_, %g1; jmp %g1; nop + set miosei_, %g1; jmp %g1; nop + set miosti_, %g1; jmp %g1; nop + set msvfwa_, %g1; jmp %g1; nop + set mtalle_, %g1; jmp %g1; nop + set mtcap_, %g1; jmp %g1; nop + set mtclen_, %g1; jmp %g1; nop + set mtclre_, %g1; jmp %g1; nop + set mtdeae_, %g1; jmp %g1; nop + set mtdevd_, %g1; jmp %g1; nop + set mtence_, %g1; jmp %g1; nop + set mtfile_, %g1; jmp %g1; nop + set mtfnae_, %g1; jmp %g1; nop + set mtgets_, %g1; jmp %g1; nop + set mtglok_, %g1; jmp %g1; nop + set mtgtyn_, %g1; jmp %g1; nop + set mtloce_, %g1; jmp %g1; nop + set mtneeo_, %g1; jmp %g1; nop + set mtopen_, %g1; jmp %g1; nop + set mtpare_, %g1; jmp %g1; nop + set mtposn_, %g1; jmp %g1; nop + set mtpute_, %g1; jmp %g1; nop + set mtreae_, %g1; jmp %g1; nop + set mtrewd_, %g1; jmp %g1; nop + set mtsavd_, %g1; jmp %g1; nop + set mtsavs_, %g1; jmp %g1; nop + set mtskid_, %g1; jmp %g1; nop + set mtstas_, %g1; jmp %g1; nop + set mtsync_, %g1; jmp %g1; nop + set mtupde_, %g1; jmp %g1; nop + set mwalld_, %g1; jmp %g1; nop + set mwalls_, %g1; jmp %g1; nop + set mwaxtn_, %g1; jmp %g1; nop + set mwc1td_, %g1; jmp %g1; nop + set mwc1tr_, %g1; jmp %g1; nop + set mwc2td_, %g1; jmp %g1; nop + set mwc2tr_, %g1; jmp %g1; nop + set mwcloe_, %g1; jmp %g1; nop + set mwcopd_, %g1; jmp %g1; nop + set mwcops_, %g1; jmp %g1; nop + set mwctfe_, %g1; jmp %g1; nop + set mwctrd_, %g1; jmp %g1; nop + set mwctrr_, %g1; jmp %g1; nop + set mwfins_, %g1; jmp %g1; nop + set mwflop_, %g1; jmp %g1; nop + set mwgaxp_, %g1; jmp %g1; nop + set mwgaxt_, %g1; jmp %g1; nop + set mwgctd_, %g1; jmp %g1; nop + set mwgctr_, %g1; jmp %g1; nop + set mwgltd_, %g1; jmp %g1; nop + set mwgltr_, %g1; jmp %g1; nop + set mwgsym_, %g1; jmp %g1; nop + set mwgwas_, %g1; jmp %g1; nop + set mwgwsd_, %g1; jmp %g1; nop + set mwgwsr_, %g1; jmp %g1; nop + set mwgwtd_, %g1; jmp %g1; nop + set mwgwtr_, %g1; jmp %g1; nop + set mwinvd_, %g1; jmp %g1; nop + set mwinvr_, %g1; jmp %g1; nop + set mwload_, %g1; jmp %g1; nop + set mwloam_, %g1; jmp %g1; nop + set mwltrd_, %g1; jmp %g1; nop + set mwltrr_, %g1; jmp %g1; nop + set mwlubb_, %g1; jmp %g1; nop + set mwlude_, %g1; jmp %g1; nop + set mwmkid_, %g1; jmp %g1; nop + set mwmkir_, %g1; jmp %g1; nop + set mwmmud_, %g1; jmp %g1; nop + set mwmmur_, %g1; jmp %g1; nop + set mwnewm_, %g1; jmp %g1; nop + set mwnewy_, %g1; jmp %g1; nop + set mwopem_, %g1; jmp %g1; nop + set mwopen_, %g1; jmp %g1; nop + set mwrefr_, %g1; jmp %g1; nop + set mwrote_, %g1; jmp %g1; nop + set mwsave_, %g1; jmp %g1; nop + set mwsavm_, %g1; jmp %g1; nop + set mwsaxp_, %g1; jmp %g1; nop + set mwscae_, %g1; jmp %g1; nop + set mwsctn_, %g1; jmp %g1; nop + set mwsdes_, %g1; jmp %g1; nop + set mwseti_, %g1; jmp %g1; nop + set mwshit_, %g1; jmp %g1; nop + set mwshow_, %g1; jmp %g1; nop + set mwsltd_, %g1; jmp %g1; nop + set mwsltr_, %g1; jmp %g1; nop + set mwssym_, %g1; jmp %g1; nop + set mwstai_, %g1; jmp %g1; nop + set mwswas_, %g1; jmp %g1; nop + set mwswsd_, %g1; jmp %g1; nop + set mwswsr_, %g1; jmp %g1; nop + set mwswtd_, %g1; jmp %g1; nop + set mwswte_, %g1; jmp %g1; nop + set mwswtr_, %g1; jmp %g1; nop + set mwtrad_, %g1; jmp %g1; nop + set mwtrar_, %g1; jmp %g1; nop + set mwv1td_, %g1; jmp %g1; nop + set mwv1tr_, %g1; jmp %g1; nop + set mwv2td_, %g1; jmp %g1; nop + set mwv2tr_, %g1; jmp %g1; nop + set mwvmud_, %g1; jmp %g1; nop + set mwvmur_, %g1; jmp %g1; nop + set mwvtrd_, %g1; jmp %g1; nop + set mwvtrr_, %g1; jmp %g1; nop + set ndopen_, %g1; jmp %g1; nop + set noti_, %g1; jmp %g1; nop + set notl_, %g1; jmp %g1; nop + set nots_, %g1; jmp %g1; nop + set nowhie_, %g1; jmp %g1; nop + set nscan_, %g1; jmp %g1; nop + set oifacs_, %g1; jmp %g1; nop + set oifcle_, %g1; jmp %g1; nop + set oifcoy_, %g1; jmp %g1; nop + set oifdee_, %g1; jmp %g1; nop + set oifgpe_, %g1; jmp %g1; nop + set oifmke_, %g1; jmp %g1; nop + set oifopn_, %g1; jmp %g1; nop + set oifopx_, %g1; jmp %g1; nop + set oifrdr_, %g1; jmp %g1; nop + set oifree_, %g1; jmp %g1; nop + set oiftrm_, %g1; jmp %g1; nop + set oifupr_, %g1; jmp %g1; nop + set oifwrr_, %g1; jmp %g1; nop + set onerre_, %g1; jmp %g1; nop + set onerrr_, %g1; jmp %g1; nop + set onexie_, %g1; jmp %g1; nop + set onexit_, %g1; jmp %g1; nop + set ord1_, %g1; jmp %g1; nop + set ord2_, %g1; jmp %g1; nop + set ori_, %g1; jmp %g1; nop + set orl_, %g1; jmp %g1; nop + set ors_, %g1; jmp %g1; nop + set oscmd_, %g1; jmp %g1; nop + set osfnik_, %g1; jmp %g1; nop + set osfnlk_, %g1; jmp %g1; nop + set osfnms_, %g1; jmp %g1; nop + set osfnpe_, %g1; jmp %g1; nop + set osfnrk_, %g1; jmp %g1; nop + set osfntt_, %g1; jmp %g1; nop + set osfnuk_, %g1; jmp %g1; nop + set pagefe_, %g1; jmp %g1; nop + set pagefs_, %g1; jmp %g1; nop + set pargb_, %g1; jmp %g1; nop + set pargc_, %g1; jmp %g1; nop + set pargd_, %g1; jmp %g1; nop + set pargg_, %g1; jmp %g1; nop + set pargi_, %g1; jmp %g1; nop + set pargl_, %g1; jmp %g1; nop + set pargr_, %g1; jmp %g1; nop + set pargs_, %g1; jmp %g1; nop + set pargsr_, %g1; jmp %g1; nop + set pargx_, %g1; jmp %g1; nop + set patamh_, %g1; jmp %g1; nop + set patfit_, %g1; jmp %g1; nop + set patgel_, %g1; jmp %g1; nop + set patgse_, %g1; jmp %g1; nop + set patinx_, %g1; jmp %g1; nop + set patloe_, %g1; jmp %g1; nop + set patmae_, %g1; jmp %g1; nop + set patmah_, %g1; jmp %g1; nop + set patomh_, %g1; jmp %g1; nop + set patsts_, %g1; jmp %g1; nop + set pggetd_, %g1; jmp %g1; nop + set pggete_, %g1; jmp %g1; nop + set pggetr_, %g1; jmp %g1; nop + set pgpage_, %g1; jmp %g1; nop + set pgpeed_, %g1; jmp %g1; nop + set pgpusd_, %g1; jmp %g1; nop + set pgsett_, %g1; jmp %g1; nop + set placcs_, %g1; jmp %g1; nop + set plallc_, %g1; jmp %g1; nop + set plascp_, %g1; jmp %g1; nop + set plbox_, %g1; jmp %g1; nop + set plcire_, %g1; jmp %g1; nop + set plcler_, %g1; jmp %g1; nop + set plcloe_, %g1; jmp %g1; nop + set plcome_, %g1; jmp %g1; nop + set plcoms_, %g1; jmp %g1; nop + set plcree_, %g1; jmp %g1; nop + set pldebg_, %g1; jmp %g1; nop + set pldebt_, %g1; jmp %g1; nop + set plempe_, %g1; jmp %g1; nop + set plempy_, %g1; jmp %g1; nop + set plfacs_, %g1; jmp %g1; nop + set plfcle_, %g1; jmp %g1; nop + set plfcoy_, %g1; jmp %g1; nop + set plfdee_, %g1; jmp %g1; nop + set plfnul_, %g1; jmp %g1; nop + set plfopn_, %g1; jmp %g1; nop + set plfree_, %g1; jmp %g1; nop + set plfupr_, %g1; jmp %g1; nop + set plgete_, %g1; jmp %g1; nop + set plglls_, %g1; jmp %g1; nop + set plglpi_, %g1; jmp %g1; nop + set plglpl_, %g1; jmp %g1; nop + set plglps_, %g1; jmp %g1; nop + set plglri_, %g1; jmp %g1; nop + set plglrl_, %g1; jmp %g1; nop + set plglrs_, %g1; jmp %g1; nop + set plgsie_, %g1; jmp %g1; nop + set pll2pi_, %g1; jmp %g1; nop + set pll2pl_, %g1; jmp %g1; nop + set pll2ps_, %g1; jmp %g1; nop + set pll2ri_, %g1; jmp %g1; nop + set pll2rl_, %g1; jmp %g1; nop + set pll2rs_, %g1; jmp %g1; nop + set pllcot_, %g1; jmp %g1; nop + set pllemy_, %g1; jmp %g1; nop + set plleql_, %g1; jmp %g1; nop + set plline_, %g1; jmp %g1; nop + set pllinl_, %g1; jmp %g1; nop + set pllinp_, %g1; jmp %g1; nop + set plliny_, %g1; jmp %g1; nop + set plllen_, %g1; jmp %g1; nop + set pllneg_, %g1; jmp %g1; nop + set plload_, %g1; jmp %g1; nop + set plloaf_, %g1; jmp %g1; nop + set plloam_, %g1; jmp %g1; nop + set plloop_, %g1; jmp %g1; nop + set pllprs_, %g1; jmp %g1; nop + set plnewy_, %g1; jmp %g1; nop + set plopen_, %g1; jmp %g1; nop + set plp2li_, %g1; jmp %g1; nop + set plp2ll_, %g1; jmp %g1; nop + set plp2ls_, %g1; jmp %g1; nop + set plp2ri_, %g1; jmp %g1; nop + set plp2rl_, %g1; jmp %g1; nop + set plp2rs_, %g1; jmp %g1; nop + set plpixi_, %g1; jmp %g1; nop + set plpixl_, %g1; jmp %g1; nop + set plpixs_, %g1; jmp %g1; nop + set plplls_, %g1; jmp %g1; nop + set plplpi_, %g1; jmp %g1; nop + set plplpl_, %g1; jmp %g1; nop + set plplps_, %g1; jmp %g1; nop + set plplri_, %g1; jmp %g1; nop + set plplrl_, %g1; jmp %g1; nop + set plplrs_, %g1; jmp %g1; nop + set plpoit_, %g1; jmp %g1; nop + set plpoln_, %g1; jmp %g1; nop + set plr2li_, %g1; jmp %g1; nop + set plr2ll_, %g1; jmp %g1; nop + set plr2ls_, %g1; jmp %g1; nop + set plr2pi_, %g1; jmp %g1; nop + set plr2pl_, %g1; jmp %g1; nop + set plr2ps_, %g1; jmp %g1; nop + set plrani_, %g1; jmp %g1; nop + set plranl_, %g1; jmp %g1; nop + set plrans_, %g1; jmp %g1; nop + set plrcle_, %g1; jmp %g1; nop + set plrefe_, %g1; jmp %g1; nop + set plregp_, %g1; jmp %g1; nop + set plreqi_, %g1; jmp %g1; nop + set plreql_, %g1; jmp %g1; nop + set plreqs_, %g1; jmp %g1; nop + set plrget_, %g1; jmp %g1; nop + set plrgex_, %g1; jmp %g1; nop + set plrop_, %g1; jmp %g1; nop + set plropn_, %g1; jmp %g1; nop + set plrpri_, %g1; jmp %g1; nop + set plrprl_, %g1; jmp %g1; nop + set plrprs_, %g1; jmp %g1; nop + set plrset_, %g1; jmp %g1; nop + set plsave_, %g1; jmp %g1; nop + set plsavf_, %g1; jmp %g1; nop + set plsavm_, %g1; jmp %g1; nop + set plsect_, %g1; jmp %g1; nop + set plsecy_, %g1; jmp %g1; nop + set plsete_, %g1; jmp %g1; nop + set plseti_, %g1; jmp %g1; nop + set plssie_, %g1; jmp %g1; nop + set plsslv_, %g1; jmp %g1; nop + set plstai_, %g1; jmp %g1; nop + set plstel_, %g1; jmp %g1; nop + set plubox_, %g1; jmp %g1; nop + set plucie_, %g1; jmp %g1; nop + set plupde_, %g1; jmp %g1; nop + set plupon_, %g1; jmp %g1; nop + set plvald_, %g1; jmp %g1; nop + set pmaccs_, %g1; jmp %g1; nop + set pmascp_, %g1; jmp %g1; nop + set pmbox_, %g1; jmp %g1; nop + set pmcire_, %g1; jmp %g1; nop + set pmcler_, %g1; jmp %g1; nop + set pmempy_, %g1; jmp %g1; nop + set pmglls_, %g1; jmp %g1; nop + set pmglpi_, %g1; jmp %g1; nop + set pmglpl_, %g1; jmp %g1; nop + set pmglps_, %g1; jmp %g1; nop + set pmglri_, %g1; jmp %g1; nop + set pmglrl_, %g1; jmp %g1; nop + set pmglrs_, %g1; jmp %g1; nop + set pmline_, %g1; jmp %g1; nop + set pmliny_, %g1; jmp %g1; nop + set pmnewk_, %g1; jmp %g1; nop + set pmplls_, %g1; jmp %g1; nop + set pmplpi_, %g1; jmp %g1; nop + set pmplpl_, %g1; jmp %g1; nop + set pmplps_, %g1; jmp %g1; nop + set pmplri_, %g1; jmp %g1; nop + set pmplrl_, %g1; jmp %g1; nop + set pmplrs_, %g1; jmp %g1; nop + set pmpoit_, %g1; jmp %g1; nop + set pmpoln_, %g1; jmp %g1; nop + set pmrcle_, %g1; jmp %g1; nop + set pmrgex_, %g1; jmp %g1; nop + set pmrop_, %g1; jmp %g1; nop + set pmropn_, %g1; jmp %g1; nop + set pmrset_, %g1; jmp %g1; nop + set pmsect_, %g1; jmp %g1; nop + set pmsecy_, %g1; jmp %g1; nop + set pmsete_, %g1; jmp %g1; nop + set pmseti_, %g1; jmp %g1; nop + set pmstai_, %g1; jmp %g1; nop + set pmstel_, %g1; jmp %g1; nop + set prchdr_, %g1; jmp %g1; nop + set prclcr_, %g1; jmp %g1; nop + set prcldr_, %g1; jmp %g1; nop + set prcloe_, %g1; jmp %g1; nop + set prdone_, %g1; jmp %g1; nop + set prdumn_, %g1; jmp %g1; nop + set prenve_, %g1; jmp %g1; nop + set prenvt_, %g1; jmp %g1; nop + set prfilf_, %g1; jmp %g1; nop + set prfinc_, %g1; jmp %g1; nop + set prgete_, %g1; jmp %g1; nop + set prgetr_, %g1; jmp %g1; nop + set prkill_, %g1; jmp %g1; nop + set pronic_, %g1; jmp %g1; nop + set propcr_, %g1; jmp %g1; nop + set propdr_, %g1; jmp %g1; nop + set propen_, %g1; jmp %g1; nop + set proscd_, %g1; jmp %g1; nop + set protet_, %g1; jmp %g1; nop + set prpsio_, %g1; jmp %g1; nop + set prpsld_, %g1; jmp %g1; nop + set prredr_, %g1; jmp %g1; nop + set prseti_, %g1; jmp %g1; nop + set prsigl_, %g1; jmp %g1; nop + set prstai_, %g1; jmp %g1; nop + set prupde_, %g1; jmp %g1; nop + set prvret_, %g1; jmp %g1; nop + set przclr_, %g1; jmp %g1; nop + set pscenr_, %g1; jmp %g1; nop + set pscens_, %g1; jmp %g1; nop + set pschwh_, %g1; jmp %g1; nop + set pscloe_, %g1; jmp %g1; nop + set psdept_, %g1; jmp %g1; nop + set psesct_, %g1; jmp %g1; nop + set psfone_, %g1; jmp %g1; nop + set psfonr_, %g1; jmp %g1; nop + set psfoor_, %g1; jmp %g1; nop + set psgett_, %g1; jmp %g1; nop + set pshear_, %g1; jmp %g1; nop + set psindt_, %g1; jmp %g1; nop + set psioit_, %g1; jmp %g1; nop + set psioxr_, %g1; jmp %g1; nop + set pslink_, %g1; jmp %g1; nop + set psnewe_, %g1; jmp %g1; nop + set psopen_, %g1; jmp %g1; nop + set psoutt_, %g1; jmp %g1; nop + set pspage_, %g1; jmp %g1; nop + set pspagk_, %g1; jmp %g1; nop + set psrigy_, %g1; jmp %g1; nop + set psrjps_, %g1; jmp %g1; nop + set pssets_, %g1; jmp %g1; nop + set pssett_, %g1; jmp %g1; nop + set pssety_, %g1; jmp %g1; nop + set psspft_, %g1; jmp %g1; nop + set pstese_, %g1; jmp %g1; nop + set pstexh_, %g1; jmp %g1; nop + set pstrar_, %g1; jmp %g1; nop + set pswrig_, %g1; jmp %g1; nop + set pswrtk_, %g1; jmp %g1; nop + set psxpos_, %g1; jmp %g1; nop + set psypos_, %g1; jmp %g1; nop + set putcc_, %g1; jmp %g1; nop + set putci_, %g1; jmp %g1; nop + set putlie_, %g1; jmp %g1; nop + set qmaccs_, %g1; jmp %g1; nop + set qmgetc_, %g1; jmp %g1; nop + set qmscan_, %g1; jmp %g1; nop + set qmscao_, %g1; jmp %g1; nop + set qmsetm_, %g1; jmp %g1; nop + set qmsetr_, %g1; jmp %g1; nop + set qmsets_, %g1; jmp %g1; nop + set qmspai_, %g1; jmp %g1; nop + set qmspar_, %g1; jmp %g1; nop + set qmsymb_, %g1; jmp %g1; nop + set qmupds_, %g1; jmp %g1; nop + set qpaccf_, %g1; jmp %g1; nop + set qpaccs_, %g1; jmp %g1; nop + set qpaddb_, %g1; jmp %g1; nop + set qpaddc_, %g1; jmp %g1; nop + set qpaddd_, %g1; jmp %g1; nop + set qpaddf_, %g1; jmp %g1; nop + set qpaddi_, %g1; jmp %g1; nop + set qpaddl_, %g1; jmp %g1; nop + set qpaddr_, %g1; jmp %g1; nop + set qpadds_, %g1; jmp %g1; nop + set qpaddx_, %g1; jmp %g1; nop + set qpargt_, %g1; jmp %g1; nop + set qpastr_, %g1; jmp %g1; nop + set qpbind_, %g1; jmp %g1; nop + set qpcfnl_, %g1; jmp %g1; nop + set qpcloe_, %g1; jmp %g1; nop + set qpclot_, %g1; jmp %g1; nop + set qpcopf_, %g1; jmp %g1; nop + set qpcopy_, %g1; jmp %g1; nop + set qpctod_, %g1; jmp %g1; nop + set qpctoi_, %g1; jmp %g1; nop + set qpdele_, %g1; jmp %g1; nop + set qpdelf_, %g1; jmp %g1; nop + set qpdsym_, %g1; jmp %g1; nop + set qpdtye_, %g1; jmp %g1; nop + set qpelee_, %g1; jmp %g1; nop + set qpexad_, %g1; jmp %g1; nop + set qpexai_, %g1; jmp %g1; nop + set qpexar_, %g1; jmp %g1; nop + set qpexcd_, %g1; jmp %g1; nop + set qpexce_, %g1; jmp %g1; nop + set qpexci_, %g1; jmp %g1; nop + set qpexcr_, %g1; jmp %g1; nop + set qpexdc_, %g1; jmp %g1; nop + set qpexde_, %g1; jmp %g1; nop + set qpexdg_, %g1; jmp %g1; nop + set qpexdr_, %g1; jmp %g1; nop + set qpexee_, %g1; jmp %g1; nop + set qpexfe_, %g1; jmp %g1; nop + set qpexge_, %g1; jmp %g1; nop + set qpexgr_, %g1; jmp %g1; nop + set qpexmk_, %g1; jmp %g1; nop + set qpexmr_, %g1; jmp %g1; nop + set qpexon_, %g1; jmp %g1; nop + set qpexpd_, %g1; jmp %g1; nop + set qpexpi_, %g1; jmp %g1; nop + set qpexpn_, %g1; jmp %g1; nop + set qpexpr_, %g1; jmp %g1; nop + set qpexps_, %g1; jmp %g1; nop + set qpexpt_, %g1; jmp %g1; nop + set qpexrd_, %g1; jmp %g1; nop + set qpexsd_, %g1; jmp %g1; nop + set qpexsi_, %g1; jmp %g1; nop + set qpexsr_, %g1; jmp %g1; nop + set qpfacs_, %g1; jmp %g1; nop + set qpfcle_, %g1; jmp %g1; nop + set qpfcos_, %g1; jmp %g1; nop + set qpfcoy_, %g1; jmp %g1; nop + set qpfdee_, %g1; jmp %g1; nop + set qpflur_, %g1; jmp %g1; nop + set qpfopn_, %g1; jmp %g1; nop + set qpfopx_, %g1; jmp %g1; nop + set qpfree_, %g1; jmp %g1; nop + set qpfupr_, %g1; jmp %g1; nop + set qpfwar_, %g1; jmp %g1; nop + set qpfwfr_, %g1; jmp %g1; nop + set qpfzcl_, %g1; jmp %g1; nop + set qpfzop_, %g1; jmp %g1; nop + set qpfzrd_, %g1; jmp %g1; nop + set qpfzst_, %g1; jmp %g1; nop + set qpfzwr_, %g1; jmp %g1; nop + set qpfzwt_, %g1; jmp %g1; nop + set qpgetb_, %g1; jmp %g1; nop + set qpgetc_, %g1; jmp %g1; nop + set qpgetd_, %g1; jmp %g1; nop + set qpgeti_, %g1; jmp %g1; nop + set qpgetk_, %g1; jmp %g1; nop + set qpgetl_, %g1; jmp %g1; nop + set qpgetm_, %g1; jmp %g1; nop + set qpgetr_, %g1; jmp %g1; nop + set qpgets_, %g1; jmp %g1; nop + set qpgetx_, %g1; jmp %g1; nop + set qpgmsm_, %g1; jmp %g1; nop + set qpgnfn_, %g1; jmp %g1; nop + set qpgpsm_, %g1; jmp %g1; nop + set qpgstr_, %g1; jmp %g1; nop + set qpinht_, %g1; jmp %g1; nop + set qpioce_, %g1; jmp %g1; nop + set qpioge_, %g1; jmp %g1; nop + set qpiogr_, %g1; jmp %g1; nop + set qpiogs_, %g1; jmp %g1; nop + set qpiolk_, %g1; jmp %g1; nop + set qpiols_, %g1; jmp %g1; nop + set qpiomx_, %g1; jmp %g1; nop + set qpioon_, %g1; jmp %g1; nop + set qpiope_, %g1; jmp %g1; nop + set qpiops_, %g1; jmp %g1; nop + set qpiori_, %g1; jmp %g1; nop + set qpiors_, %g1; jmp %g1; nop + set qpiort_, %g1; jmp %g1; nop + set qpiosc_, %g1; jmp %g1; nop + set qpiose_, %g1; jmp %g1; nop + set qpiosi_, %g1; jmp %g1; nop + set qpiosr_, %g1; jmp %g1; nop + set qpiost_, %g1; jmp %g1; nop + set qpiour_, %g1; jmp %g1; nop + set qpiovr_, %g1; jmp %g1; nop + set qpiowt_, %g1; jmp %g1; nop + set qplenf_, %g1; jmp %g1; nop + set qplenl_, %g1; jmp %g1; nop + set qplesd_, %g1; jmp %g1; nop + set qplesi_, %g1; jmp %g1; nop + set qplesr_, %g1; jmp %g1; nop + set qploas_, %g1; jmp %g1; nop + set qpmaxd_, %g1; jmp %g1; nop + set qpmaxi_, %g1; jmp %g1; nop + set qpmaxr_, %g1; jmp %g1; nop + set qpmind_, %g1; jmp %g1; nop + set qpmini_, %g1; jmp %g1; nop + set qpminr_, %g1; jmp %g1; nop + set qpmkfe_, %g1; jmp %g1; nop + set qpnexk_, %g1; jmp %g1; nop + set qpofnl_, %g1; jmp %g1; nop + set qpofns_, %g1; jmp %g1; nop + set qpofnu_, %g1; jmp %g1; nop + set qpopen_, %g1; jmp %g1; nop + set qpopet_, %g1; jmp %g1; nop + set qppare_, %g1; jmp %g1; nop + set qpparl_, %g1; jmp %g1; nop + set qppcle_, %g1; jmp %g1; nop + set qppopn_, %g1; jmp %g1; nop + set qppstr_, %g1; jmp %g1; nop + set qpputb_, %g1; jmp %g1; nop + set qpputc_, %g1; jmp %g1; nop + set qpputd_, %g1; jmp %g1; nop + set qpputi_, %g1; jmp %g1; nop + set qpputl_, %g1; jmp %g1; nop + set qpputm_, %g1; jmp %g1; nop + set qpputr_, %g1; jmp %g1; nop + set qpputs_, %g1; jmp %g1; nop + set qpputx_, %g1; jmp %g1; nop + set qpquef_, %g1; jmp %g1; nop + set qprawk_, %g1; jmp %g1; nop + set qpread_, %g1; jmp %g1; nop + set qprebd_, %g1; jmp %g1; nop + set qprene_, %g1; jmp %g1; nop + set qprenf_, %g1; jmp %g1; nop + set qprlmd_, %g1; jmp %g1; nop + set qprlmi_, %g1; jmp %g1; nop + set qprlmr_, %g1; jmp %g1; nop + set qpsavs_, %g1; jmp %g1; nop + set qpseel_, %g1; jmp %g1; nop + set qpseti_, %g1; jmp %g1; nop + set qpsetr_, %g1; jmp %g1; nop + set qpsizf_, %g1; jmp %g1; nop + set qpstai_, %g1; jmp %g1; nop + set qpstar_, %g1; jmp %g1; nop + set qpsync_, %g1; jmp %g1; nop + set qpungk_, %g1; jmp %g1; nop + set qpwrie_, %g1; jmp %g1; nop + set qpxgvd_, %g1; jmp %g1; nop + set qpxgvi_, %g1; jmp %g1; nop + set qpxgvl_, %g1; jmp %g1; nop + set qpxgvr_, %g1; jmp %g1; nop + set qpxgvs_, %g1; jmp %g1; nop + set r1mach_, %g1; jmp %g1; nop + set r2tr_, %g1; jmp %g1; nop + set r2tx_, %g1; jmp %g1; nop + set r4syn_, %g1; jmp %g1; nop + set r4tr_, %g1; jmp %g1; nop + set r4tx_, %g1; jmp %g1; nop + set r8syn_, %g1; jmp %g1; nop + set r8tr_, %g1; jmp %g1; nop + set r8tx_, %g1; jmp %g1; nop + set rdukey_, %g1; jmp %g1; nop + set reopen_, %g1; jmp %g1; nop + set resetn_, %g1; jmp %g1; nop + set salloc_, %g1; jmp %g1; nop + set scanc_, %g1; jmp %g1; nop + set sfree_, %g1; jmp %g1; nop + set shifti_, %g1; jmp %g1; nop + set shiftl_, %g1; jmp %g1; nop + set shifts_, %g1; jmp %g1; nop + set smark_, %g1; jmp %g1; nop + set sprinf_, %g1; jmp %g1; nop + set sscan_, %g1; jmp %g1; nop + set stallc_, %g1; jmp %g1; nop + set stcloe_, %g1; jmp %g1; nop + set stentr_, %g1; jmp %g1; nop + set stfacs_, %g1; jmp %g1; nop + set stfadr_, %g1; jmp %g1; nop + set stfcle_, %g1; jmp %g1; nop + set stfcos_, %g1; jmp %g1; nop + set stfcoy_, %g1; jmp %g1; nop + set stfcte_, %g1; jmp %g1; nop + set stfdee_, %g1; jmp %g1; nop + set stfgeb_, %g1; jmp %g1; nop + set stfgei_, %g1; jmp %g1; nop + set stfgen_, %g1; jmp %g1; nop + set stfges_, %g1; jmp %g1; nop + set stfget_, %g1; jmp %g1; nop + set stfind_, %g1; jmp %g1; nop + set stfinl_, %g1; jmp %g1; nop + set stfins_, %g1; jmp %g1; nop + set stfmeb_, %g1; jmp %g1; nop + set stfmke_, %g1; jmp %g1; nop + set stfnee_, %g1; jmp %g1; nop + set stfopn_, %g1; jmp %g1; nop + set stfopx_, %g1; jmp %g1; nop + set stforb_, %g1; jmp %g1; nop + set stfrdr_, %g1; jmp %g1; nop + set stfree_, %g1; jmp %g1; nop + set stfrek_, %g1; jmp %g1; nop + set stfrfr_, %g1; jmp %g1; nop + set stfrgb_, %g1; jmp %g1; nop + set stfrne_, %g1; jmp %g1; nop + set stfupr_, %g1; jmp %g1; nop + set stfwfr_, %g1; jmp %g1; nop + set stfwgb_, %g1; jmp %g1; nop + set sthash_, %g1; jmp %g1; nop + set sthead_, %g1; jmp %g1; nop + set stinfo_, %g1; jmp %g1; nop + set stkmkg_, %g1; jmp %g1; nop + set stmark_, %g1; jmp %g1; nop + set stname_, %g1; jmp %g1; nop + set stnext_, %g1; jmp %g1; nop + set stnsys_, %g1; jmp %g1; nop + set stopen_, %g1; jmp %g1; nop + set stpstr_, %g1; jmp %g1; nop + set strcle_, %g1; jmp %g1; nop + set strdic_, %g1; jmp %g1; nop + set strefb_, %g1; jmp %g1; nop + set streff_, %g1; jmp %g1; nop + set streq_, %g1; jmp %g1; nop + set strese_, %g1; jmp %g1; nop + set strge_, %g1; jmp %g1; nop + set strgee_, %g1; jmp %g1; nop + set strgt_, %g1; jmp %g1; nop + set strids_, %g1; jmp %g1; nop + set stridx_, %g1; jmp %g1; nop + set strlds_, %g1; jmp %g1; nop + set strldx_, %g1; jmp %g1; nop + set strle_, %g1; jmp %g1; nop + set strlt_, %g1; jmp %g1; nop + set strlwr_, %g1; jmp %g1; nop + set strmac_, %g1; jmp %g1; nop + set strmah_, %g1; jmp %g1; nop + set strncp_, %g1; jmp %g1; nop + set strne_, %g1; jmp %g1; nop + set stropn_, %g1; jmp %g1; nop + set strpak_, %g1; jmp %g1; nop + set strse1_, %g1; jmp %g1; nop + set strsee_, %g1; jmp %g1; nop + set strseh_, %g1; jmp %g1; nop + set strsrt_, %g1; jmp %g1; nop + set strtbl_, %g1; jmp %g1; nop + set strupk_, %g1; jmp %g1; nop + set strupr_, %g1; jmp %g1; nop + set stsave_, %g1; jmp %g1; nop + set stsize_, %g1; jmp %g1; nop + set stsque_, %g1; jmp %g1; nop + set sttyco_, %g1; jmp %g1; nop + set sttyet_, %g1; jmp %g1; nop + set sttygg_, %g1; jmp %g1; nop + set sttynm_, %g1; jmp %g1; nop + set sttyse_, %g1; jmp %g1; nop + set sttysm_, %g1; jmp %g1; nop + set sttytt_, %g1; jmp %g1; nop + set syserr_, %g1; jmp %g1; nop + set sysers_, %g1; jmp %g1; nop + set sysged_, %g1; jmp %g1; nop + set sysges_, %g1; jmp %g1; nop + set sysgsg_, %g1; jmp %g1; nop + set sysid_, %g1; jmp %g1; nop + set sysmte_, %g1; jmp %g1; nop + set syspac_, %g1; jmp %g1; nop + set syspat_, %g1; jmp %g1; nop + set syspte_, %g1; jmp %g1; nop + set sysret_, %g1; jmp %g1; nop + set syssct_, %g1; jmp %g1; nop + set tsleep_, %g1; jmp %g1; nop + set ttopen_, %g1; jmp %g1; nop + set ttseti_, %g1; jmp %g1; nop + set ttsets_, %g1; jmp %g1; nop + set ttstai_, %g1; jmp %g1; nop + set ttstas_, %g1; jmp %g1; nop + set ttybih_, %g1; jmp %g1; nop + set ttybre_, %g1; jmp %g1; nop + set ttycas_, %g1; jmp %g1; nop + set ttycds_, %g1; jmp %g1; nop + set ttycle_, %g1; jmp %g1; nop + set ttycln_, %g1; jmp %g1; nop + set ttyclr_, %g1; jmp %g1; nop + set ttyctl_, %g1; jmp %g1; nop + set ttydee_, %g1; jmp %g1; nop + set ttydey_, %g1; jmp %g1; nop + set ttyeny_, %g1; jmp %g1; nop + set ttyexs_, %g1; jmp %g1; nop + set ttyfey_, %g1; jmp %g1; nop + set ttyfiy_, %g1; jmp %g1; nop + set ttygds_, %g1; jmp %g1; nop + set ttygeb_, %g1; jmp %g1; nop + set ttygei_, %g1; jmp %g1; nop + set ttyger_, %g1; jmp %g1; nop + set ttyges_, %g1; jmp %g1; nop + set ttygoo_, %g1; jmp %g1; nop + set ttygpe_, %g1; jmp %g1; nop + set ttygse_, %g1; jmp %g1; nop + set ttyins_, %g1; jmp %g1; nop + set ttyint_, %g1; jmp %g1; nop + set ttylod_, %g1; jmp %g1; nop + set ttyods_, %g1; jmp %g1; nop + set ttyopn_, %g1; jmp %g1; nop + set ttypue_, %g1; jmp %g1; nop + set ttypus_, %g1; jmp %g1; nop + set ttyred_, %g1; jmp %g1; nop + set ttysce_, %g1; jmp %g1; nop + set ttysei_, %g1; jmp %g1; nop + set ttyso_, %g1; jmp %g1; nop + set ttysti_, %g1; jmp %g1; nop + set ttysui_, %g1; jmp %g1; nop + set ttywre_, %g1; jmp %g1; nop + set ungete_, %g1; jmp %g1; nop + set ungeti_, %g1; jmp %g1; nop + set unread_, %g1; jmp %g1; nop + set urand_, %g1; jmp %g1; nop + set vfnadd_, %g1; jmp %g1; nop + set vfncle_, %g1; jmp %g1; nop + set vfndee_, %g1; jmp %g1; nop + set vfndel_, %g1; jmp %g1; nop + set vfnene_, %g1; jmp %g1; nop + set vfnenr_, %g1; jmp %g1; nop + set vfnexr_, %g1; jmp %g1; nop + set vfngen_, %g1; jmp %g1; nop + set vfnise_, %g1; jmp %g1; nop + set vfnman_, %g1; jmp %g1; nop + set vfnmap_, %g1; jmp %g1; nop + set vfnmau_, %g1; jmp %g1; nop + set vfnopn_, %g1; jmp %g1; nop + set vfnsqe_, %g1; jmp %g1; nop + set vfntre_, %g1; jmp %g1; nop + set vfnunn_, %g1; jmp %g1; nop + set vfnunp_, %g1; jmp %g1; nop + set vlibinit_, %g1; jmp %g1; nop + set vmallc_, %g1; jmp %g1; nop + set vvfncm_, %g1; jmp %g1; nop + set vvfnee_, %g1; jmp %g1; nop + set vvfnip_, %g1; jmp %g1; nop + set vvfnis_, %g1; jmp %g1; nop + set vvfnre_, %g1; jmp %g1; nop + set wfaitd_, %g1; jmp %g1; nop + set wfaitt_, %g1; jmp %g1; nop + set wfaitv_, %g1; jmp %g1; nop + set wfarcd_, %g1; jmp %g1; nop + set wfarct_, %g1; jmp %g1; nop + set wfarcv_, %g1; jmp %g1; nop + set wfcard_, %g1; jmp %g1; nop + set wfcart_, %g1; jmp %g1; nop + set wfcarv_, %g1; jmp %g1; nop + set wfcscd_, %g1; jmp %g1; nop + set wfcsct_, %g1; jmp %g1; nop + set wfcscv_, %g1; jmp %g1; nop + set wfdecs_, %g1; jmp %g1; nop + set wffnld_, %g1; jmp %g1; nop + set wfglsd_, %g1; jmp %g1; nop + set wfglst_, %g1; jmp %g1; nop + set wfglsv_, %g1; jmp %g1; nop + set wfgsbb_, %g1; jmp %g1; nop + set wfgsbg_, %g1; jmp %g1; nop + set wfgsbl_, %g1; jmp %g1; nop + set wfgsce_, %g1; jmp %g1; nop + set wfgscf_, %g1; jmp %g1; nop + set wfgsdr_, %g1; jmp %g1; nop + set wfgsel_, %g1; jmp %g1; nop + set wfgson_, %g1; jmp %g1; nop + set wfgsre_, %g1; jmp %g1; nop + set wfinit_, %g1; jmp %g1; nop + set wfmerd_, %g1; jmp %g1; nop + set wfmert_, %g1; jmp %g1; nop + set wfmerv_, %g1; jmp %g1; nop + set wfmold_, %g1; jmp %g1; nop + set wfmolt_, %g1; jmp %g1; nop + set wfmolv_, %g1; jmp %g1; nop + set wfmspd_, %g1; jmp %g1; nop + set wfmspf_, %g1; jmp %g1; nop + set wfmspi_, %g1; jmp %g1; nop + set wfmspl_, %g1; jmp %g1; nop + set wfmspt_, %g1; jmp %g1; nop + set wfmspv_, %g1; jmp %g1; nop + set wfmspy_, %g1; jmp %g1; nop + set wfpard_, %g1; jmp %g1; nop + set wfpart_, %g1; jmp %g1; nop + set wfparv_, %g1; jmp %g1; nop + set wfpcod_, %g1; jmp %g1; nop + set wfpcot_, %g1; jmp %g1; nop + set wfpcov_, %g1; jmp %g1; nop + set wfqscd_, %g1; jmp %g1; nop + set wfqsct_, %g1; jmp %g1; nop + set wfqscv_, %g1; jmp %g1; nop + set wfsind_, %g1; jmp %g1; nop + set wfsint_, %g1; jmp %g1; nop + set wfsinv_, %g1; jmp %g1; nop + set wfsmph_, %g1; jmp %g1; nop + set wfsmpn_, %g1; jmp %g1; nop + set wfsmpt_, %g1; jmp %g1; nop + set wfstgd_, %g1; jmp %g1; nop + set wfstgt_, %g1; jmp %g1; nop + set wfstgv_, %g1; jmp %g1; nop + set wftand_, %g1; jmp %g1; nop + set wftant_, %g1; jmp %g1; nop + set wftanv_, %g1; jmp %g1; nop + set wftnxd_, %g1; jmp %g1; nop + set wftnxt_, %g1; jmp %g1; nop + set wftnxv_, %g1; jmp %g1; nop + set wftnxy_, %g1; jmp %g1; nop + set wftscd_, %g1; jmp %g1; nop + set wftsct_, %g1; jmp %g1; nop + set wftscv_, %g1; jmp %g1; nop + set wfzead_, %g1; jmp %g1; nop + set wfzeat_, %g1; jmp %g1; nop + set wfzeav_, %g1; jmp %g1; nop + set wfzpxd_, %g1; jmp %g1; nop + set wfzpxt_, %g1; jmp %g1; nop + set wfzpxv_, %g1; jmp %g1; nop + set wfzpxy_, %g1; jmp %g1; nop + set xalloe_, %g1; jmp %g1; nop + set xcallc_, %g1; jmp %g1; nop + set xdeale_, %g1; jmp %g1; nop + set xdevor_, %g1; jmp %g1; nop + set xdevss_, %g1; jmp %g1; nop + set xeract_, %g1; jmp %g1; nop + set xerfmg_, %g1; jmp %g1; nop + set xerpoi_, %g1; jmp %g1; nop + set xerpop_, %g1; jmp %g1; nop + set xerpsh_, %g1; jmp %g1; nop + set xerpsr_, %g1; jmp %g1; nop + set xerpuc_, %g1; jmp %g1; nop + set xerpue_, %g1; jmp %g1; nop + set xerret_, %g1; jmp %g1; nop + set xerror_, %g1; jmp %g1; nop + set xersel_, %g1; jmp %g1; nop + set xervey_, %g1; jmp %g1; nop + set xevadg_, %g1; jmp %g1; nop + set xevbip_, %g1; jmp %g1; nop + set xevbop_, %g1; jmp %g1; nop + set xevcan_, %g1; jmp %g1; nop + set xever1_, %g1; jmp %g1; nop + set xever2_, %g1; jmp %g1; nop + set xeverr_, %g1; jmp %g1; nop + set xevfrp_, %g1; jmp %g1; nop + set xevgek_, %g1; jmp %g1; nop + set xevinp_, %g1; jmp %g1; nop + set xevmap_, %g1; jmp %g1; nop + set xevnee_, %g1; jmp %g1; nop + set xevpae_, %g1; jmp %g1; nop + set xevpah_, %g1; jmp %g1; nop + set xevqut_, %g1; jmp %g1; nop + set xevstt_, %g1; jmp %g1; nop + set xevunp_, %g1; jmp %g1; nop + set xfaccs_, %g1; jmp %g1; nop + set xfatal_, %g1; jmp %g1; nop + set xfchdr_, %g1; jmp %g1; nop + set xfcloe_, %g1; jmp %g1; nop + set xfdele_, %g1; jmp %g1; nop + set xffluh_, %g1; jmp %g1; nop + set xfgetc_, %g1; jmp %g1; nop + set xfgetr_, %g1; jmp %g1; nop + set xfnote_, %g1; jmp %g1; nop + set xfopen_, %g1; jmp %g1; nop + set xfputc_, %g1; jmp %g1; nop + set xfputr_, %g1; jmp %g1; nop + set xfread_, %g1; jmp %g1; nop + set xfrnam_, %g1; jmp %g1; nop + set xfscan_, %g1; jmp %g1; nop + set xfseek_, %g1; jmp %g1; nop + set xfungc_, %g1; jmp %g1; nop + set xfwrie_, %g1; jmp %g1; nop + set xgdevt_, %g1; jmp %g1; nop + set xgtpid_, %g1; jmp %g1; nop + set xgtuid_, %g1; jmp %g1; nop + set xisaty_, %g1; jmp %g1; nop + set xmallc_, %g1; jmp %g1; nop + set xmfree_, %g1; jmp %g1; nop + set xmjbuf_, %g1; jmp %g1; nop + set xmktep_, %g1; jmp %g1; nop + set xonerr_, %g1; jmp %g1; nop + set xonext_, %g1; jmp %g1; nop + set xori_, %g1; jmp %g1; nop + set xorl_, %g1; jmp %g1; nop + set xors_, %g1; jmp %g1; nop + set xpages_, %g1; jmp %g1; nop + set xprinf_, %g1; jmp %g1; nop + set xqsort_, %g1; jmp %g1; nop + set xrealc_, %g1; jmp %g1; nop + set xsizef_, %g1; jmp %g1; nop + set xstdeh_, %g1; jmp %g1; nop + set xstrcp_, %g1; jmp %g1; nop + set xstrct_, %g1; jmp %g1; nop + set xstrcy_, %g1; jmp %g1; nop + set xstrln_, %g1; jmp %g1; nop + set xtoc_, %g1; jmp %g1; nop + set xttyse_, %g1; jmp %g1; nop + set xvvadg_, %g1; jmp %g1; nop + set xvvbip_, %g1; jmp %g1; nop + set xvvbop_, %g1; jmp %g1; nop + set xvvcan_, %g1; jmp %g1; nop + set xvvche_, %g1; jmp %g1; nop + set xvver1_, %g1; jmp %g1; nop + set xvver2_, %g1; jmp %g1; nop + set xvverr_, %g1; jmp %g1; nop + set xvvfrp_, %g1; jmp %g1; nop + set xvvgek_, %g1; jmp %g1; nop + set xvvinp_, %g1; jmp %g1; nop + set xvvlos_, %g1; jmp %g1; nop + set xvvmap_, %g1; jmp %g1; nop + set xvvnee_, %g1; jmp %g1; nop + set xvvnud_, %g1; jmp %g1; nop + set xvvnui_, %g1; jmp %g1; nop + set xvvnul_, %g1; jmp %g1; nop + set xvvnur_, %g1; jmp %g1; nop + set xvvnus_, %g1; jmp %g1; nop + set xvvpae_, %g1; jmp %g1; nop + set xvvpah_, %g1; jmp %g1; nop + set xvvqut_, %g1; jmp %g1; nop + set xvvstt_, %g1; jmp %g1; nop + set xvvunp_, %g1; jmp %g1; nop + set xwhen_, %g1; jmp %g1; nop + set xxscan_, %g1; jmp %g1; nop + set zardbf_, %g1; jmp %g1; nop + set zardgd_, %g1; jmp %g1; nop + set zardks_, %g1; jmp %g1; nop + set zardlp_, %g1; jmp %g1; nop + set zardmt_, %g1; jmp %g1; nop + set zardnd_, %g1; jmp %g1; nop + set zardnu_, %g1; jmp %g1; nop + set zardpl_, %g1; jmp %g1; nop + set zardpr_, %g1; jmp %g1; nop + set zardps_, %g1; jmp %g1; nop + set zardsf_, %g1; jmp %g1; nop + set zawrbf_, %g1; jmp %g1; nop + set zawrgd_, %g1; jmp %g1; nop + set zawrks_, %g1; jmp %g1; nop + set zawrlp_, %g1; jmp %g1; nop + set zawrmt_, %g1; jmp %g1; nop + set zawrnd_, %g1; jmp %g1; nop + set zawrnu_, %g1; jmp %g1; nop + set zawrpl_, %g1; jmp %g1; nop + set zawrpr_, %g1; jmp %g1; nop + set zawrps_, %g1; jmp %g1; nop + set zawrsf_, %g1; jmp %g1; nop + set zawset_, %g1; jmp %g1; nop + set zawtbf_, %g1; jmp %g1; nop + set zawtgd_, %g1; jmp %g1; nop + set zawtks_, %g1; jmp %g1; nop + set zawtlp_, %g1; jmp %g1; nop + set zawtmt_, %g1; jmp %g1; nop + set zawtnd_, %g1; jmp %g1; nop + set zawtnu_, %g1; jmp %g1; nop + set zawtpl_, %g1; jmp %g1; nop + set zawtpr_, %g1; jmp %g1; nop + set zawtps_, %g1; jmp %g1; nop + set zawtsf_, %g1; jmp %g1; nop + set zclcpr_, %g1; jmp %g1; nop + set zcldir_, %g1; jmp %g1; nop + set zcldpr_, %g1; jmp %g1; nop + set zclm70_, %g1; jmp %g1; nop + set zclm75_, %g1; jmp %g1; nop + set zclsbf_, %g1; jmp %g1; nop + set zclsgd_, %g1; jmp %g1; nop + set zclsks_, %g1; jmp %g1; nop + set zclslp_, %g1; jmp %g1; nop + set zclsmt_, %g1; jmp %g1; nop + set zclsnd_, %g1; jmp %g1; nop + set zclsnu_, %g1; jmp %g1; nop + set zclspl_, %g1; jmp %g1; nop + set zclsps_, %g1; jmp %g1; nop + set zclssf_, %g1; jmp %g1; nop + set zclstt_, %g1; jmp %g1; nop + set zclstx_, %g1; jmp %g1; nop + set zclsty_, %g1; jmp %g1; nop + set zdojmp_, %g1; jmp %g1; nop + set zdvall_, %g1; jmp %g1; nop + set zdvown_, %g1; jmp %g1; nop + set zfacss_, %g1; jmp %g1; nop + set zfaloc_, %g1; jmp %g1; nop + set zfchdr_, %g1; jmp %g1; nop + set zfdele_, %g1; jmp %g1; nop + set zfgcwd_, %g1; jmp %g1; nop + set zfinfo_, %g1; jmp %g1; nop + set zflsnu_, %g1; jmp %g1; nop + set zflstt_, %g1; jmp %g1; nop + set zflstx_, %g1; jmp %g1; nop + set zflsty_, %g1; jmp %g1; nop + set zfmkcp_, %g1; jmp %g1; nop + set zfmkdr_, %g1; jmp %g1; nop + set zfnbrk_, %g1; jmp %g1; nop + set zfpath_, %g1; jmp %g1; nop + set zfprot_, %g1; jmp %g1; nop + set zfrnam_, %g1; jmp %g1; nop + set zfsubd_, %g1; jmp %g1; nop + set zfxdir_, %g1; jmp %g1; nop + set zgcmdl_, %g1; jmp %g1; nop + set zgetnu_, %g1; jmp %g1; nop + set zgettt_, %g1; jmp %g1; nop + set zgettx_, %g1; jmp %g1; nop + set zgetty_, %g1; jmp %g1; nop + set zgfdir_, %g1; jmp %g1; nop + set zghost_, %g1; jmp %g1; nop + set zgmtco_, %g1; jmp %g1; nop + set zgtime_, %g1; jmp %g1; nop + set zgtpid_, %g1; jmp %g1; nop + set zintpr_, %g1; jmp %g1; nop + set zlocpr_, %g1; jmp %g1; nop + set zlocva_, %g1; jmp %g1; nop + set zmaloc_, %g1; jmp %g1; nop + set zmfree_, %g1; jmp %g1; nop + set znotnu_, %g1; jmp %g1; nop + set znottt_, %g1; jmp %g1; nop + set znottx_, %g1; jmp %g1; nop + set znotty_, %g1; jmp %g1; nop + set zopcpr_, %g1; jmp %g1; nop + set zopdir_, %g1; jmp %g1; nop + set zopdpr_, %g1; jmp %g1; nop + set zopm70_, %g1; jmp %g1; nop + set zopm75_, %g1; jmp %g1; nop + set zopnbf_, %g1; jmp %g1; nop + set zopngd_, %g1; jmp %g1; nop + set zopnks_, %g1; jmp %g1; nop + set zopnlp_, %g1; jmp %g1; nop + set zopnmt_, %g1; jmp %g1; nop + set zopnnd_, %g1; jmp %g1; nop + set zopnnu_, %g1; jmp %g1; nop + set zopnpl_, %g1; jmp %g1; nop + set zopnsf_, %g1; jmp %g1; nop + set zopntt_, %g1; jmp %g1; nop + set zopntx_, %g1; jmp %g1; nop + set zopnty_, %g1; jmp %g1; nop + set zoscmd_, %g1; jmp %g1; nop + set zpanic_, %g1; jmp %g1; nop + set zputnu_, %g1; jmp %g1; nop + set zputtt_, %g1; jmp %g1; nop + set zputtx_, %g1; jmp %g1; nop + set zputty_, %g1; jmp %g1; nop + set zraloc_, %g1; jmp %g1; nop + set zrdm70_, %g1; jmp %g1; nop + set zrdm75_, %g1; jmp %g1; nop + set zseknu_, %g1; jmp %g1; nop + set zsektt_, %g1; jmp %g1; nop + set zsektx_, %g1; jmp %g1; nop + set zsekty_, %g1; jmp %g1; nop + set zsestt_, %g1; jmp %g1; nop + set zsettt_, %g1; jmp %g1; nop + set zstm70_, %g1; jmp %g1; nop + set zstm75_, %g1; jmp %g1; nop + set zststt_, %g1; jmp %g1; nop + set zsttbf_, %g1; jmp %g1; nop + set zsttgd_, %g1; jmp %g1; nop + set zsttks_, %g1; jmp %g1; nop + set zsttlp_, %g1; jmp %g1; nop + set zsttmt_, %g1; jmp %g1; nop + set zsttnd_, %g1; jmp %g1; nop + set zsttnu_, %g1; jmp %g1; nop + set zsttpl_, %g1; jmp %g1; nop + set zsttpr_, %g1; jmp %g1; nop + set zsttps_, %g1; jmp %g1; nop + set zsttsf_, %g1; jmp %g1; nop + set zstttt_, %g1; jmp %g1; nop + set zstttx_, %g1; jmp %g1; nop + set zsttty_, %g1; jmp %g1; nop + set zttgeg_, %g1; jmp %g1; nop + set zttger_, %g1; jmp %g1; nop + set zttloe_, %g1; jmp %g1; nop + set zttloo_, %g1; jmp %g1; nop + set zttlov_, %g1; jmp %g1; nop + set zttpbf_, %g1; jmp %g1; nop + set zttplk_, %g1; jmp %g1; nop + set zttpug_, %g1; jmp %g1; nop + set zttquy_, %g1; jmp %g1; nop + set zttttt_, %g1; jmp %g1; nop + set zttupe_, %g1; jmp %g1; nop + set zwmsec_, %g1; jmp %g1; nop + set zwrm70_, %g1; jmp %g1; nop + set zwrm75_, %g1; jmp %g1; nop + set zwtm70_, %g1; jmp %g1; nop + set zwtm75_, %g1; jmp %g1; nop + set zxgmes_, %g1; jmp %g1; nop + set zxwhen_, %g1; jmp %g1; nop + set zzclmt_, %g1; jmp %g1; nop + set zzopmt_, %g1; jmp %g1; nop + set zzrdii_, %g1; jmp %g1; nop + set zzrdmt_, %g1; jmp %g1; nop + set zzrwmt_, %g1; jmp %g1; nop + set zzsetk_, %g1; jmp %g1; nop + set zzstmt_, %g1; jmp %g1; nop + set zzwrii_, %g1; jmp %g1; nop + set zzwrmt_, %g1; jmp %g1; nop + set zzwtmt_, %g1; jmp %g1; nop + set zzzend_, %g1; jmp %g1; nop + set fxfnoe_, %g1; jmp %g1; nop + set futime_, %g1; jmp %g1; nop + set kfutim_, %g1; jmp %g1; nop + set zfutim_, %g1; jmp %g1; nop + set dtmday_, %g1; jmp %g1; nop + set dtmlte_, %g1; jmp %g1; nop + set poll_, %g1; jmp %g1; nop + set pollce_, %g1; jmp %g1; nop + set pollcr_, %g1; jmp %g1; nop + set pollgs_, %g1; jmp %g1; nop + set pollon_, %g1; jmp %g1; nop + set pollpt_, %g1; jmp %g1; nop + set pollst_, %g1; jmp %g1; nop + set polltt_, %g1; jmp %g1; nop + set pollzo_, %g1; jmp %g1; nop + set zfpoll_, %g1; jmp %g1; nop + .global vshend_ +vshend_: diff --git a/unix/shlib/aout.c b/unix/shlib/aout.c new file mode 100644 index 00000000..832fc42e --- /dev/null +++ b/unix/shlib/aout.c @@ -0,0 +1,59 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include + +/* AOUT -- Examine the header of a AOUT file. + */ +main (argc, argv) +int argc; +char *argv[]; +{ + struct exec fh; + int fd; + + if (argc < 2) { + fprintf (stderr, "Usage: aout \n"); + exit (0); + } + + if ((fd = open (argv[1], 0)) == -1) { + fprintf (stderr, "cannot open %s\n", argv[1]); + exit (1); + } + + /* Show file header. */ + if (read (fd, &fh, sizeof(fh)) != sizeof(fh)) + goto readerr; + else if (fh.a_magic != ZMAGIC) { + fprintf (stderr, "not a page-aligned executable format file\n"); + /* exit (2); */ + } + + printf ("File header:\n"); + printf ("%16s: %10d %10x %012o\n", + "a_magic", fh.a_magic, fh.a_magic, fh.a_magic); + printf ("%16s: %10d %10x %012o\n", + "a_text", fh.a_text, fh.a_text, fh.a_text); + printf ("%16s: %10d %10x %012o\n", + "a_data", fh.a_data, fh.a_data, fh.a_data); + printf ("%16s: %10d %10x %012o\n", + "a_bss", fh.a_bss, fh.a_bss, fh.a_bss); + printf ("%16s: %10d %10x %012o\n", + "a_syms", fh.a_syms, fh.a_syms, fh.a_syms); + printf ("%16s: %10d %10x %012o\n", + "a_entry", fh.a_entry, fh.a_entry, fh.a_entry); + printf ("%16s: %10d %10x %012o\n", + "a_trsize", fh.a_trsize, fh.a_trsize, fh.a_trsize); + printf ("%16s: %10d %10x %012o\n", + "a_drsize", fh.a_drsize, fh.a_drsize, fh.a_drsize); + + fflush (stdout); + close (fd); + exit (0); + +readerr: + fprintf (stderr, "file read error\n"); + exit (4); +} diff --git a/unix/shlib/coff.c b/unix/shlib/coff.c new file mode 100644 index 00000000..a0a0128c --- /dev/null +++ b/unix/shlib/coff.c @@ -0,0 +1,87 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include + +/* COFF -- Examine the header of a COFF file. + */ +main (argc, argv) +int argc; +char *argv[]; +{ + struct filehdr fh; + struct aouthdr sh; + struct scnhdr nh; + int fd; + + if (argc < 2) { + fprintf (stderr, "Usage: coff \n"); + exit (0); + } + + if ((fd = open (argv[1], 0)) == -1) { + fprintf (stderr, "cannot open %s\n", argv[1]); + exit (1); + } + + /* Show file header. */ + if (read (fd, &fh, sizeof(fh)) != sizeof(fh)) + goto readerr; + else if (!ISCOFF(fh.f_magic)) { + fprintf (stderr, "not a COFF format file\n"); + /* exit (2); */ + } + + printf ("File header:\n"); + printf ("%16s: %10d %10x %012o\n", + "f_magic", fh.f_magic, fh.f_magic, fh.f_magic); + printf ("%16s: %10d %10x %012o\n", + "f_nscns", fh.f_nscns, fh.f_nscns, fh.f_nscns); + printf ("%16s: %10d %10x %012o\n", + "f_timdat", fh.f_timdat, fh.f_timdat, fh.f_timdat); + printf ("%16s: %10d %10x %012o\n", + "f_symptr", fh.f_symptr, fh.f_symptr, fh.f_symptr); + printf ("%16s: %10d %10x %012o\n", + "f_nsyms", fh.f_nsyms, fh.f_nsyms, fh.f_nsyms); + printf ("%16s: %10d %10x %012o\n", + "f_opthdr", fh.f_opthdr, fh.f_opthdr, fh.f_opthdr); + printf ("%16s: %10d %10x %012o\n", + "f_flags", fh.f_flags, fh.f_flags, fh.f_flags); + + /* Show system header. */ + if (read (fd, &sh, sizeof(sh)) != sizeof(sh)) + goto readerr; + else if (sh.magic != 0413) { + fprintf (stderr, "bad magic %o in system header\n", sh.magic); + exit (3); + } + + printf ("System header:\n"); + printf ("%16s: %10d %10x %012o\n", + "magic", sh.magic, sh.magic, sh.magic); + printf ("%16s: %10d %10x %012o\n", + "vstamp", sh.vstamp, sh.vstamp, sh.vstamp); + printf ("%16s: %10d %10x %012o\n", + "tsize", sh.tsize, sh.tsize, sh.tsize); + printf ("%16s: %10d %10x %012o\n", + "dsize", sh.dsize, sh.dsize, sh.dsize); + printf ("%16s: %10d %10x %012o\n", + "bsize", sh.bsize, sh.bsize, sh.bsize); + printf ("%16s: %10d %10x %012o\n", + "entry", sh.entry, sh.entry, sh.entry); + printf ("%16s: %10d %10x %012o\n", + "text_start", sh.text_start, sh.text_start, sh.text_start); + printf ("%16s: %10d %10x %012o\n", + "data_start", sh.data_start, sh.data_start, sh.data_start); + + fflush (stdout); + close (fd); + exit (0); + +readerr: + fprintf (stderr, "file read error\n"); + exit (4); +} diff --git a/unix/shlib/edsym-sos4.c b/unix/shlib/edsym-sos4.c new file mode 100644 index 00000000..e81e83c1 --- /dev/null +++ b/unix/shlib/edsym-sos4.c @@ -0,0 +1,598 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +/* + * EDSYM -- Edit the symbol table of a process or object module which uses + * the IRAF shared library. + * + * Usage: edsym file shimage [flags] + * + * -d debug: show symbol table being edited + * -k keep: do not omit "uninteresting" symbols + * -n noact: do not modify any files + * -t delete symbols pointing into transfer vector + * -T delete all shared image symbols, keeping only client symbols + */ + +# ifdef i386 +#include +#include +#include + +#define AOUT +#include +#define N_name _n._n_name +#define N_zeroes _n._n_n._n_zeroes +#define N_offset _n._n_n._n_offset +#define N_abs -1 +#define HDROFF 0xd0 +#define OBJECT 0514 + +# else +#include + +#define HDROFF 0 +#define OBJECT 0407 +#define SYMESZ sizeof(struct nlist) +# endif + +#define DEF_SBUFSIZE 32768 +#define INC_SBUFSIZE 8192 +#define MAXLEN 256 +#define VHDRSIZE 0x1c +#define v_end vec[4] +#define IS_TVECT(a) ((a)>=(vshlib+VHDRSIZE)&&(a)=(b))?(a):(b)) + +static int debug = 0; /* print symbol table */ +static int noact = 0; /* do not modify any files */ +static int omit_tv = 0; /* omit transfer vector symbols */ +static int omit_shsym = 0; /* omit all shlib symbols */ +static int keep_sym = 0; /* do not omit uninteresting symbols */ + +static char *i_sbuf, *o_sbuf; +static char *op, *otop; +static int o_sbufsize; +extern char *malloc(); +extern char *realloc(); + + +/* EDSYM -- Edit the symbol table of a process which uses the IRAF shared + * library. For each symbol found which points to a location in the shared + * library transfer vector, add a V prefix to the symbol name, and add a + * symbol with the old name pointing to the actual function in the shared + * image. This is desirable before runtime debugging of processes linked + * with the shared library. + */ +main (argc, argv) +int argc; +char *argv[]; +{ + unsigned vshlib, vshend, vbase, vsize; + int offset, nbytes; +#ifdef i386 + struct filehdr fh, sh; + struct aouthdr ah; +#else + struct exec fh, sh; +#endif + + unsigned *vec; + char *fname, *shlib, *ip, *oop, *out; + int fd, nsym, nosym, arg; + int errcode = 0; + char tempfile[256]; + char shpath[256]; + struct nlist nl[3]; + FILE *fp, *tp; + int version; + + if (argc < 3) { + fprintf (stderr, "Usage: edsym [-dkntT]\n"); + exit (0); + + } else { + fname = argv[1]; + shlib = argv[2]; + for (arg=3; arg < argc; arg++) { + if (argv[arg][0] != '-') + continue; + for (ip=argv[arg]+1; *ip; ip++) { + switch (*ip) { + case 'd': /* print symbols */ + debug++; + break; + case 'k': /* do not omit uninteresting symbols */ + keep_sym++; + break; + case 'n': /* do not edit object file */ + noact++; + break; + case 't': /* omit transfer vector symbols */ + omit_tv++; + break; + case 'T': /* omit all shlib symbols */ + omit_shsym++; + break; + default: + fprintf (stderr, "edsym: unknown switch -%c\n", *ip); + } + } + } + + } + + /* Open the file to be edited. */ + if ((fp = fopen (fname, "r+")) == NULL) { + fprintf (stderr, "cannot open file %s\n", fname); + exit (1); + } else { + /* Get the file header. */ +#ifdef i386 + if (fread (&fh, sizeof(fh), 1, fp) != 1) { + errcode = 1; goto readerr; + } else if (!ISCOFF(fh.f_magic) && fh.f_magic != OBJECT) { + fprintf (stderr, "not a COFF format file\n"); + exit (2); + } else if (fh.f_symptr == 0 || fh.f_nsyms <= 0) { + fprintf (stderr, "%s has been stripped\n", fname); + exit (3); + } +#else + if (fread (&fh, sizeof(fh), 1, fp) != 1) { + errcode = 1; goto readerr; + } else if (N_BADMAG(fh) && fh.a_magic != OBJECT) { + fprintf (stderr, "not a valid executable or object file\n"); + /* exit (2); */ + } else if (fh.a_syms <= 0) { + fprintf (stderr, "%s has been stripped\n", fname); + exit (3); + } +#endif + } + + /* Get the shared image version number. This is stored in the + * first element of the ushlib vector in the file being edited. + */ +#ifdef i386 + nl[0].n_name = "ushlib_"; + nl[1].n_name = NULL; +#else + nl[0].n_un.n_name = "_ushlib_"; + nl[1].n_un.n_name = NULL; +#endif + if (nlist (fname, nl) != 0) { + fprintf (stderr, "cannot read name list from %s\n", fname); + exit (4); + } + +#ifdef i386 + lseek (fileno(fp), (unsigned)nl[0].n_value - 0x1000, L_SET); +#else + lseek (fileno(fp), (unsigned)nl[0].n_value - PAGSIZ, L_SET); +#endif + if (read (fileno(fp), &version, sizeof(version)) != sizeof(version)) { + fprintf (stderr, + "cannot read shared image version number from %s\n", fname); + exit (9); + } + + /* Use the correct version of the shared image. */ + for (ip=shlib, out=oop=shpath; *oop = *ip++; oop++) + if (*oop == '/') + out = oop + 1; + if (strcmp (out, "S.e") == 0) { + sprintf (out, "S%d.e", version); + shlib = shpath; + } + + if (debug) + printf ("use shared image %s\n", shlib); + + /* Get the location of the shared image transfer vector. */ +#ifdef i386 + nl[0].n_name = "vshlib_"; + nl[1].n_name = "vshend_"; + nl[2].n_name = NULL; +#else + nl[0].n_un.n_name = "_vshlib_"; + nl[1].n_un.n_name = "_vshend_"; + nl[2].n_un.n_name = NULL; +#endif + if (nlist (shlib, nl) != 0) { + fprintf (stderr, "cannot read name list from %s\n", shlib); + exit (4); + } + + /* Open the shared image. */ + if ((fd = open (shlib, O_RDONLY)) == -1) { + fprintf (stderr, "cannot open shared image %s\n", shlib); + exit (5); + + } else { +#ifdef i386 + /* Get the file header. */ + if (read (fd, &sh, sizeof(sh)) != sizeof(sh)) { + errcode = 2; goto readerr; + } else if (!ISCOFF(sh.f_magic)) { + fprintf (stderr, "not a COFF format file\n"); + exit (6); + } + + /* Get the system header. */ + if (read (fd, &ah, sizeof(ah)) != sizeof(ah)) { + errcode = 3; goto readerr; + } else if (ah.magic != 0413) { + fprintf (stderr, "bad magic %o in system header\n", ah.magic); + exit (7); + } +#else + /* Get the file header. */ + if (read (fd, &sh, sizeof(sh)) != sizeof(sh)) { + errcode = 2; goto readerr; + } else if (sh.a_magic != ZMAGIC) { + fprintf (stderr, "not a page-aligned executable file\n"); + exit (6); + } +#endif + /* Read the transfer vector. */ + vshlib = (unsigned) nl[0].n_value; + vshend = (unsigned) nl[1].n_value; + vsize = vshend - vshlib; +#ifdef i386 + vbase = ah.text_start; +#else + vbase = (sh.a_entry & ~0xffffff); +#endif + if (debug) { + printf ("vshlib=%x, vshend=%x, vbase=%x, vsize=%x\n", + vshlib, vshend, vbase, vsize); + } + + vec = (unsigned *) malloc (vsize); + if (vec == NULL) { + fprintf (stderr, "out of memory\n"); + exit (8); + } + + lseek (fd, vshlib - vbase + HDROFF, L_SET); + if (read (fd, vec, vsize) != vsize) { + fprintf (stderr, + "cannot read transfer vector from %s\n", shlib); + exit (9); + } + + close (fd); + } + + /* Now edit the symbol table of the object file. To do this we must + * first read the string buffer into memory. We then open a scratch + * file for symbol output. Successive symbols are read from the input + * file. For each symbol which points into the transfer vector area + * we output two symbols, one a copy of the input symbol with V + * prepended to the symbol name, the second a copy with the symbol + * value changed to point to the location of the actual procedure in + * the shared image. Other symbols are merely copied to the scratch + * file. When all symbols have been processed we overwrite the symbol + * table and string buffer of the file being edited with the contents + * of the scratch buffer (containing the new symbols) and the new + * string buffer, completing the editing operation. + */ + + /* Read the string buffer. */ +#ifdef i386 + if (fh.f_symptr != 0) { + offset = fh.f_symptr + (fh.f_nsyms * SYMESZ); +#else + if ((offset = N_STROFF(fh)) != 0) { +#endif + /* The size of the string buffer in bytes is stored in the first + * four bytes of the buffer. + */ + fseek (fp, offset, L_SET); + if (fread (&nbytes, sizeof(int), 1, fp) != 1) { + errcode = 5; goto readerr; + } + + i_sbuf = malloc (max(nbytes,DEF_SBUFSIZE)); + o_sbuf = malloc (o_sbufsize = max(nbytes,DEF_SBUFSIZE)); + if (i_sbuf == NULL || o_sbuf == NULL) { + fprintf (stderr, "out of memory\n"); + exit (8); + } + + fseek (fp, offset, L_SET); + if (fread (i_sbuf, 1, nbytes, fp) != nbytes) { + fprintf (stderr, "cannot read string buffer from %x\n", fname); + errcode = 5; goto readerr; + } + op = o_sbuf; + otop = o_sbuf + o_sbufsize; + } + + /* Open the scratch file. */ + sprintf (tempfile, "%s.T", fname); + if ((tp = fopen (tempfile, "w+")) == NULL) { + fprintf (stderr, "cannot create %s\n", tempfile); + exit (10); + } + + /* Process the symbol table, writing out two symbols for every + * function symbol pointing into the transfer vector, and copying + * all other symbols unmodified. + */ + fseek (tp, 0L, L_SET); +#ifdef i386 + fseek (fp, fh.f_symptr, L_SET); + for (nsym=fh.f_nsyms, nosym=0; --nsym >= 0; ) { + register int n, ch; + struct syment sym, osym; + char name[MAXLEN]; + int keep, naux; + unsigned v, *epa; + + if (fread (&sym, SYMESZ, 1, fp) != 1) { + errcode = 6; goto readerr; + } + v = (unsigned)sym.n_value; + if (sym.N_zeroes) { + strncpy (name, sym.N_name, 8); + name[8] = '\0'; + } else + strncpy (name, i_sbuf+sym.N_offset, MAXLEN-1); + + if (debug) { + printf ("%20s %8x %3d %6o %3d %2d", name, sym.n_value, + sym.n_scnum, sym.n_type, sym.n_sclass, sym.n_numaux); + } + + if ((sym.n_scnum != N_abs) || !IS_TVECT(v) || (name[0] == 'V')) { +#else + fseek (fp, N_SYMOFF(fh), L_SET); + for (nsym=(fh.a_syms/SYMESZ), nosym=0; --nsym >= 0; ) { + register int n, ch; + struct nlist sym, osym; + char name[MAXLEN]; + int keep, naux; + unsigned v, *epa; + + if (fread (&sym, SYMESZ, 1, fp) != 1) { + errcode = 6; goto readerr; + } + v = (unsigned)sym.n_value; + if (sym.n_un.n_strx) + strncpy (name, i_sbuf+sym.n_un.n_strx, MAXLEN-1); + + if (debug) { + printf ("%20s %3x %8x %6o", + name, sym.n_type, sym.n_value, sym.n_desc); + } + + if (!(sym.n_type & N_ABS) || !IS_TVECT(v) || (name[1] == 'V')) { +#endif + /* Omit "uninteresting" symbols. */ + ch = name[0]; + keep = (keep_sym || ( + !(ch == 'L') && + !(ch == 'v' && name[1] == '.') && + !(ch == 'V' && strncmp(name,"VAR_SEG",7)==0) && + !(ch == 'A' && strncmp(name,"ARR_SEG",7)==0) + /* + && !(n=strlen(name), (name[n-2] == '.' && name[n-1] == 'o')) + */ + )); + + if (keep && !(omit_shsym && v >= vshlib && v <= v_end)) { + editname (&sym, NULL); + fwrite (&sym, SYMESZ, 1, tp); + nosym++; + } else if (debug) + printf (" deleted"); + + if (debug) + printf ("\n"); + + } else { + /* Output the V symbol pointing to the transfer vector. + */ + if (!omit_tv && !omit_shsym) { + osym = sym; + editname (&osym, "V"); + fwrite (&osym, SYMESZ, 1, tp); + nosym++; + } + + /* Disassemble the JMP instruction in the transfer vector to + * get the address of the referenced procedure in the shared + * library. [extracted from os.zlocpr]. + */ + epa = (unsigned *)((char *)vec + (v - vshlib)); +#ifdef i386 + v = ((unsigned)v + *((unsigned *)((char *)epa + 1)) + 5); +#else +#ifdef mc68000 + v = *((unsigned *)((char *)epa + 2)); +#else +#ifdef sparc + v = (((*epa & 0x3fffff) << 10) | (*(epa+1) & 0x3ff)); +#endif +#endif +#endif + + /* Output the same-name symbol, pointing to the function + * pointed to by the transfer vector. + */ + if (!omit_shsym) { + osym = sym; + osym.n_value = v; + editname (&osym, NULL); + fwrite (&osym, SYMESZ, 1, tp); + nosym++; + + if (debug) + printf (" -> %x\n", v); + + } else if (debug) + printf (" deleted\n"); + } +#ifdef i386 + for (naux = sym.n_numaux; --naux >= 0; --nsym) { + if (fread (&sym, SYMESZ, 1, fp) != 1) { + errcode = 7; goto readerr; + } + editname (&sym, NULL); + fwrite (&sym, SYMESZ, 1, tp); + nosym++; + } +#endif + } + + if (!noact) { + /* Copy the new symbol table to the object file, replacing the old + * one. + */ + if (nosym > 0) { +#ifdef i386 + struct syment sym; + fseek (fp, fh.f_symptr, L_SET); +#else + struct nlist sym; + fseek (fp, N_SYMOFF(fh), L_SET); +#endif + fseek (tp, 0L, L_SET); + for (nsym=nosym; --nsym >= 0; ) { + if (fread (&sym, SYMESZ, 1, tp) != 1) { + errcode = 8; goto readerr; + } + fwrite (&sym, SYMESZ, 1, fp); + } + } + + /* Append the string buffer. */ + if (op > o_sbuf) { + *((int *)o_sbuf) = op - o_sbuf; + fwrite (o_sbuf, 1, op - o_sbuf, fp); + fflush (fp); + } + + /* Truncate the file at the point just past the string buffer. + */ + if (ftruncate (fileno(fp), ftell(fp)) != 0) + fprintf (stderr, "Warning: cannot truncate %s\n", fname); + + /* Update the file header. */ +#ifdef i386 + fh.f_nsyms = nosym; +#else + fh.a_syms = nosym * SYMESZ; +#endif + fseek (fp, 0L, L_SET); + fwrite (&fh, sizeof(fh), 1, fp); + fflush (fp); + } + + /* All done. */ + free (vec); + free (i_sbuf); + free (o_sbuf); + fclose (tp); + fclose (fp); + unlink (tempfile); + exit (0); + +readerr: + fprintf (stderr, "read error %d on %s\n", errcode, fname); + exit (11); +} + + +/* EDITNAME -- Replace the name 'name' of a symbol by 'Vname', copying the + * edited name to the output string buffer, and editing the symbol structure + * as necessary to point to the new name. If called with a NULL or null string + * prefix, this serves to copy out the symbol name. + */ +editname (sym, prefix) +#ifdef i386 +register struct syment *sym; +#else +register struct nlist *sym; +#endif +char *prefix; +{ + register char *ip, *np; + char name[MAXLEN]; + int used, n; + +#ifdef i386 + /* Construct the new name. */ + n = 0; + if (prefix) + for (ip=prefix; (name[n] = *ip++); n++) + ; + + if (sym->N_zeroes) { + strncpy (&name[n], sym->N_name, SYMNMLEN); + name[n+SYMNMLEN] = '\0'; + } else + strncpy (&name[n], i_sbuf + sym->N_offset, MAXLEN-n); + + /* If the new name is no longer than SYMNMLEN place it directly in + * the symstruct, else append it to the string buffer. + */ + if ((n = strlen(name)) <= SYMNMLEN) + strncpy (sym->N_name, name, SYMNMLEN); + else { + sym->N_zeroes = 0; + sym->N_offset = putname(name); + } +#else + /* Construct the new name. */ + if (sym->n_un.n_strx) { + /* Copy any leading underscores. */ + for (np = i_sbuf + sym->n_un.n_strx, n=0; *np == '_'; np++) + name[n++] = '_'; + + /* Add the prefix string, if any. */ + if (prefix) + for (ip=prefix; (name[n] = *ip++); n++) + ; + + /* Append the symbol name. */ + strncpy (&name[n], np, MAXLEN-n); + + /* Write the new symbol to the output symbol table. */ + sym->n_un.n_strx = putname(name); + } +#endif +} + + +/* PUTNAME -- Append a string to the output string buffer. + */ +putname (name) +char *name; +{ + register char *ip, *oop; + int used, offset; + + if (op == o_sbuf) + op = o_sbuf + sizeof(int); + + if (op + strlen(name) >= otop) { + used = op - o_sbuf; + o_sbuf = realloc (o_sbuf, o_sbufsize += INC_SBUFSIZE); + op = o_sbuf + used; + otop = o_sbuf + o_sbufsize; + } + + offset = op - o_sbuf; + for (ip=name, oop=op; *oop++ = *ip++; ) + ; + op = oop; + + return (offset); +} diff --git a/unix/shlib/edsym-ssol.c b/unix/shlib/edsym-ssol.c new file mode 100644 index 00000000..8e20c26c --- /dev/null +++ b/unix/shlib/edsym-ssol.c @@ -0,0 +1,265 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +/* + * EDSYM -- Edit the symbol table of a process or object module which uses + * the IRAF shared library. (Sun Solaris version July94). + * + * Usage: edsym file shimage [flags] + * + * -d debug: show symbol table being edited + * -k keep: do not omit "uninteresting" symbols + * -n noact: do not modify any files + * -t delete symbols pointing into transfer vector + * -T delete all shared image symbols, keeping only client symbols + */ + + +#define VHDRSIZE 0x1c +#define v_end vec[4] +#define IS_TVECT(a) ((a)>=(vshlib+VHDRSIZE)&&(a)=(b))?(a):(b)) + +static int debug = 0; /* print symbol table */ +static int noact = 0; /* do not modify any files */ +static int omit_tv = 0; /* omit transfer vector symbols */ +static int omit_shsym = 0; /* omit all shlib symbols */ +static int keep_sym = 0; /* do not omit uninteresting symbols */ + +extern char *malloc(); + + +/* EDSYM -- Edit the symbol table of a process which uses the IRAF shared + * library. For each symbol found which points to a location in the shared + * library transfer vector, add a V prefix to the symbol name, and add a + * symbol with the old name pointing to the actual function in the shared + * image. This is desirable before runtime debugging of processes linked + * with the shared library. + */ +main (argc, argv) +int argc; +char *argv[]; +{ + register Elf32_Phdr *phdr; + register Elf32_Ehdr *ehdr; + register Elf32_Shdr *shdr; + register Elf32_Sym *sym; + unsigned vshlib, vshend, vsize; + char *fname, *shlib, *buf, *ip, *op; + int version, fd, fd_sh, nsyms, arg; + char *out, shpath[256]; + int offset, nbytes; + struct nlist nl[3]; + unsigned ushlib[8]; + unsigned *vec, *epa; + Elf *elf, *elf_sh; + Elf_Scn *scn; + + /* Process arguments. This version of edsym does not support all of + * the following arguments. + */ + if (argc < 3) { + fprintf (stderr, "Usage: edsym [-dkntT]\n"); + exit (0); + } else { + fname = argv[1]; + shlib = argv[2]; + for (arg=3; arg < argc; arg++) { + if (argv[arg][0] != '-') + continue; + for (ip=argv[arg]+1; *ip; ip++) { + switch (*ip) { + case 'd': /* print symbols */ + debug++; + break; + case 'k': /* do not omit uninteresting symbols */ + keep_sym++; + break; + case 'n': /* do not edit object file */ + noact++; + break; + case 't': /* omit transfer vector symbols */ + omit_tv++; + break; + case 'T': /* omit all shlib symbols */ + omit_shsym++; + break; + default: + fprintf (stderr, "edsym: unknown switch -%c\n", *ip); + } + } + } + + } + + /* Open the file to be edited. */ + if ((fd = open (fname, 2)) < 0) { + fprintf (stderr, "edsym: cannot open file %s\n", fname); + exit (1); + } + + elf_version (EV_CURRENT); + elf = elf_begin (fd, ELF_C_READ, NULL); + if (!elf) { + fprintf (stderr, "edsym: not an ELF format executable\n"); + exit (2); + } + + /* Read file header. */ + ehdr = elf32_getehdr (elf); + if (!ehdr) { + fprintf (stderr, "edsym: cannot read file header\n"); + exit (3); + } + + /* Read program header for text segment, which we assume to be the + * first loadable program segment. + */ + phdr = elf32_getphdr (elf); + if (ehdr->e_phnum <= 0 || !phdr) { + printf ("cannot read program header\n"); + exit (4); + } + + /* Get the ushlib vector from the file being edited. + */ + nl[0].n_name = "ushlib_"; + nl[1].n_name = NULL; + if (nlist (fname, nl) != 0) { + fprintf (stderr, "cannot read name list from %s\n", fname); + exit (4); + } + + offset = (unsigned)nl[0].n_value - phdr->p_vaddr + phdr->p_offset; + lseek (fd, offset, L_SET); + if (read (fd, (char *)ushlib, sizeof(ushlib)) != sizeof(ushlib)) { + fprintf (stderr, "cannot read shared image %s\n", fname); + exit (9); + } + + version = ushlib[0]; + vshlib = ushlib[2]; + vshend = ushlib[3]; + vsize = vshend - vshlib; + + /* Read transfer vector from shared image. + */ + + /* Use the correct version of the shared image. */ + for (ip=shlib, out=op=shpath; *op = *ip++; op++) + if (*op == '/') + out = op + 1; + if (strcmp (out, "S.e") == 0) { + sprintf (out, "S%d.e", version); + shlib = shpath; + } + + /* Open the file to be edited. */ + if ((fd_sh = open (shlib, 0)) < 0) { + fprintf (stderr, "edsym: cannot open file %s\n", shlib); + exit (1); + } + + elf_sh = elf_begin (fd_sh, ELF_C_READ, NULL); + if (!elf_sh) { + fprintf (stderr, "edsym: not an ELF format executable\n"); + exit (2); + } + + /* Read file header. */ + ehdr = elf32_getehdr (elf_sh); + if (!ehdr) { + fprintf (stderr, "edsym: cannot read file header\n"); + exit (3); + } + + /* Read program header for text segment, which we assume to be the + * first loadable program segment. + */ + phdr = elf32_getphdr (elf_sh); + if (ehdr->e_phnum <= 0 || !phdr) { + printf ("cannot read program header\n"); + exit (4); + } + + if (!(vec = (unsigned *) malloc (vsize))) { + fprintf (stderr, "out of memory\n"); + exit (10); + } + offset = vshlib - phdr->p_vaddr + phdr->p_offset; + lseek (fd_sh, offset, L_SET); + if (read (fd_sh, vec, vsize) != vsize) { + fprintf (stderr, + "cannot read transfer vector from %s\n", shlib); + exit (11); + } + + /* Locate symbol table section in file to be edited. */ + scn = NULL; + while (scn = elf_nextscn(elf,scn)) { + shdr = elf32_getshdr (scn); + if (shdr->sh_type == SHT_SYMTAB) + break; + } + if (!scn) { + fprintf (stderr, "edsym: file %s has no symbol table\n", fname); + exit (12); + } + + /* Read symbol table into memory. */ + nbytes = shdr->sh_size; + nsyms = nbytes / sizeof(Elf32_Sym); + if (!(buf = (char *) malloc (nbytes))) { + fprintf (stderr, "edsym: out of memory\n"); + exit (13); + } + lseek (fd, shdr->sh_offset, 0); + if (read (fd, buf, nbytes) != nbytes) { + fprintf (stderr, "edsym: cannot read symbol table\n"); + exit (14); + } + + /* Now edit the symbol table of the object file. + */ + for (sym = (Elf32_Sym *)buf; --nsyms >= 0; sym++) { + Elf32_Addr v = sym->st_value; + if (debug) { + printf ("name=%d value=0x%x size=0x%x info=%o shndx=%d", + sym->st_name, sym->st_value, sym->st_size, + sym->st_info, sym->st_shndx); + } + if (sym->st_size == 0 && + ELF32_ST_BIND(sym->st_info) == STB_GLOBAL && IS_TVECT(v)) { + epa = (unsigned *)((char *)vec + (v - vshlib)); + v = (((*epa & 0x3fffff) << 10) | (*(epa+1) & 0x3ff)); + if (debug) + printf ("\t%x -> %x", sym->st_value, v); + sym->st_value = (Elf32_Addr) v; + } + if (debug) + printf ("\n"); + } + + /* Write out the edited symbol table. */ + lseek (fd, shdr->sh_offset, 0); + if (write (fd, buf, nbytes) != nbytes) { + fprintf (stderr, "edsym: cannot update symbol table\n"); + exit (7); + } + + /* All done. */ + free (buf); + free ((char *)vec); + elf_end (elf_sh); + close (fd_sh); + elf_end (elf); + close (fd); + + exit (0); +} diff --git a/unix/shlib/elf.c b/unix/shlib/elf.c new file mode 100644 index 00000000..31c18891 --- /dev/null +++ b/unix/shlib/elf.c @@ -0,0 +1,96 @@ +#include + +/* + * ELF -- Test program to access an ELF format file (executable). + */ +main (argc,argv) +int argc; +char **argv; +{ + register Elf32_Phdr *phdr; + register Elf32_Ehdr *ehdr; + register Elf32_Shdr *shdr; + Elf32_Phdr *phdr_array; + int phnum, fd, i; + char strbuf[512]; + Elf_Scn *scn; + Elf *elf; + + elf_version (EV_CURRENT); + + fd = open (argv[1], 2); + if (fd < 0) { + printf ("cannot open file\n"); + exit (1); + } + elf = elf_begin (fd, ELF_C_READ, NULL); + if (!elf) { + printf ("not an ELF format file\n"); + exit (2); + } + + /* Read and print file header. + */ + ehdr = elf32_getehdr (elf); + if (!ehdr) { + printf ("cannot read file header\n"); + exit (3); + } + printf ("File type=%d machine=%d version=%d shnum=%d phnum=%d\n", + ehdr->e_type, + ehdr->e_machine, + ehdr->e_version, + ehdr->e_shnum, + phnum = ehdr->e_phnum); + printf ("--------------------------------------------------------\n"); + + /* Read and print program header. + */ + phdr_array = elf32_getphdr (elf); + if (phnum <= 0 || !phdr_array) { + printf ("cannot read program header\n"); + } else { + for (i=0; i < phnum; i++) { + phdr = (Elf32_Phdr *) + ((char *)phdr_array + i*ehdr->e_phentsize); + printf ("type=%d offset=%d", + phdr->p_type, + phdr->p_offset); + printf (" vaddr=0x%x fsize=0x%x msize=0x%x align=0x%x\n", + phdr->p_vaddr, + phdr->p_filesz, + phdr->p_memsz, + phdr->p_align); + } + } + printf ("--------------------------------------------------------\n"); + + /* Summarize files sections. + */ + + /* Get section header string buffer. */ + scn = elf_getscn (elf, ehdr->e_shstrndx); + shdr = elf32_getshdr (scn); + if (!scn || !shdr) + goto nosec; + lseek (fd, (long)shdr->sh_offset, 0); + if (read (fd, strbuf, sizeof(strbuf)) < sizeof(strbuf)) { +nosec: printf ("cannot read section header\n"); + exit (4); + } + + /* Print section headers. */ + scn = NULL; + while (scn = elf_nextscn(elf,scn)) { + shdr = elf32_getshdr (scn); + printf ("type=%d addr=0x%x offset=0x%x size=0x%x %s\n", + shdr->sh_type, + shdr->sh_addr, + shdr->sh_offset, + shdr->sh_size, + strbuf + shdr->sh_name); + } + + elf_end (elf); + close (fd); +} diff --git a/unix/shlib/inode.c b/unix/shlib/inode.c new file mode 100644 index 00000000..98d2dd86 --- /dev/null +++ b/unix/shlib/inode.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +/* + * INODE -- Print the inode number and other information for a file or files. + */ +main (argc, argv) +int argc; +char *argv[]; +{ + struct stat fi; + int argno; + char *file; + + printf ("IDEVICE INO MODE NLK UID DEV SIZE FILE\n"); + for (argno=1; argno < argc; argno++) + if (stat (file=argv[argno], &fi) == -1) + fprintf (stderr, "cannot stat %s\n", file); + else { + printf ("%7d%7d%7o%4d%5d%8d%8d %s\n", + fi.st_dev, fi.st_ino, fi.st_mode, fi.st_nlink, + fi.st_uid, fi.st_rdev, fi.st_size, file); + } +} diff --git a/unix/shlib/mapfile b/unix/shlib/mapfile new file mode 100644 index 00000000..73cfa24f --- /dev/null +++ b/unix/shlib/mapfile @@ -0,0 +1,2 @@ +text = V0x10000078 A0x2000; +data = A0x2000; diff --git a/unix/shlib/medit.c b/unix/shlib/medit.c new file mode 100644 index 00000000..b84b9567 --- /dev/null +++ b/unix/shlib/medit.c @@ -0,0 +1,77 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +/* + * MEDIT -- Replace all occurrences of the given string in a file by a + * different string of the same length. Works for binary files as well + * as text files. This is a crude but effective way of editing the symbol + * table of object files, without having to know the data structures. + * (String *data* will be edited too). + */ + +/* Solaris used to need this but it doesn't any longer. +#define bcopy(a,b,n) memmove(b,a,n) */ + +#define BUFLEN 16384 +static char buf[BUFLEN]; +static int nbytes; + +main (argc, argv) +int argc; +char *argv[]; +{ + register char *ip, *itop, ch; + char *fname, *oldname, *newname; + int fd, nch, total, nmatch, i; + + if (argc < 4) { + fprintf (stderr, "Usage: medit file oldname newname\n"); + exit (1); + } + + fname = argv[1]; + if ((fd = open (fname, 2)) == -1) { + fprintf (stderr, "Cannot open %s\n", fname); + exit (2); + } + + if ((nbytes = read (fd, buf, BUFLEN)) <= 0) { + fprintf (stderr, "Cannot read %s\n", fname); + exit (2); + } + + for (i=2, total=0; i+1 < argc; i=i+2, total+=nmatch) { + oldname = argv[i]; + newname = argv[i+1]; + + if (strlen(oldname) != strlen(newname)) { + fprintf (stderr, + "Replacement string must be same length as the original\n"); + exit (3); + } + + ch = oldname[0]; + nch = strlen (oldname); + itop = buf + nbytes - nch; + + for (ip=buf, nmatch=0; ip < itop; ip++) + if (*ip == ch && (strncmp (ip, oldname, nch) == 0)) { + bcopy (newname, ip, nch); + ip = ip + nch - 1; + nmatch++; + } + + printf ("%s, %s -> %s: %d entries edited\n", + fname, oldname, newname, nmatch); + } + + if (total) { + lseek (fd, 0L, 0); + write (fd, buf, nbytes); + } + + close (fd); + exit (0); +} diff --git a/unix/shlib/mkpkg b/unix/shlib/mkpkg new file mode 100644 index 00000000..4b364873 --- /dev/null +++ b/unix/shlib/mkpkg @@ -0,0 +1,103 @@ +# Make the Sun/IRAF shared library. + + +$call relink +$exit + +update: + $call relink + $call install + $iffile (V.o) $call clean $endif + ; + +relink: + $set rebuild = no + $goto relink_ +Relink: + $set rebuild = yes +relink_: + $set ADDR = 10000000 + $set VV = "$$(@S.ver.$(MACH))" + + $ifeq (OSVERSION, 4) + $set SI = bin$$S$(VV).e + $else + $set SI = bin$$S$(VV)_$(OSRELEASE).e + $endif + + $set L1 = + $set L2 = + $set L3 = + $set L4 = + + $ifnfile ($(SI), lib$libshare.a) + $set rebuild = yes + $else $ifolder ($(SI): $(L1), $(L2), $(L3), $(L4), Slib.c) + $set rebuild = yes + $end + + $ifeq (rebuild, yes) + $ifeq (OSVERSION, 4) + !./mkshlib.sos4 -a $(ADDR) + $else + !./mkshlib.ssol -a $(ADDR) + $endif + $call libshare + $else + $echo "shared library is up to date" + $endif + ; + +install: + $set VV = "$$(@S.ver.$(MACH))" + $ifeq (OSVERSION, 4) + $set SI = S$(VV).e + $else + $set SI = S$(VV)_$(OSRELEASE).e + $endif + + $iffile (S.e) + $iffile (bin$$$(SI).2) $move bin$$$(SI).2 bin$$$(SI).3 $endif + $iffile (bin$$$(SI).1) $move bin$$$(SI).1 bin$$$(SI).2 $endif + $iffile (bin$$$(SI) ) $move bin$$$(SI) bin$$$(SI).1 $endif + $move S.e bin$$$(SI) + $move libshare.a bin$ + $iffile (bin$$$(SI).1, bin$$$(SI).2, bin$$$(SI).3) + !(find $(iraf)bin/$(SI).[123] -atime +1 -exec rm {} \;) + $endif + $endif + ; + +libshare: +libshare.a: + $set SYSF = onentry.o + $omake S.s + !ar xv $(iraf)bin.$(MACH)/libsys.a $(SYSF) + !ar rv libshare.a S.o $(SYSF); ranlib libshare.a; rm -f $(SYSF) + $endif + ; + +coff: +coff.e: + $omake coff.c + !cc coff.o -o coff.e + ; + +edsym: +edsym.e: + $ifeq (OSVERSION, 4) + $omake edsym-sos4.c + !cc edsym-sos4.o -o edsym.e + $else + $omake edsym-ssol.c + !cc edsym-ssol.o -lelf -o edsym.e + $endif + ; + +clean: + $ifeq (OSVERSION, 4) + !./mkshlib.sos4 -c + $else + !./mkshlib.ssol -c + $endif + ; diff --git a/unix/shlib/mkpkg.sh b/unix/shlib/mkpkg.sh new file mode 100644 index 00000000..5f95b4f5 --- /dev/null +++ b/unix/shlib/mkpkg.sh @@ -0,0 +1,12 @@ +# Bootstrap EDSYM (required by XC). + +echo "make edsym.e" +if [ $OSVERSION = 4 ] ; then +$CC -c $HSI_CF edsym-sos4.c +$CC $HSI_LFLAGS edsym-sos4.o $HSI_LIBS -o edsym.e ; +else +$CC -c $HSI_CF edsym-ssol.c +$CC $HSI_LFLAGS edsym-ssol.o $HSI_LIBS -o edsym.e ; +fi +mv -f edsym.e ../hlib +rm -f edsym.o diff --git a/unix/shlib/mkshlib.csh.403 b/unix/shlib/mkshlib.csh.403 new file mode 100755 index 00000000..883ef970 --- /dev/null +++ b/unix/shlib/mkshlib.csh.403 @@ -0,0 +1,497 @@ +#! /bin/csh +# Make the Sun/IRAF shared library and associated objects. + +#set echo +unset noclobber + +set BMACH = `ls -l $iraf/bin | sed -e 's+^.*bin\.++'` +set MACH = $BMACH +set GCRT0 = crt0.o +set PGLIB = "" + +if ($BMACH == pg) then + set MACH = f68881 + set GCRT0 = gcrt0.o + set PGLIB = -lc_p +endif +if (`mach` == mc68020) then + setenv FLOAT_OPTION $MACH +endif + +set PROC = S.e +set SNML = S.nm.$BMACH +set SVER = S.ver.$BMACH +set OMIT = omit.$BMACH +set EXCL = "zshlib.o zzstrt.o" +set ADDR = 0a000000 # default base address of shared region +set PGSZ = 0x2000 # page size + +set FIOCOMSZ = 0x1560 # exported commons +set XERCOMSZ = 0x158 +set TOTCOMSZ = 0x16b8 + +if (`mach` == i386) then + set FHSZ = 0xd0 # .e file header size +else + set FHSZ = 0x20 +endif + +# Process command line options. +while ("$1" != "") + switch ($1) + case "-a": # set base address of shared library + shift + set ADDR = $1 + # I couldn't get a direct !~ csh pattern match test to work here. + if ("`echo $ADDR | grep '[0-9][0-9a-f]*'`" == "") then + set ADDR = 0a000000 + echo -n "Warning: shared library base address not given," + echo " defaults to $ADDR" + endif + breaksw + case "-as": + set PROC = assemble # assemble S.s, V.s + breaksw + case "-c": # delete any temporary files + set PROC = clean + breaksw + case "-f": + set PROC = files + set version = `cat $SVER` + breaksw + case "-l": # merely relink the shared library + set PROC = link + breaksw + case "-nm": + set PROC = names + breaksw + case "-rl": # merely relink the shared library + set PROC = relink + breaksw + endsw + shift +end + +set TB = `echo 0x$ADDR+$FHSZ=X | adb` +set libs = "libos.a libex.a libsys.a libvops.a" + +if ($?IRAFULIB) then + if ($PROC == S.e) then + echo "Warning: user library IRAFULIB=$IRAFULIB will be searched" + endif + set dirs = "$IRAFULIB $iraf/lib $iraf/unix/bin.`mach`" +else + set dirs = "$iraf/lib $iraf/unix/bin.`mach`" +endif + +# In the following, the object V.o must be the first object to be linked, +# as we require it to be at a fixed and predictable address. + +set OBJS = "Slib.o Malloc.o lib*.o zzzend.o" + +switch ($MACH) +case sparc: + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o /usr/lib/crt0.o $OBJS" + set hlibs = "-lm -lF77 -lI77 -lm -lc" + set mcode = 1 + breaksw +case i386: + set lflags = "-Bstatic -d -dc -dp -e _start -X -T $TB" + set objs = "V.o /lib/crt0.o $OBJS" + set hlibs = "-lm -lF77 -lI77 -lm -lc" + set mcode = 2 + breaksw +case f68881: + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o /usr/lib/$GCRT0 /usr/lib/Mcrt1.o -L/usr/lib/$MACH $OBJS" + set hlibs = "-lm -lF77 -lI77 -lm -lc" + set mcode = 3 + breaksw +case ffpa: + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o /usr/lib/crt0.o /usr/lib/Wcrt1.o -L/usr/lib/$MACH $OBJS" + set hlibs = "-lm -lF77 -lI77 -lm -lc" + set mcode = 4 + breaksw +default: + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o /usr/lib/crt0.o /usr/lib/Mcrt1.o -L/usr/lib/fsoft $OBJS" + set hlibs = "-lm -lF77 -lI77 -lm -lc" + set mcode = 0 +endsw + +alias link "ld -o S.e $lflags $objs $hlibs $PGLIB" +alias names "(nm -p S.e | egrep 'T [_]?[a-z0-9]+_"'$'"' | fgrep -v -f $OMIT | sed -e 's+^.* ++' | sort)" + +goto $PROC + +# Build the shared library and associated runtime files. +# -------------- + +S.e: +link: + # Initialize the `objs' working directory. + echo "initialize the 'objs' working directory" + if (-e objs) then + rm -rf objs + endif + mkdir objs + + # Recompile the shlib support objects if necessary. + if (! -e Slib.o) cc -c Slib.c + if (! -e zzzend.o) cc -c zzzend.c + + # Construct private version of MALLOC etc. for S.e run standalone; + # extract standard object and edit the symbol table. + + if (! -e Malloc.o) then + if (! -e medit.e) then + if (`mach` == mc68020) then + cc -fsoft medit.c -o medit.e + else + cc medit.c -o medit.e + endif + endif + ar x /usr/lib/libc.a malloc.o; mv malloc.o Malloc.o + medit.e Malloc.o malloc Malloc realloc Realloc free Free + endif + + if (! -e $OMIT) then + echo "Warning: $OMIT file not found" + echo "fiocom" >> $OMIT + echo "onenty" >> $OMIT + echo "ushlib" >> $OMIT + echo "vshend" >> $OMIT + echo "vshlib" >> $OMIT + echo "xercom" >> $OMIT + echo "zcall" >> $OMIT + echo "zfunc" >> $OMIT + echo "zgtenv" >> $OMIT + echo "zzstop" >> $OMIT + echo "zzstrt" >> $OMIT + endif + + # Create a dummy transfer vector V.o for linking purposes. + if (! -e V.o) then + echo "vshlib_(){}vshend_(){}" > V.c + cc -c V.c; rm V.c + endif + + # Link a new shared library. Custom IRAFULIB libraries are supported. + cd objs + set noclobber + foreach i ($libs) + foreach j ($dirs) + set file = $j/$i + if (-e $file) then + break + endif + end + echo "prelink $file" + ar x $file + if (-e __.SYMDEF) then + rm __.SYMDEF + endif + foreach j ($EXCL) + if (-e $j) rm $j + end + ld -r -o ../$i.o *.o + rm *.o + end + unset noclobber + cd .. + + echo "link the shared library" + link; if ($PROC == "link") exit 0 + +names: + # Generate the external names list for the new shared library. + echo "generate the name list for the new shared library" + names > S.nm.new + if (-e $SNML) then + sort $SNML > S.nm.old + else + cp S.nm.new $SNML + cp S.nm.new S.nm.old + endif + + # If any externals present in the old library have been deleted, + # increment the shlib version number to indicate that old executables + # much be relinked. If any new symbols have been added, append these + # to the end of the name list so that the order of the existing + # externals is not changed, allowing old executables to be used with + # the new shared library without relinking. + + if (! -e $SVER) then + echo "1" > $SVER + endif + + set new_version = no + set version = `cat $SVER` + comm -23 S.nm.old S.nm.new > S.nm.deleted + comm -13 S.nm.old S.nm.new > S.nm.added + + if ($PROC == "names") then + exit 0 + endif + + if ("`head -1 S.nm.deleted`" != "") then + set version = `expr $version + 1` + echo $version > $SVER + echo "shlib version incremented to $version" + echo "deleted externals: `cat S.nm.deleted`" + set new_version = yes + cp S.nm.new $SNML + else if ("`head -1 S.nm.added`" != "") then + echo "new externals: `cat S.nm.added`" + cat S.nm.added >> $SNML + endif +files: + if (-e S.s) rm S.s + if (-e V.s) rm V.s + + # Get the number of symbols in the name list. + foreach i (`wc $SNML`) + set nsymbols = $i + break + end + + # Write out the shared library transfer vector module. Each external + # in the shared library has a fixed offset in the transfer vector; + # the instruction at that offset is a jump to the actual procedure. + # Memory is allocated as follows: 0x20 byte file header, 0x14 byte + # transfer vector header, FIO common storage, and then the transfer + # vector. The FIO common is allocated the entire first page (8192 + # bytes) of the mapped file. This first page will be mapped RW even + # though it is technically part of the text area. The transfer vector + # and the remainder of the text area are mapped RO. The FIO common + # and the MEM common need to be located at absolute addresses (MEM is + # at zero) so that they may be referenced in both the client process + # and in the shared library. + + echo "create the V.s file" + switch ("`mach`") + case "i386": + echo ' .file "V.s"' > V.s + echo " .text" >> V.s + echo " .globl mem_" >> V.s + echo " .set mem_, 0" >> V.s + echo " .globl fiocom_" >> V.s + echo "fiocom_:" >> V.s + echo " .set ., [ . + $FIOCOMSZ ]" >> V.s + echo " .globl xercom_" >> V.s + echo "xercom_:" >> V.s + echo " .set ., [ . + $XERCOMSZ ]" >> V.s + echo " .set ., [ . + $PGSZ - $FHSZ - $TOTCOMSZ ]" >> V.s + echo " .globl vshlib_" >> V.s + echo "vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long etext" >> V.s + echo " .long edata" >> V.s + echo " .long end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ jmp &+' < $SNML >> V.s + echo " .globl vshend_" >> V.s + echo "vshend_:" >> V.s + breaksw + + case "sparc": + echo ' .seg "text"' >> V.s + echo " .global _mem_" >> V.s + echo " _mem_ = 0" >> V.s + echo " .global _fiocom_" >> V.s + echo "_fiocom_:" >> V.s + echo " .skip $FIOCOMSZ" >> V.s + echo " .global _xercom_" >> V.s + echo "_xercom_:" >> V.s + echo " .skip $XERCOMSZ" >> V.s + echo " .skip ( $PGSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .global _vshlib_" >> V.s + echo "_vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ set &, %g1; jmp %g1; nop+' < $SNML >> V.s + echo " .global _vshend_" >> V.s + echo "_vshend_:" >> V.s + breaksw + + case "mc68020": + echo " .text" >> V.s + echo " .globl _mem_" >> V.s + echo " _mem_ = 0" >> V.s + echo " .globl _fiocom_" >> V.s + echo "_fiocom_:" >> V.s + echo " . = ( . + $FIOCOMSZ )" >> V.s + echo " .globl _xercom_" >> V.s + echo "_xercom_:" >> V.s + echo " . = ( . + $XERCOMSZ )" >> V.s + echo " . = ( . + $PGSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .globl _vshlib_" >> V.s + echo "_vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ jmp &+' < $SNML >> V.s + echo " .globl _vshend_" >> V.s + echo "_vshend_:" >> V.s + breaksw + + default: + echo "unknown machine type `mach`" + exit 1 + endsw + + # Write out the shared library object containing the names of all + # shared library externals, to be linked into each applications + # program. Each external is represented in the object (S.o) by the + # address (i.e., as a symbol) of the corresponding jmp instruction + # in the transfer vector in the shared library. + +set LOC = `echo 0x$ADDR+0x$PGSZ+0x20=D | adb` + + echo "create the S.s file" + switch ("`mach`") + case "i386": + echo ' .file "S.s"' > S.s + echo " .data" >> S.s + echo " .globl ushlib_" >> S.s + echo "ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo " .text" >> S.s + echo " .globl mem_" >> S.s + echo " .set mem_, 0" >> S.s + echo " .globl fiocom_" >> S.s + echo " .set fiocom_, [ 0x$ADDR+$FHSZ ]" >> S.s + echo " .globl xercom_" >> S.s + echo " .set xercom_, [ 0x$ADDR+$FHSZ+$FIOCOMSZ ]" >> S.s + echo " .globl vshlib_" >> S.s + echo " .set vshlib_, [ 0x$ADDR + $PGSZ ]" >> S.s + echo " .set LOC, [ 0x$ADDR + $PGSZ + 0x20 ]" >> S.s + sed -e 's/.*/ .globl &; .set &, [ LOC ]; .set LOC, [ LOC + 5 ]/' < $SNML >> S.s + echo " .globl vshend_" >> S.s + echo "vshend_:" >> S.s + breaksw + + case "sparc": + echo ' .seg "data"' >> S.s + echo " .global _ushlib_" >> S.s + echo "_ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo ' .seg "text"' >> S.s + echo " .global _mem_" >> S.s + echo " _mem_ = 0" >> S.s + echo " .global _fiocom_" >> S.s + echo " _fiocom_ = ( 0x$ADDR+$FHSZ )" >> S.s + echo " .global _xercom_" >> S.s + echo " _xercom_ = ( 0x$ADDR+$FHSZ+$FIOCOMSZ )" >> S.s + echo " .global _vshlib_" >> S.s + echo " _vshlib_ = ( 0x$ADDR + $PGSZ )" >> S.s + awk "BEGIN { s = $LOC }"' { printf ("\t.global %s; %s = 0x%x\n", $1, $1, s); s += 16 }' S.nm.sparc >> S.s + echo " .global _vshend_" >> S.s + echo "_vshend_:" >> S.s + breaksw + + case "mc68020": + echo " .data" >> S.s + echo " .globl _ushlib_" >> S.s + echo "_ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo " .text" >> S.s + echo " .globl _mem_" >> S.s + echo " _mem_ = 0" >> S.s + echo " .globl _fiocom_" >> S.s + echo " _fiocom_ = ( 0x$ADDR+$FHSZ )" >> S.s + echo " .globl _xercom_" >> S.s + echo " _xercom_ = ( 0x$ADDR+$FHSZ+$FIOCOMSZ )" >> S.s + echo " .globl _vshlib_" >> S.s + echo " _vshlib_ = ( 0x$ADDR + $PGSZ )" >> S.s + echo " LOC = ( 0x$ADDR + $PGSZ + 0x20 )" >> S.s + sed -e 's/.*/ .globl &; & = ( LOC ); LOC = ( LOC + 6 )/' < $SNML >> S.s + echo " .globl _vshend_" >> S.s + echo "_vshend_:" >> S.s + breaksw + + default: + echo "unknown machine type `mach`" + exit 1 + endsw + + if ($PROC == "files") then + exit 0 + endif + +assemble: + if (`mach` == sparc) then + echo "assemble V.s"; as V.s -o V.o |& grep -v "questionable use" + echo "assemble S.s"; as S.s -o S.o |& grep -v "questionable use" + else + echo "assemble V.s"; as V.s -o V.o + echo "assemble S.s"; as S.s -o S.o + endif + if ($PROC == "assemble") exit 0 + +relink: + # Relink the shared library with the new transfer vector. + echo "relink the shared library with the new transfer vector" + link; if ($PROC == "relink") exit 0 + +# All done with build S.e sequence. +echo "delete the 'objs' working directory" +rm -rf objs +exit 0 + +# Utilities. +# ------------------- + +clean: + # Delete all intermediate files. + if (-e objs) then + rm -rf objs + endif + + foreach i (V.s S.s S.nm.added S.nm.deleted S.nm.old S.nm.new) + if (-e $i) then + rm -f $i + endif + end + + if ("`find . -name '*.[aoe]' -print | head -1`" != "") then + rm -f *.[aoe] + endif + exit 0 diff --git a/unix/shlib/mkshlib.csh.411 b/unix/shlib/mkshlib.csh.411 new file mode 100755 index 00000000..06feda8a --- /dev/null +++ b/unix/shlib/mkshlib.csh.411 @@ -0,0 +1,516 @@ +#! /bin/csh +# Make the Sun/IRAF shared library and associated objects. + +#set echo +unset noclobber + +set BMACH = `ls -l $iraf/bin | sed -e 's+^.*bin\.++'` +set MACH = $BMACH +set GCRT0 = crt0.o +set PGLIB = "" +set LIB = /usr/lang/SC0.0 + +if ($BMACH == pg) then + set MACH = f68881 + set GCRT0 = gcrt0.o + set PGLIB = -lc_p +endif +if (`mach` == mc68020) then + setenv FLOAT_OPTION $MACH +endif + +set PROC = S.e +set SNML = S.nm.$BMACH +set SVER = S.ver.$BMACH +set OMIT = omit.$BMACH +set EXCL = "zshlib.o zzstrt.o" +set ADDR = 0a000000 # default base address of shared region +set PGSZ = 0x2000 # page size + +set FIOCOMSZ = 0x1560 # exported commons +set XERCOMSZ = 0x158 +set TOTCOMSZ = 0x16b8 + +if (`mach` == i386) then + set FHSZ = 0xd0 # .e file header size +else + set FHSZ = 0x20 +endif + +# Process command line options. +while ("$1" != "") + switch ($1) + case "-a": # set base address of shared library + shift + set ADDR = $1 + # I couldn't get a direct !~ csh pattern match test to work here. + if ("`echo $ADDR | grep '[0-9][0-9a-f]*'`" == "") then + set ADDR = 0a000000 + echo -n "Warning: shared library base address not given," + echo " defaults to $ADDR" + endif + breaksw + case "-as": + set PROC = assemble # assemble S.s, V.s + breaksw + case "-c": # delete any temporary files + set PROC = clean + breaksw + case "-f": + set PROC = files + set version = `cat $SVER` + breaksw + case "-l": # merely relink the shared library + set PROC = link + breaksw + case "-nm": + set PROC = names + breaksw + case "-rl": # merely relink the shared library + set PROC = relink + breaksw + endsw + shift +end + +set TB = `echo 0x$ADDR+$FHSZ=X | adb` +set libs = "libos.a libex.a libsys.a libvops.a" + +if ($?IRAFULIB) then + if ($PROC == S.e) then + echo "Warning: user library IRAFULIB=$IRAFULIB will be searched" + endif + set dirs = "$IRAFULIB $iraf/lib $iraf/unix/bin.`mach`" +else + set dirs = "$iraf/lib $iraf/unix/bin.`mach`" +endif + +# In the following, the object V.o must be the first object to be linked, +# as we require it to be at a fixed and predictable address. + +set OBJS = "Slib.o Malloc.o lib*.o zzzend.o" + +switch ($MACH) +case sparc: + set FLIB = $LIB/cg87 + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/crt0.o $FLIB/_crt1.o -L$LIB $OBJS" + set hlibs = "-lF77 -lm -lc" + set mcode = 1 + breaksw +case i386: + # The following has NOT been modified for use with the new Sun Fortran + # compiler, as we don't have this on our 386i. + set lflags = "-Bstatic -d -dc -dp -e _start -X -T $TB" + set objs = "V.o /lib/crt0.o $OBJS" + set hlibs = "-lm -lF77 -lI77 -lm -lc" + set mcode = 2 + breaksw +case f68881: + set FLIB = $LIB/f68881 + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "-lF77 -lm -lc" + set mcode = 3 + breaksw +case ffpa: + set FLIB = $LIB/ffpa + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "-lF77 -lm -lc" + set mcode = 4 + breaksw +default: + set FLIB = $LIB/fsoft + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "-lF77 -lm -lc" + set mcode = 0 +endsw + +alias link "ld -o S.e $lflags $objs $hlibs $PGLIB" +alias names "(nm -p S.e | egrep 'T [_]?[a-z0-9]+_"'$'"' | fgrep -v -f $OMIT | sed -e 's+^.* ++' | sort)" + +goto $PROC + +# Build the shared library and associated runtime files. +# -------------- + +S.e: +link: + # Initialize the `objs' working directory. + echo "initialize the 'objs' working directory" + if (-e objs) then + rm -rf objs + endif + mkdir objs + + # Recompile the shlib support objects if necessary. + if (! -e Slib.o) cc -c Slib.c + if (! -e zzzend.o) cc -c zzzend.c + + # Construct private version of MALLOC etc. for S.e run standalone; + # extract standard object and edit the symbol table. + + if (! -e Malloc.o) then + if (! -e medit.e) then + if (`mach` == mc68020) then + cc -fsoft medit.c -o medit.e + else + cc medit.c -o medit.e + endif + endif + ar x /usr/lib/libc.a malloc.o; mv malloc.o Malloc.o + medit.e Malloc.o malloc Malloc realloc Realloc free Free + endif + + if (! -e $OMIT) then + echo "Warning: $OMIT file not found" + echo "fiocom" >> $OMIT + echo "onenty" >> $OMIT + echo "ushlib" >> $OMIT + echo "vshend" >> $OMIT + echo "vshlib" >> $OMIT + echo "xercom" >> $OMIT + echo "zcall" >> $OMIT + echo "zfunc" >> $OMIT + echo "zgtenv" >> $OMIT + echo "zzstop" >> $OMIT + echo "zzstrt" >> $OMIT + endif + + # Create a dummy transfer vector V.o for linking purposes. + if (! -e V.o) then + echo "vshlib_(){}vshend_(){}" > V.c + cc -c V.c; rm V.c + endif + + # Link a new shared library. Custom IRAFULIB libraries are supported. + cd objs + set noclobber + foreach i ($libs) + foreach j ($dirs) + set file = $j/$i + if (-e $file) then + break + endif + end + echo "prelink $file" + ar x $file + if (-e __.SYMDEF) then + rm __.SYMDEF + endif + foreach j ($EXCL) + if (-e $j) rm $j + end + ld -r -o ../$i.o *.o + rm *.o + end + unset noclobber + cd .. + + echo "link the shared library" + link; if ($PROC == "link") exit 0 + +names: + # Generate the external names list for the new shared library. + echo "generate the name list for the new shared library" + names > S.nm.new + if (-e $SNML) then + sort $SNML > S.nm.old + else + cp S.nm.new $SNML + cp S.nm.new S.nm.old + endif + + # If any externals present in the old library have been deleted, + # increment the shlib version number to indicate that old executables + # much be relinked. If any new symbols have been added, append these + # to the end of the name list so that the order of the existing + # externals is not changed, allowing old executables to be used with + # the new shared library without relinking. + + if (! -e $SVER) then + echo "1" > $SVER + endif + + set new_version = no + set version = `cat $SVER` + comm -23 S.nm.old S.nm.new > S.nm.deleted + comm -13 S.nm.old S.nm.new > S.nm.added + + if ($PROC == "names") then + exit 0 + endif + + if ("`head -1 S.nm.deleted`" != "") then + set version = `expr $version + 1` + echo $version > $SVER + echo "shlib version incremented to $version" + echo "deleted externals: `cat S.nm.deleted`" + set new_version = yes + cp S.nm.new $SNML + else if ("`head -1 S.nm.added`" != "") then + echo "new externals: `cat S.nm.added`" + cat S.nm.added >> $SNML + endif +files: + if (-e S.s) rm S.s + if (-e V.s) rm V.s + + # Get the number of symbols in the name list. + foreach i (`wc $SNML`) + set nsymbols = $i + break + end + + # Write out the shared library transfer vector module. Each external + # in the shared library has a fixed offset in the transfer vector; + # the instruction at that offset is a jump to the actual procedure. + # Memory is allocated as follows: 0x20 byte file header, 0x14 byte + # transfer vector header, FIO common storage, and then the transfer + # vector. The FIO common is allocated the entire first page (8192 + # bytes) of the mapped file. This first page will be mapped RW even + # though it is technically part of the text area. The transfer vector + # and the remainder of the text area are mapped RO. The FIO common + # and the MEM common need to be located at absolute addresses (MEM is + # at zero) so that they may be referenced in both the client process + # and in the shared library. + + echo "create the V.s file" + switch ("`mach`") + case "i386": + echo ' .file "V.s"' > V.s + echo " .text" >> V.s + echo " .globl mem_" >> V.s + echo " .set mem_, 0" >> V.s + echo " .globl fiocom_" >> V.s + echo "fiocom_:" >> V.s + echo " .set ., [ . + $FIOCOMSZ ]" >> V.s + echo " .globl xercom_" >> V.s + echo "xercom_:" >> V.s + echo " .set ., [ . + $XERCOMSZ ]" >> V.s + echo " .set ., [ . + $PGSZ - $FHSZ - $TOTCOMSZ ]" >> V.s + echo " .globl vshlib_" >> V.s + echo "vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long etext" >> V.s + echo " .long edata" >> V.s + echo " .long end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ jmp &+' < $SNML >> V.s + echo " .globl vshend_" >> V.s + echo "vshend_:" >> V.s + breaksw + + case "sparc": + echo ' .seg "text"' >> V.s + echo " .global _mem_" >> V.s + echo " _mem_ = 0" >> V.s + echo " .global _fiocom_" >> V.s + echo "_fiocom_:" >> V.s + echo " .skip $FIOCOMSZ" >> V.s + echo " .global _xercom_" >> V.s + echo "_xercom_:" >> V.s + echo " .skip $XERCOMSZ" >> V.s + echo " .skip ( $PGSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .global _vshlib_" >> V.s + echo "_vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ set &, %g1; jmp %g1; nop+' < $SNML >> V.s + echo " .global _vshend_" >> V.s + echo "_vshend_:" >> V.s + breaksw + + case "mc68020": + echo " .text" >> V.s + echo " .globl _mem_" >> V.s + echo " _mem_ = 0" >> V.s + echo " .globl _fiocom_" >> V.s + echo "_fiocom_:" >> V.s + echo " . = ( . + $FIOCOMSZ )" >> V.s + echo " .globl _xercom_" >> V.s + echo "_xercom_:" >> V.s + echo " . = ( . + $XERCOMSZ )" >> V.s + echo " . = ( . + $PGSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .globl _vshlib_" >> V.s + echo "_vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ jmp &+' < $SNML >> V.s + echo " .globl _vshend_" >> V.s + echo "_vshend_:" >> V.s + breaksw + + default: + echo "unknown machine type `mach`" + exit 1 + endsw + + # Write out the shared library object containing the names of all + # shared library externals, to be linked into each applications + # program. Each external is represented in the object (S.o) by the + # address (i.e., as a symbol) of the corresponding jmp instruction + # in the transfer vector in the shared library. + +set LOC = `echo 0x$ADDR+0x$PGSZ+0x20=D | adb` + + echo "create the S.s file" + switch ("`mach`") + case "i386": + echo ' .file "S.s"' > S.s + echo " .data" >> S.s + echo " .globl sh_debug" >> S.s + echo "sh_debug:" >> S.s + echo " .long 0" >> S.s + echo " .text" >> S.s + echo " .globl ushlib_" >> S.s + echo "ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo " .text" >> S.s + echo " .globl mem_" >> S.s + echo " .set mem_, 0" >> S.s + echo " .globl fiocom_" >> S.s + echo " .set fiocom_, [ 0x$ADDR+$FHSZ ]" >> S.s + echo " .globl xercom_" >> S.s + echo " .set xercom_, [ 0x$ADDR+$FHSZ+$FIOCOMSZ ]" >> S.s + echo " .globl vshlib_" >> S.s + echo " .set vshlib_, [ 0x$ADDR + $PGSZ ]" >> S.s + echo " .set LOC, [ 0x$ADDR + $PGSZ + 0x20 ]" >> S.s + sed -e 's/.*/ .globl &; .set &, [ LOC ]; .set LOC, [ LOC + 5 ]/' < $SNML >> S.s + echo " .globl vshend_" >> S.s + echo "vshend_:" >> S.s + breaksw + + case "sparc": + echo ' .seg "data"' >> S.s + echo " .global _sh_debug" >> S.s + echo "_sh_debug:" >> S.s + echo " .long 0" >> S.s + echo ' .seg "text"' >> S.s + echo " .global _ushlib_" >> S.s + echo "_ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo ' .seg "text"' >> S.s + echo " .global _mem_" >> S.s + echo " _mem_ = 0" >> S.s + echo " .global _fiocom_" >> S.s + echo " _fiocom_ = ( 0x$ADDR+$FHSZ )" >> S.s + echo " .global _xercom_" >> S.s + echo " _xercom_ = ( 0x$ADDR+$FHSZ+$FIOCOMSZ )" >> S.s + echo " .global _vshlib_" >> S.s + echo " _vshlib_ = ( 0x$ADDR + $PGSZ )" >> S.s + awk "BEGIN { s = $LOC }"' { printf ("\t.global %s; %s = 0x%x\n", $1, $1, s); s += 16 }' S.nm.sparc >> S.s + echo " .global _vshend_" >> S.s + echo "_vshend_:" >> S.s + breaksw + + case "mc68020": + echo " .data" >> S.s + echo " .globl _sh_debug" >> S.s + echo "_sh_debug:" >> S.s + echo " .long 0" >> S.s + echo " .text" >> S.s + echo " .globl _ushlib_" >> S.s + echo "_ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo " .text" >> S.s + echo " .globl _mem_" >> S.s + echo " _mem_ = 0" >> S.s + echo " .globl _fiocom_" >> S.s + echo " _fiocom_ = ( 0x$ADDR+$FHSZ )" >> S.s + echo " .globl _xercom_" >> S.s + echo " _xercom_ = ( 0x$ADDR+$FHSZ+$FIOCOMSZ )" >> S.s + echo " .globl _vshlib_" >> S.s + echo " _vshlib_ = ( 0x$ADDR + $PGSZ )" >> S.s + echo " LOC = ( 0x$ADDR + $PGSZ + 0x20 )" >> S.s + sed -e 's/.*/ .globl &; & = ( LOC ); LOC = ( LOC + 6 )/' < $SNML >> S.s + echo " .globl _vshend_" >> S.s + echo "_vshend_:" >> S.s + breaksw + + default: + echo "unknown machine type `mach`" + exit 1 + endsw + + if ($PROC == "files") then + exit 0 + endif + +assemble: + if (`mach` == sparc) then + echo "assemble V.s"; as V.s -o V.o |& grep -v "questionable use" + echo "assemble S.s"; as S.s -o S.o |& grep -v "questionable use" + else + echo "assemble V.s"; as V.s -o V.o + echo "assemble S.s"; as S.s -o S.o + endif + if ($PROC == "assemble") exit 0 + +relink: + # Relink the shared library with the new transfer vector. + echo "relink the shared library with the new transfer vector" + link; if ($PROC == "relink") exit 0 + +# All done with build S.e sequence. +echo "delete the 'objs' working directory" +rm -rf objs +exit 0 + +# Utilities. +# ------------------- + +clean: + # Delete all intermediate files. + if (-e objs) then + rm -rf objs + endif + + foreach i (V.s S.s S.nm.added S.nm.deleted S.nm.old S.nm.new) + if (-e $i) then + rm -f $i + endif + end + + if ("`find . -name '*.[aoe]' -print | head -1`" != "") then + rm -f *.[aoe] + endif + exit 0 diff --git a/unix/shlib/mkshlib.sos4 b/unix/shlib/mkshlib.sos4 new file mode 100755 index 00000000..b64b1b3c --- /dev/null +++ b/unix/shlib/mkshlib.sos4 @@ -0,0 +1,554 @@ +#! /bin/csh +# Make the Sun/IRAF shared library and associated objects. + +#set echo +unset noclobber + +set BMACH = `ls -l $iraf/bin | sed -e 's+^.*bin\.++'` +set MACH = $BMACH +set DEFARCH = sparc +set GCRT0 = crt0.o +set PGLIB = "" + +set LIB = /usr/lang/SC1.0 +set VER = 1 +if (! -e $LIB) then +set LIB = /usr/lang/SC0.0 +set VER = 0 +endif + +switch ($BMACH) +case "sparc": +case "f68881": +case "ffpa": +case "i386": + breaksw +default: + echo "Warning: the iraf system architecture is set to $BMACH" + echo "building for architecture $DEFARCH..." + set BMACH = $DEFARCH + set MACH = $BMACH + breaksw +endsw + + +if ($BMACH == pg) then + set MACH = f68881 + set GCRT0 = gcrt0.o + set PGLIB = -lc_p +endif +if (`mach` == mc68020) then + setenv FLOAT_OPTION $MACH +endif + +# Use name server if installed? +if ($MACH != i386 && -e /lib/libresolv.a) then + # -l44bsd is needed for some (non-Sun) enhanced versions of libresolv. + #set RESOLV = "-lresolv -l44bsd" + set RESOLV = -lresolv +else + set RESOLV = "" +endif + +set PROC = S.e +set SNML = S.nm.$BMACH +set SVER = S.ver.$BMACH +set OMIT = omit.$BMACH +set EXCL = "zshlib.o zzstrt.o" +set ADDR = 10000000 # default base address of shared region (hex) +set PGSZ = 0x2000 # page size +set CMSZ = 0x26000 # common area (must be N*PGSZ > TOTCOMSZ) + +set FIOCOMSZ = 0x24660 # exported commons +set XERCOMSZ = 0x810 +set TOTCOMSZ = 0x24e70 + +if (`mach` == i386) then + set FHSZ = 0xd0 # .e file header size +else + set FHSZ = 0x20 +endif + +# Process command line options. +while ("$1" != "") + switch ($1) + case "-a": # set base address of shared library + shift + set ADDR = $1 + # I couldn't get a direct !~ csh pattern match test to work here. + if ("`echo $ADDR | grep '[0-9][0-9a-f]*'`" == "") then + set ADDR = 10000000 + echo -n "Warning: shared library base address not given," + echo " defaults to $ADDR" + endif + breaksw + case "-as": + set PROC = assemble # assemble S.s, V.s + breaksw + case "-c": # delete any temporary files + set PROC = clean + breaksw + case "-f": + set PROC = files + set version = `cat $SVER` + breaksw + case "-l": # merely relink the shared library + set PROC = link + breaksw + case "-nm": + set PROC = names + breaksw + case "-rl": # merely relink the shared library + set PROC = relink + breaksw + endsw + shift +end + +set TB = `echo 0x$ADDR+$FHSZ=X | adb` +set libs = "libos.a libex.a libsys.a libvops.a" + +if ($?IRAFULIB) then + if ($PROC == S.e) then + echo "Warning: user library IRAFULIB=$IRAFULIB will be searched" + endif + set dirs = "$IRAFULIB $iraf/bin.$BMACH $iraf/unix/bin.`mach`" +else + set dirs = "$iraf/bin.$BMACH $iraf/unix/bin.`mach`" +endif + +# In the following, the object V.o must be the first object to be linked, +# as we require it to be at a fixed and predictable address. + +set OBJS = "Slib.o Malloc.o lib*.o zzzend.o" + +switch ($MACH) +case sparc: + set FLIB = $LIB/cg87 + if ($VER == 0) then + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/crt0.o $FLIB/_crt1.o -L$LIB $OBJS" + else + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/crt0.o $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + endif + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 1 + breaksw +case i386: + # The following has NOT been modified for use with the new Sun Fortran + # compiler, as we don't have this on our 386i. + set lflags = "-Bstatic -d -dc -dp -e _start -X -T $TB" + set objs = "V.o /lib/crt0.o $OBJS" + set hlibs = "$RESOLV -lm -lF77 -lI77 -lm -lc" + set mcode = 2 + breaksw +case f68881: + set FLIB = $LIB/f68881 + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 3 + breaksw +case ffpa: + set FLIB = $LIB/ffpa + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 4 + breaksw +default: + set FLIB = $LIB/fsoft + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 0 +endsw + +alias link "ld -o S.e $lflags $objs $hlibs $PGLIB" +alias names "(nm -p S.e | egrep 'T [_]?[a-z0-9]+_"'$'"' | fgrep -v -f $OMIT | sed -e 's+^.* ++' | sort)" + +goto $PROC + +# Build the shared library and associated runtime files. +# -------------- + +S.e: +link: + # Initialize the `objs' working directory. + echo "initialize the 'objs' working directory" + if (-e objs) then + rm -rf objs + endif + mkdir objs + + # Recompile the shlib support objects if necessary. + if (! -e Slib.o) cc -c Slib.c + if (! -e zzzend.o) cc -c zzzend.c + + # Construct private version of MALLOC etc. for S.e run standalone; + # extract standard object and edit the symbol table. + + if (! -e Malloc.o) then + if (! -e medit.e) then + if (`mach` == mc68020) then + cc -fsoft medit.c -o medit.e + else + cc medit.c -o medit.e + endif + endif + ar x /usr/lib/libc.a malloc.o; mv malloc.o Malloc.o + medit.e Malloc.o malloc Malloc realloc Realloc free Free + endif + + if (! -e $OMIT) then + echo "Warning: $OMIT file not found" + echo "fiocom" >> $OMIT + echo "onenty" >> $OMIT + echo "ushlib" >> $OMIT + echo "vshend" >> $OMIT + echo "vshlib" >> $OMIT + echo "xercom" >> $OMIT + echo "zcall" >> $OMIT + echo "zfunc" >> $OMIT + echo "zgtenv" >> $OMIT + echo "zzstop" >> $OMIT + echo "zzstrt" >> $OMIT + endif + + # Create a dummy transfer vector V.o for linking purposes. + if (! -e V.o) then + echo "vshlib_(){}vshend_(){}" > V.c + cc -c V.c; rm V.c + endif + + # Link a new shared library. Custom IRAFULIB libraries are supported. + cd objs + set noclobber + foreach i ($libs) + foreach j ($dirs) + set file = $j/$i + if (-e $file) then + break + endif + end + echo "prelink $file" + ar x $file + if (-e __.SYMDEF) then + rm __.SYMDEF + endif + foreach j ($EXCL) + if (-e $j) rm $j + end + ld -r -o ../$i.o *.o + rm *.o + end + unset noclobber + cd .. + + echo "link the shared library" + link; if ($PROC == "link") exit 0 + +names: + # Generate the external names list for the new shared library. + echo "generate the name list for the new shared library" + names > S.nm.new + if (-e $SNML) then + sort $SNML > S.nm.old + else + cp S.nm.new $SNML + cp S.nm.new S.nm.old + endif + + # If any externals present in the old library have been deleted, + # increment the shlib version number to indicate that old executables + # much be relinked. If any new symbols have been added, append these + # to the end of the name list so that the order of the existing + # externals is not changed, allowing old executables to be used with + # the new shared library without relinking. + + if (! -e $SVER) then + echo "1" > $SVER + endif + + set new_version = no + set version = `cat $SVER` + comm -23 S.nm.old S.nm.new > S.nm.deleted + comm -13 S.nm.old S.nm.new > S.nm.added + + if ($PROC == "names") then + exit 0 + endif + + if ("`head -1 S.nm.deleted`" != "") then + set version = `expr $version + 1` + echo $version > $SVER + echo "shlib version incremented to $version" + echo "deleted externals: `cat S.nm.deleted`" + set new_version = yes + cp S.nm.new $SNML + else if ("`head -1 S.nm.added`" != "") then + echo "new externals: `cat S.nm.added`" + cat S.nm.added >> $SNML + endif +files: + if (-e S.s) rm S.s + if (-e V.s) rm V.s + + # Get the number of symbols in the name list. + foreach i (`wc $SNML`) + set nsymbols = $i + break + end + + # Write out the shared library transfer vector module. Each external + # in the shared library has a fixed offset in the transfer vector; + # the instruction at that offset is a jump to the actual procedure. + # Memory is allocated as follows: 0x20 byte file header, 0x14 byte + # transfer vector header, FIO common storage, and then the transfer + # vector. The FIO common is allocated the entire first page (8192 + # bytes) of the mapped file. This first page will be mapped RW even + # though it is technically part of the text area. The transfer vector + # and the remainder of the text area are mapped RO. The FIO common + # and the MEM common need to be located at absolute addresses (MEM is + # at zero) so that they may be referenced in both the client process + # and in the shared library. + + echo "create the V.s file" + switch ("`mach`") + case "i386": + echo ' .file "V.s"' > V.s + echo " .text" >> V.s + echo " .globl mem_" >> V.s + echo " .set mem_, 0" >> V.s + echo " .globl fiocom_" >> V.s + echo "fiocom_:" >> V.s + echo " .set ., [ . + $FIOCOMSZ ]" >> V.s + echo " .globl xercom_" >> V.s + echo "xercom_:" >> V.s + echo " .set ., [ . + $XERCOMSZ ]" >> V.s + echo " .set ., [ . + $CMSZ - $FHSZ - $TOTCOMSZ ]" >> V.s + echo " .globl vshlib_" >> V.s + echo "vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long etext" >> V.s + echo " .long edata" >> V.s + echo " .long end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ jmp &+' < $SNML >> V.s + echo " .globl vshend_" >> V.s + echo "vshend_:" >> V.s + breaksw + + case "sparc": + echo ' .seg "text"' >> V.s + echo " .global _mem_" >> V.s + echo " _mem_ = 0" >> V.s + echo " .global _fiocom_" >> V.s + echo "_fiocom_:" >> V.s + echo " .skip $FIOCOMSZ" >> V.s + echo " .global _xercom_" >> V.s + echo "_xercom_:" >> V.s + echo " .skip $XERCOMSZ" >> V.s + echo " .skip ( $CMSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .global _vshlib_" >> V.s + echo "_vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ set &, %g1; jmp %g1; nop+' < $SNML >> V.s + echo " .align 4096" >> V.s + echo " .global _vshend_" >> V.s + echo "_vshend_:" >> V.s + breaksw + + case "mc68020": + echo " .text" >> V.s + echo " .globl _mem_" >> V.s + echo " _mem_ = 0" >> V.s + echo " .globl _fiocom_" >> V.s + echo "_fiocom_:" >> V.s + echo " . = ( . + $FIOCOMSZ )" >> V.s + echo " .globl _xercom_" >> V.s + echo "_xercom_:" >> V.s + echo " . = ( . + $XERCOMSZ )" >> V.s + echo " . = ( . + $CMSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .globl _vshlib_" >> V.s + echo "_vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ jmp &+' < $SNML >> V.s + echo " .globl _vshend_" >> V.s + echo "_vshend_:" >> V.s + breaksw + + default: + echo "unknown machine type `mach`" + exit 1 + endsw + + # Write out the shared library object containing the names of all + # shared library externals, to be linked into each applications + # program. Each external is represented in the object (S.o) by the + # address (i.e., as a symbol) of the corresponding jmp instruction + # in the transfer vector in the shared library. + +set LOC = `echo 0x$ADDR+0x$CMSZ+0x20=D | adb` + + echo "create the S.s file" + switch ("`mach`") + case "i386": + echo ' .file "S.s"' > S.s + echo " .data" >> S.s + echo " .globl sh_debug" >> S.s + echo "sh_debug:" >> S.s + echo " .long 0" >> S.s + echo " .text" >> S.s + echo " .globl ushlib_" >> S.s + echo "ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo " .text" >> S.s + echo " .globl mem_" >> S.s + echo " .set mem_, 0" >> S.s + echo " .globl fiocom_" >> S.s + echo " .set fiocom_, [ 0x$ADDR+$FHSZ ]" >> S.s + echo " .globl xercom_" >> S.s + echo " .set xercom_, [ 0x$ADDR+$FHSZ+$FIOCOMSZ ]" >> S.s + echo " .globl vshlib_" >> S.s + echo " .set vshlib_, [ 0x$ADDR + $CMSZ ]" >> S.s + echo " .set LOC, [ 0x$ADDR + $CMSZ + 0x20 ]" >> S.s + sed -e 's/.*/ .globl &; .set &, [ LOC ]; .set LOC, [ LOC + 5 ]/' < $SNML >> S.s + echo " .globl vshend_" >> S.s + echo "vshend_:" >> S.s + breaksw + + case "sparc": + echo ' .seg "data"' >> S.s + echo " .global _sh_debug" >> S.s + echo "_sh_debug:" >> S.s + echo " .long 0" >> S.s + echo ' .seg "text"' >> S.s + echo " .global _ushlib_" >> S.s + echo "_ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo ' .seg "text"' >> S.s + echo " .global _mem_" >> S.s + echo " _mem_ = 0" >> S.s + echo " .global _fiocom_" >> S.s + echo " _fiocom_ = ( 0x$ADDR+$FHSZ )" >> S.s + echo " .global _xercom_" >> S.s + echo " _xercom_ = ( 0x$ADDR+$FHSZ+$FIOCOMSZ )" >> S.s + echo " .global _vshlib_" >> S.s + echo " _vshlib_ = ( 0x$ADDR + $CMSZ )" >> S.s + awk "BEGIN { s = $LOC }"' { printf ("\t.global %s; %s = 0x%x\n", $1, $1, s); s += 16 }' S.nm.sparc >> S.s + echo " .global _vshend_" >> S.s + echo "_vshend_:" >> S.s + breaksw + + case "mc68020": + echo " .data" >> S.s + echo " .globl _sh_debug" >> S.s + echo "_sh_debug:" >> S.s + echo " .long 0" >> S.s + echo " .text" >> S.s + echo " .globl _ushlib_" >> S.s + echo "_ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo " .text" >> S.s + echo " .globl _mem_" >> S.s + echo " _mem_ = 0" >> S.s + echo " .globl _fiocom_" >> S.s + echo " _fiocom_ = ( 0x$ADDR+$FHSZ )" >> S.s + echo " .globl _xercom_" >> S.s + echo " _xercom_ = ( 0x$ADDR+$FHSZ+$FIOCOMSZ )" >> S.s + echo " .globl _vshlib_" >> S.s + echo " _vshlib_ = ( 0x$ADDR + $CMSZ )" >> S.s + echo " LOC = ( 0x$ADDR + $CMSZ + 0x20 )" >> S.s + sed -e 's/.*/ .globl &; & = ( LOC ); LOC = ( LOC + 6 )/' < $SNML >> S.s + echo " .globl _vshend_" >> S.s + echo "_vshend_:" >> S.s + breaksw + + default: + echo "unknown machine type `mach`" + exit 1 + endsw + + if ($PROC == "files") then + exit 0 + endif + +assemble: + if (`mach` == sparc) then + echo "assemble V.s"; as V.s -o V.o |& grep -v "questionable use" + echo "assemble S.s"; as S.s -o S.o |& grep -v "questionable use" + else + echo "assemble V.s"; as V.s -o V.o + echo "assemble S.s"; as S.s -o S.o + endif + if ($PROC == "assemble") exit 0 + +relink: + # Relink the shared library with the new transfer vector. + echo "relink the shared library with the new transfer vector" + link; if ($PROC == "relink") exit 0 + +# All done with build S.e sequence. +echo "delete the 'objs' working directory" +rm -rf objs +exit 0 + +# Utilities. +# ------------------- + +clean: + # Delete all intermediate files. + if (-e objs) then + rm -rf objs + endif + + foreach i (V.s S.s S.nm.added S.nm.deleted S.nm.old S.nm.new) + if (-e $i) then + rm -f $i + endif + end + + if ("`find . -name '*.[aoe]' -print | head -1`" != "") then + rm -f *.[aoe] + endif + exit 0 diff --git a/unix/shlib/mkshlib.ssol b/unix/shlib/mkshlib.ssol new file mode 120000 index 00000000..f4eaf309 --- /dev/null +++ b/unix/shlib/mkshlib.ssol @@ -0,0 +1 @@ +mkshlib.ssol-sc34 \ No newline at end of file diff --git a/unix/shlib/mkshlib.ssol-sc2 b/unix/shlib/mkshlib.ssol-sc2 new file mode 100755 index 00000000..ccc161ad --- /dev/null +++ b/unix/shlib/mkshlib.ssol-sc2 @@ -0,0 +1,447 @@ +#! /bin/csh +# Make the Sun/IRAF shared library and associated objects. +# Version for Solaris/IRAF, July 1994. Version 2.x compilers. + +#set echo +unset noclobber + +set BMACH = `ls -l $iraf/bin | sed -e 's+^.*bin\.++'` +set MACH = $BMACH +set GCRT0 = crt0.o +set PGLIB = "" + +if ($BMACH == ssun) then + set LIB = /opt/SUNWspro/SC* + set VER = 1 +else if ($BMACH == sf2c) then + set LIB = /opt/cygnus/lib/gcc-lib/sparc-sun-solaris2/cygnus-2.3.3 + set VER = 1 +endif + +if (! -e $LIB) then + set LIB = /opt/SUNWspro/SC2.0.1 + set VER = 1 +endif + +if ($BMACH == pg) then + set MACH = sf2c + set GCRT0 = gcrt0.o + set PGLIB = -lc_p +endif +if (`uname -m` == sun3) then + setenv FLOAT_OPTION $MACH +endif + +# Use name server if installed? +if ($MACH != i386 && -e /lib/libresolv.a) then + set RESOLV = -lresolv +else + set RESOLV = "" +endif + +set PROC = S.e +set SNML = S.nm.$BMACH +set SVER = S.ver.$BMACH +set OMIT = omit.$BMACH +set EXCL = "zshlib.o zzstrt.o" +set ADDR = 0a000000 # default base address of shared region +set PGSZ = 0x2000 # page size + +set FIOCOMSZ = 0x1560 # exported commons +set XERCOMSZ = 0x158 +set TOTCOMSZ = 0x16b8 + +if (`uname -m` == i386) then + set FHSZ = 0xd0 # .e file header size +else + # set FHSZ = 0x20 # Sunos + set FHSZ = 0x74 # Solaris +endif + +# Process command line options. +while ("$1" != "") + switch ($1) + case "-a": # set base address of shared library + shift + set ADDR = $1 + # I couldn't get a direct !~ csh pattern match test to work here. + if ("`echo $ADDR | grep '[0-9][0-9a-f]*'`" == "") then + set ADDR = 0a000000 + echo -n "Warning: shared library base address not given," + echo " defaults to $ADDR" + endif + breaksw + case "-as": + set PROC = assemble # assemble S.s, V.s + breaksw + case "-c": # delete any temporary files + set PROC = clean + breaksw + case "-f": + set PROC = files + set version = `cat $SVER` + breaksw + case "-l": # merely relink the shared library + set PROC = link + breaksw + case "-nm": + set PROC = names + breaksw + case "-rl": # merely relink the shared library + set PROC = relink + breaksw + case "-p": + set PROC = patch + breaksw + endsw + shift +end + +set TB = `echo 0x$ADDR+$FHSZ=X | adb` +set libs = "libos.a libex.a libsys.a libvops.a" + +if ($?IRAFULIB) then + if ($PROC == S.e) then + echo "Warning: user library IRAFULIB=$IRAFULIB will be searched" + endif + set dirs = "$IRAFULIB $iraf/lib $iraf/unix/bin.ssol" +else + set dirs = "$iraf/lib $iraf/unix/bin.ssol" +endif + +# In the following, the object V.o must be the first object to be linked, +# as we require it to be at a fixed and predictable address. + +set OBJS = "Slib.o Malloc.o lib*.o zzzend.o" + +switch ($MACH) +case ssun: + set FLIB = $LIB/cg89 + echo "text = V0x$TB A0x2000;" > mapfile + set lflags = "-dn -Bstatic -t -e _start -M mapfile" + set lpath = "./:/opt/SUNWspro/lib:${LIB}:/usr/ccs/lib:/usr/lib" + set objs = \ + "V.o $LIB/crti.o $LIB/crt1.o $FLIB/__fstd.o $LIB/values-xt.o $OBJS" + set hlibs = \ + "-Y P,$lpath -lM77 -lF77 -lm -lsocket -lnsl -lintl -lc" + set mcode = 5 + breaksw +case sparc: + set FLIB = $LIB/cg87 + if ($VER == 0) then + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/crt0.o $FLIB/_crt1.o -L$LIB $OBJS" + else + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/crt0.o $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + endif + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 1 + breaksw +case i386: + # The following has NOT been modified for use with the new Sun Fortran + # compiler, as we don't have this on our 386i. + set lflags = "-Bstatic -d -dc -dp -e _start -X -T $TB" + set objs = "V.o /lib/crt0.o $OBJS" + set hlibs = "$RESOLV -lm -lF77 -lI77 -lm -lc" + set mcode = 2 + breaksw +case f68881: + set FLIB = $LIB/f68881 + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 3 + breaksw +case ffpa: + set FLIB = $LIB/ffpa + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 4 + breaksw +default: + set FLIB = $LIB/fsoft + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 0 +endsw + +alias link "ld -o S.e $lflags $objs $hlibs $PGLIB |& grep -v 'has differing types' |& grep -v 'file V.o type=NOTY' |& grep -v 'V.o definition taken'" +alias names "(nm -p S.e | egrep 'T [_]?[a-z0-9]+_"'$'"' | fgrep -v -f $OMIT | sed -e 's+^.* ++' | sort)" + +goto $PROC + +# Build the shared library and associated runtime files. +# -------------- + +S.e: +link: + # Initialize the `objs' working directory. + echo "initialize the 'objs' working directory" + if (-e objs) then + rm -rf objs + endif + mkdir objs + + # Recompile the shlib support objects if necessary. + if (! -e Slib.o) cc -c $HSI_CF Slib.c + if (! -e zzzend.o) cc -c $HSI_CF zzzend.c + + # Construct private version of MALLOC etc. for S.e run standalone; + # extract standard object and edit the symbol table. + + if (! -e Malloc.o) then + if (! -e medit.e) then + if (`uname -m` == sun3) then + cc -fsoft medit.c -o medit.e + else + cc $HSI_CF medit.c -o medit.e + endif + endif + ar x /usr/lib/libc.a malloc.o; mv malloc.o Malloc.o + medit.e Malloc.o malloc Malloc realloc Realloc free Free \ + __Malloc_lock __malloc_lock + endif + + if (! -e $OMIT) then + echo "Warning: $OMIT file not found" + echo "fiocom" >> $OMIT + echo "onenty" >> $OMIT + echo "ushlib" >> $OMIT + echo "vshend" >> $OMIT + echo "vshlib" >> $OMIT + echo "xercom" >> $OMIT + echo "zcall" >> $OMIT + echo "zfunc" >> $OMIT + echo "zgtenv" >> $OMIT + echo "zzstop" >> $OMIT + echo "zzstrt" >> $OMIT + endif + + # Create a dummy transfer vector V.o for linking purposes. + if (! -e V.o) then + echo "vshlib_(){}vshend_(){}" > V.c + cc -c V.c; rm V.c + endif + + # Link a new shared library. Custom IRAFULIB libraries are supported. + cd objs + set noclobber + foreach i ($libs) + foreach j ($dirs) + set file = $j/$i + if (-e $file) then + break + endif + end + echo "prelink $file" + ar x $file + if (-e __.SYMDEF) then + rm __.SYMDEF + endif + foreach j ($EXCL) + if (-e $j) rm $j + end + ld -r -t -o ../$i.o *.o + rm *.o + end + unset noclobber + cd .. + + echo "link the shared library" + link; if ($PROC == "link") exit 0 + +names: + # Generate the external names list for the new shared library. + echo "generate the name list for the new shared library" + names > S.nm.new + if (-e $SNML) then + sort $SNML > S.nm.old + else + cp S.nm.new $SNML + cp S.nm.new S.nm.old + endif + + # If any externals present in the old library have been deleted, + # increment the shlib version number to indicate that old executables + # much be relinked. If any new symbols have been added, append these + # to the end of the name list so that the order of the existing + # externals is not changed, allowing old executables to be used with + # the new shared library without relinking. + + if (! -e $SVER) then + echo "1" > $SVER + endif + + set new_version = no + set version = `cat $SVER` + comm -23 S.nm.old S.nm.new > S.nm.deleted + comm -13 S.nm.old S.nm.new > S.nm.added + + if ($PROC == "names") then + exit 0 + endif + + if ("`head -1 S.nm.deleted`" != "") then + set version = `expr $version + 1` + echo $version > $SVER + echo "shlib version incremented to $version" + echo "deleted externals: `cat S.nm.deleted`" + set new_version = yes + cp S.nm.new $SNML + else if ("`head -1 S.nm.added`" != "") then + set number = `cat S.nm.added | wc -l` + echo "$number new externals added:" + head -200 S.nm.added + cat S.nm.added >> $SNML + endif +files: + if (-e S.s) rm S.s + if (-e V.s) rm V.s + + # Get the number of symbols in the name list. + foreach i (`wc $SNML`) + set nsymbols = $i + break + end + + # Write out the shared library transfer vector module. Each external + # in the shared library has a fixed offset in the transfer vector; + # the instruction at that offset is a jump to the actual procedure. + # Memory is allocated as follows: 0x20 byte file header, 0x14 byte + # transfer vector header, FIO common storage, and then the transfer + # vector. The FIO common is allocated the entire first page (8192 + # bytes) of the mapped file. This first page will be mapped RW even + # though it is technically part of the text area. The transfer vector + # and the remainder of the text area are mapped RO. The FIO common + # and the MEM common need to be located at absolute addresses (MEM is + # at zero) so that they may be referenced in both the client process + # and in the shared library. + + echo "create the V.s file" + + echo ' .seg "text"' >> V.s + echo " .common mem_,8" >> V.s + echo " mem_ = 0" >> V.s + echo " .common fiocom_,$FIOCOMSZ" >> V.s + echo "fiocom_:" >> V.s + echo " .skip $FIOCOMSZ" >> V.s + echo " .common xercom_,$XERCOMSZ" >> V.s + echo "xercom_:" >> V.s + echo " .skip $XERCOMSZ" >> V.s + echo " .skip ( $PGSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .global vshlib_" >> V.s + echo "vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ set &, %g1; jmp %g1; nop+' < $SNML >> V.s + echo " .global vshend_" >> V.s + echo "vshend_:" >> V.s + + # Write out the shared library object containing the names of all + # shared library externals, to be linked into each applications + # program. Each external is represented in the object (S.o) by the + # address (i.e., as a symbol) of the corresponding jmp instruction + # in the transfer vector in the shared library. + + if (-e S.e) then + set fiocom_addr = `nm -p -x S.e | grep fiocom | cut -f1 -d \ ` + set xercom_addr = `nm -p -x S.e | grep xercom | cut -f1 -d \ ` + set vshlib_addr = `nm -p -x S.e | grep vshlib | cut -f1 -d \ ` + set vshend_addr = `nm -p -x S.e | grep vshend | cut -f1 -d \ ` + else + set fiocom_addr = $ADDR + set xercom_addr = $ADDR + set vshlib_addr = $ADDR + set vshend_addr = $ADDR + endif + + echo "create the S.s file" + set LOC = `echo $vshlib_addr+0x20=D | adb` + + echo ' .seg "data"' >> S.s + echo " .global sh_debug" >> S.s + echo "sh_debug:" >> S.s + echo " .long 0" >> S.s + echo ' .seg "text"' >> S.s + echo " .global ushlib_" >> S.s + echo "ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long $vshlib_addr" >> S.s + echo " .long $vshend_addr" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo ' .seg "text"' >> S.s + echo " .common mem_,8" >> S.s + echo " mem_ = 0" >> S.s + echo " .common fiocom_,$FIOCOMSZ" >> S.s + echo " fiocom_ = ( $fiocom_addr )" >> S.s + echo " .common xercom_,$XERCOMSZ" >> S.s + echo " xercom_ = ( $xercom_addr )" >> S.s + echo " .global vshlib_" >> S.s + echo " vshlib_ = ( $vshlib_addr )" >> S.s + awk "BEGIN { s = $LOC }"' { printf ("\t.global %s; %s = 0x%x\n", $1, $1, s); s += 16 }' S.nm.ssun >> S.s + echo " .global vshend_" >> S.s + echo "vshend_:" >> S.s + + if ($PROC == "files") then + exit 0 + endif + +assemble: + if (`uname -p` == sparc) then + echo "assemble V.s"; as V.s -o V.o + echo "assemble S.s"; as S.s -o S.o + else + echo "assemble V.s"; as V.s -o V.o + echo "assemble S.s"; as S.s -o S.o + endif + if ($PROC == "assemble") exit 0 + +relink: + # Relink the shared library with the new transfer vector. + echo "relink the shared library with the new transfer vector" + link; if ($PROC == "relink") exit 0 + +patch: + # Need to rebuild S.o to pick up the final vshlib, vshend. + echo "rebuild S.o" + mkshlib.csh -a $ADDR -f + mkshlib.csh -a $ADDR -as + if ($PROC == "patch") exit 0 + +# All done with build S.e sequence. +echo "delete the 'objs' working directory" +rm -rf objs +exit 0 + +# Utilities. +# ------------------- + +clean: + # Delete all intermediate files. + if (-e objs) then + rm -rf objs + endif + + foreach i (V.s S.s S.nm.added S.nm.deleted S.nm.old S.nm.new) + if (-e $i) then + rm -f $i + endif + end + + if ("`find . -name '*.[aoe]' -print | head -1`" != "") then + rm -f *.[aoe] + endif + exit 0 diff --git a/unix/shlib/mkshlib.ssol-sc34 b/unix/shlib/mkshlib.ssol-sc34 new file mode 100755 index 00000000..18763659 --- /dev/null +++ b/unix/shlib/mkshlib.ssol-sc34 @@ -0,0 +1,483 @@ +#! /bin/csh +# Make the Sun/IRAF shared library and associated objects. +# Version for Solaris/IRAF, July 1994, Apr 95. +# Updated Mon Mar 25 13:19:03 MST 1996 for Solaris 2.5. +# Version 3.x and 4.x compilers, Solaris 2.4/2.5. + +#set echo +unset noclobber + +set BMACH = `ls -l $iraf/bin | sed -e 's+^.*bin\.++'` +set MACH = $BMACH +set DEFARCH = ssun +set GCRT0 = crt0.o +set PGLIB = "" +set VER = 1 + +setarch: + if ($BMACH == ssun) then + set dir = /opt/SUNWspro; pushd $dir + set SC3LIB = `find . -name "SC3*" -print` + set SC4LIB = `find . -name "SC4*" -print` + set SC5LIB = `find . -name "SC5*" -print` + if ($SC5LIB != "") then + set LIB = ${dir}/${SC5LIB}/lib + set VER = 5 + else if ($SC4LIB != "") then + set LIB = ${dir}/${SC4LIB}/lib + set VER = 4 + else if ($SC3LIB != "") then + set LIB = ${dir}/${SC3LIB}/lib + set VER = 3 + endif + popd + else if ($BMACH == sf2c) then + set LIB = /opt/cygnus/lib/gcc-lib/sparc-sun-solaris2/cygnus-2.3.3 + else + echo "Warning: the iraf system architecture is set to $BMACH" + echo "building for architecture $DEFARCH..." + set BMACH = $DEFARCH + set MACH = $BMACH + goto setarch + endif + +if (! -e $LIB) then + set LIB = /opt/SUNWspro/SC3.0.1/lib +endif + +if ($BMACH == pg) then + set MACH = sf2c + set GCRT0 = gcrt0.o + set PGLIB = -lc_p +endif +if (`uname -m` == sun3) then + setenv FLOAT_OPTION $MACH +endif + +# Use name server if installed? +if ($MACH != i386 && -e /lib/libresolv.a) then + set RESOLV = -lresolv +else + set RESOLV = "" +endif + +set PROC = S.e +set SNML = S.nm.$BMACH +set SVER = S.ver.$BMACH +set OMIT = omit.$BMACH +set EXCL = "zshlib.o zzstrt.o" +set ADDR = 10000000 # default base address of shared region +set PGSZ = 0x2000 # maximum page size +set CMSZ = 0x26000 # common area (must be N*PGSZ > TOTCOMSZ) + +set FIOCOMSZ = 0x24660 # exported commons +set XERCOMSZ = 0x810 +set TOTCOMSZ = 0x24e70 + +if (`uname -m` == i386) then + set FHSZ = 0xd0 # .e file header size +else + # set FHSZ = 0x20 # Sunos + set FHSZ = 0x78 # Solaris +endif + + +######### +#exit + +# Process command line options. +while ("$1" != "") + switch ($1) + case "-a": # set base address of shared library + shift + set ADDR = $1 + # I couldn't get a direct !~ csh pattern match test to work here. + if ("`echo $ADDR | grep '[0-9][0-9a-f]*'`" == "") then + set ADDR = 10000000 + echo -n "Warning: shared library base address not given," + echo " defaults to $ADDR" + endif + breaksw + case "-as": + set PROC = assemble # assemble S.s, V.s + breaksw + case "-c": # delete any temporary files + set PROC = clean + breaksw + case "-f": + set PROC = files + set version = `cat $SVER` + breaksw + case "-l": # merely relink the shared library + set PROC = link + breaksw + case "-nm": + set PROC = names + breaksw + case "-rl": # merely relink the shared library + set PROC = relink + breaksw + case "-p": + set PROC = patch + breaksw + endsw + shift +end + +set TB = `echo 0x$ADDR+$FHSZ=X | adb` +set libs = "libos.a libex.a libsys.a libvops.a" + +if ($?IRAFULIB) then + if ($PROC == S.e) then + echo "Warning: user library IRAFULIB=$IRAFULIB will be searched" + endif + set dirs = "$IRAFULIB $iraf/bin.ssun $iraf/unix/bin.ssol" +else + set dirs = "$iraf/bin.ssun $iraf/unix/bin.ssol" +endif + +# In the following, the object V.o must be the first object to be linked, +# as we require it to be at a fixed and predictable address. + +set OBJS = "Slib.o Malloc.o lib*.o zzzend.o" + +switch ($MACH) +case ssun: + set FLIB = $LIB/cg89 + echo "text = V0x$TB A0x2000;" > mapfile + echo "data = A0x2000;" >> mapfile + set lflags = "-dn -Bstatic -t -e _start -M mapfile" + set lpath = "./:/opt/SUNWspro/lib:${LIB}:/usr/ccs/lib:/usr/lib" + if ($VER == 5) then + set objs = \ + "V.o $LIB/crti.o $LIB/crt1.o $LIB/values-xi.o $OBJS" + else if ($VER == 4) then + set objs = \ + "V.o $LIB/crti.o $LIB/crt1.o $LIB/values-xi.o $OBJS" + else + set objs = \ + "V.o $LIB/crti.o $LIB/crt1.o $FLIB/__fstd.o $LIB/values-xt.o $OBJS" + endif + set hlibs = \ + "-Y P,$lpath -lM77 -lF77 -lsunmath -lm -lsocket -lnsl -lintl -lc $hbin/libcompat.a $LIB/crtn.o" + set mcode = 5 + breaksw +case sparc: + set FLIB = $LIB/cg87 + if ($VER == 0) then + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/crt0.o $FLIB/_crt1.o -L$LIB $OBJS" + else + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/crt0.o $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + endif + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 1 + breaksw +case i386: + # The following has NOT been modified for use with the new Sun Fortran + # compiler, as we don't have this on our 386i. + set lflags = "-Bstatic -d -dc -dp -e _start -X -T $TB" + set objs = "V.o /lib/crt0.o $OBJS" + set hlibs = "$RESOLV -lm -lF77 -lI77 -lm -lc" + set mcode = 2 + breaksw +case f68881: + set FLIB = $LIB/f68881 + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 3 + breaksw +case ffpa: + set FLIB = $LIB/ffpa + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 4 + breaksw +default: + set FLIB = $LIB/fsoft + set lflags = "-Bstatic -d -dc -dp -e start -X -T $TB" + set objs = "V.o $LIB/$GCRT0 $FLIB/_crt1.o -L$FLIB -L$LIB $OBJS" + set hlibs = "$RESOLV -lF77 -lm -lc" + set mcode = 0 +endsw + +alias link "ld -o S.e $lflags $objs $hlibs $PGLIB |& grep -v 'has differing types' |& grep -v 'file V.o type=NOTY' |& grep -v 'V.o definition taken'" +alias names "(nm -p S.e | egrep 'T [_]?[a-z0-9]+_"'$'"' | fgrep -v -f $OMIT | sed -e 's+^.* ++' | sort)" + +goto $PROC + +# Build the shared library and associated runtime files. +# -------------- + +S.e: +link: + # Initialize the `objs' working directory. + echo "initialize the 'objs' working directory" + if (-e objs) then + rm -rf objs + endif + mkdir objs + + # Recompile the shlib support objects if necessary. + if (! -e Slib.o) cc -c $HSI_CF Slib.c + if (! -e zzzend.o) cc -c $HSI_CF zzzend.c + + # Construct private version of MALLOC etc. for S.e run standalone; + # extract standard object and edit the symbol table. + + if (! -e Malloc.o) then + if (! -e medit.e) then + if (`uname -m` == sun3) then + cc -fsoft medit.c -o medit.e + else + cc $HSI_CF medit.c -o medit.e + endif + endif + ar x /usr/lib/libc.a malloc.o; mv malloc.o Malloc.o + medit.e Malloc.o malloc Malloc realloc Realloc free Free \ + __Malloc_lock __malloc_lock + endif + + if (! -e $OMIT) then + echo "Warning: $OMIT file not found" + echo "fiocom" >> $OMIT + echo "onenty" >> $OMIT + echo "ushlib" >> $OMIT + echo "vshend" >> $OMIT + echo "vshlib" >> $OMIT + echo "xercom" >> $OMIT + echo "zcall" >> $OMIT + echo "zfunc" >> $OMIT + echo "zgtenv" >> $OMIT + echo "zzstop" >> $OMIT + echo "zzstrt" >> $OMIT + endif + + # Create a dummy transfer vector V.o for linking purposes. + if (! -e V.o) then + echo "vshlib_(){}vshend_(){}" > V.c + cc -c V.c; rm V.c + endif + + # Link a new shared library. Custom IRAFULIB libraries are supported. + cd objs + set noclobber + foreach i ($libs) + foreach j ($dirs) + set file = $j/$i + if (-e $file) then + break + endif + end + echo "prelink $file" + ar x $file + if (-e __.SYMDEF) then + rm __.SYMDEF + endif + foreach j ($EXCL) + if (-e $j) rm $j + end + ld -r -t -o ../$i.o *.o + rm *.o + end + unset noclobber + cd .. + + echo "link the shared library" + link; if ($PROC == "link") exit 0 + +names: + # Generate the external names list for the new shared library. + echo "generate the name list for the new shared library" + names > S.nm.new + if (-e $SNML) then + sort $SNML > S.nm.old + else + cp S.nm.new $SNML + cp S.nm.new S.nm.old + endif + + # If any externals present in the old library have been deleted, + # increment the shlib version number to indicate that old executables + # much be relinked. If any new symbols have been added, append these + # to the end of the name list so that the order of the existing + # externals is not changed, allowing old executables to be used with + # the new shared library without relinking. + + if (! -e $SVER) then + echo "1" > $SVER + endif + + set new_version = no + set version = `cat $SVER` + comm -23 S.nm.old S.nm.new > S.nm.deleted + comm -13 S.nm.old S.nm.new > S.nm.added + + if ($PROC == "names") then + exit 0 + endif + + if ("`head -1 S.nm.deleted`" != "") then + set version = `expr $version + 1` + echo $version > $SVER + echo "shlib version incremented to $version" + echo "deleted externals: `cat S.nm.deleted`" + set new_version = yes + cp S.nm.new $SNML + else if ("`head -1 S.nm.added`" != "") then + set number = `cat S.nm.added | wc -l` + echo "$number new externals added:" + head -200 S.nm.added + cat S.nm.added >> $SNML + endif +files: + if (-e S.s) rm S.s + if (-e V.s) rm V.s + + # Get the number of symbols in the name list. + foreach i (`wc $SNML`) + set nsymbols = $i + break + end + + # Write out the shared library transfer vector module. Each external + # in the shared library has a fixed offset in the transfer vector; + # the instruction at that offset is a jump to the actual procedure. + # Memory is allocated as follows: 0x20 byte file header, 0x14 byte + # transfer vector header, FIO common storage, and then the transfer + # vector. The FIO common is allocated the entire first page (8192 + # bytes) of the mapped file. This first page will be mapped RW even + # though it is technically part of the text area. The transfer vector + # and the remainder of the text area are mapped RO. The FIO common + # and the MEM common need to be located at absolute addresses (MEM is + # at zero) so that they may be referenced in both the client process + # and in the shared library. + + echo "create the V.s file" + + echo ' .seg "text"' >> V.s + echo " .common mem_,8" >> V.s + echo " mem_ = 0" >> V.s + echo " .common fiocom_,$FIOCOMSZ" >> V.s + echo "fiocom_:" >> V.s + echo " .skip $FIOCOMSZ" >> V.s + echo " .common xercom_,$XERCOMSZ" >> V.s + echo "xercom_:" >> V.s + echo " .skip $XERCOMSZ" >> V.s + echo " .skip ( $CMSZ - $FHSZ - $TOTCOMSZ )" >> V.s + echo " .global vshlib_" >> V.s + echo "vshlib_:" >> V.s + echo " .long $version" >> V.s + echo " .long 0x$ADDR" >> V.s + echo " .long _etext" >> V.s + echo " .long _edata" >> V.s + echo " .long _end" >> V.s + echo " .long $nsymbols" >> V.s + echo " .long $mcode" >> V.s + echo " .long 8" >> V.s + sed -e 's+.*+ set &, %g1; jmp %g1; nop+' < $SNML >> V.s + echo " .global vshend_" >> V.s + echo "vshend_:" >> V.s + + # Write out the shared library object containing the names of all + # shared library externals, to be linked into each applications + # program. Each external is represented in the object (S.o) by the + # address (i.e., as a symbol) of the corresponding jmp instruction + # in the transfer vector in the shared library. + + if (-e S.e) then + set fiocom_addr = `nm -p -x S.e | grep fiocom | cut -f1 -d \ ` + set xercom_addr = `nm -p -x S.e | grep xercom | cut -f1 -d \ ` + set vshlib_addr = `nm -p -x S.e | grep vshlib | cut -f1 -d \ ` + set vshend_addr = `nm -p -x S.e | grep vshend | cut -f1 -d \ ` + else + set fiocom_addr = $ADDR + set xercom_addr = $ADDR + set vshlib_addr = $ADDR + set vshend_addr = $ADDR + endif + + echo "create the S.s file" + set LOC = `echo $vshlib_addr+0x20=D | adb` + + echo ' .seg "data"' >> S.s + echo " .global sh_debug" >> S.s + echo "sh_debug:" >> S.s + echo " .long 0" >> S.s + echo ' .seg "text"' >> S.s + echo " .global ushlib_" >> S.s + echo "ushlib_:" >> S.s + echo " .long $version" >> S.s + echo " .long 0x$ADDR" >> S.s + echo " .long $vshlib_addr" >> S.s + echo " .long $vshend_addr" >> S.s + echo " .long 0" >> S.s + echo " .long $nsymbols" >> S.s + echo " .long $mcode" >> S.s + echo " .long 8" >> S.s + echo ' .seg "text"' >> S.s + echo " .common mem_,8" >> S.s + echo " mem_ = 0" >> S.s + echo " .common fiocom_,$FIOCOMSZ" >> S.s + echo " fiocom_ = ( $fiocom_addr )" >> S.s + echo " .common xercom_,$XERCOMSZ" >> S.s + echo " xercom_ = ( $xercom_addr )" >> S.s + echo " .global vshlib_" >> S.s + echo " vshlib_ = ( $vshlib_addr )" >> S.s + awk "BEGIN { s = $LOC }"' { printf ("\t.global %s; %s = 0x%x\n", $1, $1, s); s += 16 }' S.nm.ssun >> S.s + echo " .global vshend_" >> S.s + echo "vshend_:" >> S.s + + if ($PROC == "files") then + exit 0 + endif + +assemble: + if (`uname -p` == sparc) then + echo "assemble V.s"; as V.s -o V.o + echo "assemble S.s"; as S.s -o S.o + else + echo "assemble V.s"; as V.s -o V.o + echo "assemble S.s"; as S.s -o S.o + endif + if ($PROC == "assemble") exit 0 + +relink: + # Relink the shared library with the new transfer vector. + echo "relink the shared library with the new transfer vector" + link; if ($PROC == "relink") exit 0 + +patch: + # Need to rebuild S.o to pick up the final vshlib, vshend. + echo "rebuild S.o" + mkshlib.ssol -a $ADDR -f + mkshlib.ssol -a $ADDR -as + if ($PROC == "patch") exit 0 + +# All done with build S.e sequence. +echo "delete the 'objs' working directory" +rm -rf objs +exit 0 + +# Utilities. +# ------------------- + +clean: + # Delete all intermediate files. + if (-e objs) then + rm -rf objs + endif + + foreach i (V.s S.s S.nm.added S.nm.deleted S.nm.old S.nm.new) + if (-e $i) then + rm -f $i + endif + end + + if ("`find . -name '*.[aoe]' -print | head -1`" != "") then + rm -f *.[aoe] + endif + exit 0 diff --git a/unix/shlib/omit.f68881 b/unix/shlib/omit.f68881 new file mode 100644 index 00000000..e092f23b --- /dev/null +++ b/unix/shlib/omit.f68881 @@ -0,0 +1,15 @@ +fiocom +fpamode +ma93n +minitfp +mswitchfp +onenty +ushlib +vshend +vshlib +xercom +zcall +zfunc +zgtenv +zzstop +zzstrt diff --git a/unix/shlib/omit.ffpa b/unix/shlib/omit.ffpa new file mode 100644 index 00000000..01555bf8 --- /dev/null +++ b/unix/shlib/omit.ffpa @@ -0,0 +1,16 @@ +fiocom +fpamode +ma93n +onenty +ushlib +vshend +vshlib +minitfp +winitfp +wswitchfp +xercom +zcall +zfunc +zgtenv +zzstop +zzstrt diff --git a/unix/shlib/omit.generic b/unix/shlib/omit.generic new file mode 100644 index 00000000..d653d888 --- /dev/null +++ b/unix/shlib/omit.generic @@ -0,0 +1,11 @@ +fiocom +onenty +ushlib +vshend +vshlib +xercom +zcall +zfunc +zgtenv +zzstop +zzstrt diff --git a/unix/shlib/omit.i386 b/unix/shlib/omit.i386 new file mode 100644 index 00000000..d653d888 --- /dev/null +++ b/unix/shlib/omit.i386 @@ -0,0 +1,11 @@ +fiocom +onenty +ushlib +vshend +vshlib +xercom +zcall +zfunc +zgtenv +zzstop +zzstrt diff --git a/unix/shlib/omit.pg b/unix/shlib/omit.pg new file mode 100644 index 00000000..e092f23b --- /dev/null +++ b/unix/shlib/omit.pg @@ -0,0 +1,15 @@ +fiocom +fpamode +ma93n +minitfp +mswitchfp +onenty +ushlib +vshend +vshlib +xercom +zcall +zfunc +zgtenv +zzstop +zzstrt diff --git a/unix/shlib/omit.sparc b/unix/shlib/omit.sparc new file mode 100644 index 00000000..d653d888 --- /dev/null +++ b/unix/shlib/omit.sparc @@ -0,0 +1,11 @@ +fiocom +onenty +ushlib +vshend +vshlib +xercom +zcall +zfunc +zgtenv +zzstop +zzstrt diff --git a/unix/shlib/omit.ssun b/unix/shlib/omit.ssun new file mode 100644 index 00000000..d653d888 --- /dev/null +++ b/unix/shlib/omit.ssun @@ -0,0 +1,11 @@ +fiocom +onenty +ushlib +vshend +vshlib +xercom +zcall +zfunc +zgtenv +zzstop +zzstrt diff --git a/unix/shlib/zzzend.c b/unix/shlib/zzzend.c new file mode 100644 index 00000000..c9ff4821 --- /dev/null +++ b/unix/shlib/zzzend.c @@ -0,0 +1,8 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +/* + * ZZZEND -- Dummy symbol used to mark the end of the shared image. + * (makes debugger stack traces easier to understand). + */ +zzzend_(){} diff --git a/unix/sun/Gterm.hlp b/unix/sun/Gterm.hlp new file mode 100644 index 00000000..d97b4407 --- /dev/null +++ b/unix/sun/Gterm.hlp @@ -0,0 +1,198 @@ +.help gterm Dec86 "Vector Graphics for the Sun Workstation" +.sp 2 +.ce +\fBVector Graphics for IRAF on the Sun Workstation\fR +.ce +Doug Tody +.ce +December, 1986 +.ce +(design document) +.sp 3 +.NH +Graphics Terminal Model + + The window based, native vector graphics facility for Sun/IRAF will be +implemented as a purely data driven interface based on the concept of an +intelligent virtual graphics terminal. The virtual graphics terminal will +be implemented in software as a process running under a window system such +as Sunview or X. + +A virtual terminal interface will allow the Sun workstation to be used as an +ordinary graphics terminal to access IRAF or other software on either the +local or a foreign host via any data stream interface, e.g., rlogin, telnet, +or a modem connection. For example, one will be able to use telnet running +in a GTERM window to login on a VMS machine, then run IRAF on the VMS machine +in the normal fashion. Conversely, since the IRAF software on the Sun node +will always think that it is talking to a conventional data driven graphics +terminal, the Sun/IRAF software may in fact be run from a conventional +graphics terminal, via either a direct or remote login. Finally, a pure data +stream TTY interface where all details of the windowing system are isolated +into a server process makes it possible for a single version of IRAF to support +multiple window systems on the same host. + +The graphics terminal to be implemented by GTERM shall consist of independent +text and graphics frames. These will be implemented as separate windows +(frames) under SunView, allowing them to be moved, resized, exposed, hidden, +open, closed, etc., independently of each other. Note however that since both +frames are connected to the controlling process via a single terminal i/o +connection, the controlling process (e.g., the CL) can only read from or +write to one frame at a time. + +In normal use, the user will work for a time in the text frame, issuing +commands to run tasks which do not require interactive graphics facilities. +When a graphics program is run the graphics frame will be opened or exposed +and the plot drawn. If the graphics program is interactive, i.e., uses +cursor input, the cursor will be moved to the center of the window and the +crosshairs turned on to indicate that cursor input is required. A sequence +of keystroke or mouse button triggered cursor reads will follow, and +eventually graphics mode will be exited by transmission of the close +workstation sequence to GTERM by GIO running in the applications program. + +When graphics mode is exited GTERM terminal i/o is redirected to the text +frame and the cursor is restored to its former position in the text frame, +automatically restoring interactive control to the text frame. The graphics +frame may or may not be closed or hidden, depending upon the GTERM defaults +set up by the user. If the graphics frame is to be closed or hidden this +should probably require interactive confirmation by the user, else the plot +might disappear immediately after being drawn. Since control naturally +toggles back and forth between the text and graphics frames and since screen +space is always limited and a large, high resolution graph is generally +desired, it is expected that the graphics frame will normally be displayed +only while in graphics mode. + +.NH +GTERM Graphics Language + + The tektronix graphics language is a simple and efficient standard language +for graphics terminal i/o which will work about as well as anything in our +application. In particular, the vector encoding scheme is simple, compact and +efficient, and well suited to use with a variety of terminal drivers and +modems (since binary data is avoided). The best approach to implementing the +GTERM graphics language would seem to be to take the tektronix language as a +starting point and add additional functionality by extending the language +with new control sequences. Some of the extensions defined here a taken from +the Retrographics vt640 and the Pericom. Others more specific to window based +applications will be added in the future in an upwards compatible fashion. + + +.ks +.nf + GS open workstation if not already open + open/expose graphics frame (icon -> full window) + direct terminal i/o to graphics frame + save cursor (mouse) position + issue GS dark vector command (see below) + CAN close workstation + restore control to text frame (restore cursor) + close/hide graphics frame (full window -> icon) + keystroke required to trigger close-window? + + + GS (workstation already opened) + enter vector drawing mode, dark vector + FS enter point plot mode + US,CR enter alpha mode + text is drawn in graphics frame + defaults to transparent text, erase permitted + ESC CR enter text mode + lines of text are drawn on status line in + nontransparent (overwrite) mode + + ESC SUB enter crosshair mode + ESC FF clear screen, initialize drawing modes + ESC/f [x,y] set crosshair position + GS [x,y] US sets alpha cursor position + + ESC[0123] set character size (normal,2x,3x,4x) + ESC[`abcd] set line drawing style (normal,dotted,dotdash,sd,ld) + ESC/[012]d set drawing mode (set, clear, toggle) + ESC/[0123]w set polyline linewidth (normal,2x,3x,4x) + + Standard screen resolution is 1024 by 780. + In graphics mode, chars are interpreted as [x,y] coordinate pairs. + In alpha mode, chars are interpreted as characters to be drawn. +.fi +.ke + + +A number of extensions to this basic language are being considered for future +implementation. Support for color, multiple text fonts, general polymarkers, +area fill, and possibly cell array are contemplated, as well as simple +extensions for window control and pop-down menus. Support for the standard +textronix features which have been omitted (vector point elimination, +incremental point mode, status enquiry) is possible. The interface is easily +extensible hence there is no need to attempt to define or support such features +in the initial interface. + +.NH +Implementation Notes + + The GTERM virtual terminal consists of two independent frames, the text +frame and the graphics frame. Selection of the frame to which output is to +be delivered is done at the lowest possible level, i.e., when the read system +call is issued by the terminal to accept terminal output from the pty +(pseudo-terminal driver) stream for the terminal. This is done by linking in +a custom version of the notify_read() primitive, the low level read primitive +for notifer based programs. Output is initially to the text frame. Output +is redirected to the graphics frame when GS is seen in the output stream, +and later restored to the text frame when CAN is seen. Input is controlled +independently by the two frames at a high level, hence does not have to be +switched. + +All terminal operations are event driven. Graphics data is deposited into a +circular input buffer by an event driven read routine, which can issue +/ to the terminal driver to control the rate at which input +is accumulated. A separate drawing routine running off an interval timer +is used to process data appearing in the input buffer. The drawing code is +always in one of three modes: vector drawing mode, alpha mode (randomly +addressable character drawing), or text mode (textual output to the status +line). + +.SH +Appendix: Tektronix Graphics Language (Retrographics vt640) + +.ks +.nf + *GS enter graphics mode; dark vector + *FS enter point plot mode + RS enter incremental point mode + *US,CR enter alpha mode, graphics plane, tek font + CAN disable graphics mode, restore output to terminal plane + + ESC"0g alias for enter transparent mode + ESC"4g alias for enter crosshair mode + ESC"5g enter light pen mode + + *ESC SUB enter crosshair mode + *ESC FF clear screen, initialize drawing modes + *ESC ENQ return cursor position, other status + + ESC[0123] set character size (normal,2x,3x,4x) + ESC[`abcd] set line drawing style (normal,dotted,dotdash,sd,ld) + ESC/[012]d set drawing mode (set, clear, toggle) + + ESC/f set crosshair position + *GS [x,y] US sets alpha cursor position + + Vector coordinate encoding (max 10 bits = 1024 points res.): + + high y P01XXXXX + low y P11XXXXX + high x P01XXXXX + low x P10XXXXX + + Cursor return structure: + + key PXXXXXXX + high x P01XXXXX + low x P01XXXXX + high y P01XXXXX + low y P01XXXXX + trailer + + Standard 4010/4012 screen resolution is 1024 by 780. + In graphics mode, chars are interpreted as [x,y] coordinate pairs. + In alpha mode, chars are interpreted as characters to be drawn. +.fi +.ke diff --git a/unix/sun/Imtool.hlp b/unix/sun/Imtool.hlp new file mode 100644 index 00000000..39d42dbe --- /dev/null +++ b/unix/sun/Imtool.hlp @@ -0,0 +1,420 @@ +.help imtool Jan87 "Image Display on the Sun Workstation" +.sp 3 +.ce +\fBImage Display on the Sun Workstation\fR +.ce +Design Specification (prototype display) +.ce +Doug Tody +.ce +January 1987 + +.NH +Introduction + + This document describes the prototype Sunview based SUN/IRAF image display. +The standard Sun-3 color workstation provides an 1152 by 900 by 8 bit frame +buffer (some models are larger) with an associated 256 entry color table and +an RGB display. A keyboard and a three button mouse are provided for +interactive control and command entry. + +In typical interactive use the user will have a number of windows open on the +screen, e.g., a GTERM virtual graphics terminal with text and graphics windows, +the image display window, a small console window, and several icons. +Due to limitations on the amount of screen space available and due to speed +limitations when refreshing a full 8 bit deep window, it is desirable to limit +the size of the image display window to a fraction of the screen space most +of the time. + +Due to the complexity of the task of designing a fully functional, device +independent image display interface, and the need to get at least a basic +image display capability functioning for SUN/IRAF as soon as possible, +a prototype display will be implemented first in January 1987 followed by +the full interface later in the year. Although the prototype will not provide +full functionality or system and device independence, the basic features are +expected to be provided im much the same form that they will take in the final +interface. + +.NH +User Interfaces + + The prototype image display will use the existing TV/DISPLAY program to +load images into the image display. None of the other tasks in the TV package +will be supported and the entire contents of the TV package will disappear +later this year. Display interaction and cursor readback will be via the +same cursor mode interface currently used for the graphics terminal interface. +Additional display-level interaction will be available under mouse control, +e.g., to support display dependent functions not otherwise supported in cursor +mode, such as greyscale windowing, filtering (resampling), region of interest +control, and the like. + +.NH +Display Features +.NH 2 +Image and Graphics Planes + + The display size is a setup configuration parameter but is fixed while the +display is in use. Typical display sizes might be 512, 800, 1024, or 2048 +pixels square, or some rectangular size. Sufficient physical memory should be +available so that the internal frame buffers may be locked into memory. + +The image display will be 7 bits deep with 1 bit of graphics +overlay, leaving half of the color table entries for use by other +graphics windows. The image may be windowed without affecting the +color table entries of the other windows on the screen. If 7 bits +of greyscale proves to be a serious limitation something on the order +of 7.9 bits is possible by playing tricks with the software (clever +use of the color table). This latter feature will not be available +in the initial prototype. + +The prototype display will provide N image frames, all of which must be the +same size, each with its own independent lookup table and viewport. +The frame size and number of frames are arbitrary and will be a setup option. +Blinking, split screen, true color representation, and other operations +involving simultaneous display of multiple frames will not be implemented +n the prototype display. + +The full display will support N image frames, each with an associated 1 bit +graphics overlay, with all frame-graphics pairs the same size, and with +support for multiple screen operations such as blink and split screen. +Independent lookup tables will not be possible in split screen mode, +but this may not be a serious problem given the autoscaling algorithm in +the DISPLAY task, and the possibility of normalization of multiple image +frames to use a common lookup table (by modifying the loaded pixel values), +once the lookup table has been independently adjusted for each frame. + +.NH 2 +Pseudocolor and True Color + + Pseudocolor will probably not be supported in the initial prototype, +although it may be added to the prototype before the final interface is written. +True color can probably be provided in the final interface by maintaining an +independent lookup table for each of the three frames (RGB) in software, +generating the compound output in software, and displaying the result in +hardware using a software generated linear pseudocolor lookup table. Once the +true color image is generated all of the zoom, pan, etc. functions will work +with their usual speed. Since true color display is used infrequently (and +fully buffered memory to memory operations are fairly fast anyhow) this +technique should prove quite adequate. + +.NH 2 +The Display Window + + The user views the displayed image through a window which may be resized and +moved about on the screen at any time, under interactive control of the mouse. +Resizing the window changes only the size of the subraster of the fixed-size +image frame to be displayed. Moving the window under Sunview does not change +the window into the image, merely the position of the image display window on +the screen. + +Zoom and pan is implemented in software. Zoom is implemented by pixel +replication and dezoom by pixel subsampling, operating simultaneously on both +the greyscale and graphics planes. Each operation results in a reload of the +portion of the image displayed in the image window from data stored in the +fixed size internal frame buffer. Zoom, dezoom, and roam are controlled +interactively using either the normal cursor mode keystrokes (ZXYEP,1-9M,0), +the mouse, or both. + +Once the region of interest has been adjusted on the display via the full pixel +sampling techniques, a "resample" operation may be performed to recompute the +contents of the displayed subraster using block averaging and/or bilinear +interpolation techniques. A possible variation on this is to compute several +block averaged versions of the full image at various dezoom factors, e.g., +2, 4, and 8 times dezoom, and read from these rather than the full frame when +dezoom is selected. For example, if the frame size is 2048 square, the display +would simultaneously store 2048, 1024, 512, and 256 square block-averaged +versions of the frame and dynamically select the version to be used depending +upon the dezoom factor. The percentage of additional memory required to hold +the dezoomed frames is only about 40% greater than the fully sampled frame. +Timing tests need to be performed to see if this is worthwhile. + +.NH 2 +Region of Interest + + Due to screen space limitations the image window will rarely exceed about +512 square pixels in size, hence one will normally view either a dezoomed +version of the image or a subraster of the full frame (full screen display +will of course be an option). One possible way to live with dezoom without +suffering loss of resolution is to use an icon, e.g., 64 pixels square, +to always display the region under the cursor at full resolution or better. +The display would consist of, for example, a 512 square main window displaying +the dezoomed image, and an independently movable 64 square by 8 bit icon +displaying an enlarged version of the image cursor, crosshairs, graphics +overlay, and all. + +Alternatively, the cursor could be positioned on the full window and then a +mouse button pressed to display the cursor at full resolution (or better), +at the position of the cursor, with the display returning to normal when the +mouse button is released. Yet another possibility is for the cursor to act +as a magnifier which is moved about over the dezoomed image. Most probably +all these choices will be provided as options, since they are all variations +on the same thing. + +.NH 2 +Windowing + + The lookup tables will be readable and writable under software control for +sophisticated applications such as interactive entry of a piecewise linear +transfer function. Most commonly, however, greyscale windowing will be +performed by the image display under control of the mouse. The most attractive +way to do this is probably to display a histogram of the image in the graphics +plane, overlaid by the current transfer function, which typically looks like +this: + +.ks +.nf + /------------ + / + / + ---------/ +.fi +.ke + +Moving the cursor to the left will lower the threshold (move the displayed +curve to the left), and moving the cursor up will increase the contrast +(increase the slope of the transfer function). Ideally window mode would +be entered by pressing a mouse button (or some combination of a mouse button +and a control or shift key), windowing performed with the mouse button held +down, and window mode exited when the mouse button is released. + +.NH 2 +Reading the Cursor + + The image display cursor may be any 64 pixel square object with a shape +which is suitable for centering on two dimensional objects. The default cursor +will be a pair of 64 pixel long crosshairs with a gap in the middle. When a +cursor read is in progress the cursor will blink rapidly, e.g., at 4-8 Hz, +signaling to the user that the program is waiting for a cursor read (this is +like turning on the full crosshairs on the GTERM graphics screen). The cursor +may be moved either with the mouse or with the HJKL keys in cursor mode. +A cursor read will be terminated by typing a key on the keyboard, or by +pressing a mouse button which has been aliased to a key (as in GTERM). + +All cursor input will be via the standard IRAF cursor mode cursor input +facility. The result of an image cursor read will be a line of text identical +to that returned for a graphics cursor read, i.e., containing the cursor +position in world coordinates (image pixel coordinates in this case), the +WCS number, the key typed, and so on. Semi-automatic readout of the image +cursor coordinates may be obtained via the "C" function in cursor mode, +perhaps aliased to a mouse button. + +.NH 2 +Hardcopy Output + + While there will be no snap/crtpict support initially, it will be possible +to get pseudo-greyscale output hardcopy on the laserwriter via menu selection, +as in GTERM, by taking advantage of the greyscale rendering capabilities of +Postscript and the 300 dpi resolution of the laserwriter. It also should be +possible to use :.snap or "=" to get hardcopy output in cursor mode. + +.NH +Features Not Supported + + The prototype display will provide as IRAF callable functions only image +frame buffer i/o, screen clear, viewport control (zoom/pan), and read and write +cursor position. Greyscale windowing, hardcopy output, and window resize and +move will be handled directly by the image display and Sunview, under mouse +control. Initially there will be no access to the graphics overlay, and only +monochrome display will be supported (pseudocolor may be added to the prototype +at some point). Full functionality will follow when the GIO imaging extensions +and IDI interface specification have been completed. + +.NH +Implementation + + The following subsystems need to be added or modified to implement the +prototype SUN/IRAF Sunview image display. +.ls +.ls [1] +The software image display program (new code). This will be implemented as +a Sunview tool (process), to be linked into the "basetools" executable (where +GTERM lives). The image display process (or processes if there are multiple +displays) will communicate with other processes via sockets and/or shared +memory. A special file entry will be required in /dev for each display +pseudo-device. The Sunview server process will normally be set up when the +user's .suntools file is interpreted, but will not be displayed until the +display is first loaded. Commands and data will be passed between the server +process and the client (e.g.,some IRAF process) via the conventional socket +based IPC mechanism and an application defined RPC mechanism. Shared memory +will be used to eliminate pixel i/o to the image frame buffers when the server +resides on the same machine as the client. +.le +.ls [2] +The low level code in the DISPLAY program must be modified to talk with the +display server. For the prototype, this is probably best done using the FIO +based display interface rather than GIO, since the current display program +is written to use FIO. The display task will directly read and write the +display server frame buffer using the Sys V shared memory facilities. The +final interface will do the same (or use a socket if the server is on a remote +machine), but will use the more flexible GIO interface. The DISPLAY task +must also be modified to compute the WCS and output it to the cursor mode +code via GIO, in order for cursor readback to function. +.le +.ls [3] +Cursor mode must be modified to support cursor input from imaging devices. +The principle modification seems to be the addition of a set device viewport +instruction, to be used to pass zoom and pan instructions on to the device +kernel rather than implementing them directly in the cursor mode software as +is done for the STDGRAPH devices. The open / close workstation, activate / +deactivate workstation, clear screen, set cursor, and get cursor functions +are also needed, but need not be different than the equivalent STDGRAPH +functions. +.le +.le + +Cursor mode requires implementation of some portion of a GIO device interface +for the image display. Probably this will be implemented using an inline +kernel, at least for the prototype display. Both the GIO kernel and the +DISPLAY task will communicate directly with the display server via IPC. + +.NH 2 +Display Control Interface + + Applications programs such as the DISPLAY task or the CL cursor mode code +will access the display via IPC carrying a GKI command and data stream. Most +of the GKI instructions used are already provided by the current GIO/GKI +interface. These are summarized below for reference. + + +.ks +.nf + GKI_EOF = BOI 0 L +* GKI_OPENWS = BOI 1 L M N D +* GKI_CLOSEWS = BOI 2 L N D +* GKI_REACTIVATEWS = BOI 3 L +* GKI_DEACTIVATEWS = BOI 4 L +* GKI_MFTITLE = BOI 5 L N T +* GKI_CLEARWS = BOI 6 L + GKI_CANCEL = BOI 7 L + GKI_FLUSH = BOI 8 L + GKI_POLYLINE = BOI 9 L N P + GKI_POLYMARKER = BOI 10 L N P + GKI_TEXT = BOI 11 L P N T + GKI_FILLAREA = BOI 12 L N P +* GKI_PUTCELLARRAY = BOI 13 L LL UR NC NL P +* GKI_SETCURSOR = BOI 14 L CN POS + GKI_PLSET = BOI 15 L LT LW CI + GKI_PMSET = BOI 16 L MT MW CI + GKI_TXSET = BOI 17 L UP SZ SP P HJ VJ F Q CI + GKI_FASET = BOI 18 L FS CI +* GKI_GETCURSOR = BOI 19 L CN + GKI_CURSORVALUE = BOI 19 L CN POS KEY +* GKI_GETCELLARRAY = BOI 20 L LL UR NC NL + GKI_CELLARRAY = BOI 20 L NP P + GKI_ESCAPE = BOI 25 L FN N DC + GKI_SETWCS = BOI 26 L N WCS + GKI_GETWCS = BOI 27 L N +.fi +.ke + + +Those instructions which are required in the prototype interface are marked +with an asterisk. In addition we need a number of new instructions to +perform various common image display control functions. This is the topic +of the GIO imaging extensions project, which we do not wish to attempt to +seriously address in the prototype display. The new GKI instructions outlined +in the remainder of this section are intended only to permit the implementation +of the prototype SUN image display, and will be replaced by a full and much +more carefully defined set of instructions when the full interface is designed. + +A new instruction is needed to set the device viewport, i.e., the portion of +the frame buffer to be displayed in the display window. The set viewport +instructions are used to implement zoom and pan at the cursor level. + + +.ks +.nf + GKI_SETVIEWPORT = BOI 28 L XC YC ZX ZY + GKI_GETVIEWPORT = BOI 29 L XC YC ZX ZY + GKI_VIEWPORT = BOI 29 L XC YC ZX ZY +.fi +.ke + + +The device viewport is specified by the [x,y] center of the displayed area in +frame buffer pixel coordinates (1-indexed), and the zoom or dezoom factor in +each axis. This representation is used, rather than specifying the corner +points of the intended viewport, so that the viewport may be specified +independently of the size of the actual device window used, and to avoid +questions about what happens near the edge of the frame. + +Instructions are also needed to set and inquire the index of the frame +currently being displayed, and the index of the reference frame for the i/o +and control functions; these need not be the same frame. + + +.ks +.nf + GKI_SETFRAME = BOI 30 L RF DF + GKI_GETFRAME = BOI 31 L + GKI_FRAME = BOI 31 L RF DF +.fi +.ke + + +Here, RF is the index of the reference frame, i.e., the frame to be operated +upon or referenced in all set, get, and pixel i/o operations, and DF is the +index of the frame currently being displayed or to be displayed. The frames +are numbered 1, 2, ..., N; 0 indicates that the reference frame or display +frame is not to be changed. + +The concept of the display frame is important in cursor reads. In a cursor +read or write operation, a CN (cursor number) index of 0 indicates that the +cursor of the display frame is to be referenced; the index of the frame +actually referenced will be returned in the CN field of the cursor value +structure. If a nonzero CN is given the cursor of the indicated frame is +referenced, whether or not the indicated reference frame is currently +displayed. + +Lastly, we need an inquiry function to determine the size and depth of the +image frame buffer, and the number of image planes. It is assumed that the +frame buffer size, etc., will be set up in advance by the user, either using +the mouse and the display setup panel, or via command line arguments in the +.suntools file when the display server is initially spawned. + + +.ks +.nf + GKI_GETFRAMESIZE = BOI 32 L + GKI_FRAMESIZE = BOI 32 L NP NX NY NZ +.fi +.ke + + +Here, NP is the number of image planes, NX and NY are the size in pixels of +each image plane, and NZ is the number of displayable greylevels, e.g., 256. +Note that NZ need not be a power of two as the entire colortable may not be +available. + +The image display will be a standard GIO (inline or sub) kernel down to the +level where some action occurs, after decoding the i/o instruction to be +executed. At that point a device dependent C subroutine will be called which +will pass the command on to the display server, which will always reside in a +separate process (it has to, due to the peculiar notifier based nature of the +Sunview environment). + +.NH 2 +Display Internals + + The primary functions of the display server are [1] to maintain a frame +buffer, and respond to requests to display portions of the frame buffer in the +display window at some zoom or dezoom factor, and [2] to read and execute +commands from a client process. + +Case [1] includes both refresh of the primary window, which occurs whenever a +new image is loaded, the device viewport changes, or the window is resized or +uncovered, and refresh of the region of interest (cursor) window, which occurs +whenever any of the above events occurs or whenever the cursor is moved. +In fact it appears that both operations are really the same thing, except that +the cursor window always hides the main window, has a narrower border and no +label, and is refreshed more often than the main window. The refresh operation +sets up a mapping between the frame buffer and a window and then either does +a series of pixrect operations to refresh the window (which may be partially +or fully covered), or carries out a resampling operation on a region of the +frame buffer, writing the zoomed or dezoomed data to the display window. + +The commands to be executed in case [2] are the GKI functions described in the +previous section. In the prototype display the primary commands are open / +close workstation, set viewport, set cursor position, and read cursor. +The set viewport function merely sets up a transformation and calls the +window refresh code described in the previous paragraph. diff --git a/unix/sun/Makefile b/unix/sun/Makefile new file mode 100644 index 00000000..029b957e --- /dev/null +++ b/unix/sun/Makefile @@ -0,0 +1,67 @@ +# Make the Sunview GTERM graphics terminal server, IMTOOL image display server. + +SRCS= arrow.c mouse.c notify_read.c screendump.c +OBJS= arrow.o mouse.o notify_read.o screendump.o +LIBS= -lsuntool -lsunwindow -lpixrect -lm +SUNOBJS= imtool.o gterm.o gtermio.o screendump.o arrow.o mouse.o notify_read.o + +# Set the following to "-f68881" on a Sun-3, to "" on a Sun-4 or 386i. +#FLOAT= -f68881 +FLOAT= + +# Make the custom suntools executable only on versions of SunOS prior to 4.0. +default: + sh -c 'if [ "`grep Release.4 /etc/motd`" != ""\ + -o `mach` = "i386" ]; then\ + make gterm.e; make imtool.e;\ + else\ + make suntools.e;\ + fi' + +# Make a custom SUNTOOLS with GTERM, IMTOOL, linked in. +suntools.e: gterm.c imtool.c gtermio.o $(OBJS) + chmod +x mksuntool.csh; mksuntool.csh + cc -c -O $(FLOAT) gterm.c imtool.c + mv -f gterm.o imtool.o suntool + cp gtermio.o $(OBJS) suntool + (cd ./suntool; make basetools MOREOBJS="$(SUNOBJS)" CPUFLAG="" ;\ + mv -f suntools ../suntools.e) + +# Make the GTERM test executable. +gterm.e: gterm.o gtermio.o $(OBJS) + cc $(FLOAT) gterm.o gtermio.o $(OBJS) $(LIBS) -o gterm.e + +# Make the IMTOOL test executable. +imtool.e: imtool.o $(OBJS) + cc $(FLOAT) imtool.o $(OBJS) $(LIBS) -o imtool.e + +# Install the executables in iraf$local, which is where the INSTALL script +# expects to find it. + +install: + strip *.e; mv -f *.e $$iraf/unix/bin.`mach` + +clean: + rm -f *.[aoe] + rm -rf suntool + +gterm.o: gterm.c gterm.h gterm.icon + cc -c -O -DSTANDALONE $(FLOAT) gterm.c + +imtool.o: imtool.c imtool.h imtool.icon imtool.cursor + cc -c -O -DSTANDALONE $(FLOAT) imtool.c + +gtermio.o: gtermio.c gterm.h gterm.esc + cc -c -O $(FLOAT) gtermio.c + +arrow.o: arrow.c + cc -c -O $(FLOAT) arrow.c + +mouse.o: mouse.c + cc -c -O $(FLOAT) mouse.c + +notify_read.o: notify_read.c + cc -c -O $(FLOAT) notify_read.c + +screendump.o: screendump.c + cc -c -O $(FLOAT) screendump.c diff --git a/unix/sun/README b/unix/sun/README new file mode 100644 index 00000000..4196b336 --- /dev/null +++ b/unix/sun/README @@ -0,0 +1,5 @@ +GTERM -- Graphics terminal emulator. +IMTOOL -- Image display server. + +See gterm.man, imtool.man for detailed documentation. +This software is installed by the $iraf/unix/hlib/install script. diff --git a/unix/sun/arrow.c b/unix/sun/arrow.c new file mode 100644 index 00000000..1cc55aad --- /dev/null +++ b/unix/sun/arrow.c @@ -0,0 +1,66 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include + +/* + * ARROW.C -- Code to enable and disable the arrow key function-key mappings + * (R8,10,12,14). + */ + +#define NKEYS 4 +static unsigned char station[NKEYS] = { 0x45, 0x5b, 0x5d, 0x71 }; +static unsigned char entry[NKEYS] = { RF(8), RF(10), RF(12), RF(14) }; +static struct kiockey o_key[NKEYS]; + + +/* DISABLE_ARROW_KEYS -- Save the arrow key keyboard translation table + * entries, and then disable the mapping of the function keys to the ANSI + * arrow key sequences. This is necessary to read the function key as + * an event rather than an escape sequence in a Sunview event handler. + */ +disable_arrow_keys() +{ + register int fd, i; + struct kiockey key; + int status = 0; + + if ((fd = open ("/dev/kbd", 2)) == -1) + return (-1); + + for (i=0; i < NKEYS; i++) { + o_key[i].kio_station = station[i]; + if ((status = ioctl (fd, KIOCGETKEY, &o_key[i])) != 0) + break; + key = o_key[i]; + key.kio_entry = entry[i]; + if ((status = ioctl (fd, KIOCSETKEY, &key)) != 0) + break; + } + + close (fd); + return (status); +} + + +/* ENABLE_ARROW_KEYS -- Restore the saved arrow key keyboard translation table + * entries. + */ +enable_arrow_keys() +{ + register int fd, i; + struct kiockey key; + int status = 0; + + if ((fd = open ("/dev/kbd", 2)) == -1) + return (-1); + + for (i=0; i < NKEYS; i++) + if ((status = ioctl (fd, KIOCSETKEY, &o_key[i])) != 0) + break; + + close (fd); + return (status); +} diff --git a/unix/sun/fifo.c b/unix/sun/fifo.c new file mode 100644 index 00000000..65471a77 --- /dev/null +++ b/unix/sun/fifo.c @@ -0,0 +1,759 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include + +#define SUNOS4 + +/* + * FIFO.C -- Test fifo i/o. This is a server process much like IMTOOL, + * except that all the process does is respond to datastream requests + * to read and write an internal 512 sq frame buffer maintained as an + * array in memory (only one frame buffer is supported). A log is kept + * to the stderr of all datastream requests. + * + * Used to debug fifo i/o - NOT USED IN THE ONLINE PROGRAMS. + * + * To make: cc fifo.c -o fifo.e + * + * Usage: fifo.e >& spool run server, logging output to spool + * fifo.e -i run interactively + * + * In interactive mode, cursor value strings may be typed in on the fifo.e + * stdin in response to cursor read requests from the client. Otherwise, + * a constant cursor value "1.0 1.0 101 q" is returned. + */ + +#define I_DEVNAME "/dev/imt1o" +#define O_DEVNAME "/dev/imt1i" +#define OLD_DEVNAME "/dev/imt1" +#define IO_TIMEOUT 30 +#define SZ_FIFOBUF 4000 +#define SZ_WCSBUF 320 /* WCS text buffer size */ +#define MAX_FRAMES 1 +#define SZ_FNAME 256 + +#define MEMORY 01 /* frame buffer i/o */ +#define LUT 02 /* lut i/o */ +#define FEEDBACK 05 /* used for frame clears */ +#define IMCURSOR 020 /* logical image cursor */ +#define WCS 021 /* used to set WCS */ + +#define SZ_IMCURVAL 160 +#define PACKED 0040000 +#define COMMAND 0100000 +#define IIS_READ 0100000 +#define IMC_SAMPLE 0040000 +#define IMT_FBCONFIG 077 + +struct iism70 { + short tid; + short thingct; + short subunit; + short checksum; + short x, y, z; + short t; +}; + +#ifndef abs +#define abs(a) (((a)<0)?(-a):(a)) +#endif + +#ifndef min +#define min(a,b) ((a)<(b)?(a):(b)) +#endif +#ifndef max +#define max(a,b) ((a)<(b)?(b):(a)) +#endif + +static int interactive=0; +static int background=0; +static int datain, dataout=0; +static char framebuf[512*512]; +static int frame=1, reference_frame=1, display_frame=1; +static int fb_config_index=1, fb_nframes=1; +static int Fb_width = 512, Fb_height = 512; +static char wcsbuf[MAX_FRAMES][SZ_WCSBUF]; + + +/* FIFO -- Text fifo i/o. + */ +main (argc, argv) +int argc; +char **argv; +{ + fd_set fds; + + if (argc > 1) + if (strcmp (argv[1], "-i") == 0) + interactive++; /* type in cursor values */ + + /* Open the output fifo. We have to open it ourselves first as a + * client to get around the fifo open-no-client error. + */ + if ((datain = open (O_DEVNAME, O_RDONLY|O_NDELAY)) != -1) { + if ((dataout = open (O_DEVNAME, O_WRONLY|O_NDELAY)) != -1) + fcntl (dataout, F_SETFL, O_WRONLY); + close (datain); + } + + /* Open the input stream, a FIFO pseudodevice file used by + * applications to send us commands and data. + */ + if ((datain = open (I_DEVNAME, O_RDONLY|O_NDELAY)) == -1) { + if ((datain = open (OLD_DEVNAME, O_RDONLY|O_NDELAY)) == -1) + fprintf (stderr, "Warning: cannot open %s\n", I_DEVNAME); + } else { + /* Clear O_NDELAY for reading. */ + fcntl (datain, F_SETFL, O_RDONLY); + } + + FD_ZERO (&fds); FD_SET (datain, &fds); + while (select (FD_SETSIZE, &fds, NULL, NULL, NULL) > 0) { + ev_cmdinput(); + fflush (stdout); + fflush (stderr); + FD_ZERO (&fds); FD_SET (datain, &fds); + } + + close (datain); + exit (0); +} + + +/* EV_CMDINPUT -- Called when command or data input has arrived via the + * pseudodevice input stream from some applications process. + */ +ev_cmdinput() +{ + register unsigned char *cp; + register int sum, i; + register short *p; + int ndatabytes, nbytes, n, ntrys=0; + static int errmsg=0, bswap=0; + struct iism70 iis; + char buf[SZ_FIFOBUF]; + int fb_index; + + /* Get the IIS header. */ + if (read (datain, (char *)&iis, sizeof(iis)) < sizeof(iis)) { + fprintf (stderr, "imtool: command input read error\n"); + fflush (stderr); + return (0); + } else if (bswap) + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + + /* Verify the checksum. If it fails swap the bytes and try again. + */ + for (;;) { + for (i=0, sum=0, p=(short *)&iis; i < 8; i++) + sum += *p++; + if ((sum & 0177777) == 0177777) + break; + + if (ntrys++) { + if (!errmsg++) { + fprintf (stderr, "imtool: bad data header checksum\n"); + fflush (stderr); + if (bswap) + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + fprintf (stderr, "noswap:"); + for (i=0, p=(short *)&iis; i < 8; i++) + fprintf (stderr, " %6o", p[i]); + fprintf (stderr, "\n"); + + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + fprintf (stderr, " swap:"); + for (i=0, p=(short *)&iis; i < 8; i++) + fprintf (stderr, " %6o", p[i]); + fprintf (stderr, "\n"); + fflush (stderr); + } + break; + + } else { + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + bswap = !bswap; + } + } + + ndatabytes = -iis.thingct; + if (!(iis.tid & PACKED)) + ndatabytes *= 2; + + /* Log command. */ + fprintf (stderr, + "subunit=%06o tid=%06o nbytes=%7d x=%06o y=%06o z=%06o\n", + iis.subunit & 077, + iis.tid, + ndatabytes, + iis.x & 0177777, + iis.y & 0177777, + iis.z & 0177777); + fflush (stderr); + + switch (iis.subunit & 077) { + case FEEDBACK: + /* The feedback unit is used only to clear a frame. + */ + set_reference_frame (decode_frameno (iis.z & 07777)); + /* erase (rf_p); */ + fprintf (stderr, "erase frame %d\n", reference_frame); + break; + + case LUT: + /* Data mode writes to the frame lookup tables are not implemented. + * A command mode write to the LUT subunit is used to connect + * image memories up to the RGB channels, i.e., to select the frame + * to be displayed. We ignore any attempt to assign multiple + * frames to multiple color channels, and just do a simple frame + * select. + */ + if (iis.subunit & COMMAND) { + int frame, z, n; + short x[14]; + + if (read (datain, (char *)x, ndatabytes) == ndatabytes) { + if (bswap) + bswap2 ((char *)x, (char *)x, ndatabytes); + + z = x[0]; + if (!z) z = 1; + for (n=0; !(z & 1); z >>= 1) + n++; + + frame = max (1, n + 1); + if (frame > fb_nframes) { + if (frame < MAX_FRAMES) { + /* set_fbconfig (fb_config_index, frame); */ + fprintf (stderr, "set_fbconfig (%d, %d)\n", + fb_config_index, frame); + } else { + fprintf (stderr, "imtool warning: "); + fprintf (stderr, + "attempt to display nonexistent frame %d\n", frame); + frame = fb_nframes - 1; + } + } + + /* set_frame (frame); */ + fprintf (stderr, "set_frame (%d)\n", frame); + return (0); + } + } + + case MEMORY: + /* Load data into the frame buffer. Data is assumed to be byte + * packed. + */ + if (iis.tid & IIS_READ) { + /* Read from the display. + */ + unsigned char *fb, *ip; + int nbytes, nleft, n, x, y; + long starttime; + + /* Get the frame to be read from. */ + set_reference_frame (decode_frameno (iis.z & 07777)); + + fb = (unsigned char *)framebuf; + nbytes = ndatabytes; + x = iis.x & 01777; + y = iis.y & 01777; + + ip = max (fb, min (fb + Fb_width * Fb_height - nbytes, + fb + y * Fb_width + x)); + if (ip != fb + y * Fb_width + x) { + fprintf (stderr, + "imtool: attempted read out of bounds on framebuf\n"); + fprintf (stderr, + "read %d bytes at [%d,%d]\n", nbytes, x, y); + } + + /* Log i/o command. */ + fprintf (stderr, "read %d bytes at x=%d, y=%d\n", + nbytes, x, y); + + /* Return the data from the frame buffer. */ + starttime = time(0); + for (nleft = nbytes; nleft > 0; nleft -= n) { + n = (nleft < SZ_FIFOBUF) ? nleft : SZ_FIFOBUF; + if ((n = write (dataout, ip, n)) <= 0) { + if (n < 0 || (time(0) - starttime > IO_TIMEOUT)) { + fprintf (stderr, "IMTOOL: timeout on write\n"); + break; + } + } else + ip += n; + } + + return (0); + + } else { + /* Write to the display. + */ + unsigned char *fb, *op; + int nbytes, nleft, n, x, y; + long starttime; + + /* Get the frame to be written into (encoded with a bit for + * each frame, 01 is frame 1, 02 is frame 2, 04 is frame 3, + * and so on). + */ + set_reference_frame (decode_frameno (iis.z & 07777)); + + /* Get a pointer into the frame buffer where the data will + * be put. + */ + fb = (unsigned char *)framebuf; + nbytes = ndatabytes; + x = iis.x & 07777; + y = iis.y & 07777; + + op = max (fb, min (fb + Fb_width * Fb_height - nbytes, + fb + y * Fb_width + x)); + if (op != fb + y * Fb_width + x) { + fprintf (stderr, + "imtool: attempted write out of bounds on framebuf\n"); + fprintf (stderr, + "write %d bytes to [%d,%d]\n", nbytes, x, y); + } + + /* Log i/o command. */ + fprintf (stderr, "write %d bytes at x=%d, y=%d\n", + nbytes, x, y); + + /* Read the data into the frame buffer. + */ + starttime = time(0); + for (nleft = nbytes; nleft > 0; nleft -= n) { + n = (nleft < SZ_FIFOBUF) ? nleft : SZ_FIFOBUF; + if ((n = read (datain, op, n)) <= 0) { + if (n < 0 || (time(0) - starttime > IO_TIMEOUT)) + break; + } else { + /* Set any zeroed pixels to the background color, + * if a special background color is specified. + */ + if (background) + for (cp=op, i=n; --i >= 0; cp++) + if (!*cp) + *cp = background; + op += n; + } + } + + /* Refresh the display, if the current display frame is the + * same as the reference frame. + if (rf_p == df_p) { + BRect fb_r, pw_r; + + fb_r.r_left = x * zoom; + fb_r.r_top = y * zoom; + fb_r.r_width = min (nbytes * zoom, fb_width); + fb_r.r_height = ((nbytes*zoom*zoom + fb_width-1)/fb_width); + + Bpw_get_region_rect (gio_pw, &pw_rect); + Bpw_lock (gio_pw, &pw_rect); + + pw_rect.r_left = df_p->fb_xoff; + pw_rect.r_top = df_p->fb_yoff; + + if (maprect (&fb_rect, &fb_r, &pw_rect, &pw_r)) + if (maprect (&pw_rect, &pw_r, &fb_rect, &fb_r)) { + ds_write (gio_pw, + pw_r.r_left, pw_r.r_top, + pw_r.r_width, pw_r.r_height, + PIX_SRC | PIX_COLOR(NGREY-1), + df_p->fb_pr, fb_r.r_left, fb_r.r_top); + + if (pw_r.r_top + pw_r.r_height >= pw_rect.r_height + - cb_height) + put_colorbar(); + } + + Bpw_unlock (gio_pw); + } + */ + + return (0); + } + break; + + case WCS: + /* Read or write the WCS for a frame. The frame number to + * which the WCS applies is passed in Z and the frame buffer + * configuration in T. The client changes the frame buffer + * configuration in a WCS set. The WCS text follows the header + * as byte packed ASCII data. + */ + if (iis.tid & IIS_READ) { + /* Return the WCS for the referenced frame. + */ + register char *op; + register int n; + char emsg[SZ_WCSBUF]; + char *text; + int frame; + + for (op=emsg, n=SZ_WCSBUF; --n >=0; ) + *op++ = 0; + + frame = decode_frameno (iis.z & 07777); + if (frame > fb_nframes) + strcpy (text=emsg, "[NOSUCHFRAME]\n"); + else { + set_reference_frame (frame); + text = wcsbuf[reference_frame-1]; + } + + fprintf (stderr, "query wcs:\n"); + write (2, text, SZ_WCSBUF); + + write (dataout, text, SZ_WCSBUF); + + } else { + /* Set the WCS for the referenced frame. + */ + char buf[1024]; + int fb_config, frame; + + frame = decode_frameno (iis.z & 07777); + if (frame > fb_nframes) + if (frame < MAX_FRAMES) { + /* set_fbconfig (fb_config_index, frame); */ + fprintf (stderr, "set_fbconfig (%d, %d)\n", + fb_config_index, frame); + } + + set_reference_frame (frame); + if ((fb_config = iis.t & 077) != fb_config_index) { + /* set_fbconfig (fb_config_index, frame); */ + fprintf (stderr, "set_fbconfig (%d, %d)\n", + fb_config_index, frame); + } + + /* Read in and set up the WCS. */ + if (read (datain, buf, ndatabytes) == ndatabytes) + strncpy (wcsbuf[reference_frame-1], buf, SZ_WCSBUF); + + fprintf (stderr, "set wcs:\n"); + write (2, buf, SZ_WCSBUF); + + /* + strcpy (rf_p->fb_ctran.format, W_DEFFORMAT); + rf_p->fb_ctran.imtitle[0] = '\0'; + rf_p->fb_ctran.valid = 0; + rf_p->fb_imageno++; + rf_p->fb_objno = 1; + + wcs_update (rf_p); + if (rf_p == df_p) + window_set (gio_frame, FRAME_LABEL, framelabel(), 0); + */ + } + + return (0); + break; + + case IMCURSOR: + /* Read or write the logical image cursor. This is an extension + * added to provide a high level cursor read facility; this is + * not the same as a low level access to the IIS cursor subunit. + * Cursor reads may be either nonblocking (immediate) or blocking, + * using the keyboard or mouse to terminate the read, and + * coordinates may be returned in either image (world) or frame + * buffer pixel coordinates. + */ + if (iis.tid & IIS_READ) { + /* Read the logical image cursor. In the case of a blocking + * read all we do is initiate a cursor read; completion occurs + * when the user hits a key or button. + */ + fprintf (stderr, "read cursor position\n"); + if (iis.tid & IMC_SAMPLE) { + /* Sample the cursor position. */ + /* + register struct ctran *ct; + int wcs = iis.z; + int sx, sy; + float wx, wy; + + wx = sx = last_x + pw_rect.r_left; + wy = sy = last_y + pw_rect.r_top; + + if (wcs) { + ct = wcs_update (df_p); + if (ct->valid) { + if (abs(ct->a) > .001) + wx = ct->a * sx + ct->c * sy + ct->tx; + if (abs(ct->d) > .001) + wy = ct->b * sx + ct->d * sy + ct->ty; + } + } + */ + + int wcs = iis.z, key = 'q'; + float wx=1.0, wy=1.0; + + /* Return the cursor value on the output datastream encoded + * in a fixed size ascii buffer. + */ + gio_retcursorval (wx, wy, display_frame*100+wcs, key, ""); + + } else { + /* Initiate a user triggered cursor read. */ + /* gio_readcursor (iis.z); */ + int wcs = iis.z, key = 'q'; + float wx=1.0, wy=1.0; + gio_retcursorval (wx, wy, display_frame*100+wcs, key, ""); + } + + } else { + /* Write (set) the logical image cursor position. */ + /* + fprintf (stderr, "write cursor position\n"); + register struct ctran *ct; + int sx = iis.x, sy = iis.y; + float wx = sx, wy = sy; + int wcs = iis.z; + + if (wcs) { + ct = wcs_update (df_p); + if (ct->valid) { + if (abs(ct->a) > .001) + sx = (wx - ct->tx) / ct->a; + if (abs(ct->d) > .001) + sy = (wy - ct->ty) / ct->d; + } + } + + gio_setcursorpos (sx - pw_rect.r_left, sy - pw_rect.r_top); + */ + } + + return (0); + break; + + default: + /* Ignore unsupported command input. + */ + break; + } + + /* Discard any data following the header. */ + if (!(iis.tid & IIS_READ)) + for (nbytes = ndatabytes; nbytes > 0; nbytes -= n) { + n = (nbytes < SZ_FIFOBUF) ? nbytes : SZ_FIFOBUF; + if ((n = read (datain, buf, n)) <= 0) + break; + } + + fflush (stderr); + return (0); +} + + +/* SET_REFERENCE_FRAME -- Set reference frame. If the frame referenced is + * greater than the current number of frames, attempt to increase the number + * of frames. + */ +static +set_reference_frame (n) +register int n; +{ + reference_frame = max (1, n); + if (reference_frame > fb_nframes) { + if (reference_frame < MAX_FRAMES) { + /* set_fbconfig (fb_config_index, reference_frame); */ + fprintf (stderr, "set_fbconfig %d %d\n", + fb_config_index, reference_frame); + } else { + fprintf (stderr, "imtool warning: "); + fprintf (stderr, + "attempt to reference nonexistent frame %d\n", + reference_frame); + reference_frame = fb_nframes; + } + } + + /* rf_p = frames + (reference_frame - 1); */ +} + + +/* DECODE_FRAMENO -- Decode encoded IIS register frame number. + */ +static +decode_frameno (z) +register int z; +{ + register int n; + + /* Get the frame number, encoded with a bit for each frame, 01 is + * frame 1, 02 is frame 2, 04 is frame 3, and so on. + */ + if (!z) z = 1; + for (n=0; !(z & 1); z >>= 1) + n++; + + return (max (1, n + 1)); +} + + +/* BSWAP2 - Move bytes from array "a" to array "b", swapping successive + * pairs of bytes. The two arrays may be the same but may not be offset + * and overlapping. + */ +static +bswap2 (a, b, nbytes) +char *a, *b; /* input array */ +int nbytes; /* number of bytes to swap */ +{ + register char *ip=a, *op=b, *otop; + register unsigned temp; + + /* Swap successive pairs of bytes. + */ + for (otop = op + (nbytes & ~1); op < otop; ) { + temp = *ip++; + *op++ = *ip++; + *op++ = temp; + } + + /* If there is an odd byte left, move it to the output array. + */ + if (nbytes & 1) + *op = *ip; +} + + +/* GIO_RETCURSORVAL -- Return the cursor value on the output datastream to + * the client which requested the cursor read. + */ +static +gio_retcursorval (wx, wy, wcs, key, strval) +float wx, wy; /* cursor coordinates */ +int wcs; /* encoded WCS value */ +int key; /* keystroke used as trigger */ +char *strval; /* optional string value */ +{ + register char *op; + register int n; + char curval[SZ_IMCURVAL]; + char keystr[20]; + + for (op=curval, n=SZ_IMCURVAL; --n >=0; ) + *op++ = 0; + + /* If running FIFO in interactive mode, allow the user to type + * in the cursor value on the standard input. + */ + if (interactive) { + fprintf (stderr, "enter cursor value string: "); + fflush (stderr); + if (fgets (curval, SZ_IMCURVAL, stdin) != NULL) + goto ret; + } + + /* Encode the cursor value. */ + if (key == EOF) + sprintf (curval, "EOF\n"); + else { + if (isprint (key) && !isspace(key)) { + keystr[0] = key; + keystr[1] = '\0'; + } else + sprintf (keystr, "\\%03o", key); + + sprintf (curval, "%10.3f %10.3f %d %s %s\n", + wx, wy, wcs, keystr, strval); + } +ret: + fprintf (stderr, "%s", curval); + + /* Send it to the client program. */ + write (dataout, curval, sizeof(curval)); +} + + +#define mask(s) (1<<((s)-1)) +#define setvec(vec, a) \ + vec.sv_handler = a; vec.sv_mask = vec.sv_onstack = 0 + +static int ringring; + + +/* WMSEC -- Suspend task execution (sleep) for the specified number + * of milliseconds. + */ +wmsec (msec) +int msec; +{ + struct itimerval itv, oitv; + register struct itimerval *itp = &itv; + struct sigvec vec, ovec; +#ifdef SUNOS4 + void napmsx(); +#else + int napmsx(); +#endif + int omask; + + if (msec == 0) + return; + + timerclear (&itp->it_interval); + timerclear (&itp->it_value); + if (setitimer (ITIMER_REAL, itp, &oitv) < 0) + return; + + setvec (ovec, SIG_DFL); + omask = sigblock(0); + + itp->it_value.tv_usec = (msec * 1000) % 1000000; + itp->it_value.tv_sec = (msec * 1000) / 1000000; + + if (timerisset (&oitv.it_value)) { + if (timercmp(&oitv.it_value, &itp->it_value, >)) + oitv.it_value.tv_sec -= itp->it_value.tv_sec; + else { + itp->it_value = oitv.it_value; + /* This is a hack, but we must have time to + * return from the setitimer after the alarm + * or else it'll be restarted. And, anyway, + * sleep never did anything more than this before. + */ + oitv.it_value.tv_sec = 1; + oitv.it_value.tv_usec = 0; + } + } + + setvec (vec, napmsx); + (void) sigvec (SIGALRM, &vec, &ovec); + ringring = 0; + (void) setitimer (ITIMER_REAL, itp, (struct itimerval *)0); + + while (!ringring) + sigpause (omask &~ mask(SIGALRM)); + + (void) sigvec (SIGALRM, &ovec, (struct sigvec *)0); + (void) setitimer (ITIMER_REAL, &oitv, (struct itimerval *)0); +} + + +#ifdef SUNOS4 +static void +#else +static int +#endif +napmsx() +{ + ringring = 1; +} diff --git a/unix/sun/gterm.c b/unix/sun/gterm.c new file mode 100644 index 00000000..57c4eb43 --- /dev/null +++ b/unix/sun/gterm.c @@ -0,0 +1,1984 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "gterm.h" + +/* + * GTERM -- Graphics terminal emulator. This code implements a virtual + * graphics terminal consisting of independent text and graphics frames. + * The text (tty) frame is a standard Sun TTY frame. The graphics (gio) + * frame is a tektronix 4012 with extensions, some of which are patterned + * after the Retrographics vt100, Pericom, etc., and others of which are or + * will be added to provide GKS like capabilities via a conventional data + * driven graphics terminal interface. The tty and gio frames are independent + * frames under Sunview, hence they may be resized, moved, opened or closed, + * hidden or exposed, etc., independently of each other. Both frames are + * active at all times, but since a single terminal i/o stream is used to + * drive both frames an applications program can communicate with only one + * frame at a time, just like a conventional graphics terminal. + * + * D.Tody, January 1987 (NOAO/IRAF project) + */ + +#define MAX_ARGS 50 /* max tty or gio cmdline args */ +#define DEF_TEKXRES 1024 /* default logical X resolution */ +#define DEF_TEKYRES 780 /* default logical Y resolution */ + +#define NO_ACTION 0 /* no action on open/close ws */ +#define SHOW_FRAME 1 /* show or unshow gio frame */ +#define UNSHOW_FRAME 1 /* show or unshow gio frame */ +#define EXPOSE_FRAME 2 /* expose or hide gio frame */ +#define HIDE_FRAME 2 /* expose or hide gio frame */ +#define CROSSHAIR_OFF 1 /* crosshair cursor off */ +#define CROSSHAIR_ON 2 /* turn crosshair cursor on */ +#define SZ_LOGBUF 1024 /* size of logfile buffer */ +#define SZ_GINMODETERM 10 /* ginmode string length */ +#define SZ_FNAME 128 + +#define R_TYPE 0 /* 0=postscript, 1=rasterfile */ +#define R_DISPOSE "lpr -s %s" /* dispose command */ +#define R_FILENAME "" /* output filename */ + +/* External variables. */ +extern int gio_graphicsenabled; /* set when in graphics mdoe */ +int cursor_show = -1; /* cursor state: on or off */ +Window gt_baseframe, gt_ttysw, gio_frame, gio_canvas; +FILE *gt_logfp = NULL; /* logfile file pointer */ + +/* Screendump stuff. */ +int r_type = R_TYPE; +char r_dispose[SZ_FNAME+1] = R_DISPOSE; +char r_filename[SZ_FNAME+1] = R_FILENAME; + +/* Both external and a user option. */ +int clip_graphics = 1; /* disable rasterop clipping */ + +/* User options. */ +static int graphics_enable; /* enable graphics plane */ +static int openws_action; /* default action on openws */ +static int closews_action; /* default action on closews */ +static int closews_pause; /* pause/confirm closews? */ +static int canvas_retained; /* retain the canvas pixwin? */ +static int reverse_video; /* normal or reverse video */ +static int color; /* color or monochrome graphics */ +static int win_xsize; /* standard size graphics frame */ +static int win_ysize; +static int win_xoff; /* standard offset from tty fr. */ +static int win_yoff; +static int ignore; /* ignore suspend/stop codes? */ +static char gin_modeterm[SZ_GINMODETERM+1]; +static char logfile[SZ_FNAME+1] = "gterm.out"; + +/* The following are used to save and later restore the option parameters. */ +static int s_clip_graphics = 1; +static int s_graphics_enable = GRAPHICS_ON; +static int s_openws_action = SHOW_FRAME; +static int s_closews_action= HIDE_FRAME; +static int s_closews_pause = 0; +static int s_canvas_retained = 1; +static int s_reverse_video = 0; +static int s_color = 1; +static int s_win_xsize = 800; +static int s_win_ysize = 630; +static int s_win_xoff = 100; +static int s_win_yoff = 19; +static int s_ignore = 0; +static char s_gin_modeterm[SZ_GINMODETERM] = "015"; + +/* Internal state variables. */ +static int cursor_type = -1; /* crosshair or small cursor */ +static int cursor_read_pending=0; /* waiting for cursor event */ +static int key_left = 0; /* key aliased to left msbutton */ +static int key_middle = 0; /* key aliased to mid msbutton */ +static int key_right = 0; /* key aliased to mid msbutton */ +static int last_key = 0; /* last cursor read key */ +static int last_x= -1,last_y= -1; /* last cursor read position */ +static int pause_mode = 0; /* waiting for closews event */ +static int cursor_used = 0; /* set if cursor is used */ +static int gio_frame_has_moved=0; /* set when user moves giowin */ +static int setup_xoff = 140; /* offset to setup panel */ +static int setup_yoff = 60; +static int tty_lastx, tty_lasty; /* cursor position in gt_ttysw */ +static int height_is_set = 0; /* tty w. height set on cmdline */ +static int tty_nlines = 0; /* number of lines in tty w. */ +static int shell = 0; /* we are running a shell */ +static char t_suspc, t_dsuspc, t_set=0; + +/* The following is a kludge and should be determined at runtime */ +static int pty_fd = 3; /* fd of tty pseudoterminal */ + +/* Graphics fonts. */ +static char fb_courier[] = "/usr/lib/fonts/fixedwidthfonts/cour.b.%d"; +static char fr_courier[] = "/usr/lib/fonts/fixedwidthfonts/cour.r.%d"; +static char fr_screen[] = "/usr/lib/fonts/fixedwidthfonts/screen.r.%d"; +static char fb_screen[] = "/usr/lib/fonts/fixedwidthfonts/screen.b.%d"; + +#define FULLSCREEN 5 +struct fonttab alpha_fonts[] = { + 10, 7, 12, 560, 420, NULL, fb_courier, "10:[560x420]", + 12, 8, 14, 640, 490, NULL, fb_courier, "12:[640x490]", + 14, 9, 16, 720, 560, NULL, fb_courier, "14:[720x560]", + 16, 10, 18, 800, 630, NULL, fb_courier, "16:[800x630]", + 18, 11, 19, 880, 665, NULL, fb_courier, "18:[880x665]", + 24, 14, 25, 1142, 890, NULL, fb_courier, "24:fullscreen", + /* Note nentries must match panel choice list */ + 0, 0, 0, 0, 0, NULL, NULL, NULL +}; + +struct fonttab text_fonts[] = { + 11, 7, 11, 560, 0, NULL, fr_screen, "screen.r.11", + 12, 8, 14, 640, 0, NULL, fb_screen, "screen.b.12", + 14, 9, 16, 720, 0, NULL, fb_screen, "screen.b.14", + 16, 10, 18, 800, 0, NULL, fb_courier, "courier.b.16", + 18, 11, 19, 880, 0, NULL, fb_courier, "courier.b.18", + 24, 14, 25, 1142, 0, NULL, fb_courier, "courier.b.24", + /* Note nentries must match panel choice list */ + 0, 0, 0, 0, 0, NULL, NULL, NULL +}; + +#define DEF_TEXTFONT 4 +static int alpha_font_index; +static int text_font_index = DEF_TEXTFONT; +static struct fonttab *alpha_font = NULL; +static struct fonttab *text_font = NULL; + +#define SWAP(a,b) {int temp; temp=a;a=b;b=temp;} +#define HEIGHTADJUST \ + (tool_headerheight((int)window_get(gt_baseframe, FRAME_SHOW_LABEL)) + \ + TOOL_BORDERWIDTH) + +static short iconimage[] = { +#include "gterm.icon" +}; +DEFINE_ICON_FROM_IMAGE (icon, iconimage); + +static int main_argc, tty_argc, gio_argc; +static char **main_argv, *tty_argv[MAX_ARGS], *gio_argv[MAX_ARGS]; +static unsigned char red[2] = { 0, 255 }; +static unsigned char green[2] = { 0, 255 }; +static unsigned char blue[2] = { 128, 0 }; + +static Menu_item logitem; +static struct rect screen; +static struct pixwin *pw; +static Panel setup_panel, pause_panel; +static Window setup_frame, pause_frame; +static Notify_value ev_gt_ttysw(); +static Notify_value ev_ttyframe(); +static Notify_value ev_gioframe(); +static Notify_value ev_gioinput(); +static Notify_func sig_tstp(); +static tty_adjustheight(); +extern char *getenv(); + + +/* GTERM_MAIN -- Create the graphics terminal window tree, i.e., the panel + * subwindow and tty subwindow, the gio subframe canvas in which graphics + * will be drawn, and the setup popup which is used to set the terminal + * options. Only the panel and tty (text) window is shown initially; this + * is functionally equivalent to a shelltool window with all the same command + * line arguments. Additional command line arguments are recognized for + * initialization of the graphics frame. + */ +#ifdef STANDALONE +main (argc, argv) +#else +gterm_main (argc, argv) +#endif +int argc; +char **argv; +{ + char *s; + + /* Set user settable options to their initial compiled in values. */ + restore_params(); + + main_argc = argc; + main_argv = argv; + parse_args (argc, argv, &tty_argc, tty_argv, &gio_argc, gio_argv); + + /* Screendump stuff. */ + if (s = getenv ("R_DISPOSE")) + strcpy (r_dispose, s); + if (s = getenv ("R_FILENAME")) + strcpy (r_filename, s); + if (s = getenv ("R_RASTERFILE")) { + strcpy (r_filename, s); + r_type = 1; + } + + /* Create the base frame for all the GTERM windows. */ + gt_baseframe = window_create (NULL, FRAME, + FRAME_ICON, &icon, + FRAME_LABEL, "gterm - NOAO/IRAF Sunview Graphics Terminal V1.2", + FRAME_ARGC_PTR_ARGV, &tty_argc, tty_argv, + FRAME_NO_CONFIRM, FALSE, + 0); + if (gt_baseframe == NULL) + _exit (1); + screen = *(struct rect *) window_get (gt_baseframe, WIN_SCREEN_RECT); + + create_tty_subwindow (tty_argc, tty_argv); + create_gio_popup (gio_argc, gio_argv); + create_frame_menu (gt_baseframe); + + /* Save initial options settings for later reset (in setup panel). */ + save_params(); + + notify_interpose_event_func (gt_baseframe, ev_ttyframe, NOTIFY_SAFE); + notify_interpose_event_func (gt_ttysw, ev_gt_ttysw, NOTIFY_SAFE); + notify_interpose_event_func (gio_frame, ev_gioframe, NOTIFY_SAFE); + notify_interpose_event_func (gio_canvas, ev_gioinput, NOTIFY_SAFE); + + notify_set_signal_func (gt_baseframe, sig_tstp, SIGTSTP, NOTIFY_SYNC); + +#ifdef TTY_TTY_FD + /* SunOS 3.4 provides just what we needed to fix the pty-fd kludge! */ + pty_fd = (int) window_get (ttysw, TTY_TTY_FD); +#endif + gio_setup (pty_fd, pw); + gio_hardreset (DEF_TEKXRES, DEF_TEKYRES, alpha_font, text_font); + + window_main_loop (gt_baseframe); + exit (0); +} + + +/* PARSE_ARGS -- Parse the argument list into the arguments for the tty + * frame and the arguments for the gio frame. This is very easy; the gio + * args, if any, are whatever follows the arg "-G" in the argument list. + * All args preceding the -G are considered to be tty args. + */ +static +parse_args (argc, argv, tty_argc, tty_argv, gio_argc, gio_argv) +int argc; +char *argv[]; +int *tty_argc, *gio_argc; +char *tty_argv[], *gio_argv[]; +{ + register char *argp, *last; + register int arg = 1; + + /* Copy the tty arguments. */ + tty_argv[0] = argv[0]; + for (*tty_argc=1; arg <= argc && (argp = argv[arg]) != NULL; arg++) + if (strcmp (argv[arg], "-G") != 0) { + tty_argv[(*tty_argc)++] = argp; + if ((strcmp(argp, "-Ws") == 0) || (strcmp(argp, "-size") == 0)) + height_is_set = 1; + else if ((strcmp(argp, "-Wh") == 0) || + (strcmp(argp, "-height") == 0)) { + height_is_set = 0; + tty_nlines = atoi (argv[arg+1]); + } + } else { + arg++; + break; + } + + gio_argv[0] = argv[0]; + last = ""; + + /* Copy the gio arguments. */ + for (*gio_argc=1; arg <= argc && (argp = argv[arg]) != NULL; arg++) { + + /* If an argument string is encountered which is not an argument + * to a GIO window switch, assume that it is the first word of the + * command to be executed in the text window, and move the + * remaining arguments to the tty_argv list. + */ + if (strncmp(last,"-Gopen",3) && strncmp(last,"-Gclose",3) && + isalpha(argp[0])) { + + for (; arg <= argc && (argp = argv[arg]) != NULL; arg++) + tty_argv[(*tty_argc)++] = argp; + break; + } + + gio_argv[(*gio_argc)++] = argp; + last = argp; + } + + tty_argv[(*tty_argc)] = NULL; + gio_argv[(*gio_argc)] = NULL; +} + + +/* CREATE_TTY_SUBWINDOW -- Create a standard TTY subwindow of the base frame. + * This code emulates the shelltool arguments. + */ +static +create_tty_subwindow (argc, argv) +int argc; +char *argv[]; +{ + static char *sh_argv[2]; + register char *argp; + register int arg; + char **tty_argv = argv; + char *tool_name = argv[0]; + char *init_cmd = NULL; + char *bold_name = NULL; + int become_console = 0; + + /* Get gt_ttysw related args. The standard frame arguments will + * already have been removed from the list when the base frame was + * created, leaving only the tty specific arguments and possibly the + * command to be run. + */ + sh_argv[0] = NULL; + sh_argv[1] = NULL; + + for (arg=1; arg < argc && (argp = argv[arg]); arg++) { + if (*argp != '-') + break; + else if (!strncmp (argp, "-ignore", 3)) { + ignore++; + continue; + } + + switch (*(argp+1)) { + case 'C': + become_console = 1; + break; + case '?': + tool_usage (tool_name); + print_usage (tool_name); + window_destroy (gt_baseframe); + exit (1); + case 'B': + if (argc > 1) + bold_name = argv[++arg]; + break; + case 'I': + if (argc > 1) + init_cmd = argv[++arg]; + break; + case 'T': + gio_enable (0); + break; + } + } + + /* Get path to command interpreter to be run. */ + if (argp == NULL || arg >= argc) { + shell++; + tty_argv = sh_argv; + if ((tty_argv[0] = getenv("SHELL")) == NULL) { + tty_argv[0] = "/bin/sh"; + if (ignore) + shell = 0; + } + } else { + tty_argv = &argv[arg]; + if (!strcmp(tty_argv,"csh") || !strcmp(tty_argv,"/bin/csh")) + shell++; + else if (!ignore) + shell++; + } + + gt_ttysw = window_create (gt_baseframe, TTY, + TTY_ARGV, tty_argv, + TTY_QUIT_ON_CHILD_DEATH, TRUE, + TTY_CONSOLE, become_console, + 0); + + window_set (gt_ttysw, + WIN_CONSUME_KBD_EVENTS, KEY_TOP(7), KEY_TOP(8), KEY_TOP(9), 0, + 0); + + if (bold_name) + window_set (gt_ttysw, TTY_BOLDSTYLE_NAME, bold_name, 0); + + /* Pass user supplied command, if given, to the shell. */ + if (init_cmd) { + int len = strlen (init_cmd); + + if (init_cmd[len-1] != '\n') { + init_cmd[len] = '\n'; + len++; + } + ttysw_input (gt_ttysw, init_cmd, len); + } + + window_fit_height (gt_ttysw); + window_fit_height (gt_baseframe); + + /* Only correct the height if the user did not give a pixel value + * for the height. + */ + if (!height_is_set) + tty_adjustheight (tty_nlines); +} + + +/* CREATE_GIO_POPUP -- Create a canvas popup to be used for graphics i/o. + * We use a separate subframe for this so that it may be moved and sized + * independently of the tty window; tty windows like to high and narrow + * (lots of lines) whereas graphs tend to be short and wide (good resolution + * in X). We also like a large graph window to get good resolution, but + * a separate window is desired so that the screen space can be freed up + * when we are not actually doing graphics, and so that the last graph can + * easily be recalled at any time. The standard graphics window should have + * a landscape aspect ratio (y/x=.77), like most terminals and laser printers. + */ +static +create_gio_popup (argc, argv) +int argc; +char **argv; +{ + static unsigned char mono[2]; + register char *argp; + register int arg; + char *frame_argv[64]; + int frame_argc; + char pathname[256]; + char mapname[64]; + int name; + + frame_argv[0] = argv[0]; + frame_argc = 1; + + /* Override the builtin defaults with the values given by the user + * on the command line, if any. + */ + for (arg=1; arg <= argc && (argp = argv[arg]) != NULL; arg++) { + /* Standard Sunview frame args. */ + if (!strcmp (argp, "-Wb") || !strncmp (argp, "-back", 5)) { + red[0] = atoi (argv[++arg]); + green[0] = atoi (argv[++arg]); + blue[0] = atoi (argv[++arg]); + } else if (!strcmp (argp, "-Wf") || !strncmp (argp, "-fore", 5)) { + red[1] = atoi (argv[++arg]); + green[1] = atoi (argv[++arg]); + blue[1] = atoi (argv[++arg]); + } else if (!strcmp (argp, "-Wp") || !strncmp (argp, "-pos", 4)) { + win_xoff = atoi (argv[++arg]) - + (int) window_get (gt_baseframe, WIN_X); + win_yoff = atoi (argv[++arg]) - + (int) window_get (gt_baseframe, WIN_Y); + } else if (!strcmp (argp, "-Ws") || !strncmp (argp, "-size", 5)) { + win_xsize = atoi (argv[++arg]) - (TOOL_BORDERWIDTH * 2); + win_ysize = atoi (argv[++arg]) - (TOOL_BORDERWIDTH * 2); + + /* Graphics options. */ + } else if (!strncmp (argp, "-Gopen", 3)) { + argp = argv[++arg]; + if (!strncmp (argp, "noaction", 1)) + openws_action = NO_ACTION; + else if (!strncmp (argp, "show", 1)) + openws_action = SHOW_FRAME; + else if (!strncmp (argp, "expose", 1)) + openws_action = EXPOSE_FRAME; + else { + fprintf (stderr, + "Warning: unknown argument `%s' to -Gopen\n", argp); + } + } else if (!strncmp (argp, "-Gclose", 3)) { + argp = argv[++arg]; + if (!strncmp (argp, "noaction", 1)) + closews_action = NO_ACTION; + else if (!strncmp (argp, "blank", 1)) + closews_action = UNSHOW_FRAME; + else if (!strncmp (argp, "hide", 1)) + closews_action = HIDE_FRAME; + else { + fprintf (stderr, + "Warning: unknown argument `%s' to -Gclose\n", argp); + } + } else if (!strncmp (argp, "-pause", 2)) { + closews_pause = 1; + } else if (!strncmp (argp, "-nopause", 4)) { + closews_pause = 0; + } else if (!strncmp (argp, "-retain", 4)) { + canvas_retained = 1; + } else if (!strncmp (argp, "-noretain", 6)) { + canvas_retained = 0; + } else if (!strncmp (argp, "-clip", 3)) { + clip_graphics = 1; + } else if (!strncmp (argp, "-noclip", 4)) { + clip_graphics = 0; + } else if (!strncmp (argp, "-color", 3)) { + color = 1; + } else if (!strncmp (argp, "-mono", 2)) { + color = 0; + } else if (!strncmp (argp, "-reverse", 4)) { + SWAP (red[0], red[1]); + SWAP (green[0], green[1]); + SWAP (blue[0], blue[1]); + reverse_video = 1; + } else if (!strncmp (argp, "-noreverse", 6)) { + reverse_video = 0; + } else if (!strncmp (argp, "-ginterm", 2)) { + if (argv[arg+1] && isdigit (argv[arg+1][0])) + strcpy (gin_modeterm, argv[++arg]); + if (argv[arg+1] && isdigit (argv[arg+1][0])) { + strcat (gin_modeterm, " "); + strcat (gin_modeterm, argv[++arg]); + } + gio_setginmodeterm (gin_modeterm); + } else if (!strncmp (argp, "-logfile", 2)) { + strcpy (logfile, argv[++arg]); + } else + frame_argv[frame_argc++] = argp; + } + + /* Open the tek-alpha and text mode graphics fonts. */ + if (gio_getbestfont (win_xsize, win_ysize) == -1) + exit (1); + + /* Open graphics window and canvas. Generate a default size + * landscape mode window and position it relative to the base frame. + */ + gio_frame = window_create (gt_baseframe, FRAME, + FRAME_ARGS, frame_argc, frame_argv, + FRAME_NO_CONFIRM, TRUE, + WIN_HEIGHT, win_ysize + (TOOL_BORDERWIDTH * 2), + WIN_WIDTH, win_xsize + (TOOL_BORDERWIDTH * 2), + WIN_X, win_xoff, + WIN_Y, win_yoff, + 0); + gio_canvas = window_create (gio_frame, CANVAS, + CANVAS_RETAINED, canvas_retained ? TRUE : FALSE, + 0); + + /* Set the initial "plus" type graphics cursor. This changes to + * a full crosshair cursor only when the cursor position is being + * read by the applications program. + */ + gio_setcursor (CURSOR_ON, CROSSHAIR_OFF); + + /* Set input event flags. */ + window_set (gio_canvas, + WIN_CONSUME_PICK_EVENTS, WIN_NO_EVENTS, + WIN_MOUSE_BUTTONS, LOC_DRAG, WIN_UP_EVENTS, 0, + WIN_CONSUME_KBD_EVENTS, WIN_NO_EVENTS, WIN_ASCII_EVENTS, + WIN_LEFT_KEYS, WIN_TOP_KEYS, WIN_RIGHT_KEYS, 0, + 0); + + /* Get canvas pixwin */ + pw = canvas_pixwin (gio_canvas); + if (pw->pw_pixrect->pr_depth == 1) + color = 0; + + /* Set up the default color map. */ + sprintf (mapname, "MONO%04d", getpid() % 10000); + pw_setcmsname (pw, mapname); + pw_putcolormap (pw, 0, 2, red, green, blue); + + if (!color) { + /* Monochrome graphics. */ + /* window_set (gio_canvas, CANVAS_FAST_MONO, TRUE, 0); */ + if (reverse_video) + pw_whiteonblack (pw, 0, 1); + else + pw_blackonwhite (pw, 0, 1); + } +} + + +static Panel_item pan_graphics_enable, pan_openws_action, pan_closews_action; +static Panel_item pan_closews_pause, pan_retain_graphics, pan_clip_graphics; +static Panel_item pan_graphics_screen, pan_graphics_video, pan_alpha_font; + +/* CREATE_SETUP_POPUP -- Create the popup menu used to set the terminal + * setup options. + */ +static +create_setup_popup() +{ + extern reset_proc(), clear_proc(), gclear_proc(); + extern setup_proc(), toggle_graphics(); + static panel_set_item(), set_ginmodeterm(), set_logfile(); + + setup_frame = window_create (gt_baseframe, FRAME, + FRAME_NO_CONFIRM, TRUE, + WIN_X, setup_xoff, + WIN_Y, setup_yoff, + 0); + setup_panel = window_create (setup_frame, PANEL, 0); + + panel_create_item (setup_panel, PANEL_MESSAGE, + PANEL_ITEM_X, ATTR_COL(11), + PANEL_ITEM_Y, ATTR_ROW(0), + PANEL_LABEL_STRING, "Graphics Terminal Setup Options", + 0); + + pan_graphics_enable = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(1), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Graphics plane: ", + PANEL_CHOICE_STRINGS, "Disable", "Enable", + "Discard Graphics Data", 0, + PANEL_VALUE, graphics_enable, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_openws_action = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(2), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Open workstation action: ", + PANEL_CHOICE_STRINGS, "No action", "Show graphics", + "Expose graphics", 0, + PANEL_VALUE, openws_action, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_closews_action = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(3), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Close workstation action: ", + PANEL_CHOICE_STRINGS, "No action", "Blank graphics", + "Hide graphics", 0, + PANEL_VALUE, closews_action, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_closews_pause = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(4), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Pause on close workstation: ", + PANEL_CHOICE_STRINGS, "No", "Yes", 0, + PANEL_VALUE, closews_pause, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_retain_graphics = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(5), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Retain graphics frame: ", + PANEL_CHOICE_STRINGS, "No", "Yes", 0, + PANEL_VALUE, canvas_retained, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_clip_graphics = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(6), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Clip graphics: ", + PANEL_CHOICE_STRINGS, "No", "Yes", 0, + PANEL_VALUE, clip_graphics, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + if (pw->pw_pixrect->pr_depth > 1) { + pan_graphics_screen = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(7), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Graphics screen type: ", + PANEL_CHOICE_STRINGS, "Mono", "Color", 0, + PANEL_VALUE, color, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + } else { + pan_graphics_screen = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(7), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Graphics screen type: ", + PANEL_CHOICE_STRINGS, "Mono only", 0, + PANEL_VALUE, color, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + } + + pan_graphics_video = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(8), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Graphics video: ", + PANEL_CHOICE_STRINGS, "Normal", "Reverse", 0, + PANEL_VALUE, reverse_video, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_alpha_font = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(9), + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Graphics font and screen sizes:", + PANEL_CHOICE_STRINGS, alpha_fonts[0].label, + alpha_fonts[1].label, + alpha_fonts[2].label, + alpha_fonts[3].label, + alpha_fonts[4].label, + alpha_fonts[5].label, + 0, + PANEL_VALUE, alpha_font_index, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(10) + 3, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Logfile name: ", + PANEL_VALUE, logfile, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, 20, + PANEL_NOTIFY_PROC, set_logfile, + 0); + + panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(11) + 3, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "GIN mode terminators (octal): ", + PANEL_VALUE, gin_modeterm, + PANEL_VALUE_STORED_LENGTH, SZ_GINMODETERM, + PANEL_VALUE_DISPLAY_LENGTH, SZ_GINMODETERM, + PANEL_NOTIFY_PROC, set_ginmodeterm, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(12) + 3, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Reset", 0,0), + PANEL_NOTIFY_PROC, reset_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Clear", 0,0), + PANEL_NOTIFY_PROC, clear_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Gclear", 0,0), + PANEL_NOTIFY_PROC, gclear_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Show graphics", 0,0), + PANEL_NOTIFY_PROC, toggle_graphics, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Quit", 0,0), + PANEL_NOTIFY_PROC, setup_proc, + 0); + + window_fit (setup_panel); + window_fit (setup_frame); +} + + +/* PANEL_SET_ITEM -- Called when an item is seleted in the setup panel to + * set the associated global variable and possibly take some action. + */ +static +panel_set_item (item, value) +Panel_item item; +int value; +{ + if (item == pan_graphics_enable) { + gio_enable (graphics_enable = value); + } else if (item == pan_openws_action) { + openws_action = value; + } else if (item == pan_closews_action) { + closews_action = value; + } else if (item == pan_closews_pause) { + if (closews_pause != value) { + closews_pause = value; + show_pausepanel (0); + } + } else if (item == pan_clip_graphics) { + clip_graphics = value; + } else if (item == pan_graphics_screen) { + if (color != value) { + if (value) + pw_putcolormap (pw, 0, 2, red, green, blue); + else if (reverse_video) + pw_whiteonblack (pw, 0, 1); + else + pw_blackonwhite (pw, 0, 1); + color = value; + } + } else if (item == pan_graphics_video) { + if (reverse_video != value) { + if (pw->pw_pixrect->pr_depth > 1) { + unsigned char r[2], g[2], b[2]; + + pw_getcolormap (pw, 0, 2, r, g, b); + SWAP (r[0], r[1]); + SWAP (g[0], g[1]); + SWAP (b[0], b[1]); + pw_putcolormap (pw, 0, 2, r, g, b); + if (color) + pw_getcolormap (pw, 0, 2, red, green, blue); + } else if (value) { + pw_whiteonblack (pw, 0, 1); + } else + pw_blackonwhite (pw, 0, 1); + + reverse_video = value; + } + } else if (item == pan_retain_graphics) { + if (canvas_retained != value) { + canvas_retained = value; + notify_remove_event_func (gio_canvas, + ev_gioinput, NOTIFY_SAFE); + window_destroy (gio_frame); + parse_args (main_argc, main_argv, + &tty_argc, tty_argv, &gio_argc, gio_argv); + create_gio_popup (gio_argc, gio_argv); + notify_interpose_event_func (gio_canvas, + ev_gioinput, NOTIFY_SAFE); + gio_setup (pty_fd, pw); + gio_reset (DEF_TEKXRES, DEF_TEKYRES, alpha_font, text_font); + } + } else if (item == pan_alpha_font) { + if (alpha_font_index != value) { + struct fonttab *ft = &alpha_fonts[value]; + int xorigin, yorigin, xoffset, yoffset; + int g_xsize, g_ysize, g_xorig, g_yorig; + + /* Determine whether the offset of the subframe from the base + * frame needs to be modified to keep the frame on the screen. + */ + xorigin = (int) window_get (gt_baseframe, WIN_X); + yorigin = (int) window_get (gt_baseframe, WIN_Y); + xoffset = win_xoff; + yoffset = win_yoff; + + g_xsize = ft->win_xsize + (TOOL_BORDERWIDTH * 2); + g_ysize = ft->win_ysize + (TOOL_BORDERWIDTH * 2); + g_xorig = xorigin + xoffset; /* screen relative */ + g_yorig = yorigin + yoffset; /* screen relative */ + + if (g_xorig + g_xsize >= screen.r_width) + xoffset -= (g_xorig + g_xsize - screen.r_width); + if (g_yorig + g_ysize >= screen.r_height) + yoffset -= (g_yorig + g_ysize - screen.r_height); + + /* Resize and/or move the gio frame. The gio_frame event + * handler will detect the resize and select a new font. + */ + window_set (gio_frame, WIN_SHOW, FALSE, + WIN_WIDTH, g_xsize, WIN_HEIGHT, g_ysize, 0); + + /* Cannot set a negative subframe offset, so move base frame + * to screen origin temporarily if the gio frame won't fit at + * the lower right. Note that win_[xy]off are not permanently + * changed, so restoring the original size should return the + * window to its original position. + */ + if (gio_frame_has_moved = (xoffset < 0 || yoffset < 0)) { + window_set (gt_baseframe, WIN_X, 0, WIN_Y, 0, 0); + window_set (gio_frame, + WIN_X, xorigin + xoffset, WIN_Y, yorigin + yoffset, 0); + window_set (gt_baseframe, WIN_X,xorigin, WIN_Y,yorigin, 0); + } else + window_set (gio_frame, WIN_X, xoffset, WIN_Y, yoffset, 0); + + window_set (gio_frame, WIN_SHOW, TRUE, 0); + + /* If the setup panel is on, move it to the top. */ + if ((int) window_get (setup_frame, WIN_SHOW) == TRUE) + window_set (setup_frame, WIN_SHOW, TRUE, 0); + } + } +} + + +/* TOGGLE_FULLSCREEN -- Toggle between a full screen graph and a regular size + * graph. + */ +static +toggle_fullscreen() +{ + static save_index = -1; + + if (alpha_font_index == FULLSCREEN && save_index >= 0) + panel_set_item (pan_alpha_font, save_index); + else { + save_index = alpha_font_index; + panel_set_item (pan_alpha_font, FULLSCREEN); + } +} + + +/* SET_GINMODETERM -- Set the GIN mode terminators. + */ +static Panel_setting +set_ginmodeterm (item, event) +Panel_item item; +Event *event; +{ + strcpy (gin_modeterm, + (char *)panel_get_value (item)); + gio_setginmodeterm (gin_modeterm); + + return (panel_text_notify (item,event)); +} + + +/* SET_LOGFILE -- Set the filename of the logfile. + */ +static Panel_setting +set_logfile (item, event) +Panel_item item; +Event *event; +{ + if (gt_logfp) { + fclose (gt_logfp); + gt_logfp = NULL; + menu_set (logitem, MENU_STRING, "Logging on", 0); + } + + strcpy (logfile, + (char *)panel_get_value (item)); + return (panel_text_notify (item,event)); +} + + +/* SETUP_PROC -- Toggle whether or not the setup panel is shown. + */ +static +setup_proc() +{ + if (setup_frame == NULL) { + create_setup_popup(); + create_setup_popup (0, NULL); + panel_set_item(); + window_set (setup_frame, WIN_SHOW, TRUE, 0); + } else { + window_destroy (setup_frame); + setup_frame = NULL; + } +} + + +/* TEXTCOPY_PROC -- Make a hardcopy of the tty window on the laserwriter. + */ +static +textcopy_proc() +{ + int depth = 1; + + window_set (gt_baseframe, WIN_SHOW, TRUE, 0); + notify_dispatch(); + + screendump ( + (int)window_get(gt_ttysw,WIN_FD), win_get_pixwin(gt_ttysw), + (int) window_get (gt_baseframe, WIN_WIDTH) - TOOL_BORDERWIDTH * 2, + (int) window_get (gt_baseframe, WIN_HEIGHT) - HEIGHTADJUST, + (int) window_get (gt_baseframe, WIN_X) + TOOL_BORDERWIDTH, + (int) window_get (gt_baseframe, WIN_Y) + HEIGHTADJUST - + TOOL_BORDERWIDTH, + depth); +} + + +/* GRAPHCOPY_PROC -- Make a hardcopy of the gio window on the laserwriter. + */ +static +graphcopy_proc() +{ + int depth = 1; + + window_set (gio_frame, WIN_SHOW, TRUE, 0); + notify_dispatch(); + + screendump ( + (int)window_get(gio_canvas,WIN_FD), pw, + (int) window_get (gio_frame, WIN_WIDTH) - TOOL_BORDERWIDTH * 2, + (int) window_get (gio_frame, WIN_HEIGHT) - TOOL_BORDERWIDTH * 2, + (int) window_get (gt_baseframe, WIN_X) + + (int) window_get (gio_frame, WIN_X) + TOOL_BORDERWIDTH, + (int) window_get (gt_baseframe, WIN_Y) + + (int) window_get (gio_frame, WIN_Y) + TOOL_BORDERWIDTH, + depth); +} + + +/* SCREENCOPY_PROC -- Make a bitmap hardcopy of the screen on the laserwriter. + */ +static +screencopy_proc() +{ + int depth = 1; + + screendump ( + (int)window_get(gt_ttysw,WIN_FD), win_get_pixwin(gt_ttysw), + screen.r_width, screen.r_height, screen.r_left, screen.r_top, + depth); +} + + +/* SCREENCOPY8_PROC -- Make a greyscale hardcopy of the screen on the + * laserwriter. + */ +static +screencopy8_proc() +{ + int depth = 8; + + screendump ( + (int)window_get(gt_ttysw,WIN_FD), win_get_pixwin(gt_ttysw), + screen.r_width, screen.r_height, screen.r_left, screen.r_top, + depth); +} + + +/* CREATE_PAUSE_POPUP -- Create the pause popup menu used to wait for + * a user response. + */ +static +create_pause_popup() +{ + pause_frame = window_create (gt_baseframe, FRAME, + FRAME_NO_CONFIRM, TRUE, + WIN_X, win_xoff + 5, + WIN_Y, win_yoff + 5, + 0); + pause_panel = window_create (pause_frame, PANEL, 0); + + panel_create_item (pause_panel, PANEL_MESSAGE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(0), + PANEL_LABEL_STRING, "Hit any key to continue", + 0); + + window_fit (pause_panel); + window_fit (pause_frame); +} + + +/* SHOW_PAUSEPANEL -- Toggle display of the pause panel. + */ +static +show_pausepanel (onoff) +int onoff; +{ + if (onoff == 0) { + if (pause_frame) { + window_destroy (pause_frame); + pause_frame = NULL; + } + } else { + if (!pause_frame) + create_pause_popup(); + window_set (pause_frame, + WIN_X, win_xoff + 5, + WIN_Y, win_yoff + 5, + 0); + window_set (pause_frame, WIN_SHOW, TRUE, 0); + } +} + + +/* CREATE_FRAME_MENU -- Gterm uses a special frame menu which provides the + * standard frame menu as a submenu. + */ +static +create_frame_menu (frame) +Frame frame; +{ + extern textcopy_proc(), graphcopy_proc(), screencopy_proc(); + extern setup_proc(), toggle_graphics(), restart_childpgrp(); + extern toggle_logging(); + Menu new_menu, old_menu; + + /* Get the standard frame menu. */ + old_menu = (Menu) window_get (frame, WIN_MENU); + + /* Create the new frame root menu */ + new_menu = menu_create ( + MENU_PULLRIGHT_ITEM, + "Frame", + old_menu, + MENU_ACTION_ITEM, + "Setup", + setup_proc, + MENU_ACTION_ITEM, + "Continue", + restart_childpgrp, + MENU_ACTION_ITEM, + "Logging on", + toggle_logging, + MENU_ACTION_ITEM, + "Show graph", + toggle_graphics, + MENU_ACTION_ITEM, + "Textcopy", + textcopy_proc, + MENU_ACTION_ITEM, + "Graphcopy", + graphcopy_proc, + MENU_ACTION_ITEM, + "Screencopy", + screencopy_proc, + /* + MENU_ACTION_ITEM, + "Screencopy8", + screencopy8_proc, + */ + 0); + + logitem = menu_find (new_menu, MENU_STRING, "Logging on", 0); + + /* Install the new menu. */ + window_set (frame, WIN_MENU, new_menu, 0); +} + + +/* TOGGLE_LOGGING -- Called from the frame menu to turn logging on/off. + */ +static +toggle_logging() +{ + if (gt_logfp) { + fclose (gt_logfp); + gt_logfp = NULL; + menu_set (logitem, MENU_STRING, "Logging on", 0); + } else { + if ((gt_logfp = fopen (logfile, "a")) == NULL) + fprintf (stderr, "cannot open logfile %s\n", logfile); + else + menu_set (logitem, MENU_STRING, "Logging off", 0); + } +} + + +/* EV_GT_TTYSW -- TTY subwindow input event handler. + */ +static Notify_value +ev_gt_ttysw (frame, event, arg, type) +Frame frame; +Event *event; +Notify_arg arg; +Notify_event_type type; +{ + register int key = event_id(event); + + if (pause_mode && (event_is_ascii(event) || event_is_button(event))) { + /* If we are pausing for input before closing the workstation, + * complete the close workstation operation and discard the event. + */ + show_pausepanel (0); + gio_close_workstation(); + return (NOTIFY_DONE); + } + + if (event_is_ascii(event)) { + /* Save the cursor position in tty window for later restoration. */ + tty_lastx = event_x(event); + tty_lasty = event_y(event); + + /* Ignore control codes if -ignore set? */ + if (iscntrl(key) && key != '\r' && ignore_inputevent(event)) + return (NOTIFY_DONE); + + /* Ignore typein into text window while a cursor read is in + * progress, else an invalid exit from the cursor read may result. + */ + if (cursor_read_pending) + return (NOTIFY_DONE); + + } else if (event_id(event) == KEY_TOP(7) && event_is_down(event)) { + /* Toggle between full screen and regular size graph. */ + toggle_fullscreen(); + + } else if (event_id(event) == KEY_TOP(8) && event_is_down(event)) { + /* Clear or enable the graphics plane. */ + char buf[4]; + + tty_lastx = event_x(event); + tty_lasty = event_y(event); + + /* If already in graphics mode, clear the graphics plane, else + * switch to graphics mode w/o clearing the screen (the user can + * simply type F8 again if they also want to clear the screen). + */ + if (gio_graphicsenabled && !cursor_read_pending) { + buf[0] = '\035'; + buf[1] = '\033'; + buf[2] = '\014'; + ev_ptyoutput (buf, 3); + + } else if (!gio_graphicsenabled && graphics_enable == GRAPHICS_ON) { + buf[0] = '\035'; + buf[1] = '\037'; + ev_ptyoutput (buf, 2); + /* + window_set (gt_ttysw, + WIN_CONSUME_KBD_EVENTS, KEY_TOP(9), 0, + 0); + */ + } + + return (NOTIFY_DONE); + + } else if (event_id(event) == KEY_TOP(9) && event_is_down(event)) { + /* Exit graphics mode, returning to text mode. + */ + if (gio_graphicsenabled && !cursor_read_pending) { + char buf[1]; + + cursor_used++; /* disable pause on CW */ + buf[0] = '\030'; + ev_ptyoutput (buf, 1); + /* + window_set (gt_ttysw, + WIN_IGNORE_KBD_EVENTS, KEY_TOP(9), 0, + 0); + */ + return (NOTIFY_DONE); + } else if (!gio_graphicsenabled) + ttysw_output (gt_ttysw, "\f", 1); + } + + /* Let frame operate upon the event. */ + return (notify_next_event_func (frame, event, arg, type)); +} + + +/* IGNORE_INPUTEVENT -- Ignore the current input event? + * The following is a kludge intended to prevent delivering the suspend + * signal to a process which is run in the gterm window without benefit of + * an intermediate shell. This is only done if "-ignore" (stop signals) + * is specified on the command line, and only if the command being run in + * GTERM is not a shell. This is a dangerous thing to do, as the characters + * may be valid input data to a program operating in raw input mode. + */ +static +ignore_inputevent (event) +Event *event; +{ + register int key = event_id(event); + struct ltchars lt; + struct sgttyb sg; + + if (!shell && event_ctrl_is_down(event)) { + /* Control code assignments may change, so reread them. */ + if (ioctl (pty_fd, TIOCGLTC, <) != -1) { + t_suspc = lt.t_suspc; + t_dsuspc = lt.t_dsuspc; + } + + /* Echo but ignore suspend control characters if not in raw mode. */ + if (key == t_suspc || key == t_dsuspc) { + if (ioctl(pty_fd,TIOCGETP,&sg) != -1 && (!(sg.sg_flags&RAW))) { + char out[2]; + out[0] = '^'; + out[1] = (key & 077) + '@'; + ttysw_output (gt_ttysw, out, 2); + return (1); + } + } + } + + return (0); +} + + +/* EV_TTYFRAME -- TTY frame event handler. + */ +static Notify_value +ev_ttyframe (frame, event, arg, type) +Frame frame; +Event *event; +Notify_arg arg; +Notify_event_type type; +{ + Notify_value value; + static int ignore_resize = 1; + + /* Let frame operate upon the event. */ + value = notify_next_event_func (frame, event, arg, type); + + if (event_id(event) == WIN_RESIZE) { + /* Tty_adjustheight, if it resizes the window, will cause a resize + * event to be queued and we will be called back. Set a flag to + * ignore this event or an infinite loop will result. + */ + if (ignore_resize) + ignore_resize = 0; + else { + ignore_resize = 1; + tty_adjustheight (0); + } + } + + return (value); +} + + +/* TTY_ADJUSTHEIGHT -- Called when the tty window is initially sized or when + * it is dynamically resized to adjust the size to an integral number of lines + * and allow space for the panel at the top (this is NOT done when the tty + * window resizes itself, although it should be). + */ +static +tty_adjustheight (nrows) +int nrows; +{ + struct pixfont *pf; + int height; + + if (nrows == 0) + nrows = (int) window_get (gt_ttysw, WIN_ROWS); + + pf = (struct pixfont *) window_get (gt_baseframe, WIN_FONT); + height = HEIGHTADJUST + pf->pf_defaultsize.y * nrows + 1; + + if (height != (int) window_get (gt_baseframe, WIN_HEIGHT)) + window_set (gt_baseframe, WIN_HEIGHT, height, 0); +} + + +/* GIO_OPEN_WORKSTATION -- Called by the low level gtermio code when there is + * output to the graphics frame but the frame is in a closed state. + */ +gio_open_workstation() +{ + cursor_used = 0; + gio_setcursor (CURSOR_OFF, 0); + if (openws_action == NO_ACTION) + return; + + if (!gio_frame_has_moved) + window_set (gio_frame, + WIN_HEIGHT, win_ysize + (TOOL_BORDERWIDTH * 2), + WIN_WIDTH, win_xsize + (TOOL_BORDERWIDTH * 2), + WIN_X, win_xoff, + WIN_Y, win_yoff, + 0); + + switch (openws_action) { + case SHOW_FRAME: + window_set (gio_frame, WIN_SHOW, TRUE, 0); + break; + case EXPOSE_FRAME: + set_coverwindow (gio_frame, gt_baseframe); + break; + } + + /* If the setup panel is on, move it to the top. */ + if ((int) window_get (setup_frame, WIN_SHOW) == TRUE) + window_set (setup_frame, WIN_SHOW, TRUE, 0); +} + + +/* GIO_CLOSE_WORKSTATION -- Called by the low level gtermio code when the CAN + * sequence is received, to turn off or hide the now inactive graphics window. + */ +gio_close_workstation() +{ + if (cursor_used) + window_set (gt_ttysw, WIN_MOUSE_XY, tty_lastx, tty_lasty, 0); + gio_setcursor (CURSOR_ON, CROSSHAIR_OFF); + + if (closews_action != NO_ACTION) + if (closews_pause && !pause_mode && !cursor_used) { + show_pausepanel (1); + pause_mode = 1; + return; + } + + /* If the window has been closed, do nothing. */ + if (window_get (gio_frame, WIN_SHOW)) + switch (closews_action) { + case UNSHOW_FRAME: + window_set (gio_frame, WIN_SHOW, FALSE, 0); + break; + case HIDE_FRAME: + set_coverwindow (gt_baseframe, gio_frame); + break; + } + + pause_mode = 0; +} + + +/* SET_COVERWINDOW -- Make the first window cover the second if they overlap. + */ +static +set_coverwindow (win_top, win_bot) +Frame win_top, win_bot; +{ + int fd_top, fd_bot; + + fd_top = (int) window_get (gt_baseframe, WIN_FD); + fd_bot = (int) window_get (gio_frame, WIN_FD); + + win_lockdata (fd_top); + win_lockdata (fd_bot); + win_remove (fd_bot); + win_setlink (fd_bot, WL_COVERING, win_fdtonumber(fd_top)); + win_insert (fd_bot); + win_unlockdata (fd_bot); + win_unlockdata (fd_top); +} + + +/* EV_GIOFRAME -- GIO frame event handler. + */ +static Notify_value +ev_gioframe (frame, event, arg, type) +Frame frame; +Event *event; +Notify_arg arg; +Notify_event_type type; +{ + Notify_value value; + int o_xoff, o_yoff, n_xoff, n_yoff; + + o_xoff = (int) window_get (gio_frame, WIN_X); + o_yoff = (int) window_get (gio_frame, WIN_Y); + + /* Let frame operate upon the event. */ + value = notify_next_event_func (frame, event, arg, type); + + n_xoff = (int) window_get (gio_frame, WIN_X); + n_yoff = (int) window_get (gio_frame, WIN_Y); + + /* Determine if the graphics window has been moved by the user. + * If so, we don't want to move it ourselves any more. + */ + if (n_xoff != o_xoff || n_yoff != o_yoff) { + gio_frame_has_moved = 1; + win_xoff = n_xoff; + win_yoff = n_yoff; + } + + return (value); +} + + +/* EV_GIOINPUT -- GIO input event handler. + */ +static Notify_value +ev_gioinput (frame, event, arg, type) +Frame frame; +Event *event; +Notify_arg arg; +Notify_event_type type; +{ + register int key; + Notify_value value; + char ch; + + /* If we are pausing for input before closing the workstation, + * complete the close workstation operation and discard the event. + */ + if (pause_mode && (event_is_ascii(event) || event_is_button(event))) { + show_pausepanel (0); + gio_close_workstation(); + return (NOTIFY_DONE); + } + + /* Let frame operate upon the event. */ + value = notify_next_event_func (frame, event, arg, type); + + switch (key = event_id (event)) { + case WIN_RESIZE: + win_xsize = (int) window_get (gio_frame, WIN_WIDTH) - + (TOOL_BORDERWIDTH * 2); + win_ysize = (int) window_get (gio_frame, WIN_HEIGHT) - + (TOOL_BORDERWIDTH * 2); + if (!gio_frame_has_moved) { + win_xoff = (int) window_get (gio_frame, WIN_X); + win_yoff = (int) window_get (gio_frame, WIN_Y); + } + + if (!cursor_read_pending) + gio_setcursor (CROSSHAIR_OFF, CURSOR_ON); + + gio_getbestfont (win_xsize, win_ysize); + gio_reset (DEF_TEKXRES, DEF_TEKYRES, alpha_font, text_font); + break; + + case MS_RIGHT: + /* When a cursor read is not in progress, i.e., the gio window + * is idle, the right mouse button will cause the crosshairs to + * be displayed while the button is held down and the cursor is + * in the graphics window. During a cursor read the right button + * may be used to alias a key, like the left and middle buttons + * below. + */ + if (cursor_read_pending && event_is_down(event)) { + if (event_ctrl_is_down (event)) + key_right = last_key; + else if (key = key_right) + goto readcur; + } else if (!cursor_read_pending) { + if (event_is_down (event)) + gio_setcursor (CROSSHAIR_ON, CURSOR_ON); + else + gio_setcursor (CROSSHAIR_OFF, 0); + } + break; + + case MS_LEFT: + case MS_MIDDLE: + /* The left and middle mouse buttons may be used while in the + * graphics window to alias keyboard events. Typing ctrl/button + * causes the last key to be aliased with the indicated button. + * Thereafter, pressing that mouse button during a cursor read + * causes the cursor read to terminate, returning the aliased + * key just as if the key had been typed on the keyboard. + */ + if (event_is_down (event)) + if (event_ctrl_is_down (event)) { + if (key == MS_LEFT) + key_left = last_key; + else + key_middle = last_key; + } else if (cursor_read_pending) { + if (key == MS_LEFT) + key = key_left; + else + key = key_middle; + if (key) + goto readcur; + } + break; + + case KEY_TOP(7): + /* Toggle full screen graphics mode. + */ + if (event_is_down(event)) + toggle_fullscreen(); + break; + + case KEY_TOP(8): + /* Clear the graphics screen, leaving the terminal in graphics + * mode. + */ + if (event_is_down(event) && !cursor_read_pending) { + char buf[3]; + + buf[0] = '\035'; + buf[1] = '\033'; + buf[2] = '\014'; + ev_ptyoutput (buf, 3); + } + break; + + case KEY_TOP(9): + case KEY_LEFT(7): + /* Exit graphics mode, returning to text mode. + */ + if (event_is_down(event) && !cursor_read_pending) { + char buf[1]; + + /* + window_set (gt_ttysw, + WIN_IGNORE_KBD_EVENTS, KEY_TOP(9), 0, + 0); + */ + + if (key == KEY_LEFT(7)) /* delay CW until after L7 */ + gio_pause (500); + + cursor_used++; /* disable pause on CW */ + buf[0] = '\030'; + ev_ptyoutput (buf, 1); + } + break; + + default: + /* Terminate a cursor read, returning the encoded cursor value + * sequence to the terminal output. + */ + if (event_is_down(event) && + (event_is_ascii(event) || event_is_key_right(event))) { + + /* Ignore control codes if -ignore set? */ + if (iscntrl(key) && key != '\r' && ignore_inputevent(event)) + return (value); + + /* Terminate cursor read? */ + if (cursor_read_pending) { + /* Map keypad function keys to digits. */ + if (event_is_key_right(event)) { + switch (key = event_id(event) - KEY_RIGHT(1) + 1) { + case 7: case 8: case 9: + break; + case 10: case 11: case 12: + key -= 6; + break; + case 13: case 14: case 15: + key -= 12; + break; + default: + return (value); + } + key += '0'; + } +readcur: + last_x = event_x (event); + last_y = event_y (event); + last_key = key; + + cursor_read_pending = 0; + gio_setcursor (CURSOR_OFF, CROSSHAIR_OFF); + gio_retcursor (key, last_x, last_y); + enable_arrow_keys(); + + } else + write (pty_fd, (ch=key, &ch), 1); + } + } + + return (value); +} + + +/* SIG_TSTP -- Signal handler for signal SIGTSTP. + */ +static Notify_func +sig_tstp() +{ + kill (getpid(), SIGSTOP); +} + + +/* RESTART_CHILDPGRP -- Send the SIGCONT signal to the process group + * associated with this terminal, e.g., to restart the processes after + * the user has accidentally typed the stop character. + */ +static +restart_childpgrp() +{ + int pgrp; + + ioctl (pty_fd, TIOCGPGRP, &pgrp); + killpg (pgrp, SIGCONT); +} + + +/* GIO_GETBESTFONT -- Scan the font table and open the tek-alpha font which + * best fits the given size window. The important dimension is the window + * width, since the character spacing is fixed. Also pick a text (status + * line) font small enough to provide space for at least 80 chars. + */ +static +gio_getbestfont (xsize, ysize) +int xsize, ysize; /* canvas size, x,y */ +{ + register struct fonttab *ft, *o_ft; + register int i; + struct pixfont *newfont; + char pathname[256]; + + /* Select tek-alpha font. + */ + for (i=0, o_ft=ft=alpha_fonts; ft->pointsize != 0; o_ft=ft++, i++) + if (ft->win_xsize > xsize) + break; + + if (i == 0) + i = 1; + + sprintf (pathname, o_ft->path, o_ft->pointsize); + if ((newfont = pf_open (pathname)) == NULL) { + fprintf (stderr, "cannot open font %s\n", pathname); + return (-1); + } else if (alpha_font != NULL) + pf_close (alpha_font->pixfont); + + alpha_font = o_ft; + alpha_font->pixfont = newfont; + alpha_font_index = i - 1; + + /* Load the text (status line) font. + */ + o_ft = &text_fonts[i-1]; + sprintf (pathname, o_ft->path, o_ft->pointsize); + if ((newfont = pf_open (pathname)) == NULL) { + fprintf (stderr, "cannot open font %s\n", pathname); + return (-1); + } else if (text_font != NULL) + pf_close (text_font->pixfont); + + text_font = o_ft; + text_font->pixfont = newfont; + text_font_index = i - 1; + + return (0); +} + + +/* GIO_SETCURSOR -- Set graphics frame cursor options. + */ +gio_setcursor (op1, op2) +int op1, op2; +{ + Cursor cursor; + int option[2], i; + int type=cursor_type, show=cursor_show; + + /* Normalize the argument list. */ + for (option[0]=op1, option[1]=op2, i=0; i < 2; i++) + switch (option[i]) { + case CROSSHAIR_OFF: + case CROSSHAIR_ON: + type = option[i]; + break; + case CURSOR_OFF: + case CURSOR_ON: + show = option[i]; + break; + } + + /* Do we need to change anything? */ + if (type == cursor_type && show == cursor_show) + return; + + /* Modify the cursor attributes. */ + cursor = window_get (gio_canvas, WIN_CURSOR); + cursor_set (cursor, + CURSOR_SHOW_CURSOR, FALSE, + CURSOR_SHOW_CROSSHAIRS, (show==CURSOR_ON) ? TRUE : FALSE, + CURSOR_CROSSHAIR_THICKNESS, 1, + CURSOR_CROSSHAIR_LENGTH, (type==CROSSHAIR_ON) ? CURSOR_TO_EDGE : 10, + CURSOR_CROSSHAIR_OP, PIX_SRC, + CURSOR_CROSSHAIR_COLOR, 1, + 0); + window_set (gio_canvas, WIN_CURSOR, cursor, 0); + + cursor_type = type; + cursor_show = show; +} + + +/* GIO_SETCURSORPOS -- Set the position of the graphics cursor within the + * graphics frame. + */ +gio_setcursorpos (x, y) +int x, y; /* pixwin pixel coords */ +{ + window_set (gio_canvas, WIN_MOUSE_XY, x, y, 0); + last_x = x; + last_y = y; + cursor_used++; +} + + +/* GIO_READCURSOR -- Initiate a cursor read. Set the cursor type to + * a full crosshair cursor to indicate to the user that the program is + * waiting for cursor input. Set the cursor read pending flag so that + * the next input event in graphics window will cause termination of the + * cursor read and transmission of the cursor value to the terminal output. + */ +gio_readcursor() +{ + /* When a cursor read is initiated, move the cursor into the gio + * window so that the user knows that cursor input is expected. + */ + if (last_x < 0) { + last_x = win_xsize / 2; + last_y = win_ysize / 2; + } + + /* Disable the mapping of the right function keys to the ansi arrow + * key escape sequences, since we want to receive these keys as + * function key events. + */ + disable_arrow_keys(); + + gio_setcursorpos (last_x, last_y); + gio_setcursor (CURSOR_ON, CROSSHAIR_ON); + cursor_read_pending++; + cursor_used++; +} + + +/* TOGGLE_GRAPHICS -- Show or hide the graphics frame. + */ +static +toggle_graphics() +{ + if ((int) window_get (gio_frame, WIN_SHOW) == TRUE) + window_set (gio_frame, WIN_SHOW, FALSE, 0); + else { + if (!gio_frame_has_moved) + window_set (gio_frame, + WIN_HEIGHT, win_ysize + (TOOL_BORDERWIDTH * 2), + WIN_WIDTH, win_xsize + (TOOL_BORDERWIDTH * 2), + WIN_X, win_xoff, + WIN_Y, win_yoff, + 0); + window_set (gio_frame, WIN_SHOW, TRUE, 0); + + /* If the setup panel is on, move it to the top. */ + if ((int) window_get (setup_frame, WIN_SHOW) == TRUE) + window_set (setup_frame, WIN_SHOW, TRUE, 0); + } +} + + +/* RESET_PROC -- Called from the setup panel to reset the state of the + * terminal. + */ +static +reset_proc() +{ + /* Cancel any pending cursor read. */ + if (cursor_read_pending) { + gio_retcursor ('\r', 0, 0); + enable_arrow_keys(); + } + + /* Cancel logging if enabled. */ + if (gt_logfp) { + fclose (gt_logfp); + gt_logfp = NULL; + menu_set (logitem, MENU_STRING, "Logging on", 0); + } + + /* Restore user settable options. */ + restore_params(); + + /* Reset internal state variables. */ + cursor_type = -1; /* crosshair or small cursor */ + cursor_show = -1; /* cursor on or off */ + cursor_read_pending = 0; /* waiting for cursor event */ + key_left = 0; /* key aliased to left msbutton */ + key_middle = 0; /* key aliased to mid msbutton */ + key_right = 0; /* key aliased to mid msbutton */ + last_key = 0; /* last cursor read key */ + last_x= -1,last_y= -1; /* last cursor read position */ + setup_xoff = 150; /* offset to setup panel */ + setup_yoff = 150; + red[0] = green[0] = 0; + red[1] = green[1] = 255; + blue[0] = 128; blue[1] = 0; + gio_frame_has_moved = 0; + pause_mode = 0; + cursor_used = 0; + + /* Reset internal state. */ + notify_remove_event_func (gio_canvas, ev_gioinput, NOTIFY_SAFE); + notify_remove_event_func (gio_frame, ev_gioframe, NOTIFY_SAFE); + window_destroy (gio_frame); + parse_args (main_argc, main_argv, + &tty_argc, tty_argv, &gio_argc, gio_argv); + create_gio_popup (gio_argc, gio_argv); + notify_interpose_event_func (gio_frame, ev_gioframe, NOTIFY_SAFE); + notify_interpose_event_func (gio_canvas, ev_gioinput, NOTIFY_SAFE); + gio_setup (pty_fd, pw); + gio_hardreset (DEF_TEKXRES, DEF_TEKYRES, alpha_font, text_font); + gio_enable (graphics_enable); + + if (pause_frame) + window_destroy (pause_frame); + + window_destroy (setup_frame); + create_setup_popup (0, NULL); + panel_set_item(); + window_set (setup_frame, WIN_SHOW, TRUE, 0); +} + + +/* SAVE_PARAMS -- Save the user settable options. + */ +static +save_params() +{ + s_clip_graphics = clip_graphics; + s_graphics_enable = graphics_enable; + s_openws_action = openws_action; + s_closews_action = closews_action; + s_closews_pause = closews_pause; + s_canvas_retained = canvas_retained; + s_reverse_video = reverse_video; + s_color = color; + s_win_xsize = win_xsize; + s_win_ysize = win_ysize; + s_win_xoff = win_xoff; + s_win_yoff = win_yoff; + s_ignore = ignore; + strcpy (s_gin_modeterm, gin_modeterm); +} + + +/* RESTORE_PARAMS -- Restore the user settable options. + */ +static +restore_params() +{ + clip_graphics = s_clip_graphics; + graphics_enable = s_graphics_enable; + openws_action = s_openws_action; + closews_action = s_closews_action; + closews_pause = s_closews_pause; + canvas_retained = s_canvas_retained; + reverse_video = s_reverse_video; + color = s_color; + win_xsize = s_win_xsize; + win_ysize = s_win_ysize; + win_xoff = s_win_xoff; + win_yoff = s_win_yoff; + ignore = s_ignore; + + strcpy (gin_modeterm, s_gin_modeterm); + gio_setginmodeterm (gin_modeterm); +} + + +/* CLEAR_PROC -- Called when the clear button is clicked to transmit the + * screen clear sequence to the TTY subwindow. + */ +static +clear_proc() +{ + static char clearscreen[] = "\f"; + ttysw_output (gt_ttysw, clearscreen, strlen(clearscreen)); +} + + +/* GCLEAR_PROC -- Called when the gclear button is clicked to clear the + * graphics window. + */ +static +gclear_proc() +{ + static char clearscreen[] = "\035\033\f"; + ev_ptyoutput (clearscreen, strlen(clearscreen)); +} + + +/* PRINT_USAGE -- Print instructions on how to use this window tool. + */ +static +print_usage (toolname) +char *toolname; +{ + char *bstyle = "[-B boldstyle] "; + + fprintf (stderr, + "syntax: %s [-C] %s[program [args]]\n", toolname, bstyle); + fprintf (stderr, + "-C redirect console output to this instance of %s\n", toolname); + fprintf (stderr, + "-B set boldstyle for this instance of %s\n", toolname); + fprintf (stderr, + " where boldstyle is a number from 1 to 8\n"); + fprintf (stderr, + "-I input the next argument to the shell run from %s\n", toolname); +} diff --git a/unix/sun/gterm.esc b/unix/sun/gterm.esc new file mode 100644 index 00000000..a557bd73 --- /dev/null +++ b/unix/sun/gterm.esc @@ -0,0 +1,46 @@ +/* + * GTERM.ESC -- Macros and data defining the escape sequences recognized by + * the graphics terminal. Ambiguous cases are resolved in favor of the + * entry which occurs first in the table. + */ +#define ESC_SETTEXTMODE 1 +#define ESC_ENQUIRE 2 +#define ESC_READCURSOR 3 +#define ESC_CLEARSCREEN 4 +#define ESC_SETCURSOR 5 +#define ESC_SETCHARSIZE0 6 +#define ESC_SETCHARSIZE1 7 +#define ESC_SETCHARSIZE2 8 +#define ESC_SETCHARSIZE3 9 +#define ESC_SETDATALEVEL0 10 +#define ESC_SETDATALEVEL1 11 +#define ESC_SETDATALEVEL2 12 +#define ESC_SETLINESTYLE0 13 +#define ESC_SETLINESTYLE1 14 +#define ESC_SETLINESTYLE2 15 +#define ESC_SETLINESTYLE3 16 +#define ESC_SETLINESTYLE4 17 +#define ESC_SETLINEWIDTH0 18 +#define ESC_SETLINEWIDTH1 19 +#define ESC_SETLINEWIDTH2 20 + +ESC_SETTEXTMODE, 015, 000, 000, 000, 000, 000, 0, +ESC_ENQUIRE, ENQ, 000, 000, 000, 000, 000, 0, +ESC_READCURSOR, SUB, 000, 000, 000, 000, 000, 0, +ESC_CLEARSCREEN, 014, 000, 000, 000, 000, 000, 0, +ESC_SETCURSOR, '/', 'f', 000, 000, 000, 000, 0, +ESC_SETCHARSIZE0, '0', 000, 000, 000, 000, 000, 0, +ESC_SETCHARSIZE1, '1', 000, 000, 000, 000, 000, 0, +ESC_SETCHARSIZE2, '2', 000, 000, 000, 000, 000, 0, +ESC_SETCHARSIZE3, '3', 000, 000, 000, 000, 000, 0, +ESC_SETDATALEVEL0, '/', '0', 'd', 000, 000, 000, 0, +ESC_SETDATALEVEL1, '/', '1', 'd', 000, 000, 000, 0, +ESC_SETDATALEVEL2, '/', '2', 'd', 000, 000, 000, 0, +ESC_SETLINESTYLE0, '`', 000, 000, 000, 000, 000, 0, +ESC_SETLINESTYLE1, 'a', 000, 000, 000, 000, 000, 0, +ESC_SETLINESTYLE2, 'b', 000, 000, 000, 000, 000, 0, +ESC_SETLINESTYLE3, 'c', 000, 000, 000, 000, 000, 0, +ESC_SETLINESTYLE4, 'd', 000, 000, 000, 000, 000, 0, +ESC_SETLINEWIDTH0, '/', '0', 'w', 000, 000, 000, 0, +ESC_SETLINEWIDTH1, '/', '1', 'w', 000, 000, 000, 0, +ESC_SETLINEWIDTH2, '/', '2', 'w', 000, 000, 000, 0, diff --git a/unix/sun/gterm.h b/unix/sun/gterm.h new file mode 100644 index 00000000..121587ae --- /dev/null +++ b/unix/sun/gterm.h @@ -0,0 +1,18 @@ +/* GTERM.H -- Global definitions for GTERM. + */ +#define CURSOR_OFF 3 /* turn cursor off entirely */ +#define CURSOR_ON 4 /* turn it back on */ + +#define GRAPHICS_OFF 0 +#define GRAPHICS_ON 1 +#define GRAPHICS_DISCARD 2 + + +struct fonttab { /* Gterm font descriptor. */ + short pointsize; + char ch_xsize, ch_ysize; + short win_xsize, win_ysize; + struct pixfont *pixfont; + char *path; + char *label; +}; diff --git a/unix/sun/gterm.icon b/unix/sun/gterm.icon new file mode 100644 index 00000000..05c634a6 --- /dev/null +++ b/unix/sun/gterm.icon @@ -0,0 +1,34 @@ +/* Format_version=1, Width=64, Height=64, Depth=1, Valid_bits_per_item=16 + */ + 0xFFFF,0xFFFF,0xFFFF,0xFFFF,0xFFFF,0xF3FF,0xFFFF,0xFFFF, + 0xFFFF,0xF0FF,0xFFFF,0xFFFF,0xFFFF,0xF03F,0xFFFF,0xFFFF, + 0xFFFF,0xE01F,0xFFFF,0xFFFF,0xFFFF,0xE00F,0xFFFF,0xFFFF, + 0xFFFF,0xE007,0xFFFF,0xFFFF,0xFFFF,0xE003,0xFFFF,0xFFFF, + 0xFFFF,0xE103,0xFFFF,0xFFFF,0xFFFF,0xE101,0xFFFF,0xFFFF, + 0xFFFF,0xC181,0x3FFF,0xFFFF,0xFFFF,0xC181,0x9FFF,0xFFFF, + 0xFFFF,0xC1C1,0x8FFF,0xFFFF,0xFFFF,0xC1C1,0x87FF,0xFF8F, + 0xFFFF,0xC1C0,0x8307,0xFE1F,0xFFFE,0xC1E0,0x8180,0x001F, + 0xFFFC,0xC1E0,0xC0C0,0x00FF,0xFFF8,0x81E0,0xC0C0,0x3FFF, + 0xFFE0,0x81E0,0xC060,0x1DFF,0xFE01,0x81E0,0xC030,0x11FF, + 0xF001,0x81E0,0xC038,0x03FF,0x8001,0x81C0,0xC018,0x07FF, + 0x8001,0x8180,0xC00C,0x03FF,0x8001,0x0100,0xC006,0x03FF, + 0xFC01,0x0001,0xC007,0x01FF,0xFF81,0x0001,0xC083,0x03FF, + 0xFFE3,0x0007,0xC0C1,0x87FF,0xFFF3,0x0007,0xC060,0xDFFF, + 0xFFF3,0x0007,0xC030,0xFFFF,0xFFFB,0x0003,0xC030,0x7FFF, + 0xFFFE,0x0003,0xC018,0x3FFF,0xFFFE,0x0001,0xC018,0x1FFF, + 0xFFFE,0x0001,0xC00C,0x1FFF,0xFFFE,0x0000,0xC00C,0x0FFF, + 0xFFFE,0x0000,0xC00E,0x0FFF,0xFFFE,0x0000,0x4006,0x07FF, + 0xFFFC,0x0000,0xC006,0x07FF,0xFFFC,0x0001,0xC007,0x03FF, + 0xFFFC,0x0003,0xE007,0x03FF,0xFFFC,0x0187,0xF007,0x01FF, + 0xFFF8,0x01EF,0xF807,0x01FF,0xFFF8,0x01FF,0xF807,0x80FF, + 0xFFF0,0x01FF,0xFC07,0x80FF,0xFFF0,0x01FF,0xFF07,0x80FF, + 0xFFF0,0x01FF,0xFF81,0x807F,0xFFF0,0x03FF,0xFFC0,0x007F, + 0xFFF0,0x07FF,0xFFE6,0x007F,0xFFE0,0x07FF,0xFFF7,0x803F, + 0xFFE0,0x0FFF,0xFFFF,0x803F,0xFFE0,0x1FFF,0xFFFF,0x801F, + 0xFFE0,0x3FFF,0xFFFF,0x800F,0xFFC0,0x3FFF,0xFFFF,0x800F, + 0xFFC0,0x7FFF,0xFFFF,0x800F,0xFFC0,0xFFFF,0xFFFF,0xE007, + 0xFFC1,0x8000,0x0000,0xF007,0xFF81,0x8040,0x0000,0xF803, + 0xFF83,0x9CF1,0x8A34,0xFC03,0xFF87,0xA442,0x4D2A,0xFF03, + 0xFF8F,0xA443,0x882A,0xFF81,0xFF9F,0x9C42,0x082A,0xFFE1, + 0xFF1F,0x8431,0xC82A,0xFFF1,0xFF3F,0xB800,0x0000,0xFFF9, + 0xFF7F,0x8000,0x0000,0xFFFF,0xFFFF,0xFFFF,0xFFFF,0xFFFF diff --git a/unix/sun/gterm.icon.OLD b/unix/sun/gterm.icon.OLD new file mode 100644 index 00000000..6a40db4b --- /dev/null +++ b/unix/sun/gterm.icon.OLD @@ -0,0 +1,34 @@ +/* Format_version=1, Width=64, Height=64, Depth=1, Valid_bits_per_item=16 + */ + 0x8888,0x8888,0x8888,0x8888,0x8888,0x889F,0xFC88,0x8888, + 0x2222,0x23FF,0xFFE2,0x2222,0x2222,0x27FF,0xFFF2,0x2222, + 0x8888,0xBFFF,0xFFFE,0x8888,0x8888,0xFFFF,0xFFFF,0x8888, + 0x2223,0xFFFF,0xFFFF,0xE222,0x2223,0xFFF0,0x07FF,0xE222, + 0x888F,0xFF00,0x007F,0xF888,0x888F,0xFC00,0x001F,0xF888, + 0x223F,0xF000,0x0007,0xFE22,0x223F,0xE000,0x0003,0xFE22, + 0x88FF,0x8000,0x0000,0xFF88,0x88FF,0x0000,0x0000,0x7F88, + 0x23FE,0x0000,0x0000,0x3FE2,0x23FC,0x0000,0x0000,0x1FE2, + 0x8BF8,0x0000,0x0000,0x0FE8,0x8FF8,0x0000,0x0000,0x0FF8, + 0x27F0,0x0000,0x0000,0x07F2,0x27E0,0x0000,0x0000,0x03F2, + 0x8FE0,0x0000,0x0000,0x03F8,0x8FC0,0x0000,0x0000,0x01F8, + 0x3FC0,0x0000,0x0000,0x01FE,0x3F80,0x0000,0x0000,0x00FE, + 0x9F80,0x0000,0x0000,0x00FC,0x9F83,0xE3F0,0x1C3F,0xC0FC, + 0x3F81,0xC1D8,0x1C1C,0xC0FE,0x3F01,0xC1DC,0x1C1C,0x007E, + 0xBF01,0xC1DC,0x1C1C,0x007E,0xBF01,0xC1D8,0x3E1F,0x007E, + 0x3F01,0xC1F0,0x3E1F,0x007E,0x3F01,0xC1F0,0x3E1F,0x007E, + 0xBF01,0xC1F8,0x3E1C,0x007E,0xBF01,0xC1F8,0x671C,0x007E, + 0x3F01,0xC1DE,0x671C,0x007E,0x3F03,0xE3EE,0xFFBE,0x007E, + 0xBF80,0x0000,0x0000,0x00FE,0x9F80,0x0000,0x0000,0x00FC, + 0x3F80,0x0000,0x0000,0x00FE,0x3F80,0x0000,0x0000,0x00FE, + 0x9FC0,0x0000,0x0000,0x01FC,0x8FC0,0x0000,0x0000,0x01F8, + 0x2FE0,0x0000,0x0000,0x03FA,0x27E0,0x0000,0x0000,0x03F2, + 0x8FF0,0x0000,0x0000,0x07F8,0x8FF8,0x0000,0x0000,0x0FF8, + 0x23F8,0x0000,0x0000,0x0FE2,0x23FC,0x0000,0x0000,0x1FE2, + 0x89FE,0x0000,0x0000,0x3FC8,0x88FF,0x0000,0x0000,0x7F88, + 0x227F,0x8000,0x0000,0xFF22,0x223F,0xE000,0x0003,0xFE22, + 0x889F,0xF000,0x0007,0xFC88,0x888F,0xFC00,0x001F,0xF888, + 0x2227,0xFF00,0x007F,0xF222,0x2223,0xFFF0,0x07FF,0xE222, + 0x8889,0xFFFF,0xFFFF,0xC888,0x8888,0xFFFF,0xFFFF,0x8888, + 0x2222,0x3FFF,0xFFFE,0x2222,0x2222,0x27FF,0xFFF2,0x2222, + 0x8888,0x89FF,0xFFC8,0x8888,0x8888,0x889F,0xFC88,0x8888, + 0x2222,0x2222,0x2222,0x2222,0x2222,0x2222,0x2222,0x2222 diff --git a/unix/sun/gterm.man b/unix/sun/gterm.man new file mode 100644 index 00000000..fd09b5f4 --- /dev/null +++ b/unix/sun/gterm.man @@ -0,0 +1,784 @@ +.\" @(#)gterm.1 1.1 28-Jul-87 DCT +.TH GTERM 1 "31 December 1987" +.SH NAME +gterm \- virtual graphics terminal for the SunView environment +.SH SYNOPSIS +.B gterm +[ +.B \-C +] +[ +.B \-T +] +[ +.B \-B +\fIboldstyle\fR +] +[ +.B \-I +\fIcommand\fR +] +.if n .ti +0.5i +[ +.B \-ignore +] +[ +\fIttyargs\fR +] +.ti +.5i +[ +.B \-G +[ +.B \-Gopen +\fR(\fP\fBnoaction\fR | \fBshow\fR | \fBexpose\fR\fR)\fP +] +.if n .ti +1.0i +[ +.B \-Gclose +\fR(\fP\fBnoaction\fR | \fBblank\fR | \fBhide\fR\fR)\fP +] +.ne 4 +.ti +1.0i +[ +.B \-\fR[\fPno\fR]\fPpause +] +[ +.B \-\fR[\fPno\fR]\fPretain +] +[ +.B \-\fR[\fPno\fR]\fPclip +] +.if n .ti +1.0i +[ +.B \-\fR[\fPno\fR]\fPreverse +] +[ +.B \-color +| +.B \-mono +] +.ti +1.0i +[ +.B \-ginterm +\fR[\fIchar \fR[\fIchar\fR]] +] +[ +\fIgioargs\fR +] +] +.ti +.5i +[ +\fIprogram\fR +[ +\fIargs\fR +] +] +.SH GETTING STARTED +\fIgterm\fR is a virtual graphics terminal implemented as a set of windows +running within the SunView environment. The graphics terminal consists of +two primary windows, the main \fBtext window\fR and a \fBgraphics subwindow\fR. +The text window is a standard SunView TTY subwindow, identical to that used +in \fIshelltool\fR. The graphics window is a Tektronix 4012 compatible +graphics window. The two windows may be moved and sized independently. +Terminal i/o may be directed to either window, but to only +one window at a time. When i/o is directed to the text window the terminal +is said to be in \fBtext mode\fR, and when i/o is directed to the graphics +window the terminal is said to be in \fBgraphics mode\fR. Mode switching +may be performed either manually or under program control. +\fIgterm\fR is upwards compatible with \fIshelltool\fR. +.SH OPTIONS +.TP +.B \-C +Redirect system console output to this instance of \fIgterm\fR. +.TP +.B \-T +Run \fIgterm\fR with the graphics plane disabled. Any graphics commands +embedded in the input data stream will appear as printable characters in the +text window. This option is useful when using \fIgterm\fR for a nongraphics +session over a noisy line, or when debugging a graphics program and switching +back and forth between text and graphics mode would interfere with the +operation of the debugger. +.TP +\fB\-B\fP \fIboldstyle\fR +Sets the \fIboldstyle\fR +(rendering of boldface type in the text window) +for this instance of \fIgterm\fR. +The choices are the same as for any tool based +on a SunView tty subwindow: see \fIshelltool\fR(1) for a description of the +\fIboldstyle\fR options. +.TP +\fB\-I\fP \fIcommand\fR +Input the given command to the program or shell run in the \fIgterm\fR window, +as if it had been typed into the window. Spaces in the command must be +escaped, or the command string must be quoted. +.TP +.B \-ignore +Ignore the suspend control characters (SIGTSTP), \fIif\fR the process being +run in the \fIgterm\fR window is not the default SHELL process. +If this option is in effect, typing one of the \fIstty\fR suspend-process +control characters \fBsusp\fR or \fBdsusp\fR while the terminal is not in raw +mode will cause the character to be echoed in the text window, but to be +otherwise ignored. This may be desirable if the process being run in the +\fIgterm\fR window is not capable of restarting itself after it has been +suspended (see also the \fBcontinue\fR frame menu option). +.TP +\fIttyargs\fR +\fIgterm\fR also takes generic tool arguments; see \fIsuntools\fR(1) for a +list of these arguments. The \fIttyargs\fR generic tool arguments affect +only the text window. +.TP +.B \-G +Generic tool arguments preceding this optional placeholder switch affect only +the text window; those following the switch affect only the graphics window. +.TP +\fB-Gopen \fR(\fPnoaction \fR|\fP show \fR|\fP expose\fR)\fP +Specifies the action to be taken when graphics mode is entered, i.e., when +terminal i/o is redirected from the text window to the graphics window. +\fBnoaction\fR means do nothing which visibly affects the screen. +\fBshow\fR means display the graphics frame if it is not already visible on +the screen, i.e., because the graphics window has been closed. +\fBexpose\fR means move the graphics window, if already displayed, to the +top of the stack of open windows. +.TP +\fB-Gclose \fR(\fPnoaction \fR|\fP blank \fR|\fP hide\fR)\fP +Specifies the action to be taken when graphics mode is exited, restoring +terminal i/o to the text window. +\fBnoaction\fR means do nothing which visibly affects the screen. +\fBblank\fR means close the graphics subwindow, causing the window to +disappear from the screen (the closed window can be redisplayed at any time +provided the contents are \fIretained\fR). +\fBhide\fR means move the graphics window to the bottom of the stack of +open windows. +.TP +\fB\-\fR[\fPno\fR]\fPpause +Pause before closing the graphics window and returning to text mode, +after opening the graphics frame to display a plot noninteractively +(no cursor reads). If \fB\-nopause\fR is specified and the \fB\-Gclose\fR +option is \fBblank\fR, a newly plotted graph will disappear immediately after +the plotting operation is completed, assuming no blocking operation such as +a cursor read occurs while in graphics mode. If \fB\-pause\fR is specified +\fIgterm\fR will detect this condition and pause for a keystroke to be typed +before exiting graphics mode. +.TP +\fB\-\fR[\fPno\fR]\fPretain +Specifies whether or not the contents of the graphics frame are to be retained. +If \fB\-noretain\fR is specified plotting will be somewhat faster, but any +window event which affects the region of the workstation screen occupied by +the graphics frame will cause the plot to be lost. +.TP +\fB\-\fR[\fPno\fR]\fPclip +Specifies whether or not clipping of graphics vectors is to be performed. +If \fB\-noclip\fR is specified plotting will be somewhat faster, but vectors +may be drawn outside the graphics window if the screen changes while a graph +is being drawn. +.TP +\fB\-\fR[\fPno\fR]\fPreverse +Specifies whether the graphics frame is to be displayed in normal or reverse +video. What constitutes normal video depends upon whether color or monochrome +is specified, and upon what has been specified for the foreground and +background colors. Reverse video swaps the foreground and background colors +within the graphics window. +.TP +.B \-color +Display the graphics frame in two colors, if \fIgterm\fR is run on a color +workstation. +.TP +.B \-mono +Display the graphics frame in monochrome, using the foreground and background +colors specified when \fIsuntools\fR(1) was started. +.TP +.B \-ginterm \fR[\fIchar \fR[\fIchar\fR]] +Set the GIN terminator character or characters (used to delimit the value +returned for a cursor read) to the indicated octal values \fIchar\fR. +If a \fIchar\fR value is omitted the corresponding GIN mode terminator will +be omitted when a cursor value is returned. For example, "\-ginterm" causes +both GIN delimiter characters to be omitted, and "\-ginterm 015" causes the +single GIN terminator character CR (carriage return) to be transmitted. +.TP +\fIgioargs\fR +\fIgterm\fR also takes generic tool arguments; see \fIsuntools\fR(1) for a +list of these arguments. The \fIgioargs\fR generic tool arguments affect +only the graphics subwindow, and are recognized only after the \fB\-G\fR +placeholder argument. +.TP +[\fIprogram\fP [\fIargs\fP]] +If a \fIprogram\fR argument is present, the named program is run in the +\fIgterm\fR window without spawning an intermediate shell. +If no \fIprogram\fR is specified, +\fIgterm\fR runs the shell specified by your \fLSHELL\fR environment +variable. If this environment variable is not defined, \fIgterm\fR runs +\fB/bin/sh\fR. +.LP +Minimum match abbreviations are permitted for all \fIgterm\fR arguments except +the generic tool arguments, which have two character aliases. Use of the full +names is however recommended, as the number of characters required for minimum +matching a specific argument may change in a future release of \fIgterm\fR +when new command line arguments are added. +.if t .sp 0.08i +.SH DESCRIPTION +.SS Virtual Graphics Terminal +.LP +\fIgterm\fR is a virtual graphics terminal implemented as a set of windows +running within the SunView environment. The terminal consists of two primary +windows, a \fBtext window\fR and a \fBgraphics window\fR, and several special +purpose subwindows, the most important of which is the \fBsetup panel\fR, +used to dynamically change \fIgterm\fR options at runtime, or to reset the +terminal to a known state. The virtual terminal is interfaced to applications +programs via the UNIX pseudoterminal or \fIpty\fR(4) interface, providing an +applications interface identical to that provided for ordinary terminals, +allowing applications running either on the local machine or on a remote +node communicating via a network interface (\fItelnet\fR, \fIrlogin\fR, +modem etc.) to communicate transparently with the \fIgterm\fR virtual terminal. +.if t .sp 0.08i +.SS Text Window +.LP +The text window is a standard SunView TTY subwindow, as used in +\fIshelltool\fR, \fIgfxtool\fR, and so on. Documentation for tty subwindows, +including both user documentation and a description of the special escape +sequences recognized by tty subwindows, is given in \fIshelltool\fR(1). +In particular, note that a \fB.ttyswrc\fR file may be placed in one's login +directory to set tty subwindow parameters, and to map function keys to control +sequences to be sent either to the tty subwindow or to the program running in +the tty subwindow. The \fBselection service\fR can be useful for passing +text to programs via the mouse instead of the keyboard, and numerous terminal +\fBescape sequences\fR are defined for resizing the text window, setting the +frame label, and so on. +.if t .sp 0.08i +.SS Graphics Window +The graphics window emulates a Tektronix 4012 terminal with minor differences, +e.g., the screen size is 35x80 rather than 35x75, and some significant +extensions, e.g., graphics and text can be selectively erased, and support +is provided for a \fBstatus line\fR at the bottom of the screen, in which text +can be dynamically read and written without affecting the contents of the +graphics plane. Although nonstandard, these features are very useful when +designing interactive user interfaces, and they can be emulated on most +modern graphics terminals (hence programs which use these features need not +be device dependent). +.LP +The position and size of the graphics window may be set at startup time via +the generic tool arguments \fIgioargs\fR. A number of preprogrammed sizes +may also be selected via the setup panel at runtime, or the mouse may be used +to directly resize the window to produce a window of any size and aspect ratio. +The standard graphics window sizes range from very small to the full screen +and all share the same standard landscape mode aspect ratio; users should note +that manually adjusting the window size usually results in a window with a +nonstandard aspect ratio, which may cause graphics programs which assume the +standard aspect ratio to misbehave, producing oddly shaped objects, or poorly +centered text strings. +.LP +\fIgterm\fR will automatically detect any changes in the size of the graphics +window, adjusting the transformation from 4012 coordinates (780x1024) to +screen coordinates so that subsequent graphics and text will be drawn at the +correct relative position within the window. The best text font for the new +window size is also selected; if the window is of an arbitrary size it will +not in general be possible to select a font which provides exactly 35x80 +characters on the screen without overlap, since there are only a limited number +of fixed size fonts to choose from. If the window is especially wide and +short text lines may overlap vertically. After resizing the graphics window, +the previously displayed graph \fImust\fR be redrawn under program control to +adjust the graph to fit the new window. +.LP +By default, the graphics window overlaps the text window, with eight or ten +characters of text visible to the left of the graphics window. If the graphics +window is left in its default position and the text window is repositioned on +the workstation screen, the graphics window will "track" the text window, +i.e., retain its position relative to the text window (this is desirable when +there are multiple instances of \fIgterm\fR in use at one time to avoid losing +track of which graphics frame goes with which text window). If the graphics +window is manually repositioned, however, then thereafter the positions of +the two windows are completely independent. +.LP +Although the graphics window is normally used only for graphics (plotting), +one should not forget that the graphics window emulates an (80 column wide) +Tektronix 4012 terminal, and hence may be used as a terminal for ordinary +text i/o, as well as for graphics. The TTY subwindow will normally be +superior for terminal graphics, but the extra page of text and the larger, +brighter font typically used in the graphics window may occasionally be useful +for some applications. Text i/o may easily be switched back and forth between +the text and graphics windows via the function keys described below, +transparently to most applications software. +.if t .sp 0.08i +.SS Active Window +.LP +At any one time, terminal output is always directed to either the text window +or the graphics window, but never to both at the same time. When output is +directed to the text window the terminal is said to be in \fBtext mode\fR, +and when output is directed to the graphics window the terminal is said to +be in \fBgraphics mode\fR, although either text or graphics may be written +into the graphics plane. Mode switching is normally in response to control +codes embedded in the input data stream from the applications program being +run, but keyboard function keys may be used to manually perform mode switching +if desired. +.LP +Keyboard \fIinput\fR may be directed to either window at any time, regardless +of which window is currently active, i.e., text may be typed into one window +but echoed in the other window. This can be confusing if the window in which +text is echoed is not currently displayed; one types and nothing seems to be +happening, but in fact commands are being input and executed normally. +For example, if the \fB\-Gclose\fR option is set to \fBnoaction\fR and the +graphics window is adjusted to fill the full screen, then when graphics mode +is exited terminal output will be directed to the text window, but the text +window will be covered by the graphics window, and subsequent commands and +textual output will not be visible without manually redisplaying the text +window (or undisplaying the graphics window) with a function key. +.if t .sp 0.08i +.SS The Frame Menu +.LP +\fIgterm\fR uses a special frame menu which may be called up by the mouse +at any time, by placing the cursor on the border of the \fItext window\fR and +holding down the right mouse button. +The items in the \fIgterm\fR frame menu are as follows: +.RS +.IP "\fBFrame\fP" 15 +Access the standard SunView frame menu. +.IP "\fBSetup\fP" +Display the setup panel. +.IP "\fBContinue\fP" +Send the SIGCONT signal to the process group attached to the \fIgterm\fR +window, e.g., after accidentally suspending a process which cannot otherwise +restart itself. See also the \fB\-ignore\fR command line option. +.IP "\fBShow graph\fP" +Display the graphics window. +.IP "\fBTextcopy\fP" +Make a hardcopy of the text window. +.IP "\fBGraphcopy\fP" +Make a hardcopy of the graphics window. +(IRAF users should use the cursor mode \fIsnap\fR function instead). +.IP "\fBScreencopy\fP" +Make a hardcopy of the full screen. +.RE +.LP +The textcopy, graphcopy, and screencopy selections are all entry points to the +general screen capture utility, discussed in the next section. +.if t .sp 0.08i +.SS Hardcopy Output +.LP +The hardcopy functions produce a "what you see is what you get" bitmap of the +rectangular region of the screen occupied by the indicated object of interest. +If the region of interest is partially covered by another window, then the +hardcopy will be a picture of a partially covered window. +If the window is displayed in reverse video, the hardcopy will also be +rendered in reverse video. +.LP +The screen capture software reads out the full memory of the workstation in +the region of interest, and in the case of a color workstation, processes the +screen pixels through the colortable to produce an image corresponding to what +appears on the screen. No full color output options +are currently provided, hence the average of the red, green, and blue color +values is next computed. If a bitmap output image is desired a simple +thresholding algorithm is used to produce the final bitmap image, +otherwise a greyscale image is produced. If rasterfile output +is being generated, the raw pixel values and RGB color table entries are saved +directly in the rasterfile, rather than applying the tables in software to +produce a monochrome or bitmap image. +.LP +Two output options are currently provided, i.e., \fBPostscript\fR output +suitable for output directly to a laser writer to produce the final graphics +hardcopy, or \fBSun rasterfile\fR output. The default action is to output a +Postscript program to the device "lw", e.g., the Apple Laserwriter +(any 300 dpi Postscript device should do). +These defaults may be changed by defining the following environment variables: +.IP R_RASTERFILE +If this variable is defined a Sun rasterfile will be generated, otherwise a +Postscript plotfile is generated. The string value of the variable is a +\fIprintf\fR style format string to be used to generate the filename of +the rasterfile. If multiple rasterfiles are to be generated, the format +string may contain a decimal integer field (e.g., "\fLframe.%d\fR") to be +replaced by the \fIfile number\fR of the current rasterfile. The first file +generated will be number zero, with the file number being incremented once +for every rasterfile produced. If Postscript plotfile output is desired, +the plotfile will be a uniquely named temporary file in \fB/tmp\fR. +.IP R_DISPOSE +The string value of this variable is a \fIprintf\fR style format string with +one string valued subfield to be replaced by the plotfile or rasterfile name, +to be used to generate the command used to dispose of the output file. +If this variable is not defined and the output file is a Postscript plotfile, +the default format string \fL"lpr -Plw -r -s %s"\fR will be used. +If the variable is not defined and the output file is a rasterfile, +no action is taken. It is the responsibility of the dispose command to +delete the output file. +.LP +It should only take several seconds to capture the screen and produce the +output rasterfile or queue the Postscript job to the printer. The screen +is flashed to indicated when the operation has completed. The Postscript +processing time may take up to several minutes (of laserwriter time) in the +worst case, i.e., a hardcopy of the full workstation screen. +.if t .sp 0.08i +.SS The Setup Panel +.LP +The setup panel is used to dynamically change terminal options while the +terminal is in use. In general, nearly any terminal option which can be +set on the command line when \fBgterm\fR is started can also be set via the +setup panel, and vice versa. The setup panel can also be used to reset +the terminal to the startup or "power on" state. +The setup panel may be called up at any time via the frame menu; it is normally +closed after the desired setup action has been performed. By default the setup +panel is located within the text window, but it may be moved anywhere else on +the workstation screen if desired. +.LP +There are two types of items in the setup panel: multiple choice options and +"push buttons". To see what the choices are in a multiple choice option, +position the mouse to the area where the current choice is displayed and +depress the right mouse button. At this point a selection may be made by +moving the mouse to the desired selection and releasing the mouse button. +Alternatively, the left mouse button may be used to cycle through the choices. +To perform the action indicated on a push button, place the mouse cursor on +the button and press the left mouse button. +.LP +The multiple choice options in the setup panel are the following: +.IP "\fBGraphics plane" +These options determine what the terminal does when graphics data and +control instructions are encountered in the input stream. +\fBDisable\fR means disable the graphics plane, causing the terminal to +output graphics control codes and data as printable characters +in the text window. +\fBEnable\fR means enable the graphics plane for normal mixed text and +graphics operation. +\fBDiscard Graphics Data\fR means discard all graphics data, effectively +disabling the graphics plane. +.IP "\fBOpen workstation action\fR" +These options determine the action taken by the terminal when graphics mode +is entered. Some visible action is generally desirable to render the graphics +window fully visible, and to indicate that a mode switch has occurred. +\fBNo action\fR means do nothing which visibly affects the workstation. +\fBShow graphics\fR means open the graphics window, e.g., if the graphics +window is to be closed (not displayed) when the terminal is in text mode. +\fBExpose graphics\fR means move the graphics window to the top of the stack +of open windows, displaying any portions of the graphics window which may have +been covered by other windows (such as the text window). +.IP "\\fBClose workstation action\\fR" +These options determine the action taken by the terminal when graphics mode +is exited, returning the terminal to text mode. +\fBNo action\fR means do nothing. +\fBBlank graphics\fR means close the graphics window, i.e., remove the window +from the screen. +\fBHide graphics\fR means move the graphics window to the bottom of the stack +of open windows, allowing any overlapping windows to cover the graphics window. +.IP "\\fBPause on close workstation\\fR" +This boolean option determines whether or not the terminal displays the +\fBpause panel\fR, waiting for a key to be typed, before exiting graphics +mode following a noninteractive graphics session (no cursor input). +.IP "\\fBRetain graphics frame\\fR" +This boolean option determines whether or not the contents of the graphics +window are \fIretained\fR. Graphics drawing will be somewhat faster if the +graphics plane is not retained, but almost any event which affects the region +of the screen occupied by the graphics window will cause the contents +of an unretained window to be lost. +.IP "\\fBClip graphics\\fR" +This boolean option determines whether or not graphics vectors are clipped +to the boundaries of the visible portions of the graphics window. Graphics +drawing will be somewhat faster if clipping is disabled, but +vectors may be drawn in nearby, unrelated windows, +especially if the graphics window is partially covered by other windows. +.IP "\\fBGraphics screen type\\fR" +This option determines whether the graphics plane is to be displayed in color +or monochrome on a color workstation. If \fBmono\fR is selected the foreground +and background colors specified when \fIsuntools\fR was started are used. +If \fBcolor\fR is specified graphics will be rendered in color, with the +colors used being specified by the \fB\-Wb\fR and \fB\-Wf\fR generic tool +arguments in \fIgioargs\fR. On a monochrome workstation the only option +displayed will be \fBmono only\fR, indicating that color is not available. +.IP "\\fBGraphics video\\fR" +This option specifies whether graphics are to be rendered in \fBnormal\fR or +\fBreverse\fR video. Specifying reverse video causes the foreground and +background colors of the graphics window to be reversed. +This option may not work on some monochrome workstations. +.IP "\fBGraphics font and screen sizes\fR" +This option is used to select at runtime the size of graphics window to be used. +The graphics window may be resized at any time, including while graphics is +being drawn or during a cursor read, but any displayed graphics should always +be redrawn following a window resize to ensure that the graph reflects the new +coordinate system. +The graphics window configurations currently available are listed below +in the form ``\fIpointsize\fR:[\fIwidth\fRx\fIheight\fR]'', +where \fIwidth\fR and \fIheight\fR are in pixels. The size of the full screen +is workstation dependent, the most common size currently being 1152x900. +The exact set of fonts and screen sizes may change in the future as new +fonts become available and workstations increase in resolution. +.if t .sp 0.05i +.ti +0.3i +10:[560x420] 12:[640x490] 14:[720x560] 16:[800x630] 18:[880x665] 24:fullscreen +.if t .sp 0.05i +All choices represent 35x80 windows with the standard landscape mode aspect +ratio. The size of the graphics window is the size in pixels of a character +of the fixed width font used, scaled by 35 vertically and by 80 horizontally. +Arbitrary sized windows may also be created by manually sizing the window +with the mouse, but this is bound to result in windows with a nonstandard +number of lines or columns of text, or a nonstandard aspect ratio. +.IP "\fBGIN mode terminators\fR" +Set the GIN (graphics or cursor mode input) terminator characters to the +indicated octal values. When a key is hit to terminate a cursor read, the +terminal transmits a 5 character cursor value sequence to the applications +program, following by one or two GIN mode terminator characters. +The required GIN mode terminator(s) will in general depend upon the +applications program being run. Some programs require no terminators, +others require a single CR (octal 015), and so on. +The default GIN mode terminator is a single CR. +.if t .sp 0.05i +To enter a new value, select the value box with the left mouse button, +rubout the old value, and type in the new value as a string, with zero, one, +or two octal values denoting the desired terminator characters, then hit +return to establish the new value. Entering a blank string disables both +terminators. +.LP +The following "push buttons" are also provided in the setup panel: +.RS +.IP \fBReset\fR 15 +Reset the terminal to the "power on" state, preserving the values of any +options set on the command line, but cancelling any options selected via +the setup panel. A \fBsetup reset\fR is indicated if the terminal does not +seem to be behaving correctly. Resetting the internal state of the terminal +has no effect on the operation of any applications program being run from +the terminal. +.IP \fBClear\fR +Clear the text window (the F9 function key performs the same function). +.IP \fBGclear\fR +Clear the graphics window, leaving the terminal in graphics mode +(the F8 function key performs the same function). +.IP "\fBShow graphics\fR" +Open (display) or close (undisplay) the graphics frame. The contents of the +graphics frame are not affected. +.IP \fBQuit\fR +Close the setup panel. +.RE +.LP +Closing and opening either the text or graphics frame has no effect on the +state of the terminal or on the applications program running within it, +even while a cursor read is in progress. +.if t .sp 0.08i +.SS Function Keys +.LP +The following function keys have special significance to \fIgterm\fR: +.RS +.IP F8 15 +In text mode, causes a switch to graphics mode. +When already in graphics mode, causes the graphics frame to be cleared. +.IP F9 +In graphics mode, causes a switch to text mode. +When already in text mode, causes the text frame to be cleared. +.RE +.LP +To momentarily view the graphics frame while in text mode, one can type F8 +followed by F9, without affecting the contents of either window. +Commands may be entered in either window, hence to direct the output of +a command to the graphics window, one could hit F8, execute the command, +and then hit F9 to return to the text window. The standard SunView L7 key, +used to close a window, is also detected by \fIgterm\fR, +hence closing the graphics +window with L7 while in graphics mode will automatically cause the terminal +to revert to text mode. +.LP +Manual control of the terminal mode is sometimes necessary when running +naive graphics programs in a \fIgterm\fR window. +When running a graphics program +which uses only standard 4012 instructions, it may be necessary to manually +put the terminal into graphics mode with the F8 function key before running the +program, or part of the program output may be "lost" (directed to the text +window and discarded). Similarly, naive programs will not return the terminal +to text mode after generating a plot, hence it will be necessary for the +user to hit the F9 key to return to text mode. +.LP +Additional function keys may be defined in the user \fB~/.ttyswrc\fR file. +For example, the function key definitions +.if t .sp 0.05i +.if n .sp +.RS +.nf +mapo R1 ^[[8;24;80t +mapo R2 ^[[8;34;80t +mapo R3 ^[[8;40;80t +.fi +.RE +.if t .sp 0.05i +.if n .sp +will program the R1, R2, and R3 function keys to set the size of the text +window to 24, 34, or 40 lines by 80 columns when the corresponding function +key is typed. These definitions are handy for rapidly resizing the text +window to one of the "standard" terminal sizes; this is especially useful +when executing programs remotely over the network, as most such programs +assume some standard size terminal screen. +.if t .sp 0.08i +.SS Mouse Buttons +.LP +The significance of the mouse buttons depends upon which window the mouse is +in, and upon whether or not the terminal is in GIN mode, i.e., in the process +of reading the graphics cursor. When the terminal is in text mode and the +mouse is in the text window, the mouse buttons are used only for the +\fBselection service\fR, as described in \fIshelltool\fR(1). +The functions of the mouse buttons while the mouse is in the graphics window +are outlined below. +.RS +.IP "Left button" 15 +Ignored except in GIN mode, when it may be aliased to a keyboard key and used +to terminate a cursor read. +.IP "Middle button" +Ignored except in GIN mode, when it may be aliased to a keyboard key and used +to terminate a cursor read. +.IP "Right button" +In GIN mode, may be aliased to a keyboard key and used to terminate a cursor +read. When not in GIN mode, causes the cursor crosshairs to be displayed +while the button is depressed. +.RE +.LP +The ability to \fBalias\fR mouse buttons to keyboard keys is a very important +one as it allows arbitrary graphics programs which are driven via an +interactive graphics cursor loop to be controlled completely from the mouse, +rather than having to position the mouse and then hit a key on the keyboard +to terminate each cursor read. For example, to alias \fIkey\fR to the left +mouse button, one would depress the control key and tap the left mouse button +twice, immediately after hitting \fIkey\fR to terminate a normal cursor read. +Thereafter, either \fIkey\fR or the left mouse button may be used equivalently +to terminate a cursor read. The alias remains in effect until the terminal is +\fIreset\fR or the alias is reassigned to a different key. +.if t .sp 0.08i +.SS The Terminal Emulator +.LP +The normal function of the terminal is to simultaneously listen for input +(program output) on the pseudoterminal file descriptor, while servicing +asynchronous keyboard and mouse events generated by the user. +The input data stream from the applications program consists of a mixture +of text and graphics data transmitted as an ASCII byte stream with no record +boundaries. Null bytes in the input data stream are ignored, and no programmed +delays are needed for proper terminal operation. As input data is received +asynchronously it is copied into a circular buffer and a synchronous event is +queued to call a routine which subsequently processes the input characters +onto the screen. If input data arrives faster than it can be processed onto +the screen \fB\fR is transmitted to the \fIpty\fR terminal driver, +followed by \fB\fR once the circular buffer empties. +Characters typed by the user are transmitted directly to the terminal driver, +which in normal operation will echo the characters back to the terminal as +ordinary data. +.LP +The initial state of the terminal is text mode. Transition to graphics mode +occurs when the GS character is encountered in the input data stream. +Transition back to text mode occurs when the CAN character is encountered in +the input stream. While text mode is in effect all input is passed on to the +TTY subwindow; while graphics mode is in effect all input is passed on to the +graphics subwindow. The behavior of the ANSI standard TTY subwindow is +documented elsewhere (e.g., \fIshelltool\fR(1), \fIcons\fR(4s), and Chapter 10 +of the \fISunView Programmer's Guide\fR) hence will not be discussed further +here. Likewise, the basic Tektronix 4012 protocol is a well known standard +and need not be documented in detail here. +.LP +The control codes and escape sequences recognized by the \fIgterm\fR graphics +window are summarized below. Sequences marked with a \(**\(** at the right +are nonstandard extensions, although all except the status line feature are +fairly common extensions. +.if t .sp 0.05i +.ta +0.5i +1.5i +3.5i +.nf + GS (035) \fBopen workstation\fR, start normal vector drawing sequence + CAN (030) \fBclose workstation\fR ** + FS (034) start pointmode vector + US (037) set alpha mode + CR (015) set alpha mode and execute carriage return + BEL (007) ring bell and/or flash screen +.if t .sp 0.05i + ESC CR set status line mode (ESC = 033) ** + ESC ENQ inquire graphics state and cursor position + ESC SUB initiate a cursor read (SUB = 032) + ESC FF clear screen, home alpha cursor (FF = 014) + ESC / f set cursor position to current drawing coordinates ** + ESC 0 set character size 0 + ESC 1 set character size 1 [not implemented] + ESC 2 set character size 2 [not implemented] + ESC 3 set character size 3 [not implemented] + ESC / 0 d set data level 0 (clear bits) ** + ESC / 1 d set data level 1 (set bits) ** + ESC / 2 d set data level 2 (toggle bits) ** + ESC ` set line style 0 (solid) + ESC a set line style 1 (dashed) + ESC b set line style 2 (dotted) + ESC c set line style 3 (dashdot) + ESC d set line style 4 (dash3dot) + ESC / 0 w set line width 0 (1 pixel) ** + ESC / 1 w set line width 1 (2 pixels) ** + ESC / 2 w set line width 2 (3 pixels) ** +.fi +.if t .sp 0.05i +.LP +Both text and vectors may be erased by setting the data level to 0 and +redrawing the objects to be erased. Erasing points which are common to more +than one object will cause gaps in other objects sharing the erased point. +.LP +Setting \fBstatus line\fR mode causes the region of the graphics frame +occupied by the status line to be saved in a memory pixrect, after which the +status line is cleared and the status line alpha cursor positioned to the +start of the line (the status line is a single 80 character line of text at +the bottom of the graphics window). While output is directed to the status +line, data characters are output in the status line as for a terminal. +BS and DEL behave as expected, allowing characters to be erased. +Lines longer than 80 characters are truncated at the right margin. +LF (newline) is treated the same as CR, causing the entire line to be erased, +and if multiple lines of text are rapidly written to the status line +they will scroll as on a one-line terminal. Status line mode is terminated +by any control character in the input data stream, e.g., GS, FS, CAN, ESC, +and so on. Note that terminating status line mode does not in itself erase +the status line, restoring the saved region of the graphics frame to the +screen; this is done by transmitting newline or CR to the terminal. +.if t .sp 0.08i +.SH SEE ALSO +suntools(1), shelltool(1), tektool(1), cmdtool(1), pty(4), cons(4s) +.br +\fISunView Programmer's Guide\fR, Chapter 10 \- TTY Subwindows +.br +\fIWindows and Window-Based Tools: Beginner's Guide\fR +.if t .sp 0.08i +.SH FILES +.LP +.nf +~/.ttyswrc +/usr/bin/suntools +/usr/lib/rootmenu +/usr/lib/fonts/fixedwidthfonts/* +$iraf/local/sun/gterm.c +.fi +.if t .sp 0.08i +.SH BUGS +.IP (1) +\fIgterm\fR is a complex program operating in an extremely dynamic environment. +The program has been thoroughly tested and is quite reliable, but it is +nonetheless possible for the program to get into peculiar states where it +does not behave as expected. Should this happen, a \fIsetup reset\fR should +restore the terminal to a known state. +.IP (2) +If more than 256 characters are input to a terminal emulator subwindow without +an intervening newline, the terminal emulator may hang (to demonstrate this, +hold any key down until the autorepeat generates sufficient characters). +If this occurs, display the tty subwindow menu and select the \fBflush input\fR +item to correct the problem. +.IP (3) +When using a terminal emulator to execute a program on a remote node via a +network interface (rlogin, telnet, etc.), and the remote program continuously +outputs a large amount of data, the terminal will occasionally hang up for +several seconds, after which normal output will resume. Typing any character +will cause output to resume immediately, but the character will later be +delivered to the remote program as normal input hence should be selected with +care (\fB\fR is always harmless). The origin of this bug is not clear, +but since all terminal emulators are equally affected, it must be something +in the terminal driver, or elsewhere in the SunOS kernel. +.IP (4) +The hardcopy functions assume a 1 or 8 bit frame buffer and will not work +properly on a Sun-3/110, 3/60, etc., unless the \fB\-8bit_color_only\fR option +is specified to \fIsuntools\fR [\fIfixed in Gterm V1.2]\fR. +.IP (5) +Reverse video does not work on a monochrome workstation as there is no +colortable and no way to exchange the foreground and background colortable +entries; try the \fB\-i\fR option to \fIsuntools\fR instead. +.IP (6) +\fIgterm\fR modifies the keyboard translation table entries for the arrow keys +while a cursor read is in progress, restoring the translation table entries +when done (this is necessary to allow the arrow keys to be used to terminate +cursor reads). If something should happen to \fIgterm\fR while it is waiting +for cursor input, it is possible that the arrow key translation table entries +may not be restored. If this should happen, executing \fBsetkeys reset\fR will +fix things. Note also that changes to the keyboard translation tables are +global, i.e., all windows are affected, hence while a cursor read is in +progress in a \figterm\fR window, the arrow keys may not be usable with a +program running in a different window. +.IP (7) +When plotting with clipping disabled there are cases where it is possible for +\fIgterm\fR to coredump with a segmentation violation, killing any interactive +subprocesses running within the terminal. +.SH AUTHOR +Doug Tody, National Optical Astronomy Observatories (NOAO), IRAF project. diff --git a/unix/sun/gtermio.c b/unix/sun/gtermio.c new file mode 100644 index 00000000..d0348de2 --- /dev/null +++ b/unix/sun/gtermio.c @@ -0,0 +1,1224 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include "gterm.h" + +/* + * GTERMIO -- Graphics terminal i/o. This is the low level code which + * filters graphics output out of the pseudoterminal output stream and + * then processes the graphics instructions, drawing into the graphics + * pixwin. Graphics output from the pty is written into a circular + * buffer by a low level routine called when data is read from the pty + * by the ttysw code. A differed routine is called back by the notifier + * to process the data, writing graphics into the gio pixwin. The graphics + * data language implemented is tektronix standard plus extensions. + */ + +extern int clip_graphics; +extern int cursor_show; +extern int gio_canvas; +extern FILE *gt_logfp; +int gio_graphicsenabled = 0; /* switch text/graphics output */ +int gio_enabled = 1; /* enable graphics window */ + +/* Size limiting definitions. */ +#define SZ_GBUF 8192 /* max buffered graphics data */ +#define GB_MINSPACE 2048 /* XOFF when this much left */ +#define GB_BIGSPACE 3072 /* XON when this much available */ +#define MAX_PLPTS 4096 /* max points in a polyline */ +#define SZ_TXBUF 256 /* max chars in a polytext */ +#define MAX_TEXTCHARS 80 /* max chars in text line */ +#define SL_XOFFSET 0 /* x offset to status line */ +#define SL_YOFFSET 5 /* y offset to status line */ +#define MAX_QUOTA 512 /* limit for one proc. loop */ +#define WSOPEN_DELAY 100 /* delay at openws (msec) */ +#define WSCLOSE_DELAY 0 /* delay at closews (msec) */ +#define LOG_SYNCTIME 15 /* sync interval for logfile */ + +/* Magic numbers. */ +#define SET_BITS 0 /* draw vectors|points */ +#define CLEAR_BITS 1 /* erase vectors|points */ +#define TOGGLE_BITS 2 /* toggle data bits */ +#define COMMAND_MODE 0 /* initial state */ +#define ALPHA_MODE 1 /* tek-alpha character drawing */ +#define TEXT_MODE 2 /* output to status line */ +#define VECTOR_MODE 3 /* draw vectors or points */ +#define CURSOR_MODE 4 /* read crosshair cursor posn */ +#define BREAK_LINE (-2) /* special automargin code */ + +/* ASCII codes. */ +#define ENQ '\005' +#define BEL '\007' +#define CR '\015' +#define CAN '\030' +#define SUB '\032' +#define ESC '\033' +#define FS '\034' +#define GS '\035' +#define RS '\036' +#define US '\037' + +/* Pseudoterminal i/o. + */ +static int pty_fd; /* fd of pseudoterminal */ +static int pty_stop = 0; /* set when XOFF is set on pty */ + +/* The graphics data buffer, a circular buffer. + */ +static char g_buf[SZ_GBUF]; /* circular buffer */ +static char *g_top= &g_buf[SZ_GBUF];/* end of buffer + 1 */ +static char *g_ip = g_buf; /* input pointer */ +static char *g_op = g_buf; /* output pointer */ + +#define g_getc(c)\ + (g_ip==g_op ? -1 : ((c) = *g_ip++, g_ip >= g_top ? *(g_ip=g_buf):0)) +#define g_putc(c)\ + (*g_op++ = (c), ((g_op >= g_top) ? g_op = g_buf : g_op)) +#define g_ungetc(c)\ + (g_ip = ((g_ip==g_buf) ? g_top-1 : g_ip-1)) +#define g_spaceleft\ + (g_ip <= g_op ? (g_top - g_op + g_ip - g_buf) : (g_ip - g_op)) +#define g_havedata (g_ip != g_op) +#define g_mark(ip) ((ip)=g_ip) +#define g_reset(ip) (g_ip=(ip)) +#define g_equal(ip) ((ip)==g_ip) + +/* Polyline (polymarker) output-point buffer. + */ +static char pl_text[MAX_PLPTS]; /* encoded [x,y] coord data */ +static struct pr_pos pl_p[MAX_PLPTS]; /* polyline storage */ +static int pl_npts = 0; /* npoints in polyline */ +static int pl_op = 0; /* which char in coord pair */ +static int pl_linestyle = 0; /* dashline drawing style */ +static int pl_pointmode = 0; /* point or line mode */ + +static int ohiy=0; oloy=0; /* encoded current position */ +static int ohix=0; olox=0; + +static Pr_brush brush = { 1 }; +#define pl_linewidth brush.width /* vector drawing linewidth */ + +/* Graphics text variables. + */ +static struct fonttab *alpha_font; /* alpha mode font */ +static struct fonttab *text_font; /* text mode font */ +static char tx_buf[SZ_TXBUF+1]; /* polytext text buffer */ +static int tx_len = 0; /* nchars in buffer */ +static int tx_maxlines; /* nlines of text on a screen */ +static int tx_maxcols; /* ncols of text on a screen */ +static int tx_charheight; /* height of a char in pixels */ +static int tx_charwidth; /* width of a char in pixels */ +static int tx_charbase; /* topline to baseline distance */ +static int tx_leftmargin; /* where columns start */ +static int sl_x, sl_y; /* current pos. in status line */ +static int sl_xoff, sl_yoff; /* x,y offset of status line */ +static int sl_cwidth; /* status line char width */ +static int sl_cheight; /* status line char height */ +static int sl_cbase; /* topline to baseline distance */ +static int sl_width; /* status line rect width */ +static int sl_height; /* status line rect height */ +static int sl_rect_saved = 0; /* set after sl rect is saved */ +static struct pixrect *sl_pr=NULL; /* saved status line pixrect */ +static struct fonttab *chcur_font; /* character cursor font */ +static int chcur_x; /* character cursor xpos */ +static int chcur_y; /* character cursor ypos */ +static int chcur_on = 0; /* character cursor displayed? */ +static int chcur_skip = 0; /* used to skip cursor updates */ + +/* Miscellaneous variables. + */ +static struct pixwin *pw; /* graphics pixwin */ +static struct rect pw_r; /* full rect of the pixwin */ +static int cur_x, cur_y; /* current x,y position */ +static int win_xres, win_yres; /* size of graphics pixwin */ +static int tek_xres; /* X resolution of input data */ +static int tek_yres; /* Y resolution of input data */ +static int trailer1 = '\r'; /* trailer code, cursor value */ +static int trailer2 = -1; /* second trailer code (opt) */ +static int gio_mode=COMMAND_MODE; /* graphics drawing mode */ +static int gio_datalevel=SET_BITS; /* set, clear, or toggle bits */ +static int workstation_open = 0; /* have issued open workstation */ +static int wait_cursor = 0; /* waiting for cursor input */ +static int gio_delay = 0; /* programmed delay in progress */ + +int ev_ptyoutput(); +static Pr_texture *pl_texture(); +static Notify_value ev_gioprocessdata(); + +/* Macros to convert between tektronix and window coordinates. */ +#define X_TEK2WIN(x) ( ((x) * win_xres + tek_xres/2) / tek_xres) +#define Y_TEK2WIN(y) (win_yres - (((y) * win_yres + tek_yres/2) / tek_yres)) +#define X_WIN2TEK(x) ((( (x)) * tek_xres + win_xres/2) / win_xres) +#define Y_WIN2TEK(y) (((win_yres - (y)) * tek_yres + win_yres/2) / win_yres) + + +/* GIO_SETUP -- Called by the high level Gterm window management code to + * give the gtermio code the file descriptor of the pty and the pixwin of + * the graphics frame. + */ +gio_setup (fd, gio_pw) +int fd; /* fd of pty */ +struct pixwin *gio_pw; /* graphics pixwin */ +{ + pty_fd = fd; + pw = gio_pw; + + notify_read_post_monitor_fcn (pty_fd, ev_ptyoutput); + notify_set_event_func (ev_gioprocessdata, + ev_gioprocessdata, NOTIFY_SAFE); +} + + +/* GIO_HARDRESET -- Reset everything, including cancelling any cursor read + * that may be in progress. + */ +gio_hardreset (mc_xres, mc_yres, a_font, t_font) +int mc_xres, mc_yres; /* virtual x,y resolution */ +struct fonttab *a_font; /* alpha mode font */ +struct fonttab *t_font; /* text mode font */ +{ + gio_mode = COMMAND_MODE; + gio_graphicsenabled = 0; + workstation_open = 0; + wait_cursor = 0; + gio_delay = 0; + pty_stop = 0; + + ioctl (pty_fd, TIOCSTART, NULL); + gio_reset (mc_xres, mc_yres, a_font, t_font); +} + + +/* GIO_RESET -- Reset the state of the gtermio code. Should be called + * whenever any important data structures change, e.g., if the graphics + * frame is resized. + */ +gio_reset (mc_xres, mc_yres, a_font, t_font) +int mc_xres, mc_yres; /* virtual x,y resolution */ +struct fonttab *a_font; /* alpha mode font */ +struct fonttab *t_font; /* text mode font */ +{ + erase_cursor(); + chcur_skip = 0; + + tek_xres = mc_xres; + tek_yres = mc_yres; + alpha_font = a_font; + text_font = t_font; + + pw_get_region_rect (pw, &pw_r); + win_xres = pw_r.r_width; + win_yres = pw_r.r_height; + + tx_leftmargin = 0; + tx_charwidth = alpha_font->ch_xsize; + tx_charheight = alpha_font->ch_ysize; + tx_charbase = -alpha_font->pixfont->pf_char['0'].pc_home.y; + tx_maxlines = win_yres / tx_charheight; + tx_maxcols = win_yres / tx_charwidth; + tx_len = 0; + + sl_cwidth = text_font->ch_xsize; + sl_cheight = text_font->ch_ysize; + sl_cbase = -text_font->pixfont->pf_char['0'].pc_home.y; + sl_xoff = SL_XOFFSET; + sl_yoff = win_yres - SL_YOFFSET; + sl_x = sl_xoff; + sl_y = sl_yoff; + sl_width = win_xres - sl_xoff; + sl_height = sl_cheight; + + if (sl_pr != NULL) + pr_destroy (sl_pr); + sl_pr = mem_create (sl_width, sl_height, 1); + sl_rect_saved = 0; + + g_top = &g_buf[SZ_GBUF]; + g_ip = g_op = g_buf; + pl_npts = 0; + pl_op = 0; + pl_linestyle = 0; + pl_linewidth = 1; + pl_pointmode = 0; + ohiy = 0; oloy = 0; + ohix = 0; olox = 0; + + cur_x = tx_leftmargin; + cur_y = tx_charbase; +} + + +/* GIO_ENABLE -- Enable or disable the graphics window. If graphics is + * disabled, all i/o is directed to the text window. + */ +gio_enable (onoff) +int onoff; +{ + if ((gio_enabled = onoff) == GRAPHICS_OFF) + gio_graphicsenabled = 0; +} + + +/* GIO_SETGINMODETERM -- Set the GIN mode (cursor read) trailer codes, + * expressed as octal constants in the input string argument. + */ +gio_setginmodeterm (str) +char *str; +{ + register char *ip; + register int n; + + trailer1 = trailer2 = -1; + + for (ip=str; isspace(*ip); ip++) + ; + if (isdigit(*ip)) { + for (n=0; isdigit(*ip); ip++) + n = n * 8 + *ip - '0'; + trailer1 = n; + } + + while (*ip && isspace(*ip)) + ip++; + if (isdigit(*ip)) { + for (n=0; isdigit(*ip); ip++) + n = n * 8 + *ip - '0'; + trailer2 = n; + } +} + + +/* EV_PTYOUTPUT -- Process pty output packets. Output directed to the + * terminal (/dev/tty) by the applications program appears as read-pending + * events on the pty seen by the Gterm program. We let the TTY code monitor + * the pty and respond to read-pending events. The low level read primitive + * (notify_read) ultimately called to service a read request by TTY reads + * the data and then calls us to process the data packet. We extract any + * graphics output from the packet and append it to the gio buffer. If data + * is added to the gio buffer a gio-data-pending event is queued so that + * the graphics drawing code will be called to process the new data. The + * remaining data, or a null length packet if the packet contained only + * graphics data, is returned to TTY, completing the read. Sometime later + * the graphics drawing code will be called to process the data. + */ +ev_ptyoutput (ttybuf, nchars) +char *ttybuf; /* raw data on input, tty data on output */ +int nchars; /* nchars of raw data */ +{ + register char *itop = ttybuf + nchars; + register char *op, *ip = ttybuf, ch; + static unsigned long oldtime = 0; + + /* Copy to logfile if logging is enabled. */ + if (gt_logfp) { + fwrite (ttybuf, nchars, 1, gt_logfp); + if (time(0) - oldtime > LOG_SYNCTIME) { + /* Sync the logfile output every so often. */ + fflush (gt_logfp); + oldtime = time(0); + } + } + + if (gio_enabled == GRAPHICS_OFF || nchars <= 0) + return (nchars); + + /* If in text mode, make a quick scan for the GS character and return + * the entire data packet if GS is not seen. + */ + if (!gio_graphicsenabled) { + while (ip < itop && *ip != GS) + ip++; + if (ip >= itop) + return (nchars); + else { + gio_graphicsenabled++; + op = ip; + } + } else + op = ttybuf; + + /* Process rest of data in graphics mode. IP is pointing at the + * first char of graphics data, ITOP at the top of the buffer, + * and OP at the next tty output char. Filter out any NULs in + * the process of copying the data. + */ + while (ip < itop) + if (gio_graphicsenabled) { + while (ip < itop) + if ((ch = *ip++) == CAN) { + g_putc (ch); + gio_graphicsenabled = 0; + break; + } else if (ch) + g_putc (ch); + } else { + while (ip < itop) + if ((ch = *ip++) == GS) { + g_putc (ch); + gio_graphicsenabled = 1; + break; + } else if (ch) + *op++ = ch; + } + + /* If the gio buffer has reached the high-water mark and XOFF is + * not currently set, send XOFF to the terminal driver. + */ + if (g_spaceleft < GB_MINSPACE && !pty_stop) { + ioctl (pty_fd, TIOCSTOP, NULL); + pty_stop++; + } + + /* Post an event with the notifier to call the graphics drawing code + * back to process the new data. + */ + if (!gio_delay) + notify_post_event (ev_gioprocessdata, NULL, NOTIFY_SAFE); + + return (op - ttybuf); +} + + +/* EV_GIOPROCESSDATA -- Called to process graphics instructions and data from + * the gio buffer. This is the routine which actually draws lines and text + * in the graphics frame. May be called repeatedly to process any amount of + * data at a time. If there is a great amount of data to be processed the + * routine should return occasionally to allow the other GTERM event handlers + * to run (operation is not fully asynchronous). + * + * Graphics data is processed as a stream with no record boundaries, so that + * operation is not dependent on how data is buffered through the system. + * The graphics frame is a state machine which is by definition always in a + * legal state; garbage input causes garbage output, just like a real terminal. + * The states are as follows: + * + * COMMAND_MODE This is the initial state. Characters are accumulated + * until a known state is recognized. Receipt of ESC + * always causes command mode to be entered, since + * additional characters are needed to define the next + * instruction. + * + * ALPHA_MODE Characters are drawn in the graphics frame at the + * "current" position (normally set beforehand with a + * GS/US vector move), using the alpha mode font. + * Receipt of any control code causes alpha mode to be + * exited. + * + * TEXT_MODE Text mode is a special mode used to write transient + * text in the status line, using the text mode font. + * Lines of text are accumulated and displayed on the + * status line in reverse video; successive lines of text + * overwrite one another. The status line is cleared + * when text mode is entered, even if no text is drawn. + * Text mode is terminated by receipt of GS or CAN. + * + * VECTOR_MODE Vector mode refers to both polyline and polypoint + * vector sequences. The vertices of the points are + * accumulated in a buffer and displayed when the buffer + * fills or when vector mode is terminated. Vector + * mode is terminated by receipt of any control code; + * the tektronix coordinate encoding maps all possible + * coordinates into the printable ascii codes. + * + * CURSOR_MODE The crosshair cursor is turned on, signifying to the + * user that the system is waiting on a cursor read. + * Output processing ceases until the user types a key + * or presses a mouse button to trigger the cursor read. + * The cursor value is then encoded and transmitted back + * to the pty, and output processing resumes. + * + * Clearing the screen causes the mode to be reset to command mode, and all + * other drawing parameters to be set to their default values, e.g., data level + * on, solid line type, and so on. + */ +static Notify_value +ev_gioprocessdata() +{ + register int quota, ch; + char *save_ip, *ip_start; + int delay = 0; + + pw_lock (pw, &pw_r); + g_mark (ip_start); + + /* Process data. + */ + for (quota=MAX_QUOTA; --quota >= 0 && g_getc(ch) >= 0; ) { + if (ch == 0 || gio_enabled == GRAPHICS_DISCARD) + continue; +again: + switch (gio_mode) { + case COMMAND_MODE: + switch (ch) { + case GS: + case FS: + gio_mode = VECTOR_MODE; + pl_npts = 0; + pl_op = 0; + pl_pointmode = (ch == FS); + chcur_skip = -1; + if (cursor_show) + gio_setcursor (CURSOR_OFF, 0); + + /* Only execute an open workstation if we have not already + * done so and if the next command is something other than + * close workstation, i.e., no-op sequences GS-CAN are + * filtered out, since they would only cause a pointless + * switch to the graphics frame and back without drawing. + */ + if (ch == GS && !workstation_open) + if (g_getc(ch) < 0) { + g_ungetc (GS); + gio_mode = COMMAND_MODE; + goto exit; + } else if (ch != CAN) { + gio_open_workstation(); + workstation_open = 1; + delay = WSOPEN_DELAY; + g_ungetc (ch); + goto exit; + } + break; + + case US: + case CR: + gio_mode = ALPHA_MODE; + tx_len = 0; + if (ch == CR) + goto again; + break; + + case CAN: + if (workstation_open) { + pw_unlock (pw); + gio_close_workstation(); + workstation_open = 0; + delay = WSCLOSE_DELAY; + } + gio_mode = COMMAND_MODE; + goto exit; + + case ESC: + g_ungetc (ch); + g_mark (save_ip); + erase_cursor(); + if ((gio_mode = gio_escape()) == -1) { + gio_mode = COMMAND_MODE; + g_reset (save_ip); + goto exit; + } else if (gio_mode == CURSOR_MODE) + goto again; + break; + + case BEL: + window_bell (gio_canvas); + break; + + default: + ; /* ignore unknown control chars */ + } + break; + + case ALPHA_MODE: + /* Tek alpha mode is used to write text to random positions on + * the screen, or to write lines of text to the gio frame in + * "storage scope" mode, where the left and right columns are + * alternately written into with an inclusive-or rop. + */ + if (ch >= 040) { + tx_buf[tx_len++] = ch; + } else if (ch == '\t') { + tx_buf[tx_len++] = 040; + if (tx_leftmargin == 0) + while ((tx_len + (cur_x / tx_charwidth)) % 8 != 0) + tx_buf[tx_len++] = 040; + } else if (ch == '\010' || ch == '\177') { + if (tx_len > 0) + tx_len--; + else if (cur_x > tx_leftmargin) + cur_x -= tx_charwidth; + } else { +flush_alpha: if (tx_len > 0) { + tx_buf[tx_len] = '\0'; + erase_cursor(); + pw_text (pw, cur_x, cur_y, gio_rop(), + alpha_font->pixfont, tx_buf); + } + + cur_x += tx_len * tx_charwidth; + tx_len = 0; + + if (ch == '\n' || ch == BREAK_LINE) { + cur_y += tx_charheight; + if (cur_y > win_yres) { + if (tx_leftmargin == 0) + tx_leftmargin = win_xres / 2; + else + tx_leftmargin = 0; + cur_y = tx_charbase; + if (cur_x < tx_leftmargin) + cur_x = tx_leftmargin; + } + if (ch == BREAK_LINE) + cur_x = tx_leftmargin; + } else if (ch == '\r') { + cur_x = tx_leftmargin; + } else if (ch != 0) { + gio_mode = COMMAND_MODE; + goto again; + } + } + + /* Break long lines at the right margin. */ + if (cur_x + (tx_len * tx_charwidth) >= win_xres) { + ch = BREAK_LINE; + goto flush_alpha; + } + + break; + + case TEXT_MODE: + if (ch >= 040) + tx_buf[tx_len++] = ch; + else if (ch == '\t') + tx_buf[tx_len++] = 040; + else if (ch == '\010' || ch == '\177') { + if (tx_len > 0) { + --tx_len; + sl_x -= sl_cwidth; + erase_cursor(); + pw_text (pw, sl_x, sl_y, + PIX_SRC, text_font->pixfont, " "); + } + } else { + if (tx_len > 0) { + tx_buf[tx_len] = '\0'; + erase_cursor(); + pw_text (pw, sl_x, sl_y, + PIX_NOT(PIX_SRC), text_font->pixfont, tx_buf); + } + + sl_x += tx_len * sl_cwidth; + if (sl_x > win_xres - sl_cwidth) + sl_x = win_xres - sl_cwidth; + tx_len = 0; + + if (ch == '\r' || ch == '\n') { + sl_x = sl_xoff; + sl_restore_rect(); + } else if (ch != 0) { + gio_mode = COMMAND_MODE; + goto again; + } + } + + /* Truncate long lines. */ + if (sl_x / sl_cwidth + tx_len >= MAX_TEXTCHARS) + if (tx_len > 0) + --tx_len; + else + sl_x -= sl_cwidth; + break; + + case VECTOR_MODE: + /* Following receipt of GS, accumulate encoded coordinate data + * until the buffer fills or a control code is received, then + * decode the encoded data to reconstruct the original data + * vector, and draw the vector. + */ + if (ch >= 040) + pl_text[pl_op++] = ch; + if (ch < 040 || pl_op >= MAX_PLPTS) + pl_decodepts(); + + if (ch < 040 || pl_npts >= MAX_PLPTS) { + if (pl_pointmode && pl_npts >= 1) { + pw_polypoint (pw, 0, 0, pl_npts, pl_p, + PIX_COLOR(1) | gio_rop()); + } else if (pl_npts >= 2) { + /* Must use clipping if dashed line. */ + pw_polyline (pw, 0, 0, pl_npts, pl_p, + POLY_DONTCLOSE, &brush, pl_texture(pl_linestyle), + (PIX_COLOR(1) | gio_rop()) & + ~(pl_linestyle ? PIX_DONTCLIP : 0)); + } + + if (pl_npts > 0) { + cur_x = pl_p[pl_npts-1].x; + cur_y = pl_p[pl_npts-1].y; + pl_npts = 0; + } + + if (ch < 040) { + gio_mode = COMMAND_MODE; + pl_op = 0; + goto again; + } + } + + break; + + case CURSOR_MODE: + if (wait_cursor++) { + g_ungetc (ch); + gio_mode = COMMAND_MODE; + } else + gio_readcursor(); + break; + } + } + +exit: + /* Flush any buffered text before exiting, as applications will assume + * that text appears on the screen as soon as chars are written to the + * terminal (any buffering must be hidden). + */ + if (tx_len > 0) { + ch = 0; + goto again; + } + + update_cursor(); + pw_unlock (pw); + + /* If XOFF is set and the buffer has emptied sufficiently, + * send XON to the terminal driver to accept more data. + */ + if (pty_stop && g_spaceleft > GB_BIGSPACE) { + ioctl (pty_fd, TIOCSTART, NULL); + pty_stop = 0; + } + + /* If there is still data in the buffer (other than a partially + * formed escape sequence) post another callback event before exiting + * to allow other event handlers to run. + */ + if (delay) + gio_pause (delay); + else if (g_havedata && !g_equal(ip_start) && ch != ESC && !wait_cursor) + notify_post_event (ev_gioprocessdata, NULL, NOTIFY_SAFE); + + return (NOTIFY_DONE); +} + + +/* PL_DECODEPTS -- Convert a sequence of textronix encoded polyline vertices + * into a simple array of [x,y] coordinate pairs. Each coordinate pair is + * encoded as a sequence of from 1 to 4 bytes, with bytes being optionally + * eliminated which do not change from one coordinate pair to the next. The + * possible coordinate pair encodings are as follows: + * + * HIY LOY HIX LOX + * 01xxxxx 11xxxxx 01xxxxx 10xxxxx + * 040 140 040 100 + * + * HIY LOX + * HIY LOY LOX + * HIY LOY HIX LOX + * LOY HIX LOX + * LOY LOX + * LOX + * + * In words, bytes which do not change need not be sent, except for the low-x + * byte (LOX). If the high-x byte changes, then the low-x byte must also be + * sent. The current position, stored as the 4 byte encoding, is cleared to + * zero when the screen is cleared. + */ +static +pl_decodepts() +{ + register char *ip, *itop; + int hiy, loy, hix, lox, type, data, nb; + char *ip_save; + + for (ip_save=ip=pl_text, itop = &pl_text[pl_op]; ip < itop; ) { + hiy = ohiy; loy = oloy; + hix = ohix; lox = olox; + + for (nb=0; nb < 99 && ip < itop; nb++) { + type = (*ip & 0140); + data = (*ip++ & 037); + + switch (type) { + case 040: /* HIY, HIX */ + if (nb == 0) + hiy = data; + else + hix = data; + break; + case 0140: /* LOY */ + loy = data; + break; + + case 0100: + /* Receipt of LOX marks the end of the variable length + * sequence of bytes required to form the next [x,y]. + */ + lox = data; + pl_p[pl_npts].x = X_TEK2WIN ((hix << 5) + lox); + pl_p[pl_npts].y = Y_TEK2WIN ((hiy << 5) + loy); + + /* Update current position. */ + ohiy = hiy; oloy = loy; + ohix = hix; olox = lox; + + ip_save = ip; + pl_npts++; + nb = 99; /* EXIT */ + break; + } + } + } + + /* If there is any data left over (too few bytes to form a coordinate + * pair) move these to the start of the buffer. + */ + for (pl_op=0, ip=ip_save; ip < itop; ) + pl_text[pl_op++] = *ip++; +} + + +/* GIO_PAUSE -- Suspend output for the indicated number of milliseconds, to + * allow other event processing to catch up. When the specified interval has + * passed an ev_gioprocessdata event is posted to resume output processing. + */ +gio_pause (msec) +int msec; +{ + static Notify_value ev_restart(); + static struct itimerval itimer_delay; + + gio_delay = msec; + + itimer_delay.it_interval.tv_usec = 0; + itimer_delay.it_interval.tv_sec = 0; + + itimer_delay.it_value.tv_usec = (msec % 1000) * 1000; + itimer_delay.it_value.tv_sec = (msec / 1000); + + notify_set_itimer_func (&itimer_delay, ev_restart, ITIMER_REAL, + &itimer_delay, NULL); +} + + +/* EV_RESTART -- Called when the specified interval has passed to restart + * output processing. + */ +static Notify_value +ev_restart() +{ + gio_delay = 0; + notify_post_event (ev_gioprocessdata, NULL, NOTIFY_SAFE); + + return (NOTIFY_DONE); +} + + +/* GIO_RETCURSOR -- Encode and return a cursor value to the pty (and thence + * to the program which initiated the cursor read). Clear the cursor read + * pending flag so that output processing can resume, and post an event to + * restart the output processing routine. + */ +gio_retcursor (key, x, y) +int key; /* key (or whatever) typed to trigger read */ +int x, y; /* pixwin coords of event */ +{ + register int mc_x, mc_y; + char curval[7]; + int len; + + /* Ignore cursor events unless requested via program control. + */ + if (!wait_cursor) + return (-1); + + mc_x = X_WIN2TEK (x); + mc_y = Y_WIN2TEK (y); + + curval[0] = key; + curval[1] = ((mc_x >> 5) & 037) | 040; + curval[2] = ((mc_x ) & 037) | 040; + curval[3] = ((mc_y >> 5) & 037) | 040; + curval[4] = ((mc_y ) & 037) | 040; + curval[5] = trailer1; + curval[6] = trailer2; + + len = 5; + if (trailer1 >= 0) len++; + if (trailer2 >= 0) len++; + write (pty_fd, curval, len); + + wait_cursor = 0; + gio_mode = COMMAND_MODE; + chcur_skip = -1; + + if (!gio_delay) + notify_post_event (ev_gioprocessdata, NULL, NOTIFY_SAFE); +} + + +/* GIO_RETENQ -- Respond to the ESC ENQ request. + */ +gio_retenq() +{ + register int mc_x, mc_y; + char curval[7]; + int len; + + /* Graphics status word. */ + curval[0] = (061 | ((gio_mode == ALPHA_MODE) << 2) + | ((tx_leftmargin != 0) << 1)); + + /* Alpha cursor position. */ + mc_x = X_WIN2TEK (cur_x); + mc_y = Y_WIN2TEK (cur_y); + + curval[1] = ((mc_x >> 5) & 037) | 040; + curval[2] = ((mc_x ) & 037) | 040; + curval[3] = ((mc_y >> 5) & 037) | 040; + curval[4] = ((mc_y ) & 037) | 040; + curval[5] = trailer1; + curval[6] = trailer2; + + len = 5; + if (trailer1 >= 0) len++; + if (trailer2 >= 0) len++; + write (pty_fd, curval, len); +} + + +/* Definitions and data structures for a fast table driven fixed pattern + * escape sequence recognizer. Given character I of the sequence there will + * be N candidate sequences that have matched the first I-1 chars. Examine + * each to produce the next list of candidate sequences. Continue until either + * a sequence is matched or there are no more candidates. Variable length + * sequences such as "ESC[Pl;PcH" are handled as a special case: the general + * form of these is ESC '[' [';' ...] LET. + */ +#define MAX_CANDIDATES 32 /* max candidate escseq */ +#define MAX_FIELDS 6 /* max fields in an escseq */ + +struct _esc { + char e_tag; /* integer code for escseq */ + char e_seq[MAX_FIELDS+1]; /* the sequence itself */ +}; + +static struct _esc *e_cand1[MAX_CANDIDATES]; /* 1st candidates array */ +static struct _esc *e_cand2[MAX_CANDIDATES]; /* 2nd candidates array */ +static struct _esc **e_pcand, **e_acand; /* candidates arrays */ +static int e_npcand, e_nacand; /* number of candidates */ +static int e_charno; /* char being examined */ + +static struct _esc e_table[] = { +#include "gterm.esc" /* Gterm escape sequence table */ + { 0, 0,0,0,0,0,0,0 } +}; + + +/* GIO_ESCAPE -- Recognize and process graphics escape sequences, i.e., + * all multicharacter command codes beginning with ESC. The simple single + * character command codes are handled directly by the data processing code. + * The escapes have no well defined pattern to them, hence we must simply + * consume characters until a legal escape sequence is recognized or the + * sequence is found to not match any known sequence. It is possible that + * all of the characters forming a sequence will not yet have been deposited + * in the input buffer, in which case we return -1, indicating to our caller + * that we should be called back later to rescan the same input, when more + * data becomes available. Otherwise, we take whatever action is implied + * for the escape sequence and return the new mode to the interpreter code. + * If an unrecognized escape sequence is encountered it is discarded and we + * return in alpha mode so that subsequent input appears as garbage on the + * screen. + */ +gio_escape() +{ + register struct _esc *esc; + register int ch, i, j; + struct _esc **e_temp; + int tag; + + /* Discard the ESC and get the first char. */ + g_getc (ch); + if (g_getc (ch) < 0) + return (-1); + + /* Build the initial list of candidates. This is the most expensive + * step, since all sequences must be examined. + */ + for (esc=e_table, e_pcand=e_cand1, e_npcand=0; esc->e_tag; esc++) + if (ch == esc->e_seq[0]) { + if (esc->e_seq[1] == 0) { + tag = esc->e_tag; + goto action; + } + e_pcand[e_npcand++] = esc; + } + + /* If there were no candidates, we are done. */ + if (e_npcand == 0) { + g_ungetc (ch); + return (ALPHA_MODE); + } + + /* Examine successive characters from the input, building a new, + * shorter candidate list on each iteration. This should converge + * very rapidly one way or the other. + */ + for (j=1, e_acand=e_cand2; j < MAX_FIELDS && e_npcand > 0; j++) { + if (g_getc(ch) < 0) + return (-1); + + /* Examine the next character of each sequence in the list of + * candidate sequences. If we have a complete match, we are + * done, else if we have a single character match add the seq + * to the new candidates list. + */ + e_nacand = 0; + for (i=0; i < e_npcand; i++) { + esc = e_pcand[i]; + if (ch == esc->e_seq[j]) { + if (esc->e_seq[j+1] == 0) { + tag = esc->e_tag; + goto action; + } + e_acand[e_nacand++] = esc; + } + } + + e_temp = e_pcand; e_pcand = e_acand; e_acand = e_temp; + e_npcand = e_nacand; + } + + /* If the escape sequence was recognized the above code should have + * vectored off to the action marker below. If we fall through the + * loop it can only mean that we have an unrecognized escape sequence, + * so discard it and return in command mode. + */ + g_ungetc (ch); + return (ALPHA_MODE); + +action: + /* Process the escape sequence. */ + switch (tag) { + case ESC_SETTEXTMODE: + tx_len = 0; + sl_x = sl_xoff; + if (sl_rect_saved) + sl_restore_rect(); + else + sl_save_rect(); + return (TEXT_MODE); + + case ESC_ENQUIRE: + gio_retenq(); + break; + case ESC_READCURSOR: + return (CURSOR_MODE); + case ESC_SETCURSOR: + gio_setcursorpos (cur_x, cur_y); + break; + + case ESC_CLEARSCREEN: + pw_writebackground (pw, 0, 0, win_xres, win_yres, PIX_SRC); + tx_leftmargin = 0; + cur_x = tx_leftmargin; + cur_y = tx_charbase; + ohiy = 0; oloy = 0; + ohix = 0; olox = 0; + gio_datalevel = SET_BITS; + pl_linestyle = 0; + pl_linewidth = 1; + pl_pointmode = 0; + sl_rect_saved = 0; + chcur_on = 0; + chcur_skip = 0; + return (ALPHA_MODE); + + case ESC_SETCHARSIZE0: + case ESC_SETCHARSIZE1: + case ESC_SETCHARSIZE2: + case ESC_SETCHARSIZE3: + /* Ignore these for now. */ + break; + + case ESC_SETDATALEVEL0: + gio_datalevel = SET_BITS; + break; + case ESC_SETDATALEVEL1: + gio_datalevel = CLEAR_BITS; + break; + case ESC_SETDATALEVEL2: + gio_datalevel = TOGGLE_BITS; + break; + + case ESC_SETLINESTYLE0: + pl_linestyle = 0; + break; + case ESC_SETLINESTYLE1: + pl_linestyle = 1; + break; + case ESC_SETLINESTYLE2: + pl_linestyle = 2; + break; + case ESC_SETLINESTYLE3: + pl_linestyle = 3; + break; + case ESC_SETLINESTYLE4: + pl_linestyle = 4; + break; + + case ESC_SETLINEWIDTH0: + pl_linewidth = 1; + break; + case ESC_SETLINEWIDTH1: + pl_linewidth = 2; + break; + case ESC_SETLINEWIDTH2: + pl_linewidth = 3; + break; + default: + ; + } + + return (COMMAND_MODE); +} + + +/* UPDATE_CURSOR -- Update the state of the alpha mode cursor, used to mark + * the position of the next character on the screen when in alpha mode. + * In any other mode this cursor is turned off. + */ +update_cursor() +{ + erase_cursor(); + if (gio_mode == ALPHA_MODE && chcur_skip++ >= 0) { + /* Update the position of the alpha character cursor. + */ + pw_text (pw, cur_x, cur_y, + PIX_NOT(PIX_DST), alpha_font->pixfont, " "); + chcur_font = alpha_font; + chcur_x = cur_x; + chcur_y = cur_y; + chcur_on = 1; + + /* Turn the mouse cursor on too, if currently disabled. + */ + gio_setcursor (CURSOR_ON, 0); + } +} + + +/* ERASE_CURSOR -- If the character cursor is currently displayed, restore the + * character under the cursor to its former state. + */ +erase_cursor() +{ + if (chcur_on) { + pw_text (pw, chcur_x, chcur_y, + PIX_NOT(PIX_DST), chcur_font->pixfont, " "); + chcur_on = 0; + } +} + + +/* SL_SAVE_RECT -- Make a copy of the status line pixrect in a memory + * pixrect, so that we can later "erase" the status line by overwriting + * it with the saved data rect. + */ +sl_save_rect() +{ + if (sl_pr) { + pw_read (sl_pr, 0, 0, sl_width, sl_height, PIX_SRC, + pw, sl_xoff, sl_yoff - sl_cbase); + sl_rect_saved = 1; + } +} + + +/* SL_RESTORE_RECT -- Restore the saved status line data pixrect. + */ +sl_restore_rect() +{ + if (sl_pr) + pw_write (pw, sl_xoff, sl_yoff - sl_cbase, sl_width, sl_height, + PIX_SRC, sl_pr, 0, 0); +} + + +/* GIO_ROP -- Return the raster op appropriate for the datalevel control + * option set by the user, i.e, set, clear, or toggle bits. + */ +gio_rop() +{ + register int rop; + + switch (gio_datalevel) { + case SET_BITS: + rop = PIX_SRC | PIX_DST; + break; + case CLEAR_BITS: + rop = PIX_NOT(PIX_SRC) & PIX_DST; + break; + case TOGGLE_BITS: + rop = PIX_SRC ^ PIX_DST; + break; + default: + rop = PIX_SRC; + break; + } + + if (!clip_graphics) + rop |= PIX_DONTCLIP; + + return (rop); +} + + +#define NLINETYPES 5 +static short lt_dashed[] = { 8, 3, 8, 3, 8, 3, 8, 3, 0 }; +static short lt_dotted[] = { 2, 3, 2, 3, 2, 3, 2, 3, 0 }; +static short lt_dashdot[] = { 14, 3, 1, 3, 14, 3, 1, 3, 0 }; +static short lt_dash3dot[] = { 20, 3, 1, 3, 1, 3, 1, 3, 0 }; + +static short *lt_pattern[] = { + NULL, + lt_dashed, + lt_dotted, + lt_dashdot, + lt_dash3dot +}; + + +/* PL_TEXTURE -- Return a pointer to a texture descriptor (Breshingham + * dashed line drawing algorithm) to be used to draw a dashed polyline. + * The case linetype==0 is special, signifying a solid line. The descriptor + * must be initialized to a known state, i.e., zeroed, on each call or + * the pixrect polyline code will produce garbage. + */ +static Pr_texture * +pl_texture (linetype) +int linetype; +{ + register char *p; + register int n; + static Pr_texture tex; + short *pattern; + + if (linetype == 0) + return (NULL); /* solid line */ + else + pattern = lt_pattern[linetype % NLINETYPES]; + + for (p=(char *)(&tex), n=sizeof(tex); --n >= 0; ) + *p++ = NULL; + + tex.pattern = pattern; + tex.options.givenpattern = 1; + + return (&tex); +} diff --git a/unix/sun/halley.lut b/unix/sun/halley.lut new file mode 100644 index 00000000..ac00326a --- /dev/null +++ b/unix/sun/halley.lut @@ -0,0 +1,257 @@ +256, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.86275, +0.00000, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.51765, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98431, 0.81176, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 1.00000, +0.00000, 1.00000, 1.00000, +0.47059, 0.78431, 1.00000, +0.47059, 0.78431, 1.00000, +0.47059, 0.78431, 1.00000, +0.62745, 0.62745, 1.00000, +0.62745, 0.62745, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +1.00000, 0.70588, 1.00000, +1.00000, 0.70588, 1.00000, +1.00000, 0.76863, 1.00000, +1.00000, 0.86275, 1.00000, +1.00000, 0.86275, 1.00000, +1.00000, 1.00000, 1.00000, +1.00000, 1.00000, 1.00000, +1.00000, 1.00000, 1.00000, +1.00000, 1.00000, 1.00000, +1.00000, 0.89804, 1.00000, +1.00000, 0.86275, 1.00000, +1.00000, 0.86275, 1.00000, +1.00000, 0.86275, 1.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.92157, 0.61961, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.78431, 0.47059, 1.00000, +0.65882, 0.59608, 1.00000, +0.62745, 0.62745, 1.00000, +0.62745, 0.62745, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +0.00000, 0.00000, 1.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 0.70588, +0.00000, 1.00000, 0.65490, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.00000, 1.00000, 0.00000, +0.36078, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.70588, 1.00000, 0.00000, +0.98431, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +1.00000, 1.00000, 0.00000, +0.99608, 0.97647, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98431, 0.85098, 0.00000, +0.98824, 0.77647, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +0.98824, 0.72549, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.36863, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.00000, +1.00000, 0.00000, 0.46667, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 0.70588, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +1.00000, 0.00000, 1.00000, +0.91373, 0.00000, 0.97255, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.70588, 0.00000, 0.90196, +0.53333, 0.00000, 0.87451, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +0.47059, 0.00000, 0.86275, +1.00000, 1.00000, 1.00000, +1.00000, 1.00000, 1.00000, +1.00000, 1.00000, 1.00000, +1.00000, 1.00000, 1.00000, +1.00000, 1.00000, 1.00000, +0.00000, 0.00000, 0.86275, +0.00000, 0.00000, 0.86275, +0.00000, 0.00000, 0.86275, +0.00000, 0.00000, 0.86275, +0.00000, 0.00000, 0.80392, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.70588, +0.00000, 0.00000, 0.13725, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000, +0.00000, 0.00000, 0.00000 diff --git a/unix/sun/heat.lut b/unix/sun/heat.lut new file mode 100644 index 00000000..124a70f4 --- /dev/null +++ b/unix/sun/heat.lut @@ -0,0 +1,257 @@ +256, +0.00000, 0.00000, 0.00000, +0.01176, 0.00392, 0.00000, +0.02353, 0.00784, 0.00000, +0.03529, 0.01176, 0.00000, +0.04706, 0.01569, 0.00000, +0.05882, 0.01961, 0.00000, +0.07059, 0.02353, 0.00000, +0.08235, 0.02745, 0.00000, +0.09412, 0.03137, 0.00000, +0.10588, 0.03529, 0.00000, +0.11765, 0.03922, 0.00000, +0.12941, 0.04314, 0.00000, +0.14118, 0.04706, 0.00000, +0.15294, 0.05098, 0.00000, +0.16471, 0.05490, 0.00000, +0.17647, 0.05882, 0.00000, +0.18824, 0.06275, 0.00000, +0.20000, 0.06667, 0.00000, +0.21176, 0.07059, 0.00000, +0.22353, 0.07451, 0.00000, +0.23529, 0.07843, 0.00000, +0.24706, 0.08235, 0.00000, +0.25882, 0.08627, 0.00000, +0.27059, 0.09020, 0.00000, +0.28235, 0.09412, 0.00000, +0.29412, 0.09804, 0.00000, +0.30588, 0.10196, 0.00000, +0.31765, 0.10588, 0.00000, +0.32941, 0.10980, 0.00000, +0.34118, 0.11373, 0.00000, +0.35294, 0.11765, 0.00000, +0.36471, 0.12157, 0.00000, +0.37647, 0.12549, 0.00000, +0.38824, 0.12941, 0.00000, +0.40000, 0.13333, 0.00000, +0.41176, 0.13725, 0.00000, +0.42353, 0.14118, 0.00000, +0.43529, 0.14510, 0.00000, +0.44706, 0.14902, 0.00000, +0.45882, 0.15294, 0.00000, +0.47059, 0.15686, 0.00000, +0.48235, 0.16078, 0.00000, +0.49412, 0.16471, 0.00000, +0.50588, 0.16863, 0.00000, +0.51765, 0.17255, 0.00000, +0.52941, 0.17647, 0.00000, +0.54118, 0.18039, 0.00000, +0.55294, 0.18431, 0.00000, +0.56471, 0.18824, 0.00000, +0.57647, 0.19216, 0.00000, +0.58824, 0.19608, 0.00000, +0.60000, 0.20000, 0.00000, +0.61176, 0.20392, 0.00000, +0.62353, 0.20784, 0.00000, +0.63529, 0.21176, 0.00000, +0.64706, 0.21569, 0.00000, +0.65882, 0.21961, 0.00000, +0.67059, 0.22353, 0.00000, +0.68235, 0.22745, 0.00000, +0.69412, 0.23137, 0.00000, +0.70588, 0.23529, 0.00000, +0.71765, 0.23922, 0.00000, +0.72941, 0.24314, 0.00000, +0.74118, 0.24706, 0.00000, +0.75294, 0.25098, 0.00000, +0.76471, 0.25490, 0.00000, +0.77647, 0.25882, 0.00000, +0.78824, 0.26275, 0.00000, +0.80000, 0.26667, 0.00000, +0.81176, 0.27059, 0.00000, +0.82353, 0.27451, 0.00000, +0.83529, 0.27843, 0.00000, +0.84706, 0.28235, 0.00000, +0.85882, 0.28627, 0.00000, +0.87059, 0.29020, 0.00000, +0.88235, 0.29412, 0.00000, +0.89412, 0.29804, 0.00000, +0.90588, 0.30196, 0.00000, +0.91765, 0.30588, 0.00000, +0.92941, 0.30980, 0.00000, +0.94118, 0.31373, 0.00000, +0.95294, 0.31765, 0.00000, +0.96471, 0.32157, 0.00000, +0.97647, 0.32549, 0.00000, +0.98824, 0.32941, 0.00000, +1.00000, 0.33333, 0.00000, +1.00000, 0.33725, 0.00000, +1.00000, 0.34118, 0.00000, +1.00000, 0.34510, 0.00000, +1.00000, 0.34902, 0.00000, +1.00000, 0.35294, 0.00000, +1.00000, 0.35686, 0.00000, +1.00000, 0.36078, 0.00000, +1.00000, 0.36471, 0.00000, +1.00000, 0.36863, 0.00000, +1.00000, 0.37255, 0.00000, +1.00000, 0.37647, 0.00000, +1.00000, 0.38039, 0.00000, +1.00000, 0.38431, 0.00000, +1.00000, 0.38824, 0.00000, +1.00000, 0.39216, 0.00000, +1.00000, 0.39608, 0.00000, +1.00000, 0.40000, 0.00000, +1.00000, 0.40392, 0.00000, +1.00000, 0.40784, 0.00000, +1.00000, 0.41176, 0.00000, +1.00000, 0.41569, 0.00000, +1.00000, 0.41961, 0.00000, +1.00000, 0.42353, 0.00000, +1.00000, 0.42745, 0.00000, +1.00000, 0.43137, 0.00000, +1.00000, 0.43529, 0.00000, +1.00000, 0.43922, 0.00000, +1.00000, 0.44314, 0.00000, +1.00000, 0.44706, 0.00000, +1.00000, 0.45098, 0.00000, +1.00000, 0.45490, 0.00000, +1.00000, 0.45882, 0.00000, +1.00000, 0.46275, 0.00000, +1.00000, 0.46667, 0.00000, +1.00000, 0.47059, 0.00000, +1.00000, 0.47451, 0.00000, +1.00000, 0.47843, 0.00000, +1.00000, 0.48235, 0.00000, +1.00000, 0.48627, 0.00000, +1.00000, 0.49020, 0.00000, +1.00000, 0.49412, 0.00000, +1.00000, 0.49804, 0.00000, +1.00000, 0.50196, 0.00000, +1.00000, 0.50588, 0.00000, +1.00000, 0.50980, 0.00000, +1.00000, 0.51373, 0.00000, +1.00000, 0.51765, 0.00000, +1.00000, 0.52157, 0.00000, +1.00000, 0.52549, 0.00000, +1.00000, 0.52941, 0.00000, +1.00000, 0.53333, 0.00000, +1.00000, 0.53725, 0.00000, +1.00000, 0.54118, 0.00000, +1.00000, 0.54510, 0.00000, +1.00000, 0.54902, 0.00000, +1.00000, 0.55294, 0.00000, +1.00000, 0.55686, 0.00000, +1.00000, 0.56078, 0.00000, +1.00000, 0.56471, 0.00000, +1.00000, 0.56863, 0.00000, +1.00000, 0.57255, 0.00000, +1.00000, 0.57647, 0.00000, +1.00000, 0.58039, 0.00000, +1.00000, 0.58431, 0.00000, +1.00000, 0.58824, 0.00000, +1.00000, 0.59216, 0.00000, +1.00000, 0.59608, 0.00000, +1.00000, 0.60000, 0.00000, +1.00000, 0.60392, 0.00000, +1.00000, 0.60784, 0.00000, +1.00000, 0.61176, 0.00000, +1.00000, 0.61569, 0.00000, +1.00000, 0.61961, 0.00000, +1.00000, 0.62353, 0.00000, +1.00000, 0.62745, 0.00000, +1.00000, 0.63137, 0.00000, +1.00000, 0.63529, 0.00000, +1.00000, 0.63922, 0.00000, +1.00000, 0.64314, 0.00000, +1.00000, 0.64706, 0.00000, +1.00000, 0.65098, 0.01176, +1.00000, 0.65490, 0.02353, +1.00000, 0.65882, 0.03529, +1.00000, 0.66275, 0.04706, +1.00000, 0.66667, 0.05882, +1.00000, 0.67059, 0.07059, +1.00000, 0.67451, 0.08235, +1.00000, 0.67843, 0.09412, +1.00000, 0.68235, 0.10588, +1.00000, 0.68627, 0.11765, +1.00000, 0.69020, 0.12941, +1.00000, 0.69412, 0.14118, +1.00000, 0.69804, 0.15294, +1.00000, 0.70196, 0.16471, +1.00000, 0.70588, 0.17647, +1.00000, 0.70980, 0.18824, +1.00000, 0.71373, 0.20000, +1.00000, 0.71765, 0.21176, +1.00000, 0.72157, 0.22353, +1.00000, 0.72549, 0.23529, +1.00000, 0.72941, 0.24706, +1.00000, 0.73333, 0.25882, +1.00000, 0.73725, 0.27059, +1.00000, 0.74118, 0.28235, +1.00000, 0.74510, 0.29412, +1.00000, 0.74902, 0.30588, +1.00000, 0.75294, 0.31765, +1.00000, 0.75686, 0.32941, +1.00000, 0.76078, 0.34118, +1.00000, 0.76471, 0.35294, +1.00000, 0.76863, 0.36471, +1.00000, 0.77255, 0.37647, +1.00000, 0.77647, 0.38824, +1.00000, 0.78039, 0.40000, +1.00000, 0.78431, 0.41176, +1.00000, 0.78824, 0.42353, +1.00000, 0.79216, 0.43529, +1.00000, 0.79608, 0.44706, +1.00000, 0.80000, 0.45882, +1.00000, 0.80392, 0.47059, +1.00000, 0.80784, 0.48235, +1.00000, 0.81176, 0.49412, +1.00000, 0.81569, 0.50588, +1.00000, 0.81961, 0.51765, +1.00000, 0.82353, 0.52941, +1.00000, 0.82745, 0.54118, +1.00000, 0.83137, 0.55294, +1.00000, 0.83529, 0.56471, +1.00000, 0.83922, 0.57647, +1.00000, 0.84314, 0.58824, +1.00000, 0.84706, 0.60000, +1.00000, 0.85098, 0.61176, +1.00000, 0.85490, 0.62353, +1.00000, 0.85882, 0.63529, +1.00000, 0.86275, 0.64706, +1.00000, 0.86667, 0.65882, +1.00000, 0.87059, 0.67059, +1.00000, 0.87451, 0.68235, +1.00000, 0.87843, 0.69412, +1.00000, 0.88235, 0.70588, +1.00000, 0.88627, 0.71765, +1.00000, 0.89020, 0.72941, +1.00000, 0.89412, 0.74118, +1.00000, 0.89804, 0.75294, +1.00000, 0.90196, 0.76471, +1.00000, 0.90588, 0.77647, +1.00000, 0.90980, 0.78824, +1.00000, 0.91373, 0.80000, +1.00000, 0.91765, 0.81176, +1.00000, 0.92157, 0.82353, +1.00000, 0.92549, 0.83529, +1.00000, 0.92941, 0.84706, +1.00000, 0.93333, 0.85882, +1.00000, 0.93725, 0.87059, +1.00000, 0.94118, 0.88235, +1.00000, 0.94510, 0.89412, +1.00000, 0.94902, 0.90588, +1.00000, 0.95294, 0.91765, +1.00000, 0.95686, 0.92941, +1.00000, 0.96078, 0.94118, +1.00000, 0.96471, 0.95294, +1.00000, 0.96863, 0.96471, +1.00000, 0.97255, 0.97647, +1.00000, 0.97647, 0.98824, +1.00000, 0.98039, 1.00000, +1.00000, 0.98431, 1.00000, +1.00000, 0.98824, 1.00000, +1.00000, 0.99216, 1.00000, +1.00000, 0.99608, 1.00000, +1.00000, 1.00000, 1.00000 diff --git a/unix/sun/imtool.c b/unix/sun/imtool.c new file mode 100644 index 00000000..6c055610 --- /dev/null +++ b/unix/sun/imtool.c @@ -0,0 +1,4488 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "imtool.h" + +/* + * IMTOOL -- Software image display for the Sun workstation under Sunview. + * A variable sized window is used to peer into a "fixed" size frame buffer + * at an arbitrary offset (pan) and scale (zoom/dezoom). The number of frames + * and the size of a frame buffer is arbitrary and is a setup option. The + * depth of a frame on an 8 bit display is 7 bits with a 1 bit graphics + * overlay plane; this leaves almost half of the color table space for use + * by other windows. A data stream command interface is provided for software + * control of the display server by other processes, not necessarily on the + * same node. + * + * D.Tody, April 1987 (NOAO/IRAF project) + * Extensively revised and extended December 1987. + * Zoom and further datastream mods (WCS) added May 1989. + * (but NeWS/X is coming soon and probably none of this will work anymore...) + */ + +#ifndef abs +#define abs(a) (((a)<0)?(-(a)):(a)) +#endif + +#ifndef min +#define min(a,b) ((a)<(b)?(a):(b)) +#endif +#ifndef max +#define max(a,b) ((a)<(b)?(b):(a)) +#endif + +/* Default values, size limiting values. + */ +#define MAX_ARGS 50 /* max command line arguments */ +#define MAX_FBCONFIG 128 /* max possible frame buf sizes */ +#define MAX_FRAMES 16 /* max number of frames */ +#define FRAME_CHOICES "1","2","3","4" /* nframes choices for setup */ +#define NGREY 256 /* max physical greylevels */ +#define CLOCK_INTERVAL 500 /* main clock tick, msec */ +#define DEF_NCONFIG 1 /* number of f.b. configs */ +#define DEF_NFRAMES 1 /* save memory; only one frame */ +#define DEF_FRAME_WIDTH 512 /* 512 square frame */ +#define DEF_FRAME_HEIGHT 512 /* 512 square frame */ +#define DEF_GIOWIN_SIZE 512 /* default size gio window */ +#define SZ_LABEL 256 /* main frame label string */ +#define SZ_IMTITLE 128 /* image title string */ +#define SZ_WCTEXT 80 /* WCS box text */ +#define SZ_WCSBUF 320 /* WCS text buffer size */ +#define SZ_PANTEXT 18 /* displayed chars in o_fname */ +#define SZ_COLORBAR 11 /* height of colorbar in pixels */ +#define SZ_FNAME 128 +#define SZ_LINE 256 +#define IO_TIMEOUT 30 /* i/o not getting anywhere */ +#define SZ_FIFOBUF 4000 /* transfer size for FIFO i/o */ +#define BKG_WHITE 0 +#define BKG_BLACK 1 +#define P_IMAGE 1 +#define P_GRAPHICS 2 +#define P_COLORBAR 4 +#define P_DONTCLIP 8 +#define PANNER_EVENT 99 +#define INTERRUPT 003 +#define NEXT_SCREEN 006 +#define PREV_SCREEN 022 +#define CYCLE_BLINK 002 + +/* Reserved colormap entries. + */ +#define CMS_DATASTART 1 /* first data greylevel */ +#define CMS_DATAEND 200 /* last data greylevel */ +#define CMS_DATARANGE 200 /* number of data greylevels */ +#define CMS_CURSOR 201 /* cursor color table entry */ +#define CMS_BACKGROUND 202 /* background color */ +#define CMS_GRAPHICSSTART 203 /* first graphics greylevel */ +#define CMS_GRAPHICSEND 217 /* last graphics greylevel */ +#define CMS_GRAPHICSRANGE 15 /* number of graphics greylevel */ +#define CMS_GCOLOR(c) (203+(c)) /* graphics color table entries */ +#define CMS_FIRST 1 /* first grey level used */ +#define CMS_NGREY 218 /* total number of grey levels */ + +/* Magic numbers. */ +#define BLINK_OFF 1 /* crosshair cursor off */ +#define BLINK_ON 2 /* turn crosshair cursor on */ +#define CMMAPNAME "imtool" /* color map segment name */ +#define OLD_DEVNAME "/dev/imt1" /* original pseudodevice name */ +#define I_DEVNAME "/dev/imt1o" /* pseudo device names */ +#define O_DEVNAME "/dev/imt1i" /* our IN is client's OUT */ +#define KEY_SETUP KEY_TOP(4) /* togglt the setup panel */ +#define KEY_REMARK KEY_TOP(5) /* remark list of objects */ +#define KEY_PCOORDS KEY_TOP(6) /* cont. coords display */ +#define KEY_SNAP KEY_TOP(7) /* image hardcopy key */ +#define TEXT_FONT "/usr/lib/fonts/fixedwidthfonts/screen.b.14" +#define MARK_FONT "/usr/lib/fonts/fixedwidthfonts/screen.r.11" +#define COORDFILE "frame.%d.%d" +#define FBCONFIG_1 ".imtoolrc" +#define FBCONFIG_2 "/usr/local/lib/imtoolrc" +#define FBCONFIG_ENV1 "imtoolrc" +#define FBCONFIG_ENV2 "IMTOOLRC" + +#define R_TYPE 0 /* 0=postscript, 1=rasterfile */ +#define R_DISPOSE "lpr -s %s" /* dispose command */ +#define R_FILENAME "" /* output filename */ + +/* Global state codes. */ +#define TRACK_CURSOR 0 +#define WINDOW 1 +#define ROAM 2 + +#define MONO 0 +#define HEAT 1 +#define RAMP1 2 +#define RAMP2 3 +#define HALLEY 4 +#define LINEARPS 5 +#define RANDOMPS 6 +#define CRANDOMPS 7 +#define ULUT1 8 +#define ULUT2 9 + +/* WCS definitions. */ +#define W_UNITARY 0 +#define W_LINEAR 1 +#define W_LOG 2 +#define W_DEFFORMAT " %7.2f %7.2f %7.1f%c" + +/* Internal variables. */ +static int snap_frame_too = 1; /* include frame in imcopy? */ +static int cursor_blink = -1; /* crosshair or small cursor */ +static int cursor_show = -1; /* cursor state; on/off */ +static int display_coords = 0; /* cont. display cursor coords */ +static int p_cursor_setback = 0; /* restore cursor pos after pan */ +static int panning = 0; /* smooth image pan in progress */ +static int maptype = MONO; /* initial mapping type */ +static char o_fname[SZ_FNAME]; /* name of coord output file */ +static char o_revtext=1; /* reverse video text? */ +static int setup_xoff = 4; /* offset to setup panel */ +static int setup_yoff = 18; /* " " */ +static int wc_xoff=0, wc_yoff=0; /* offset to WCS output box */ +static int wc_width, wc_height; /* size of WCS output box */ +static char wc_text[SZ_WCTEXT+1]; /* coordinate text */ +static struct pixfont *wc_font = NULL; /* WCS box font */ +static int cb_height = SZ_COLORBAR; +static int show_colorbar = 1; +static int black = 0; +static int white = NGREY - 1; +static int background = 0; /* background color index */ +static int state = TRACK_CURSOR; /* mouse button state */ +static int last_sx, last_sy; /* window x,y of last event */ +static int save_sx, save_sy; /* save absolute mouse position */ +static int last_bx, last_by; /* last button press */ +static int fb_bkgcolor_index = BKG_WHITE; +static int window_open = 1; +static int global_colortable = 1; /* globally manage colortable */ +static int fbconfig = 0; +static int last_x, last_y, last_key, key_left=0; +static int reading_imcursor = 0; +static int imcursor_wcs; +static char wcsbuf[MAX_FRAMES][SZ_WCSBUF]; + +#define CRANDOM_CHOICES "1", "2", "4", "8", "16", "32" +static int cr_msec[] = { 1000, 2000, 4000, 8000, 16000, 32000 }; +static int crandom_blink_rate = 1; /* rate for cont. random pseudo */ + +/* Blink parameters. */ +#define BLINKRATE_CHOICES "1/2","1","2","4","8","16","32" +static int blink_rate[] = { 1, 2, 4, 8, 16, 32, 64 }; +static int blink_rate_index = 1; /* current blink rate */ +static int blink_timer = 0; /* nticks left on clock */ +static int blink_frame = 0; /* current blink frame */ +static int blink = 0; /* blink enabled? */ +static int n_blink_frames = 8; /* number of frames to blink */ +static int blink_frames[MAX_FRAMES] = { 1, 2, 3, 4, 5, 6, 7, 8 }; +static char s_blinklist[SZ_FNAME+1] = "all"; /* list of frames to blink */ + +/* Logical image cursor parameters. */ +static int marktype = 0; /* mark cursor position */ + +/* The following is needed to provide sufficient precision to allow for + * zooming virtual pixrects (Rects use type short). + */ +typedef struct bigrect { + int r_left, r_top; + int r_width, r_height; +} BRect; + +/* Predefined lookup tables. */ +struct triplet { + float red, green, blue; +}; +struct lut { + int lutlen; + struct triplet hue[NGREY]; +}; + +struct lut heat = { +#include "heat.lut" +}; + +struct lut halley = { +#include "halley.lut" +}; + +/* User defined lookup tables. */ +static char u_lut1[SZ_FNAME+1] = "none"; +static char u_lut2[SZ_FNAME+1] = "none"; + +static BRect pw_rect; /* raw frame buffer */ +static int fb_depth = 8; +static int fb_ngrey = CMS_DATARANGE; +static int fb_nframes= DEF_NFRAMES; +static int Fb_width = DEF_FRAME_WIDTH; +static int Fb_height = DEF_FRAME_HEIGHT; + +static BRect fb_rect; /* zoomed frame buffer */ +static int fb_width = DEF_FRAME_WIDTH; +static int fb_height = DEF_FRAME_HEIGHT; + +#define MAX_ZOOMS 8 +#define ZOOM_CHOICES "1","2","4","8" +static int zoom = 1; +static int nzooms = 4; /* number of zoom factors */ +static int zoom_index = 0; +static int zooms[MAX_ZOOMS] = { 1, 2, 4, 8 }; +static char s_zoomslist[SZ_FNAME+1] = "1 2 4 8"; + +static int gio_xsize = DEF_GIOWIN_SIZE; +static int gio_ysize = DEF_GIOWIN_SIZE; +static int initial_gio_xsize, initial_gio_ysize; + +/* Rotation matrix defining world coordinate system (WCS) of a frame. + */ +struct ctran { + int valid; /* has WCS been set? */ + float a, b; /* x, y scale factors */ + float c, d; /* x, y cross factors */ + float tx, ty; /* x, y translation */ + float z1, z2; /* greyscale range */ + int zt; /* greyscale mapping */ + char format[32]; /* wcs output format */ + char imtitle[SZ_IMTITLE+1]; /* image title from WCS */ +}; + +/* The frame buffers. */ +struct framebuf { + struct pixrect *fb_pr; /* frame buffer pixrect */ + int fb_frameno; /* frame number */ + int fb_xoff, fb_yoff; /* fb coords of pixwin (0,0) */ + int fb_xzoom, fb_yzoom; /* zoom/dezoom factors */ + int fb_objno; /* object number */ + int fb_imageno; /* displayed frame counter */ + int fb_maptype; /* greyscale transformation */ + float fb_center, fb_slope; /* transfer function */ + struct ctran fb_ctran; /* world coordinate system */ + char fb_label[SZ_LABEL+1]; /* frame label string */ +}; + +/* Possible frame buffer sizes. */ +struct fbconfig { + int nframes; /* number of frames */ + int width; /* frame buffer width */ + int height; /* frame buffer height */ +}; + +static int display_frame; /* currently displayed frame */ +static int reference_frame; /* reference (cmd i/o) frame */ +static struct framebuf *frames=NULL; /* array of frame descriptors */ +static struct framebuf *df_p; /* display frame descriptor */ +static struct framebuf *rf_p; /* reference frame descriptor */ +static struct pixrect *cb_pr; /* colorbar pixrect */ +static int fb_nconfig = 0; +static int fb_config_index = 0; +static struct fbconfig fb_config[MAX_FBCONFIG]; +static char startfile[SZ_FNAME+1]; /* image read on startup */ +static char rasterfile[SZ_FNAME+1] = "raster.%d.%d"; + +/* Screendump stuff. */ +int r_type = R_TYPE; +char r_dispose[SZ_FNAME+1] = R_DISPOSE; +char r_filename[SZ_FNAME+1] = R_FILENAME; + +#define HEIGHTADJUST \ + (tool_headerheight((int)window_get(gio_frame, FRAME_SHOW_LABEL)) + \ + TOOL_BORDERWIDTH) + +static short iconimage[] = { +#include "imtool.icon" +}; +DEFINE_ICON_FROM_IMAGE (icon, iconimage); + +Window gio_frame, gio_canvas; +static int gio_frame_fd; +static int datain, dataout; +static Menu_item blink_item; +static Panel setup_panel; +static Window setup_frame; +static Panel_item pan_show_colorbar, pan_globalcolor; +static Panel_item pan_set_nframes, pan_blink_rate, pan_blink_list; +static Panel_item pan_set_maptype, pan_crandom_rate, pan_set_ofname; +static Panel_item pan_snapframetoo, pan_set_background, pan_set_rfname; +static Panel_item pan_set_rtype, pan_set_rdispose, pan_set_rfilename; +static Panel_item pan_set_marker, pan_zoom_list; +static Panel_item pan_set_ulut1, pan_set_ulut2; +static unsigned char red[NGREY], blue[NGREY], green[NGREY]; +static unsigned char m_red[NGREY], m_blue[NGREY], m_green[NGREY]; + +static struct pixwin *gio_pw; +static int main_argc, gio_argc; +static char **main_argv, *gio_argv[MAX_ARGS]; + +static Notify_value ev_gioframe(), set_colortable(); +static Notify_value ev_gioinput(), ev_cmdinput(), ev_panner(); +static char *getfname(), *framelabel(); +static struct ctran *wcs_update(); +static struct pixrect *get_screen_rect(); +static refresh_display(); +extern char *getenv(); + + +/* IMTOOL_MAIN -- Create the Imtool windows, i.e., the main display window, + * the region of interest or "cursor" subwindow, and the setup panel. There + * are two principal event handlers, the display window event handler, used + * to process cursor input and mouse button commands, and the command input + * event handler, used to communicate with the client process. + */ +#ifdef STANDALONE +main (argc, argv) +#else +imtool_main (argc, argv) +#endif +int argc; +char **argv; +{ + char *s; + + main_argc = argc; + main_argv = argv; + parse_args (argc, argv, &gio_argc, gio_argv); + + /* Screendump stuff. */ + if (s = getenv ("R_DISPOSE")) + strcpy (r_dispose, s); + if (s = getenv ("R_FILENAME")) + strcpy (r_filename, s); + if (s = getenv ("R_RASTERFILE")) { + strcpy (r_filename, s); + r_type = 1; + } + + gio_frame = window_create (NULL, FRAME, + FRAME_ICON, &icon, + FRAME_LABEL, + "imtool - NOAO/IRAF Sunview Image Display V1.1", + FRAME_ARGS, gio_argc, gio_argv, + FRAME_NO_CONFIRM, FALSE, + 0); + if (gio_frame == NULL) + exit (1); + + gio_frame_fd = (int) window_get (gio_frame, WIN_FD); + parse_args (argc, argv, &gio_argc, gio_argv); + create_gio_canvas (gio_argc, gio_argv); + create_frame_menu (gio_frame); + create_setup_popup(); + notify_interpose_event_func (gio_frame, ev_gioframe, NOTIFY_SAFE); + notify_interpose_event_func (gio_canvas, ev_gioinput, NOTIFY_SAFE); + + get_fbconfig(); + set_fbconfig (fbconfig, 0); + load_testpattern (0); + set_colortable(); + gio_setcursor (CURSOR_ON, BLINK_OFF); + set_transfer_function (gio_pw, df_p->fb_center, df_p->fb_slope); + + Bpw_get_region_rect (gio_pw, &pw_rect); + pw_rect.r_left = df_p->fb_xoff; + pw_rect.r_top = df_p->fb_yoff; + init_colorbar (pw_rect.r_width); + + if (startfile[0]) + load_raster (rf_p->fb_pr, startfile); + + initial_gio_xsize = gio_xsize; + initial_gio_ysize = gio_ysize; + + /* Open the output fifo. We have to open it ourselves first as a + * client to get around the fifo open-no-client error. + */ + if ((datain = open (O_DEVNAME, O_RDONLY|O_NDELAY)) != -1) { + if ((dataout = open (O_DEVNAME, O_WRONLY|O_NDELAY)) != -1) + fcntl (dataout, F_SETFL, O_WRONLY); + close (datain); + } + + /* Open the input stream, a FIFO pseudodevice file used by + * applications to send us commands and data. + */ + if ((datain = open (I_DEVNAME, O_RDONLY|O_NDELAY)) == -1) { + if ((datain = open (OLD_DEVNAME, O_RDONLY|O_NDELAY)) == -1) + fprintf (stderr, "Warning: cannot open %s\n", I_DEVNAME); + } else { + /* Clear O_NDELAY for reading. */ + fcntl (datain, F_SETFL, O_RDONLY); + notify_set_input_func (gio_frame, ev_cmdinput, datain); + } + + imtool_clock(); + window_main_loop (gio_frame); + close (datain); + exit (0); +} + + +/* PARSE_ARGS -- Parse the argument list into the arguments for the main frame + * and the global arguments for the server. + */ +static +parse_args (argc, argv, gio_argc, gio_argv) +int argc; +char *argv[]; +int *gio_argc; +char *gio_argv[]; +{ + register char *argp; + register int arg; + static int ncalls = 0; + + gio_argv[0] = argv[0]; + *gio_argc = 1; + + for (arg=1; arg <= argc && (argp = argv[arg]) != NULL; arg++) { + if (strncmp (argp, "-fbconfig", 3) == 0) { + /* Set the frame buffer configuration. */ + if ((argp = argv[arg+1]) && isdigit(*argp)) { + fbconfig = max (0, atoi(argp) - 1); + arg++; + } else if (ncalls == 0) + fprintf (stderr, "-fbconfig argument missing\n"); + } else if (strncmp (argp, "-raster", 4) == 0) { + if ((argp = argv[arg+1])) { + strcpy (startfile, argp); + arg++; + } + } else + gio_argv[(*gio_argc)++] = argp; + } + + gio_argv[(*gio_argc)] = NULL; + ncalls++; +} + + +/* GET_FBCONFIG -- Read the IMTOOL startup file to get the set of possible + * frame buffer sizes. + * + * File format: configno nframes width height [extra fields] + * e.g., 1 2 512 512 + * 2 2 800 800 + * 3 1 1024 1024 # comment + */ +static +get_fbconfig() +{ + register char *ip; + register FILE *fp; + int config, nframes, width, height, i; + char lbuf[SZ_LINE+1], *fname; + + /* Initialize the config table. */ + for (i=0; i < MAX_FBCONFIG; i++) + fb_config[i].nframes = 0; + + /* Attempt to open the config file. */ + fp = NULL; + if ((fname=getenv(FBCONFIG_ENV1)) || (fname=getenv(FBCONFIG_ENV2))) + fp = fopen (fname, "r"); + if (!fp && (fname = getenv ("HOME"))) { + sprintf (lbuf, "%s/%s", fname, FBCONFIG_1); + fp = fopen (fname = lbuf, "r"); + } + if (!fp) + fp = fopen (fname = FBCONFIG_2, "r"); + + /* If cannot find a config file, set up the default configuration. */ + if (!fp) { + fb_config_index = fbconfig = 0; + fb_nconfig = DEF_NCONFIG; + fb_config[0].nframes = DEF_NFRAMES; + fb_config[0].width = DEF_FRAME_WIDTH; + fb_config[0].height = DEF_FRAME_HEIGHT; + return; + } + + /* Scan the frame buffer configuration file. + */ + fb_nconfig = 0; + while (fgets (lbuf, SZ_LINE, fp) != NULL) { + /* Skip comment lines and blank lines. */ + for (ip=lbuf; *ip == ' ' || *ip == '\t'; ip++) + ; + if (*ip == '\n' || *ip == '#') + continue; + if (!isdigit (*ip)) + continue; + switch (sscanf (ip, "%d%d%d%d", &config,&nframes,&width,&height)) { + case 4: + break; /* normal case */ + case 3: + height = width; /* default to square format */ + break; + default: + fprintf (stderr, "imtool: bad config `%s'\n", ip); + continue; + } + + nframes = max (1, nframes); + width = max (1, width); + height = max (1, height); + + /* Since the frame buffer is stored in a memory pixrect + * (effectively), the line length should be an integral number + * of 16 bit words. + */ + if (width & 1) { + fprintf (stderr, "imtool warning: fb config %d [%d-%dx%d] - ", + config, nframes, width, height); + fprintf (stderr, "frame width should be even, reset to %d\n", + --width); + } + + config = max(1, min(MAX_FBCONFIG, config)) - 1; + fb_config[config].nframes = nframes; + fb_config[config].width = width; + fb_config[config].height = height; + fb_nconfig = max (fb_nconfig, config+1); + } + + fclose (fp); +} + + +/* SET_FBCONFIG -- Setup a frame buffer configuration. + */ +static +set_fbconfig (config, nframes) +int config; +int nframes; +{ + register struct pixrect *pr = get_screen_rect(); + int old_config = fb_config_index; + int old_nframes = fb_nframes; + char text[SZ_LINE]; + + if (config < 0 || config >= fb_nconfig) { + fprintf (stderr, + "imtool: no such frame buffer configuration - %d\n", config+1); + return; + } else if (nframes <= 0) + nframes = fb_config[config].nframes; + + if (init_framebuffers (config, nframes) == -1) { + fprintf (stderr, "restore configuration %d\n", old_config + 1); + if (init_framebuffers (old_config, old_nframes) == -1) { + fprintf (stderr, + "cannot restore frame buffer configuration - imtool dies\n"); + exit (1); + } + } + + if (gio_xsize <= 0 || gio_xsize > Fb_width) + gio_xsize = Fb_width; + if (gio_ysize <= 0 || gio_ysize > (Fb_height + cb_height)) + gio_ysize = Fb_height + cb_height; + + gio_xsize = min (pr->pr_width - TOOL_BORDERWIDTH * 2, gio_xsize); + gio_ysize = min (pr->pr_height + - tool_headerheight ((int)window_get(gio_frame,FRAME_SHOW_LABEL)) + - TOOL_BORDERWIDTH, gio_ysize); + + window_set (gio_canvas, + WIN_WIDTH, gio_xsize, + WIN_HEIGHT, gio_ysize, + 0); + + window_fit (gio_canvas); + window_fit (gio_frame); + + Bpw_get_region_rect (gio_pw, &pw_rect); + pw_rect.r_left = df_p->fb_xoff; + pw_rect.r_top = df_p->fb_yoff; + + sprintf (text, "Frame buffer configuration %d: %d %dx%d frame%c", + fb_config_index + 1, fb_nframes, Fb_width, Fb_height, + fb_nframes > 1 ? 's' : ' '); + + window_set (gio_frame, FRAME_LABEL, text, 0); + panel_set_value (pan_set_maptype, df_p->fb_maptype); + panel_set_value (pan_set_nframes, fb_nframes - 1); +} + + +/* LOAD_RASTER -- Load a rasterfile into the display. + */ +static +load_raster (o_pr, fname) +Pixrect *o_pr; +char *fname; +{ + FILE *fp; + Pixrect *i_pr; + int width, height; + + if ((fp = fopen (fname, "r")) == NULL) + fprintf (stderr, "cannot open rasterfile %s\n", fname); + else { + if (i_pr = pr_load (fp, NULL)) { + width = min (Fb_width, i_pr->pr_width); + height = min (Fb_height, i_pr->pr_height); + pr_rop (o_pr, 0, 0, width, height, PIX_SRC, i_pr, 0, 0); + pr_close (i_pr); + repaint (P_IMAGE|P_COLORBAR|P_GRAPHICS); + } + fclose (fp); + } +} + + +/* SAVE_RASTER -- Save a frame buffer in a file. + */ +static +save_raster (i_pr, fname) +Pixrect *i_pr; +char *fname; +{ + FILE *fp; + + if ((fp = fopen (fname, "w")) == NULL) + fprintf (stderr, "cannot create rasterfile %s\n", fname); + else { + if (pr_dump (i_pr, fp, RMT_NONE, RT_STANDARD, 0) == PIX_ERR) + fprintf (stderr, "error writing rasterfile %s\n", fname); + fclose (fp); + } +} + + +/* CREATE_GIO_CANVAS -- Set up the canvas for the main display window. + */ +static +create_gio_canvas (argc, argv) +int argc; +char **argv; +{ + register char *argp; + register int arg; + char pathname[NGREY]; + struct pixwin *pw; + int name; + + /* Override the builtin defaults with the values given by the user + * on the command line, if any. + */ + for (arg=1; arg <= argc && (argp = argv[arg]) != NULL; arg++) { + if (!strcmp (argp, "-Ws") || !strncmp (argp, "-size", 5)) { + gio_xsize = atoi (argv[++arg]) - (TOOL_BORDERWIDTH * 2); + gio_ysize = atoi (argv[++arg]) - + (tool_headerheight ((int) window_get (gio_frame, + FRAME_SHOW_LABEL)) + TOOL_BORDERWIDTH); + } else if (!strncmp (argp, "-maptype", 4)) { + argp = argv[++arg]; + if (!strncmp (argp, "mono", 1)) + maptype = MONO; + else if (!strncmp (argp, "heat", 1)) + maptype = HEAT; + else if (!strncmp (argp, "ramp1", 1)) + maptype = RAMP1; + else if (!strncmp (argp, "ramp2", 1)) + maptype = RAMP2; + else if (!strncmp (argp, "halley", 1)) + maptype = HALLEY; + else if (!strncmp (argp, "linear", 1)) + maptype = LINEARPS; + else if (!strncmp (argp, "random", 1)) + maptype = RANDOMPS; + else if (!strncmp (argp, "crandom", 1)) + maptype = CRANDOMPS; + else if (!strncmp (argp, "ulut1", 1)) + maptype = ULUT1; + else if (!strncmp (argp, "ulut2", 1)) + maptype = ULUT2; + else + fprintf (stderr, "unknown arg `%s' to -maptype\n", argp); + } else if (!strncmp (argp, "-nocolorbar", 9)) { + cb_height = 0; + show_colorbar = 0; + } else if (!strncmp (argp, "-colorbar", 7)) { + cb_height = SZ_COLORBAR; + show_colorbar = 1; + } else if (!strncmp (argp, "-black", 3)) { + background = CMS_BACKGROUND; + fb_bkgcolor_index = BKG_BLACK; + } else if (!strncmp (argp, "-white", 3)) { + background = 0; + fb_bkgcolor_index = BKG_WHITE; + + } else if (!strncmp (argp, "-rtype", 3)) { + argp = argv[++arg]; + r_type = (argp[0] == 'r'); + } else if (!strncmp (argp, "-rdispose", 3)) { + argp = argv[++arg]; + strcpy (r_dispose, argp); + } else if (!strncmp (argp, "-rfilename", 3)) { + argp = argv[++arg]; + strcpy (r_filename, argp); + } else if (!strncmp (argp, "-ulut1", 6)) { + argp = argv[++arg]; + strcpy (u_lut1, argp); + } else if (!strncmp (argp, "-ulut2", 6)) { + argp = argv[++arg]; + strcpy (u_lut2, argp); + } + } + + /* Open display canvas. The display canvas is never retained at the + * pixwin level since we can easily refresh it from the frame buffer. + */ + gio_canvas = window_create (gio_frame, CANVAS, + WIN_WIDTH, gio_xsize, + WIN_HEIGHT, gio_ysize, + CANVAS_RETAINED, FALSE, + CANVAS_AUTO_CLEAR, FALSE, + CANVAS_REPAINT_PROC, refresh_display, + 0); + if (gio_canvas == NULL) + exit (1); + + /* Initialize the frame and lut parameters and the canvax pixwin + * color map. + */ + pw = (struct pixwin *) window_get (gio_canvas, WIN_PIXWIN); + fb_depth = pw->pw_pixrect->pr_depth; + if (fb_depth < 8) { + fprintf (stderr, "imtool cannot be used on monochrome displays\n"); + exit (1); + } + + white = (1 << fb_depth) - 1; + if ((fb_ngrey = CMS_DATARANGE) > (white + 1)) + fb_ngrey = 1; + init_colormap (pw); + init_colormap (gio_pw = canvas_pixwin (gio_canvas)); + + /* Set input event flags. */ + window_set (gio_canvas, + WIN_CONSUME_PICK_EVENTS, WIN_NO_EVENTS, + WIN_MOUSE_BUTTONS, WIN_UP_EVENTS, LOC_DRAG, LOC_WINEXIT, 0, + WIN_CONSUME_KBD_EVENTS, WIN_NO_EVENTS, + WIN_ASCII_EVENTS, WIN_LEFT_KEYS, WIN_RIGHT_KEYS, + KEY_SETUP, KEY_REMARK, KEY_SNAP, KEY_PCOORDS, KBD_DONE, 0, + 0); + + notify_set_event_func (ev_panner, ev_panner, NOTIFY_SAFE); +} + + +/* CREATE_SETUP_POPUP -- Create the popup menu used to set the terminal + * setup options. + */ +static +create_setup_popup () +{ + extern loadframe_proc(), saveframe_proc(), fitframe_proc(); + extern reset_proc(), iclear_proc(), gclear_proc(); + extern setup_proc(), toggle_graphics(), set_background(); + extern setframe_proc(), blinkenable_proc(), register_proc(); + static Panel_setting set_ofname(), set_rfname(); + static Panel_setting set_rtype(), set_rdispose(), set_rfilename(); + static Panel_setting set_ulut1(), set_ulut2(); + static Panel_setting set_blinklist(), set_zoomslist(); + static panel_set_item(); + + setup_frame = window_create (gio_frame, FRAME, + FRAME_NO_CONFIRM, TRUE, + WIN_X, setup_xoff, + WIN_Y, setup_yoff, + 0); + if (setup_frame == NULL) + exit (1); + setup_panel = window_create (setup_frame, PANEL, 0); + if (setup_panel == NULL) + exit (1); + + panel_create_item (setup_panel, PANEL_MESSAGE, + PANEL_ITEM_X, ATTR_COL(10), + PANEL_ITEM_Y, ATTR_ROW(0), + PANEL_LABEL_STRING, "Image Display Setup and Control", + 0); + + pan_set_nframes = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(1) + 5, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Number of frame buffers: ", + PANEL_CHOICE_STRINGS, FRAME_CHOICES, 0, + PANEL_VALUE, fb_nframes - 1, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_set_maptype = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(2) + 5, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Greyscale mapping: ", + PANEL_CHOICE_STRINGS, "Mono", + "ESO-Heat", + "Ramp1", + "Ramp2", + "Halley", + "Linear-pseudo", + "Random-pseudo", + "Crandom-pseudo", + "User 1", + "User 2", + 0, + PANEL_VALUE, maptype, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_set_ulut1 = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(3) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "User lookup table 1: ", + PANEL_VALUE, u_lut1, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_ulut1, + 0); + + pan_set_ulut2 = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(4) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "User lookup table 2: ", + PANEL_VALUE, u_lut2, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_ulut2, + 0); + + pan_globalcolor = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(5) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Globally manage colortable: ", + PANEL_CHOICE_STRINGS, "No", "Yes", 0, + PANEL_VALUE, global_colortable, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_crandom_rate = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(6) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Rate (sec) for crandom option: ", + PANEL_CHOICE_STRINGS, CRANDOM_CHOICES, 0, + PANEL_VALUE, crandom_blink_rate, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_set_background = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(7) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Background color: ", + PANEL_CHOICE_STRINGS, "white", "black", 0, + PANEL_VALUE, fb_bkgcolor_index, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_snapframetoo = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(8) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Include frame border in imcopy: ", + PANEL_CHOICE_STRINGS, "No", "Yes", 0, + PANEL_VALUE, snap_frame_too, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_show_colorbar = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(9) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Show colorbar: ", + PANEL_CHOICE_STRINGS, "No", "Yes", 0, + PANEL_VALUE, show_colorbar, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_set_marker = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(10) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Cursor marker: ", + PANEL_CHOICE_STRINGS, "None", "Circle", "Cross", "Square", 0, + PANEL_VALUE, marktype, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_blink_rate = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(11) + 8, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Blink rate (sec): ", + PANEL_CHOICE_STRINGS, BLINKRATE_CHOICES, 0, + PANEL_VALUE, blink_rate_index, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + pan_blink_list = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(12) + 11, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Frames to be blinked: ", + PANEL_VALUE, s_blinklist, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_blinklist, + 0); + + pan_zoom_list = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(13) + 11, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Zoom factors: ", + PANEL_VALUE, s_zoomslist, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_zoomslist, + 0); + + strcpy (o_fname, COORDFILE); + pan_set_ofname = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(14) + 11, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Coordinate list output file: ", + PANEL_VALUE, o_fname, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_ofname, + 0); + + pan_set_rfname = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(15) + 11, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Rasterfile name (load/save): ", + PANEL_VALUE, rasterfile, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_rfname, + 0); + + pan_set_rtype = panel_create_item (setup_panel, PANEL_CYCLE, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(16) + 13, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Screendump output type: ", + PANEL_CHOICE_STRINGS, "postscript", "rasterfile", 0, + PANEL_VALUE, r_type, + PANEL_NOTIFY_PROC, panel_set_item, + 0); + + + pan_set_rdispose = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(17) + 13, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Screendump dispose command: ", + PANEL_VALUE, r_dispose, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_rdispose, + 0); + + pan_set_rfilename = panel_create_item (setup_panel, PANEL_TEXT, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(18) + 11, + PANEL_DISPLAY_LEVEL, PANEL_CURRENT, + PANEL_LABEL_STRING, "Screendump output file: ", + PANEL_VALUE, r_filename, + PANEL_VALUE_STORED_LENGTH, SZ_FNAME, + PANEL_VALUE_DISPLAY_LENGTH, SZ_PANTEXT, + PANEL_NOTIFY_PROC, set_rfilename, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(19) + 15, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel,"Register Frames",0,0), + PANEL_NOTIFY_PROC, register_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Fit Window", 0,0), + PANEL_NOTIFY_PROC, fitframe_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Blink", 0,0), + PANEL_NOTIFY_PROC, blinkenable_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Frame", 0,0), + PANEL_NOTIFY_PROC, setframe_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_ITEM_X, ATTR_COL(0), + PANEL_ITEM_Y, ATTR_ROW(20) + 15, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Reset", 0,0), + PANEL_NOTIFY_PROC, reset_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Iclear", 0,0), + PANEL_NOTIFY_PROC, iclear_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Gclear", 0,0), + PANEL_NOTIFY_PROC, gclear_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Load", 0,0), + PANEL_NOTIFY_PROC, loadframe_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "Save", 0,0), + PANEL_NOTIFY_PROC, saveframe_proc, + 0); + + panel_create_item (setup_panel, PANEL_BUTTON, + PANEL_LABEL_IMAGE, + panel_button_image (setup_panel, "DISMISS", 0,0), + PANEL_NOTIFY_PROC, setup_proc, + 0); + + window_fit (setup_panel); + window_fit (setup_frame); +} + + +/* PANEL_SET_ITEM -- Called when an item is seleted in the setup panel to + * set the associated global variable and possibly take some action. + */ +static +panel_set_item (item, value) +Panel_item item; +int value; +{ + if (item == pan_set_nframes) { + set_fbconfig (fb_config_index, value + 1); + } else if (item == pan_set_maptype) { + df_p->fb_maptype = maptype = value; + set_colortable(); + set_transfer_function (gio_pw, df_p->fb_center, df_p->fb_slope); + } else if (item == pan_crandom_rate) { + crandom_blink_rate = value; + } else if (item == pan_set_marker) { + marktype = value; + } else if (item == pan_blink_rate) { + blink_rate_index = value; + } else if (item == pan_set_rtype) { + r_type = value; + } else if (item == pan_globalcolor) { + global_colortable = value; + + } else if (item == pan_set_background) { + /* Set the background color. + */ + if (fb_bkgcolor_index != value) { + register unsigned char *fb, *op; + register int n = Fb_height * Fb_width; + fb = (unsigned char *) mpr_d(df_p->fb_pr)->md_image; + + switch (fb_bkgcolor_index = value) { + case BKG_BLACK: + background = CMS_BACKGROUND; + for (op=fb; --n >= 0; op++) + if (!*op) + *op = background; + break; + case BKG_WHITE: + background = 0; + for (op=fb; --n >= 0; op++) + if (*op == CMS_BACKGROUND) + *op = 0; + break; + } + gclear_proc(); + } + + } else if (item == pan_show_colorbar) { + if (show_colorbar != value) { + struct pixrect *pr = get_screen_rect(); + + show_colorbar = value; + if (show_colorbar) { + cb_height = SZ_COLORBAR; + gio_ysize += cb_height; + gio_ysize = min (Fb_height + cb_height, gio_ysize); + } else { + cb_height = 0; + gio_ysize -= SZ_COLORBAR; + } + + gio_xsize = + min (pr->pr_width - TOOL_BORDERWIDTH * 2, gio_xsize); + gio_ysize = + min (pr->pr_height - + tool_headerheight ((int) window_get (gio_frame, + FRAME_SHOW_LABEL)) - TOOL_BORDERWIDTH, + gio_ysize); + + window_set (gio_canvas, + WIN_WIDTH,gio_xsize, WIN_HEIGHT,gio_ysize, 0); + + window_fit (gio_canvas); + window_fit (gio_frame); + } + + } else if (item == pan_snapframetoo) + snap_frame_too = value; +} + + +/* SET_ZOOMSLIST -- Set the list of zoom factors. + */ +static Panel_setting +set_zoomslist (item, event) +Panel_item item; +Event *event; +{ + register char *ip; + register int i; + + strcpy (s_zoomslist, (char *) panel_get_value (item)); + for (ip=s_zoomslist; isspace (*ip); ip++) + ; + + nzooms = 0; + while (*ip && isdigit (*ip)) { + zooms[nzooms++] = max (1, atoi(ip)); + while (isdigit (*ip)) + ip++; + while (isspace (*ip)) + ip++; + if (nzooms >= MAX_ZOOMS) + break; + } + + return (panel_text_notify (item,event)); +} + + +/* SET_BLINKLIST -- Set the list of frames to be blinked. + */ +static Panel_setting +set_blinklist (item, event) +Panel_item item; +Event *event; +{ + register char *ip; + register int i; + + strcpy (s_blinklist, (char *) panel_get_value (item)); + for (ip=s_blinklist; isspace (*ip); ip++) + ; + + n_blink_frames = 0; + if (strncmp (ip, "all", 3) == 0) { + n_blink_frames = MAX_FRAMES; + for (i=0; i < MAX_FRAMES; i++) + blink_frames[i] = i + 1; + } else { + while (*ip && isdigit (*ip)) { + blink_frames[n_blink_frames++] = atoi(ip); + while (isdigit (*ip)) + ip++; + while (isspace (*ip)) + ip++; + } + } + + return (panel_text_notify (item,event)); +} + + +/* BLINKENABLE_PROC -- Turn frame blink on or off. + */ +static +blinkenable_proc() +{ + blink = !blink; + menu_set (blink_item, MENU_STRING, blink ? "Blink off" : "Blink on", 0); + blink_frame = n_blink_frames - 1; + blink_timer = 0; +} + + +/* REGISTER_PROC -- Register all frames with the current frame. + */ +static +register_proc() +{ + register struct framebuf *fr_p; + register int i; + + for (i=0, fr_p=frames; i < fb_nframes; i++, fr_p++) + if (fr_p != df_p) + set_zoom (fr_p, df_p->fb_xoff, df_p->fb_yoff, df_p->fb_xzoom); +} + + +/* SET_OFNAME -- Set the file name for coordinate output. + */ +static Panel_setting +set_ofname (item, event) +Panel_item item; +Event *event; +{ + char *s; + + s = (char *) panel_get_value (item); + if (strcmp (s, o_fname)) { + strcpy (o_fname, s); + df_p->fb_imageno = 0; + df_p->fb_objno = 1; + window_set (gio_frame, FRAME_LABEL, framelabel(), 0); + } + + return (panel_text_notify (item,event)); +} + + +/* SET_ULUT1 -- Set the file name for user lookup table 1. + */ +static Panel_setting +set_ulut1 (item, event) +Panel_item item; +Event *event; +{ + char *s; + + strcpy (u_lut1, (char *) panel_get_value (item)); + return (panel_text_notify (item,event)); +} + + +/* SET_ULUT2 -- Set the file name for user lookup table 2. + */ +static Panel_setting +set_ulut2 (item, event) +Panel_item item; +Event *event; +{ + char *s; + + strcpy (u_lut2, (char *) panel_get_value (item)); + return (panel_text_notify (item,event)); +} + + +/* SET_RFNAME -- Set the file name for rasterfile load/save. + */ +static Panel_setting +set_rfname (item, event) +Panel_item item; +Event *event; +{ + char *s; + + strcpy (rasterfile, (char *) panel_get_value (item)); + return (panel_text_notify (item,event)); +} + + +/* SET_RDISPOSE -- Set the raster file dispose command. + */ +static Panel_setting +set_rdispose (item, event) +Panel_item item; +Event *event; +{ + char *s; + + strcpy (r_dispose, (char *) panel_get_value (item)); + return (panel_text_notify (item,event)); +} + + +/* SET_RFILENAME -- Set the screendump filename template. + */ +static Panel_setting +set_rfilename (item, event) +Panel_item item; +Event *event; +{ + char *s; + + strcpy (r_filename, (char *) panel_get_value (item)); + return (panel_text_notify (item,event)); +} + + +/* LOADFRAME_PROC -- Load the named rasterfile into the current frame. + */ +static +loadframe_proc() +{ + char fname[SZ_FNAME+1]; + char buf[SZ_FNAME+1]; + + sprintf (buf, rasterfile, df_p->fb_frameno, df_p->fb_imageno); + strcpy (fname, getfname(buf, 0)); + load_raster (df_p->fb_pr, fname); +} + + +/* SAVEFRAME_PROC -- Save the current frame in the named rasterfile. + */ +static +saveframe_proc() +{ + char fname[SZ_FNAME+1]; + char buf[SZ_FNAME+1]; + + sprintf (buf, rasterfile, df_p->fb_frameno, df_p->fb_imageno); + strcpy (fname, getfname(buf, 0)); + save_raster (df_p->fb_pr, fname); +} + + +/* FITFRAME_PROC -- Fit the display window to the current frame buffer size. + */ +static +fitframe_proc() +{ + register struct pixrect *pr = get_screen_rect(); + + gio_xsize = min (pr->pr_width - TOOL_BORDERWIDTH * 2, Fb_width); + gio_ysize = min (pr->pr_height + - tool_headerheight ((int)window_get(gio_frame,FRAME_SHOW_LABEL)) + - TOOL_BORDERWIDTH, + Fb_height + cb_height); + + window_set (gio_canvas, + WIN_WIDTH, gio_xsize, + WIN_HEIGHT, gio_ysize, + 0); + + window_fit (gio_canvas); + window_fit (gio_frame); +} + + +/* GET_SCREEN_RECT -- Determine the size of the workstation screen. + */ +static struct pixrect * +get_screen_rect() +{ + static struct pixrect screen; + struct pixrect *pr; + + if (!screen.pr_width) + if (pr = pr_open ("/dev/fb")) { + screen = *pr; + pr_close (pr); + } else { + screen.pr_width = 1152; + screen.pr_width = 900; + } + + return (&screen); +} + + +/* SETUP_PROC -- Toggle whether or not the setup panel is shown. + */ +static +setup_proc() +{ + if ((int) window_get (setup_frame, WIN_SHOW) == TRUE) { + setup_xoff = (int) window_get (setup_frame, WIN_X, 0); + setup_yoff = (int) window_get (setup_frame, WIN_Y, 0); + window_set (setup_frame, WIN_SHOW, FALSE, 0); + } else { + window_set (setup_frame, + WIN_X, setup_xoff, + WIN_Y, setup_yoff, + 0); + window_set (setup_frame, WIN_SHOW, TRUE, 0); + } +} + + +/* CREATE_FRAME_MENU -- Imtool uses a special frame menu which provides the + * standard frame menu as a submenu. + */ +static +create_frame_menu (frame) +Frame frame; +{ + extern imagecopy_proc(), register_proc(); + extern setup_proc(), setframe_proc(), fitframe_proc(); + extern iclear_proc(), gclear_proc(), blinkenable_proc(); + Menu new_menu, old_menu; + + /* Get the standard frame menu. */ + old_menu = (Menu) window_get (frame, WIN_MENU); + + /* Create the new frame root menu */ + new_menu = menu_create ( + MENU_PULLRIGHT_ITEM, + "Frame", + old_menu, + MENU_ACTION_ITEM, + "Setup", + setup_proc, + MENU_ACTION_ITEM, + "Register", + register_proc, + MENU_ACTION_ITEM, + "Blink on", + blinkenable_proc, + MENU_ACTION_ITEM, + "FitFrame", + fitframe_proc, + MENU_ACTION_ITEM, + "NextFrame", + setframe_proc, + MENU_ACTION_ITEM, + "Gclear", + gclear_proc, + MENU_ACTION_ITEM, + "Iclear", + iclear_proc, + MENU_ACTION_ITEM, + "Imcopy", + imagecopy_proc, + 0); + + blink_item = menu_find (new_menu, MENU_STRING, "Blink on", 0); + + /* Install the new menu. */ + window_set (frame, WIN_MENU, new_menu, 0); +} + + +/* INIT_FRAMEBUFFERS -- Allocate space for the indicated number and size of + * framebuffers, initializing the framebuffer data structures accordingly. + * If at least one frame buffer of the desired size can be allocated we + * consider it a success, but set fb_nframes accordingly. -1 is returned + * if no frames of the desired size can be allocated. + */ +static +init_framebuffers (config, nframes) +int config; /* new frame buffer configuration */ +int nframes; /* desired number of frames */ +{ + register struct framebuf *fb; + register int i; + char *calloc(); + + nframes = min (MAX_FRAMES, nframes); + + /* If we are only changing the number of frames in the current + * configuration, keep the old frames. + */ + if (frames && config == fb_config_index) { + if (nframes == fb_config[config].nframes) { + fb_nframes = nframes; + return (nframes); + + } else if (nframes < fb_config[config].nframes) { + for (i=nframes; i < fb_nframes; i++) + pr_close (frames[i].fb_pr); + fb_config[config].nframes = fb_nframes = nframes; + if (reference_frame > nframes) { + reference_frame = nframes; + rf_p = frames + (reference_frame - 1); + } + if (display_frame > nframes) + set_frame (nframes); + return (nframes); + + } else if (nframes > fb_config[config].nframes) + ; /* fall through and add more frames */ + + } else { + /* Deallocate old frame buffers, if any. */ + if (frames) { + pr_close (cb_pr); + for (i=0; i < fb_nframes; i++) + pr_close (frames[i].fb_pr); + free (frames); + } + + fb_nframes = 0; + frames = (struct framebuf *) calloc (MAX_FRAMES, + sizeof(struct framebuf)); + + df_p = rf_p = frames; + display_frame = reference_frame = 1; + strcpy (o_fname, COORDFILE); + wc_xoff = wc_yoff = 0; + } + + /* Allocate and initialize the new frame buffers. */ + fb_config_index = config; + Fb_width = fb_config[config].width; + Fb_height = fb_config[config].height; + + for (i=fb_nframes; i < nframes; i++) { + fb = frames + i; + fb->fb_pr = mem_create (Fb_width, Fb_height, fb_depth); + if (fb->fb_pr == NULL) { + fprintf (stderr, + "attempt to allocate frame buffer %d (%dx%d) fails\n", + i + 1, Fb_width, Fb_height); + if (i) + break; + else + return (-1); + } else if (!fb_nframes++) { + cb_pr = mem_create (Fb_width, cb_height, fb_depth); + if (pw_rect.r_width) + init_colorbar (pw_rect.r_width); + } + + fb->fb_xoff = 0; + fb->fb_yoff = 0; + fb->fb_xzoom = fb->fb_yzoom = 1; + fb->fb_center = fb_ngrey / 2.0; + fb->fb_slope = (float)white / (float)(fb_ngrey - 1); + fb->fb_maptype = maptype; + fb->fb_objno = 1; + fb->fb_imageno = 0; + fb->fb_frameno = i + 1; + fb->fb_ctran.valid = 0; + fb->fb_ctran.imtitle[0] = '\0'; + strcpy (fb->fb_ctran.format, W_DEFFORMAT); + } + + set_zoom (df_p, 0, 0, 1); + return (fb_config[config].nframes = fb_nframes); +} + + +/* INIT_COLORBAR -- Write the colorbar into the frame buffer. The length of + * the colorbar should correspond to the current width of the display window, + * but must not exceed the width of the frame buffer. + */ +init_colorbar (cb_width) +int cb_width; +{ + register int i; + unsigned char *lp; + Pixrect *pr; + + if (cb_height <= 0) + return; + + if ((pr = mem_create (cb_width, 1, fb_depth)) != NULL) { + lp = (unsigned char *) mpr_d(pr)->md_image; + /* Write colorbar. */ + for (i=0; i < cb_width; i++) + lp[i] = (CMS_DATARANGE-1) * i / (cb_width-1) + + CMS_DATASTART; + for (i=3; i < cb_height; i++) + pr_rop (cb_pr, 0, i, cb_width, 1, PIX_SRC, pr, 0, 0); + + /* Add a border between image and colorbar. */ + for (i=0; i < cb_width; i++) + lp[i] = NGREY-1; + for (i=0; i < 3; i++) + pr_rop (cb_pr, 0, i, cb_width, 1, PIX_SRC, pr, 0, 0); + + for (i=0; i < cb_width; i++) + lp[i] = 0; + for (i=1; i < 2; i++) + pr_rop (cb_pr, 0, i, cb_width, 1, PIX_SRC, pr, 0, 0); + + pr_close (pr); + } +} + + +/* INIT_COLORMAP -- Initialize the IMTOOL color map. + */ +static +init_colormap (pw) +struct pixwin *pw; +{ + register unsigned char *r = red; + register unsigned char *g = green; + register unsigned char *b = blue; + int planes = NGREY-1, i; + + /* Initialize the IMTOOL colormap from the current fullscreen + * colormap, so that the (small) colormap entries of the other + * windows will be preserved, as far as possible. + */ + grab_colormap (r, g, b); + + /* Set a linear transfer function for the main part of the table. */ + for (i=CMS_DATASTART; i <= CMS_DATAEND; i++) + r[i] = g[i] = b[i] = i * (white + 1) / CMS_DATARANGE; + + /* Color table entry for the cursor. */ + r[CMS_CURSOR] = white; + g[CMS_CURSOR] = white; + b[CMS_CURSOR] = white; + + /* Set the background and graphics colors. + */ + i = CMS_BACKGROUND; + r[i] = 0; g[i] = 0; b[i] = 0; i++; /* 202=black */ + + i = CMS_GRAPHICSSTART; + r[i] = 255; g[i] = 255; b[i] = 255; i++; /* 203=white */ + + r[i] = 255; g[i] = 0; b[i] = 0; i++; /* 204=red */ + r[i] = 0; g[i] = 255; b[i] = 0; i++; /* 205=green */ + r[i] = 0; g[i] = 0; b[i] = 255; i++; /* 206=blue */ + r[i] = 255; g[i] = 255; b[i] = 0; i++; /* 207=yellow */ + r[i] = 0; g[i] = 255; b[i] = 255; i++; /* 208=cyan */ + r[i] = 255; g[i] = 0; b[i] = 255; i++; /* 209=magenta */ + r[i] = 255; g[i] = 127; b[i] = 0; i++; /* 210=coral */ + r[i] = 142; g[i] = 35; b[i] = 107; i++; /* 211=maroon */ + r[i] = 204; g[i] = 50; b[i] = 50; i++; /* 212=orange */ + r[i] = 159; g[i] = 159; b[i] = 95; i++; /* 213=khaki */ + r[i] = 219; g[i] = 112; b[i] = 219; i++; /* 214=orchid */ + r[i] = 112; g[i] = 219; b[i] = 219; i++; /* 215=turquoise */ + r[i] = 159; g[i] = 95; b[i] = 159; i++; /* 216=violet */ + r[i] = 216; g[i] = 216; b[i] = 191; i++; /* 217=wheat */ + + pw_setcmsname (pw, CMMAPNAME); + pw_putcolormap (pw, 0, NGREY, r, g, b); + pw_putattributes (pw, &planes); +} + + +/* COMPUTE_TRANSFER_FUNCTION -- Compute the slope and offset of the transfer + * function for the current display frame, given the coordinates of the + * mouse in the frame. + */ +static +compute_transfer_function (event) +Event *event; +{ + float xsize, ysize; + float y, slope; + int neg; + + xsize = pw_rect.r_width; + ysize = pw_rect.r_height; + + /* Compute the slope of the transfer function. */ + y = event_y(event) / ysize * 2.0 - 1.0; + if (neg = (y < 0.0)) + y = -y; + if (y > 0.99) + y = 0.99; + if ((slope = tan (y * M_PI_2)) > white) + slope = white; + + /* Record new transfer function in frame buffer descriptor. */ + df_p->fb_center = event_x(event) / xsize * (fb_ngrey-1); + df_p->fb_slope = neg ? -slope : slope; +} + + +/* SET_TRANSFER_FUNCTION -- Load the color map as necessary to implement the + * given linear transfer function. + */ +static +set_transfer_function (pw, center, slope) +struct pixwin *pw; /* reference pixwin */ +float center; /* greyscale value at half intensity */ +float slope; /* delta-intensity per greyscale unit */ +{ + register int i; + register float z, zmin, zmax; + unsigned char o_red[NGREY], o_green[NGREY], o_blue[NGREY]; + unsigned char *p_r, *p_g, *p_b; + + if (center < CMS_DATASTART) + center = CMS_DATASTART; + else if (center > CMS_DATAEND) + center = CMS_DATAEND; + + zmin = 0.0; + zmax = white; + + z = white / 2; + for (i=center; i <= CMS_DATAEND; i++) { + o_red[i] = m_red[(unsigned char)(int)z]; + o_green[i] = m_green[(unsigned char)(int)z]; + o_blue[i] = m_blue[(unsigned char)(int)z]; + z += slope; + if (z <= zmin) + z = zmin; + else if (z >= zmax) + z = zmax; + } + + z = white / 2; + for (i=center; i >= CMS_DATASTART; i--) { + o_red[i] = m_red[(unsigned char)(int)z]; + o_green[i] = m_green[(unsigned char)(int)z]; + o_blue[i] = m_blue[(unsigned char)(int)z]; + z -= slope; + if (z <= zmin) + z = zmin; + else if (z >= zmax) + z = zmax; + } + + p_r = &o_red[CMS_DATASTART]; + p_g = &o_green[CMS_DATASTART]; + p_b = &o_blue[CMS_DATASTART]; + + /*pw_putcolormap (pw, CMS_DATASTART, CMS_DATARANGE, p_r, p_g, p_b);*/ + + bcopy (p_r, &red[CMS_DATASTART], CMS_DATARANGE); + bcopy (p_g, &green[CMS_DATASTART], CMS_DATARANGE); + bcopy (p_b, &blue[CMS_DATASTART], CMS_DATARANGE); + + /* Reset the full 8 bit colormap for the pixwin, to pick up any + * changes made in the unused regions for other windows, picked up + * by edit_colortable below. + */ + pw_putcolormap (pw, 0, NGREY, red, green, blue); +} + + +/* SET_COLORTABLE -- Set up the RGB lookup tables used to map the windowed + * monochrome output of a frame buffer into the hardware colormap. + */ +static Notify_value +set_colortable() +{ + register int v, vsat, step, i; + static int seed = 0; + int knot[7]; + + vsat = NGREY - 1; + step = NGREY / 6; + for (i=0; i < 7; i++) + knot[i] = i * step; + knot[6] = vsat; + + switch (df_p->fb_maptype) { + case MONO: + for (i=0; i < NGREY; i++) + m_red[i] = m_green[i] = m_blue[i] = i; + break; + + case HEAT: + for (i=0; i < NGREY; i++) { + m_red[i] = heat.hue[i].red * (NGREY - 1); + m_green[i] = heat.hue[i].green * (NGREY - 1); + m_blue[i] = heat.hue[i].blue * (NGREY - 1); + } + break; + + case RAMP1: + for (i=0; i < NGREY; i++) { + m_red[i] = heat.hue[i].red * NGREY; + m_green[i] = heat.hue[i].green * NGREY; + m_blue[i] = heat.hue[i].blue * NGREY; + } + break; + + case RAMP2: + for (i=0; i < NGREY; i++) { + m_red[i] = heat.hue[i].red * ((NGREY - 1) * 2); + m_green[i] = heat.hue[i].green * ((NGREY - 1) * 2); + m_blue[i] = heat.hue[i].blue * ((NGREY - 1) * 2); + } + break; + + case HALLEY: + for (i=0; i < NGREY; i++) { + m_red[i] = halley.hue[i].red * (NGREY - 1); + m_green[i] = halley.hue[i].green * (NGREY - 1); + m_blue[i] = halley.hue[i].blue * (NGREY - 1); + } + break; + + case ULUT1: + case ULUT2: + { struct lut user; + struct triplet *p; + int i, j; + FILE *fp; + char *s; + + s = (df_p->fb_maptype == ULUT1) ? u_lut1 : u_lut2; + if ((fp = fopen (getfname(s,0), "r")) == NULL) { + fprintf (stderr, "cannot open %s\n", s); + return; + } + + for (user.lutlen=0; user.lutlen < NGREY; user.lutlen++) { + p = &user.hue[user.lutlen]; + if (fscanf (fp, " %f %f %f", + &p->red, &p->green, &p->blue) == EOF) + break; + } + + for (i=0; i < NGREY; i++) { + j = max(0, min(NGREY-1, (i * user.lutlen / NGREY))); + m_red[i] = user.hue[j].red * (NGREY - 1); + m_green[i] = user.hue[j].green * (NGREY - 1); + m_blue[i] = user.hue[j].blue * (NGREY - 1); + } + + fclose (fp); + } + break; + + case LINEARPS: + for (i=0; i < NGREY; i++) + m_red[i] = m_green[i] = m_blue[i] = 0; + + for (i=knot[0]; i <= knot[1]; i++) + m_blue[i] = vsat * (i - knot[0]) / step; + for (i=knot[1]; i <= knot[2]; i++) + m_blue[i] = vsat; + for (i=knot[2]; i <= knot[3]; i++) + m_blue[i] = vsat * (knot[3] - i) / step; + + for (i=knot[1]; i <= knot[2]; i++) + m_green[i] = vsat * (i - knot[1]) / step; + for (i=knot[2]; i <= knot[4]; i++) + m_green[i] = vsat; + for (i=knot[4]; i <= knot[5]; i++) + m_green[i] = vsat * (knot[5] - i) / step; + + for (i=knot[3]; i <= knot[4]; i++) + m_red[i] = vsat * (i - knot[3]) / step; + for (i=knot[4]; i <= knot[6]; i++) + m_red[i] = vsat; + + for (i=knot[5]; i <= knot[6]; i++) { + if ((v = vsat * (i - knot[5]) / step) > vsat) + v = vsat; + m_green[i] = m_blue[i] = v; + } + break; + + case CRANDOMPS: + set_transfer_function (gio_pw, df_p->fb_center, df_p->fb_slope); + imt_pause (cr_msec[crandom_blink_rate], set_colortable); + /* fall through */ + + case RANDOMPS: + if (!seed) + seed = time(0); + srand (seed++); + for (i=0; i < NGREY; i++) { + m_red[i] = ((rand() >> 4) % NGREY); + m_green[i] = ((rand() >> 4) % NGREY); + m_blue[i] = ((rand() >> 4) % NGREY); + } + break; + } +} + + +/* GRAB_COLORMAP -- Read the current physical full screen colormap. + */ +static +grab_colormap (red, green, blue) +unsigned char red[], green[], blue[]; +{ + struct pixrect *screen; + + if (window_open) { + screen = pr_open ("/dev/fb"); + pr_getcolormap (screen, 0, NGREY, red, green, blue); + pr_close (screen); + } +} + + +/* IMTOOL_CLOCK -- The main imtool clock. + */ +static +imtool_clock (client, event, arg) +Notify_client client; +Notify_event event; +Notify_arg arg; +{ + static int delay=0, interval=0, toggle=0; + Cursor cursor; + int frame, n; + + /* Blink cursor (variable rate). */ + cursor = window_get (gio_canvas, WIN_CURSOR); + toggle = !toggle; + if (reading_imcursor) { + cursor_set (cursor, + CURSOR_OP, toggle + ? PIX_NOT(PIX_SRC) & PIX_DST + : PIX_SRC | PIX_DST | PIX_COLOR(NGREY-1), + 0); + } else { + cursor_set (cursor, + CURSOR_CROSSHAIR_COLOR, + toggle ? CMS_BACKGROUND : CMS_CURSOR, + 0); + } + window_set (gio_canvas, WIN_CURSOR, cursor, 0); + + /* Things that happen at a fixed interval. */ + if ((delay += interval) >= CLOCK_INTERVAL) { + /* Keep imtool visible (if window open). */ + edit_colormap(); + + /* Frame blink. The frames in the blink frame list do not have to + * exist; if not, then advance through the list until either a valid + * frame is found, or the list has been traversed once. + */ + if (blink && n_blink_frames > 0 && state != WINDOW && window_open) { + if (--blink_timer <= 0) { + for (n=n_blink_frames; --n >= 0; ) { + if (++blink_frame >= n_blink_frames) + blink_frame = 0; + frame = blink_frames[blink_frame]; + if (frame >= 1 && frame <= fb_nframes) { + set_frame (frame); + if (display_coords && state == TRACK_CURSOR) + update_coords (NULL); + break; + } + } + blink_timer = blink_rate[blink_rate_index]; + } + } + + delay = 0; + } + + interval = reading_imcursor ? CLOCK_INTERVAL/4 : CLOCK_INTERVAL; + imt_pause (interval, imtool_clock); +} + + +/* EDIT_COLORMAP -- Overwrite the portion of the full screen colormap used + * by the display server. This must be done in such a way that changes to + * the region of the screen colortable used by other windows are preserved. + */ +static +edit_colormap() +{ + struct pixrect *screen; + unsigned char r[NGREY], g[NGREY], b[NGREY]; + + if (state != WINDOW && window_open) { + /* Edit the physical colortable. */ + screen = pr_open ("/dev/fb"); + pr_getcolormap (screen, 0, NGREY, r, g, b); + + /* Make the cursor blink between black and white for better vis. + * (>> now done with set_cursor in imtool_clock()) + if (green[CMS_CURSOR] == white) { + red[CMS_CURSOR] = black; + green[CMS_CURSOR] = black; + blue[CMS_CURSOR] = black; + } else { + red[CMS_CURSOR] = white; + green[CMS_CURSOR] = white; + blue[CMS_CURSOR] = white; + } + */ + + bcopy (&red[CMS_FIRST], &r[CMS_FIRST], CMS_NGREY); + bcopy (&green[CMS_FIRST], &g[CMS_FIRST], CMS_NGREY); + bcopy (&blue[CMS_FIRST], &b[CMS_FIRST], CMS_NGREY); + + pw_putcolormap (gio_pw, 0, NGREY, r, g, b); + if (global_colortable) + pr_putcolormap (screen, 0, NGREY, r, g, b); + pr_close (screen); + + /* Update the canvas pixwin colortable. */ + bcopy (r, red, NGREY); + bcopy (g, green, NGREY); + bcopy (b, blue, NGREY); + } +} + + +/* SHOW_COLORMAP -- Print the contents of the color map for a pixwin. + */ +static +show_colormap (pw, first, last) +struct pixwin *pw; +int first, last; +{ + unsigned char r[NGREY], g[NGREY], b[NGREY]; + char cmsname[CMS_NAMESIZE]; + int i, n; + + pw_getcmsname (pw, cmsname); + pw_getcolormap (pw, 0, NGREY, r, g, b); + + printf ("color map segment = '%s'\n", cmsname); + for (i=first, n=0; i <= last; i++) { + printf ("%3d %3d %3d", r[i], g[i], b[i]); + printf ((++n % 5) ? " " : "\n"); + } + printf ("\n"); +} + + +/* LOAD_TESTPATTERN -- Load a test pattern into the reference frame buffer. + */ +static +load_testpattern (type) +int type; /* pattern type desired */ +{ + register unsigned char *line; + register int i, j, color; + unsigned char *fb, *oline; + + fb = (unsigned char *) mpr_d(df_p->fb_pr)->md_image; + + switch (type) { + case 0: + /* Compute first line. */ + oline = line = fb; + for (i=0, color=0; i < Fb_width; i++) + if (((i+16) % 32) == 0) { + line[i] = 0; + color = ((i+j) % CMS_DATARANGE) / 32 * 32; + } else + line[i] = color; + + /* Compute remaining lines. */ + for (j=1; j < Fb_height; j++) { + line = fb + j * Fb_width; + if (((j+16) % 32) == 0) { + for (i=0; i < Fb_width; i++) + line[i] = 0; + if (++j >= Fb_height) + break; + line = fb + j * Fb_width; + color = (j % CMS_DATARANGE) / 32 * 32; + for (i=0; i < Fb_width; i++) + if (((i+16) % 32) == 0) { + line[i] = 0; + color = ((i+j) % CMS_DATARANGE) / 32 * 32; + } else + line[i] = color; + oline = line; + } else + bcopy (oline, line, Fb_width); + } + break; + + case 1: + for (j=1; j < Fb_height; j++) { + line = fb + j * Fb_width; + for (i=0; i < Fb_width; i++) + line[i] = (i % CMS_DATARANGE); + } + break; + + case 2: + for (j=1; j < Fb_height; j++) { + line = fb + j * Fb_width; + for (i=0; i < Fb_width; i++) + line[i] = ((i+j) % CMS_DATARANGE); + } + break; + } +} + + +/* For the moment we take an IIS model 70 command/data stream as input; this + * is used to load images into the image display. This is a kludge interface + * for the prototype, convenient since the high level software is written for + * the IIS. + */ +#define MEMORY 01 /* frame buffer i/o */ +#define LUT 02 /* lut i/o */ +#define FEEDBACK 05 /* used for frame clears */ +#define IMCURSOR 020 /* logical image cursor */ +#define WCS 021 /* used to set WCS */ + +#define SZ_IMCURVAL 160 +#define PACKED 0040000 +#define COMMAND 0100000 +#define IIS_READ 0100000 +#define IMC_SAMPLE 0040000 +#define IMT_FBCONFIG 077 +#define XYMASK 077777 + +struct iism70 { + short tid; + short thingct; + short subunit; + short checksum; + short x, y, z; + short t; +}; + +/* EV_CMDINPUT -- Called when command or data input has arrived via the + * pseudodevice input stream from some applications process. + */ +static Notify_value +ev_cmdinput (frame, event, arg, type) +Frame frame; +Event *event; +Notify_arg arg; +Notify_event_type type; +{ + register unsigned char *cp; + register int sum, i; + register short *p; + int ndatabytes, nbytes, n, ntrys=0; + static int errmsg=0, bswap=0; + struct iism70 iis; + char buf[SZ_FIFOBUF]; + int fb_index; + + /* Get the IIS header. */ + if (read (datain, (char *)&iis, sizeof(iis)) < sizeof(iis)) { + fprintf (stderr, "imtool: command input read error\n"); + return (NOTIFY_DONE); + } else if (bswap) + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + + /* Verify the checksum. If it fails swap the bytes and try again. + */ + for (;;) { + for (i=0, sum=0, p=(short *)&iis; i < 8; i++) + sum += *p++; + if ((sum & 0177777) == 0177777) + break; + + if (ntrys++) { + if (!errmsg++) { + fprintf (stderr, "imtool: bad data header checksum\n"); + if (bswap) + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + fprintf (stderr, "noswap:"); + for (i=0, p=(short *)&iis; i < 8; i++) + fprintf (stderr, " %6o", p[i]); + fprintf (stderr, "\n"); + + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + fprintf (stderr, " swap:"); + for (i=0, p=(short *)&iis; i < 8; i++) + fprintf (stderr, " %6o", p[i]); + fprintf (stderr, "\n"); + } + break; + + } else { + bswap2 ((char *)&iis, (char *)&iis, sizeof(iis)); + bswap = !bswap; + } + } + + ndatabytes = -iis.thingct; + if (!(iis.tid & PACKED)) + ndatabytes *= 2; + + switch (iis.subunit & 077) { + case FEEDBACK: + /* The feedback unit is used only to clear a frame. + */ + set_reference_frame (decode_frameno (iis.z & 07777)); + erase (rf_p); + break; + + case LUT: + /* Data mode writes to the frame lookup tables are not implemented. + * A command mode write to the LUT subunit is used to connect + * image memories up to the RGB channels, i.e., to select the frame + * to be displayed. We ignore any attempt to assign multiple + * frames to multiple color channels, and just do a simple frame + * select. + */ + if (iis.subunit & COMMAND) { + int frame, z, n; + short x[14]; + + if (read (datain, (char *)x, ndatabytes) == ndatabytes) { + if (bswap) + bswap2 ((char *)x, (char *)x, ndatabytes); + + z = x[0]; + if (!z) z = 1; + for (n=0; !(z & 1); z >>= 1) + n++; + + frame = max (1, n + 1); + if (frame > fb_nframes) { + if (frame < MAX_FRAMES) + set_fbconfig (fb_config_index, frame); + else { + fprintf (stderr, "imtool warning: "); + fprintf (stderr, + "attempt to display nonexistent frame %d\n", frame); + frame = fb_nframes - 1; + } + } + + set_frame (frame); + return (NOTIFY_DONE); + } + } + + case MEMORY: + /* Load data into the frame buffer. Data is assumed to be byte + * packed. + */ + if (iis.tid & IIS_READ) { + /* Read from the display. + */ + unsigned char *fb, *ip; + int nbytes, nleft, n, x, y; + long starttime; + + /* Get the frame to be read from. */ + set_reference_frame (decode_frameno (iis.z & 07777)); + + fb = (unsigned char *) mpr_d(rf_p->fb_pr)->md_image; + nbytes = ndatabytes; + x = iis.x & XYMASK; + y = iis.y & XYMASK; + + ip = max (fb, min (fb + Fb_width * Fb_height - nbytes, + fb + y * Fb_width + x)); + if (ip != fb + y * Fb_width + x) { + fprintf (stderr, + "imtool: attempted read out of bounds on framebuf\n"); + fprintf (stderr, + "read %d bytes at [%d,%d]\n", nbytes, x, y); + } + + /* Return the data from the frame buffer. */ + starttime = time(0); + for (nleft = nbytes; nleft > 0; nleft -= n) { + n = (nleft < SZ_FIFOBUF) ? nleft : SZ_FIFOBUF; + if ((n = write (dataout, ip, n)) <= 0) { + if (n < 0 || (time(0) - starttime > IO_TIMEOUT)) { + fprintf (stderr, "IMTOOL: timeout on write\n"); + break; + } + } else + ip += n; + } + + return (NOTIFY_DONE); + + } else { + /* Write to the display. + */ + unsigned char *fb, *op; + int nbytes, nleft, n, x, y; + long starttime; + + /* Get the frame to be written into (encoded with a bit for + * each frame, 01 is frame 1, 02 is frame 2, 04 is frame 3, + * and so on). + */ + set_reference_frame (decode_frameno (iis.z & 07777)); + + /* Get a pointer into the frame buffer where the data will + * be put. + */ + fb = (unsigned char *) mpr_d(rf_p->fb_pr)->md_image; + nbytes = ndatabytes; + x = iis.x & XYMASK; + y = iis.y & XYMASK; + + op = max (fb, min (fb + Fb_width * Fb_height - nbytes, + fb + y * Fb_width + x)); + if (op != fb + y * Fb_width + x) { + fprintf (stderr, + "imtool: attempted write out of bounds on framebuf\n"); + fprintf (stderr, + "write %d bytes to [%d,%d]\n", nbytes, x, y); + } + + /* Read the data into the frame buffer. + */ + starttime = time(0); + for (nleft = nbytes; nleft > 0; nleft -= n) { + n = (nleft < SZ_FIFOBUF) ? nleft : SZ_FIFOBUF; + if ((n = read (datain, op, n)) <= 0) { + if (n < 0 || (time(0) - starttime > IO_TIMEOUT)) + break; + } else { + /* Set any zeroed pixels to the background color, + * if a special background color is specified. + */ + if (background) + for (cp=op, i=n; --i >= 0; cp++) + if (!*cp) + *cp = background; + op += n; + } + } + + /* Refresh the display, if the current display frame is the + * same as the reference frame. + */ + if (rf_p == df_p) { + BRect fb_r, pw_r; + + fb_r.r_left = x * zoom; + fb_r.r_top = y * zoom; + fb_r.r_width = min (nbytes * zoom, fb_width); + fb_r.r_height = ((nbytes*zoom*zoom + fb_width-1)/fb_width); + + Bpw_get_region_rect (gio_pw, &pw_rect); + Bpw_lock (gio_pw, &pw_rect); + + pw_rect.r_left = df_p->fb_xoff; + pw_rect.r_top = df_p->fb_yoff; + + if (maprect (&fb_rect, &fb_r, &pw_rect, &pw_r)) + if (maprect (&pw_rect, &pw_r, &fb_rect, &fb_r)) { + ds_write (gio_pw, + pw_r.r_left, pw_r.r_top, + pw_r.r_width, pw_r.r_height, + PIX_SRC | PIX_COLOR(NGREY-1), + df_p->fb_pr, fb_r.r_left, fb_r.r_top); + + if (pw_r.r_top + pw_r.r_height >= pw_rect.r_height + - cb_height) + put_colorbar(); + } + + Bpw_unlock (gio_pw); + } + + return (NOTIFY_DONE); + } + break; + + case WCS: + /* Read or write the WCS for a frame. The frame number to + * which the WCS applies is passed in Z and the frame buffer + * configuration in T. The client changes the frame buffer + * configuration in a WCS set. The WCS text follows the header + * as byte packed ASCII data. + */ + if (iis.tid & IIS_READ) { + /* Return the WCS for the referenced frame. + */ + char emsg[SZ_FNAME]; + char *text; + int frame; + + frame = decode_frameno (iis.z & 07777); + if (frame > fb_nframes) + strcpy (text=emsg, "[NOSUCHFRAME]\n"); + else { + set_reference_frame (frame); + text = wcsbuf[reference_frame-1]; + } + + write (dataout, text, SZ_WCSBUF); + + } else { + /* Set the WCS for the referenced frame. + */ + char buf[1024]; + int fb_config, frame; + + frame = decode_frameno (iis.z & 07777); + if (frame > fb_nframes) + if (frame < MAX_FRAMES) + set_fbconfig (fb_config_index, frame); + + set_reference_frame (frame); + if ((fb_config = iis.t & 077) != fb_config_index) + set_fbconfig (fb_config, reference_frame); + + /* Read in and set up the WCS. */ + if (read (datain, buf, ndatabytes) == ndatabytes) + strncpy (wcsbuf[reference_frame-1], buf, SZ_WCSBUF); + + strcpy (rf_p->fb_ctran.format, W_DEFFORMAT); + rf_p->fb_ctran.imtitle[0] = '\0'; + rf_p->fb_ctran.valid = 0; + rf_p->fb_imageno++; + rf_p->fb_objno = 1; + + wcs_update (rf_p); + if (rf_p == df_p) + window_set (gio_frame, FRAME_LABEL, framelabel(), 0); + } + + return (NOTIFY_DONE); + break; + + case IMCURSOR: + /* Read or write the logical image cursor. This is an extension + * added to provide a high level cursor read facility; this is + * not the same as a low level access to the IIS cursor subunit. + * Cursor reads may be either nonblocking (immediate) or blocking, + * using the keyboard or mouse to terminate the read, and + * coordinates may be returned in either image (world) or frame + * buffer pixel coordinates. + */ + if (iis.tid & IIS_READ) { + /* Read the logical image cursor. In the case of a blocking + * read all we do is initiate a cursor read; completion occurs + * when the user hits a key or button. + */ + if (iis.tid & IMC_SAMPLE) { + /* Sample the cursor position. */ + register struct ctran *ct; + int wcs = iis.z; + int sx, sy; + float wx, wy; + + wx = sx = last_sx + pw_rect.r_left; + wy = sy = last_sy + pw_rect.r_top; + + if (wcs) { + ct = wcs_update (df_p); + if (ct->valid) { + if (abs(ct->a) > .001) + wx = ct->a * sx + ct->c * sy + ct->tx; + if (abs(ct->d) > .001) + wy = ct->b * sx + ct->d * sy + ct->ty; + } + } + + /* Return the cursor value on the output datastream encoded + * in a fixed size ascii buffer. + */ + gio_retcursorval (wx, wy, display_frame*100+wcs, 0, ""); + + } else { + /* Initiate a user triggered cursor read. */ + gio_readcursor (iis.z); + } + + } else { + /* Write (set) the logical image cursor position. */ + register struct ctran *ct; + int sx = iis.x, sy = iis.y; + float wx = sx, wy = sy; + int wcs = iis.z; + + if (wcs) { + ct = wcs_update (df_p); + if (ct->valid) { + if (abs(ct->a) > .001) + sx = (wx - ct->tx) / ct->a; + if (abs(ct->d) > .001) + sy = (wy - ct->ty) / ct->d; + } + } + + gio_setcursorpos (sx - pw_rect.r_left, sy - pw_rect.r_top); + } + + return (NOTIFY_DONE); + break; + + default: + /* Ignore unsupported command input. + */ + break; + } + + /* Discard any data following the header. */ + if (!(iis.tid & IIS_READ)) + for (nbytes = ndatabytes; nbytes > 0; nbytes -= n) { + n = (nbytes < SZ_FIFOBUF) ? nbytes : SZ_FIFOBUF; + if ((n = read (datain, buf, n)) <= 0) + break; + } + + return (NOTIFY_DONE); +} + + +/* SET_REFERENCE_FRAME -- Set reference frame. If the frame referenced is + * greater than the current number of frames, attempt to increase the number + * of frames. + */ +static +set_reference_frame (n) +register int n; +{ + reference_frame = max (1, n); + if (reference_frame > fb_nframes) { + if (reference_frame < MAX_FRAMES) + set_fbconfig (fb_config_index, reference_frame); + else { + fprintf (stderr, "imtool warning: "); + fprintf (stderr, + "attempt to reference nonexistent frame %d\n", + reference_frame); + reference_frame = fb_nframes; + } + } + + rf_p = frames + (reference_frame - 1); +} + + +/* DECODE_FRAMENO -- Decode encoded IIS register frame number. + */ +static +decode_frameno (z) +register int z; +{ + register int n; + + /* Get the frame number, encoded with a bit for each frame, 01 is + * frame 1, 02 is frame 2, 04 is frame 3, and so on. + */ + if (!z) z = 1; + for (n=0; !(z & 1); z >>= 1) + n++; + + return (max (1, n + 1)); +} + + +/* BSWAP2 - Move bytes from array "a" to array "b", swapping successive + * pairs of bytes. The two arrays may be the same but may not be offset + * and overlapping. + */ +static +bswap2 (a, b, nbytes) +char *a, *b; /* input array */ +int nbytes; /* number of bytes to swap */ +{ + register char *ip=a, *op=b, *otop; + register unsigned temp; + + /* Swap successive pairs of bytes. + */ + for (otop = op + (nbytes & ~1); op < otop; ) { + temp = *ip++; + *op++ = *ip++; + *op++ = temp; + } + + /* If there is an odd byte left, move it to the output array. + */ + if (nbytes & 1) + *op = *ip; +} + + +/* Cursor and marker pixrects. + */ +static short p_imcursor[] = { +#include "imtool.cursor" +}; +static short p_imcross[] = { +#include "imtool.cross" +}; +static short p_imsquare[] = { +#include "imtool.square" +}; +mpr_static (old_cursor, 16, 16, 1, NULL); +mpr_static (pr_cursor, 16, 16, 1, p_imcursor); +mpr_static (pr_cross, 16, 16, 1, p_imcross); +mpr_static (pr_square, 16, 16, 1, p_imsquare); +static struct pixrect *marker[] = { NULL, &pr_cursor, &pr_cross, &pr_square }; + +/* GIO_READCURSOR -- Initiate an image cursor read. Save the current + * mouse coordinates if outside the imtool window, restore the mouse to the + * imtool window, and change the cursor shape to indicate that a cursor read + * is in progress. May be called while a cursor read is already in progress + * to reset the cursor-read cursor pixrect. + */ +static +gio_readcursor (wcs) +int wcs; +{ + Cursor cursor = window_get (gio_canvas, WIN_CURSOR); + + if (!reading_imcursor) { + /* Save cursor pixrect for later restore. */ + old_cursor = *((Pixrect *) cursor_get (cursor, CURSOR_IMAGE)); + + /* Save the absolute mouse position so that we can restore it when + * the cursor read is completed. Restore the mouse to the most + * recent position in the IMTOOL window. + */ + get_absmousepos (gio_frame_fd, &save_sx, &save_sy); + gio_setcursorpos (last_sx, last_sy); + + reading_imcursor++; + imcursor_wcs = wcs; + } + + /* Change the cursor shape while the cursor read is in progress. */ + cursor_set (cursor, + CURSOR_IMAGE, &pr_cursor, + CURSOR_SHOW_CURSOR, TRUE, + CURSOR_SHOW_CROSSHAIRS, FALSE, + CURSOR_OP, PIX_NOT(PIX_SRC) & PIX_DST | PIX_COLOR(CMS_CURSOR), + CURSOR_XHOT, 8, + CURSOR_YHOT, 8, + 0); + window_set (gio_canvas, WIN_CURSOR, cursor, 0); +} + + +/* GIO_RESTORECURSOR -- Restore the original cursor. + */ +static +gio_restorecursor() +{ + if (reading_imcursor) { + Cursor cursor; + + /* Restore the mouse position to whatever it was before IMTOOL + * grabbed the mouse for the cursor read. + */ + set_absmousepos (gio_frame_fd, save_sx, save_sy); + + /* Restore the default IMTOOL cursor shape. */ + cursor = window_get (gio_canvas, WIN_CURSOR); + cursor_set (cursor, + CURSOR_IMAGE, &old_cursor, + CURSOR_SHOW_CURSOR, FALSE, + CURSOR_SHOW_CROSSHAIRS, (cursor_show == CURSOR_ON), + 0); + window_set (gio_canvas, WIN_CURSOR, cursor, 0); + + reading_imcursor = 0; + } +} + + +/* GIO_RETCURSORVAL -- Return the cursor value on the output datastream to + * the client which requested the cursor read. + */ +static +gio_retcursorval (wx, wy, wcs, key, strval) +float wx, wy; /* cursor coordinates */ +int wcs; /* encoded WCS value */ +int key; /* keystroke used as trigger */ +char *strval; /* optional string value */ +{ + char curval[SZ_IMCURVAL]; + char keystr[20]; + + /* Encode the cursor value. */ + if (key == EOF) + sprintf (curval, "EOF\n"); + else { + if (isprint (key) && !isspace(key)) { + keystr[0] = key; + keystr[1] = '\0'; + } else + sprintf (keystr, "\\%03o", key); + + sprintf (curval, "%10.3f %10.3f %d %s %s\n", + wx, wy, wcs, keystr, strval); + } + + /* Send it to the client program. */ + write (dataout, curval, sizeof(curval)); +} + + +/* EV_GIOFRAME -- GIO frame event handler. + */ +static Notify_value +ev_gioframe (frame, event, arg, type) +Frame frame; +Event *event; +Notify_arg arg; +Notify_event_type type; +{ + Notify_value value; + + value = notify_next_event_func (frame, event, arg, type); + window_open = (((int) window_get (gio_frame, FRAME_CLOSED)) == 0); + + return (value); +} + + +/* EV_GIOINPUT -- GIO input event handler. + */ +static Notify_value +ev_gioinput (frame, event, arg, type) +Frame frame; +Event *event; +Notify_arg arg; +Notify_event_type type; +{ + register int key; + Notify_value value; + static float xsize, ysize; + BRect rect; + char ch; + + key = event_id (event); + + /* The following is to attempt to restore the image greyscale in the + * global color map, after the color map has been clobbered by the + * window manager when the mouse is moved to some other window. + */ + if (key == KBD_DONE || key == LOC_WINEXIT) { + edit_colormap(); + return (NOTIFY_DONE); + } + + /* Let frame operate upon the event. */ + if ((int)type != PANNER_EVENT) + value = notify_next_event_func (frame, event, arg, type); + + switch (key) { + case WIN_RESIZE: + Bpw_get_region_rect (gio_pw, &pw_rect); + pw_rect.r_left = df_p->fb_xoff = + max(0, min(fb_rect.r_width - pw_rect.r_width, df_p->fb_xoff)); + pw_rect.r_top = df_p->fb_yoff = + max(0, min(fb_rect.r_height - pw_rect.r_height, df_p->fb_yoff)); + + gio_xsize = pw_rect.r_width; + gio_ysize = pw_rect.r_height; + init_colorbar (pw_rect.r_width); + + wc_xoff = wc_yoff = 0; + if (display_coords && state == TRACK_CURSOR) + update_coords (event); + break; + + case KEY_SNAP: + /* Imcopy. */ + imagecopy_proc(); + break; + + case KEY_PCOORDS: + /* Enable/disable continuous display of the cursor coordinates. */ + toggle_displaycoords (event); + break; + + case KEY_SETUP: + /* Toggle display of the setup panel. */ + setup_proc(); + break; + + case KEY_REMARK: + /* Remark a list of objects. */ + if (event_is_down(event)) { + char fname[SZ_FNAME]; + + wcs_update (df_p); + o_revtext = !o_revtext; + sprintf (fname, o_fname, df_p->fb_frameno, df_p->fb_imageno); + strcpy (fname, getfname(fname, 0)); + remark_objects (fname); + } + break; + + case MS_RIGHT: + if (event_is_down(event)) { + last_sx = last_bx = event_x(event); + last_sy = last_by = event_y(event); + } + + /* If the cursor is moved while the right mouse button is + * depressed the image is windowed. If the control key is also + * depressed the cursor is used to roam about in the frame buffer. + */ + if (state == TRACK_CURSOR && event_is_down(event)) { + if (event_ctrl_is_down (event)) + state = ROAM; + else + state = WINDOW; + xsize = pw_rect.r_width; + ysize = pw_rect.r_height; + if (state == WINDOW) { + switch (df_p->fb_maptype) { + case MONO: + case HEAT: + case RAMP1: + case RAMP2: + case HALLEY: + case LINEARPS: + case ULUT1: + case ULUT2: + compute_transfer_function (event); + break; + case RANDOMPS: + case CRANDOMPS: + set_colortable(); + break; + } + set_transfer_function (gio_pw, + df_p->fb_center, df_p->fb_slope); + } + } else if (state != TRACK_CURSOR && event_is_up(event)) + state = TRACK_CURSOR; + break; + + case LOC_DRAG: + last_sx = event_x (event); + last_sy = event_y (event); + + if (panning) + p_cursor_setback--; + if (state == WINDOW) { + compute_transfer_function (event); + set_transfer_function (gio_pw, df_p->fb_center, df_p->fb_slope); + } + break; + + case LOC_MOVE: + last_sx = event_x (event); + last_sy = event_y (event); + + if (panning) + p_cursor_setback--; + if (display_coords && state == TRACK_CURSOR) + update_coords (event); + break; + + case MS_LEFT: + last_sx = event_x (event); + last_sy = event_y (event); + + if (event_is_down (event)) { + if (reading_imcursor) { + /* The left mouse button may be used to alias keyboard + * events. Typing ctrl/button causes the last key to be + * aliased with the indicated button. Thereafter, pressing + * that mouse button during a cursor read causes the cursor + * read to terminate, returning the aliased key just as if + * the key had been typed on the keyboard. + */ + if (event_ctrl_is_down (event)) { + if (key == MS_LEFT) + key_left = last_key; + } else if (reading_imcursor) { + if (key == MS_LEFT) + key = key_left; + if (key) + goto readcur; + } + + } else if (display_coords && state==TRACK_CURSOR) { + /* Add an object to a cursor list. */ + mark_object (event); + } + } + break; + + case MS_MIDDLE: + /* Pan - move the object under the cursor to the center of the + * display window (or as close as possible without wraparound). + */ + if (event_is_up (event)) { + int fb_ex, fb_ey, fb_mx, fb_my, fb_xc, fb_yc, fb_nx, fb_ny; + int pw_xc, pw_yc, dx, dy, n_x, n_y; + int newzoom, close=1; + + /* Pressing the middle button without moving the mouse causes + * the zoom factor to be advanced. In other words, placing + * the mouse on a feature and pressing the "zoom/pan" button + * causes that feature to be moved to the center of the + * display; pressing the button again causes the display to be + * zoomed about the centered feature. + */ + newzoom = zoom; + n_x = event_x(event); + n_y = event_y(event); + + if (abs(n_x-last_bx) <= close && abs(n_y-last_by) <= close) { + if (++zoom_index >= nzooms) + zoom_index = 0; + newzoom = zooms[zoom_index]; + } + + last_sx = last_bx = n_x; + last_sy = last_by = n_y; + + pw_xc = pw_rect.r_width / 2; /* window center in pw */ + pw_yc = pw_rect.r_height / 2; + fb_mx = pw_rect.r_left + n_x; /* final mouse position */ + fb_my = pw_rect.r_top + n_y; + fb_xc = pw_rect.r_left + pw_xc; /* window center in fb */ + fb_yc = pw_rect.r_top + pw_yc; + fb_nx = fb_ex = fb_mx; /* next center */ + fb_ny = fb_ey = fb_my; + + dx = n_x - pw_xc; /* step size */ + dy = n_y - pw_yc; + + /* Pan a long ways in the indicated direction, normally to the + * edge of the image. + */ + if (event_shift_is_down (event)) { + fb_ex = fb_nx = fb_mx = + max(pw_xc, min(fb_rect.r_width - pw_xc, fb_xc + dx*5)); + fb_ey = fb_ny = fb_my = + max(pw_xc, min(fb_rect.r_height - pw_yc, fb_yc + dy*5)); + if (!event_ctrl_is_down (event)) + dx = dy = 0; + } + + /* Smooth pan to ex,ey. May be combined with shift-pan. */ + if (event_ctrl_is_down (event)) { + dx = dx ? dx / abs(dx) : 0; + dy = dy ? dy / abs(dy) : 0; + + /* Increase step size if window is large. */ + if (pw_rect.r_width * pw_rect.r_height > 200000) { + dx *= 2; + dy *= 2; + } + + fb_nx = max(0, min(fb_rect.r_width, fb_xc + dx)); + fb_ny = max(0, min(fb_rect.r_height, fb_yc + dy)); + } + + /* Go to x,y starting at nx,ny stepping dx,dy per frame. */ + if (fb_nx != fb_xc || fb_ny != fb_yc || zoom != newzoom) + start_pan (fb_mx,fb_my, fb_nx,fb_ny, fb_ex,fb_ey, dx,dy, + newzoom); + } + break; + + case INTERRUPT: + /* Abort any lengthy operation currently in progress. */ + if (reading_imcursor) + goto readcur; + else + stop_pan(); + break; + + case NEXT_SCREEN: + /* Display the next screen in numerical sequence. */ + set_frame (0); + if (display_coords && state == TRACK_CURSOR) + update_coords (event); + break; + + case PREV_SCREEN: + /* Display the previous screen in numerical sequence. */ + set_frame (-1); + if (display_coords && state == TRACK_CURSOR) + update_coords (event); + break; + + case CYCLE_BLINK: + /* Display the next screen from the blink frames list. + * The frames in the blink frame list do not have to exist; + * if not, then advance through the list until either a valid + * frame is found, or the list has been traversed once. + */ + if (n_blink_frames > 0 && window_open) { + int frame, n; + for (n=n_blink_frames; --n >= 0; ) { + if (++blink_frame >= n_blink_frames) + blink_frame = 0; + frame = blink_frames[blink_frame]; + if (frame >= 1 && frame <= fb_nframes) { + set_frame (frame); + if (display_coords && state == TRACK_CURSOR) + update_coords (NULL); + break; + } + } + } + break; + + default: + /* Terminate a cursor read, returning the encoded cursor value + * sequence to client program on the output datastream. + */ + if (event_is_down(event) && + (event_is_ascii(event) || event_is_key_right(event))) { +readcur: + last_sx = event_x (event); + last_sy = event_y (event); + + /* Terminate cursor read? */ + if (reading_imcursor) { + register struct ctran *ct; + int wcs = imcursor_wcs; + int sx, sy; + float wx, wy; + + /* Map keypad function keys to digits. */ + if (event_is_key_right(event)) { + switch (key = event_id(event) - KEY_RIGHT(1) + 1) { + case 7: case 8: case 9: + break; + case 10: case 11: case 12: + key -= 6; + break; + case 13: case 14: case 15: + key -= 12; + break; + default: + return (value); + } + key += '0'; + } + + last_x = event_x (event); + last_y = event_y (event); + last_key = key; + + wx = sx = last_x + pw_rect.r_left; + wy = sy = last_y + pw_rect.r_top; + + if (wcs) { + ct = wcs_update (df_p); + if (ct->valid) { + if (abs(ct->a) > .001) + wx = sx * ct->a + ct->tx; + if (abs(ct->d) > .001) + wy = sy * ct->d + ct->ty; + } + } + + /* Map ctrl/d and ctrl/z into EOF. */ + if (key == '\004' || key == '\032') + key = EOF; + else if (marktype) { + /* Mark the cursor position? */ + edit_framebuffer (df_p, sx/zoom - 8, sy/zoom - 8, + marker[marktype], + PIX_NOT(PIX_SRC) & PIX_DST); + } + + /* Return the cursor value on the output datastream encoded + * in a fixed size ascii buffer. + */ + gio_retcursorval (wx, wy, display_frame*100+wcs, key, ""); + + /* Terminate the cursor read. */ + gio_restorecursor(); + } + } + } + + return (value); +} + + +static int p_dx, p_dy; +static int p_sx, p_sy; +static int p_left, p_top; +static int p_svdc; + +/* START_PAN -- Pan the image smoothly to the indicated position. This can + * take a while, so we want to do it on a timer and provide for interrupt. + * A new pan can be started to change the destination while an old pan is + * still in progress. + */ +static +start_pan (fb_mx,fb_my, fb_nx,fb_ny, fb_ex,fb_ey, dx,dy, newzoom) +int fb_mx, fb_my; /* mouse position in frame buffer */ +int fb_nx, fb_ny; /* center of window at next display */ +int fb_ex, fb_ey; /* center of window at final display */ +int dx, dy; /* step size for pan */ +register int newzoom; /* new zoom factor */ +{ + register int w, h; + int n_left, n_top; + int n_sx, n_sy, e_sx, e_sy; + + if (!panning) { + p_svdc = display_coords; + display_coords = 0; + panning++; + } + + p_cursor_setback = 9; + gio_setcursor (CURSOR_OFF, 0); + + Bpw_get_region_rect (gio_pw, &pw_rect); + w = pw_rect.r_width; + h = pw_rect.r_height; + + /* Scale zoomed frame buffer units to new zoom factor. + */ + p_sx = fb_mx * newzoom / zoom; + p_sy = fb_my * newzoom / zoom; + n_sx = fb_nx * newzoom / zoom; + n_sy = fb_ny * newzoom / zoom; + e_sx = fb_ex * newzoom / zoom; + e_sy = fb_ey * newzoom / zoom; + p_dx = dx * newzoom; + p_dy = dy * newzoom; + + /* The following are the final left,top values. */ + p_left = max(0, min(Fb_width*newzoom - w, + (e_sx - w/2) / newzoom * newzoom)); + p_top = max(0, min(Fb_height*newzoom - h, + (e_sy - h/2) / newzoom * newzoom)); + + /* The following are the left,top values for the next display. */ + n_left = max(0, min(Fb_width*newzoom - w, + (n_sx - w/2) / newzoom * newzoom)); + n_top = max(0, min(Fb_height*newzoom - h, + (n_sy - h/2) / newzoom * newzoom)); + + /* Set the new zoom factor for the display. */ + set_zoom (df_p, n_left, n_top, newzoom); + + notify_post_event (ev_panner, NULL, NOTIFY_SAFE); +} + + +/* STOP_PAN -- Called to abort a pan. */ +static +stop_pan() +{ + p_dx = p_dy = 0; +} + + +/* PANNER -- Called on a fast timer to do the panning. */ +static Notify_value +ev_panner() +{ + register int left, top; + + /* No clipping is done, so the imtool window must be exposed. */ + window_set (gio_frame, WIN_SHOW, TRUE, 0); + + /* repaint (P_IMAGE|P_DONTCLIP); */ + repaint (P_IMAGE); + + if (p_dx < 0 && pw_rect.r_left <= p_left || + p_dx > 0 && pw_rect.r_left >= p_left) + p_dx = 0; + else if (p_dx) { + left = pw_rect.r_left + p_dx; + if (p_dx < 0) + left = max (p_left, left); + else + left = min (p_left, left); + df_p->fb_xoff = pw_rect.r_left = left; + } + + if (p_dy < 0 && pw_rect.r_top <= p_top || + p_dy > 0 && pw_rect.r_top >= p_top) + p_dy = 0; + else if (p_dy) { + top = pw_rect.r_top + p_dy; + if (p_dy < 0) + top = max (p_top, top); + else + top = min (p_top, top); + df_p->fb_yoff = pw_rect.r_top = top; + } + + if (p_dx == 0 && p_dy == 0) { + if (panning) { + panning = 0; + display_coords = p_svdc; + if (p_cursor_setback > 0) { + int sx = p_sx - pw_rect.r_left; + int sy = p_sy - pw_rect.r_top; + if (sx >= 0 && sx < pw_rect.r_width && + sy >= 0 && sy < pw_rect.r_height) + gio_setcursorpos (sx, sy); + gio_setcursor (CURSOR_ON, 0); + gio_events(); + } + repaint (P_GRAPHICS|P_COLORBAR); + } + } else { + /* Allow the window to process any pending events. */ + gio_events(); + + /* Post another call to the panner. */ + notify_post_event (ev_panner, NULL, NOTIFY_SAFE); + } + + return (NOTIFY_DONE); +} + + +/* EDIT_FRAMEBUFFER -- Edit a frame buffer by operating upon it with the + * given pixrect and rasterop at the given location, clipping as necessary + * at the boundaries of the frame. Update the display window as well, if + * the frame being edited is the display frame. + */ +static +edit_framebuffer (fb, x, y, pr, rop) +struct framebuf *fb; /* frame to be edited */ +int x, y; /* left,top coords of rect to be edited */ +struct pixrect *pr; /* pixrect to be used */ +int rop; /* rasterop defining operation */ +{ + int width = pr->pr_width, height = pr->pr_height; + int s_left = 0, s_top = 0; + int d_left = x, d_top = y; + + /* Clip to the frame boundary. */ + while (d_left < 0) { + s_left++; + width--; + d_left++; + } + + while (d_left + width-1 > Fb_width) + width--; + + while (d_top < 0) { + s_top++; + height--; + d_top++; + } + + while (d_top + height-1 > Fb_height) + height--; + + /* All done if there is nothing left after clipping. */ + if (width*height <= 0) + return; + + /* Edit the frame buffer (clobbers the display pixels). */ + pr_rop (fb->fb_pr, d_left, d_top, width, height, + PIX_NOT(PIX_SRC) & PIX_DST, pr, s_left, s_top); + + /* Refresh the display, if the current display frame is the + * same as the reference frame. + */ + if (fb == df_p) { + BRect fb_r, pw_r; + + fb_r.r_left = d_left * zoom; + fb_r.r_top = d_top * zoom; + fb_r.r_width = width * zoom; + fb_r.r_height = height * zoom; + + Bpw_get_region_rect (gio_pw, &pw_rect); + Bpw_lock (gio_pw, &pw_rect); + + pw_rect.r_left = df_p->fb_xoff; + pw_rect.r_top = df_p->fb_yoff; + + if (maprect (&fb_rect, &fb_r, &pw_rect, &pw_r)) + if (maprect (&pw_rect, &pw_r, &fb_rect, &fb_r)) { + ds_write (gio_pw, + pw_r.r_left, pw_r.r_top, + pw_r.r_width, pw_r.r_height, + PIX_SRC | PIX_COLOR(NGREY-1), + df_p->fb_pr, fb_r.r_left, fb_r.r_top); + + if (pw_r.r_top + pw_r.r_height >= pw_rect.r_height + - cb_height) + put_colorbar(); + } + + Bpw_unlock (gio_pw); + } +} + + +/* GIO_EVENTS -- Have the image window process any queued input events. + */ +static +gio_events() +{ + Event event; + int fd, flags; + + /* Allow the window to process any pending events. */ + fd = (int) window_get (gio_canvas, WIN_FD); + flags = fcntl (fd, F_GETFL, 0); + fcntl (fd, F_SETFL, O_NDELAY); + while (window_read_event (gio_canvas, &event) != -1) + ev_gioinput (gio_canvas, + canvas_event(gio_canvas, &event), NULL, PANNER_EVENT); + fcntl (fd, F_SETFL, flags); +} + + +/* ICLEAR_PROC -- Clear the main (image) window. + */ +static +iclear_proc() +{ + erase (df_p); +} + + +/* GCLEAR_PROC -- Clear the graphics overlay. + */ +static +gclear_proc() +{ + df_p->fb_objno = 1; + repaint (P_IMAGE|P_COLORBAR); +} + + +/* SETFRAME_PROC -- Select the next frame for viewing. + */ +static +setframe_proc() +{ + set_frame (0); +} + + +/* SET_FRAME -- Set the display frame. Call with frameno=0 to advance to + * the next frame, -N will yield the previous frame in sequence, and + * anything else is actual frame number. + */ +static +set_frame (frameno) +int frameno; +{ + if (frameno < 0) { + frameno = display_frame - 1; + if (frameno < 1) + frameno = fb_nframes; + } else if (frameno == 0) { + frameno = display_frame + 1; + if (frameno > fb_nframes) + frameno = 1; + } else { + if (frameno < 1) + frameno = 1; + else if (frameno > fb_nframes) + frameno = fb_nframes; + } + + display_frame = frameno; + df_p = frames + (frameno - 1); + set_zoom (df_p, df_p->fb_xoff, df_p->fb_yoff, df_p->fb_xzoom); + + set_colortable(); + set_transfer_function (gio_pw, df_p->fb_center, df_p->fb_slope); + window_set (gio_frame, FRAME_LABEL, framelabel(), 0); + panel_set_value (pan_set_maptype, df_p->fb_maptype); + + repaint (P_IMAGE|P_COLORBAR|P_GRAPHICS); +} + + +/* SET_ZOOM -- Change the zoom factor for the referenced frame to the given + * value. If the referenced frame is the display frame, update the global + * display zoom factors as well. + */ +static +set_zoom (fr, left, top, newzoom) +register struct framebuf *fr; /* frame to be zoomed */ +int left, top; /* new left and top for frame */ +int newzoom; /* new zoom factor */ +{ + register struct ctran *ct; + int fb_zoom, i; + + /* Verify valid zoom factor. */ + newzoom = max(zooms[0], min(zooms[nzooms-1], newzoom)); + for (i=0; i < nzooms; i++) + if (zooms[i] == newzoom) { + zoom_index = i; + break; + } + + /* Set the new frame buffer zoom factor. */ + if ((fb_zoom = fr->fb_xzoom) != newzoom) { + ct = &fr->fb_ctran; + ct->a = ct->a * fb_zoom / newzoom; + ct->d = ct->d * fb_zoom / newzoom; + + /* For Apply a 0.5 pixel correction when zooming, to make the + * center of the pixel have integral coordinates (coord X,Y where + * X and Y are integral will always be the center of a pixel). + * This should be turned off for zoom=1, since there is no + * subpixel resolution, or if the image has already been zoomed + * at the host level. + */ + if (abs(ct->a * newzoom) < 1.01) { + if (fb_zoom == 1) + ct->tx += (ct->a > 0) ? -0.5 : 0.5; + else if (newzoom == 1) + ct->tx += (ct->a > 0) ? 0.5 : -0.5; + } + if (abs(ct->d * newzoom) < 1.01) { + if (fb_zoom == 1) + ct->ty += (ct->d > 0) ? -0.5 : 0.5; + else if (newzoom == 1) + ct->ty += (ct->d > 0) ? 0.5 : -0.5; + } + + fr->fb_xzoom = fr->fb_yzoom = newzoom; + } + + /* Offsets must be aligned to an unzoomed frame buffer pixel + * boundary since this constraint is applied in ds_write. + */ + fr->fb_xoff = max(0, min(Fb_width*newzoom - pw_rect.r_width, + left / newzoom * newzoom)); + fr->fb_yoff = max(0, min(Fb_height*newzoom - pw_rect.r_height, + top / newzoom * newzoom)); + + /* If the referenced frame is the display frame, make the new zoom + * factor global. + */ + if (fr == df_p) { + fb_width = Fb_width * newzoom; + fb_height = Fb_height * newzoom; + + fb_rect.r_top = 0; + fb_rect.r_left = 0; + fb_rect.r_width = fb_width; + fb_rect.r_height = fb_height; + + pw_rect.r_left = df_p->fb_xoff; + pw_rect.r_top = df_p->fb_yoff; + + zoom = newzoom; + } +} + + +/* ERASE -- Clear a frame. + */ +static +erase (fr) +struct framebuf *fr; +{ + register int *op, v, n; + unsigned char *cp; + int val; + + for (val=0, n=sizeof(int), cp = (unsigned char *)&val; --n >= 0; ) + *cp++ = background; + + if (val) { + op = (int *) mpr_d(fr->fb_pr)->md_image; + n = Fb_width * Fb_height / sizeof(int); + for (v=val; --n >= 0; ) + *op++ = v; + } else + bzero ((char *)mpr_d(fr->fb_pr)->md_image, Fb_width * Fb_height); + + if (fr == df_p) + repaint (P_IMAGE|P_COLORBAR); +} + + +/* REPAINT -- Repaint the display window. + */ +static +repaint (what) +int what; +{ + if (what & P_IMAGE) { + BRect fb_r, pw_r; + int rop; + + pw_r = pw_rect; + pw_r.r_left = pw_r.r_top = 0; + if (what & P_COLORBAR) + pw_r.r_height -= cb_height; + + rop = PIX_SRC | PIX_COLOR(NGREY-1); + if (what & P_DONTCLIP) + rop |= PIX_DONTCLIP; + + if (maprect (&pw_rect, &pw_r, &fb_rect, &fb_r)) + if (maprect (&fb_rect, &fb_r, &pw_rect, &pw_r)) + ds_write (gio_pw, + pw_r.r_left, pw_r.r_top, pw_r.r_width, pw_r.r_height, + rop, df_p->fb_pr, fb_r.r_left, fb_r.r_top); + + if (display_coords && state == TRACK_CURSOR) { + set_wcsboxpos(); + pw_text (gio_pw, wc_xoff, wc_yoff + wc_font->pf_defaultsize.y, + PIX_NOT(PIX_SRC), wc_font, wc_text); + } + } + + if (what & P_COLORBAR) + put_colorbar(); + + if ((what & P_GRAPHICS) && df_p->fb_objno > 1) { + char fname[SZ_FNAME]; + + wcs_update (df_p); + sprintf (fname, o_fname, df_p->fb_frameno, df_p->fb_imageno); + strcpy (fname, getfname(fname, 0)); + remark_objects (fname); + } +} + + +/* REFRESH_DISPLAY -- Called by the windowing system when the display needs + * to be refreshed from the frame buffer. + */ +static +refresh_display (canvas, pw, rl) +Canvas canvas; +Pixwin *pw; +Rectlist *rl; +{ + register struct rectnode *rn; + BRect fb_r, pw_r; + Rect rect, r; + + /* See if any damage has occurred and fix it. */ + rl_rectoffset (rl, &rl->rl_bound, &rect); + pw_lock (pw, &rect); + + /* Now fix all the damage. Regions of the display window which are + * not mapped onto the frame buffer are not fixed up at present. + * Scale changes (zoom/dezoom) are not currently immplemented. + */ + for (rn = rl->rl_head; rn; rn = rn->rn_next) { + rl_rectoffset (rl, &rn->rn_rect, &r); + pw_r.r_left = r.r_left; + pw_r.r_top = r.r_top; + pw_r.r_width = r.r_width; + pw_r.r_height = r.r_height; + + if (maprect (&pw_rect, &pw_r, &fb_rect, &fb_r)) + if (maprect (&fb_rect, &fb_r, &pw_rect, &pw_r)) + ds_write (pw, + pw_r.r_left, pw_r.r_top, pw_r.r_width, pw_r.r_height, + PIX_SRC | PIX_COLOR(NGREY-1), + df_p->fb_pr, fb_r.r_left, fb_r.r_top); + } + + put_colorbar(); + pw_unlock (pw); +} + + +/* DS_WRITE -- Write to the display. This is analogous to pw_write, except + * that pixel replication or subsampling is performed as indicated by the + * zoom factors for the current display frame. At present, the zoom factor + * may not be specified independently for x and y. + */ +static +ds_write (pw, left, top, width, height, rop, fb_pr, fb_left, fb_top) +Pixwin *pw; +int left, top; +int width, height; +int rop; +Pixrect *fb_pr; +int fb_left, fb_top; /* zoomed frame buffer coords */ +{ + register unsigned char pix, *ip, *op; + register int n, p; + unsigned char *otop, *fb, *lp; + int pr_left, pr_top, i, j; + Pixrect *mpr_line, *pr; + struct rect pw_r; + + if (width <= 0 || height <= 0) + return; + + /* If no zoom, just copy the frame buffer rect to the screen. */ + if (zoom <= 1) { + pw_write (pw, left,top, width,height, rop, fb_pr, fb_left,fb_top); + return; + } + + /* Zoom - magnify the image by pixel replication. (This assumes an + * 8 bit frame buffer and screen pixrect). + */ + mpr_line = mem_create (width, 1, pw->pw_pixrect->pr_depth); + fb = (unsigned char *)mpr_d(df_p->fb_pr)->md_image; + lp = (unsigned char *)mpr_d(mpr_line)->md_image; + otop = lp + width; + + /* Lock the frame buffer to avoid scribbling on other windows + * during write to raw screen.. + */ + pw_get_region_rect (pw, &pw_r); + pw_lock (pw, &pw_r); + + pr = pw->pw_pixrect; + pr_left = left + (int)window_get(gio_frame, WIN_X) + TOOL_BORDERWIDTH; + pr_top = top + (int)window_get(gio_frame, WIN_Y) + + HEIGHTADJUST - TOOL_BORDERWIDTH; + + for (j=0, i=(fb_top/zoom); j < height; j += zoom) { + ip = fb + (i++ * Fb_width) + (fb_left/zoom); + op = lp; + + /* Replicate a block of pixels. */ + switch (zoom) { + case 2: + for (n = (width/2); --n >= 0; ) { + pix = *ip++; + *op++ = pix; *op++ = pix; + } + break; + case 3: + for (n = (width/3); --n >= 0; ) { + pix = *ip++; + *op++ = pix; *op++ = pix; *op++ = pix; + } + break; + case 4: + for (n = (width/4); --n >= 0; ) { + pix = *ip++; + *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; + } + break; + case 5: + for (n = (width/5); --n >= 0; ) { + pix = *ip++; + *op++ = pix; *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; + } + break; + case 6: + for (n = (width/6); --n >= 0; ) { + pix = *ip++; + *op++ = pix; *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; *op++ = pix; + } + break; + case 7: + for (n = (width/7); --n >= 0; ) { + pix = *ip++; + *op++ = pix; *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; + } + break; + case 8: + for (n = (width/8); --n >= 0; ) { + pix = *ip++; + *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; + *op++ = pix; *op++ = pix; + } + break; + default: + for (n = (width/zoom); --n >= 0; ) { + pix = *ip++; + for (p=zoom; --p >= 0; ) + *op++ = pix; + } + break; + } + + /* Fill the last partial pixel. */ + pix = *ip++; + while (op < otop) + *op++ = pix; + + pr_replrop (pr, pr_left,pr_top+j, + width, min (height-j, zoom), rop, mpr_line, 0,0); + } + + pw_unlock (pw); + pr_close (mpr_line); +} + + +/* PUT_COLORBAR -- Refresh the colorbar on the screen. + */ +static +put_colorbar() +{ + if (cb_height) + pw_write (gio_pw, + 0, pw_rect.r_height - cb_height, + min (pw_rect.r_width, Fb_width), cb_height, + PIX_SRC, cb_pr, 0, 0); +} + + +/* TOGGLE_DISPLAYCOORDS -- Enable/disable continuous display of the cursor + * coordinates. + */ +static +toggle_displaycoords (event) +Event *event; +{ + BRect fb_r, pw_r; + + if (display_coords) { + /* Enable mouse moved input events. */ + window_set (gio_canvas, WIN_IGNORE_PICK_EVENTS, LOC_MOVE, 0, + 0); + display_coords = 0; + + /* Refresh the region of the screen used to output coordinates + * from the frame buffer, erasing the coordinate output box. + */ + pw_r.r_left = wc_xoff; + pw_r.r_top = wc_yoff; + pw_r.r_width = wc_width; + pw_r.r_height = wc_height; + + if (maprect (&pw_rect, &pw_r, &fb_rect, &fb_r)) + ds_write (gio_pw, + wc_xoff, wc_yoff, wc_width, wc_height, + PIX_SRC | PIX_COLOR(NGREY-1), + df_p->fb_pr, fb_r.r_left, fb_r.r_top); + + } else { + /* Disable mouse moved input events. */ + window_set (gio_canvas, WIN_CONSUME_PICK_EVENTS, LOC_MOVE, 0, + 0); + display_coords = 1; + update_coords (event); + } +} + + +/* UPDATE_COORDS -- Compute and output the world coordinates of the given + * event, using the WCS specified for the current display window. If called + * with event=NULL the most recent locator position is used. + */ +static +update_coords (event) +Event *event; +{ + register struct ctran *ct; + static struct timeval o_tv; + unsigned char *fb, *ip; + struct timeval n_tv; + int sx, sy, sz, fb_x, fb_y, delta_msec; + char buf[1024], ch; + float wx, wy, wz; + + /* Get frame buffer x,y; ignore events that occur faster than we + * can update the coordinate readout. + */ + if (event) { + /* Ignore event if it comes too soon. */ + n_tv = event_time(event); + if (o_tv.tv_sec) { + delta_msec = ((n_tv.tv_sec - o_tv.tv_sec) * 1000 + + (n_tv.tv_usec - o_tv.tv_usec) / 1000); + if (delta_msec < 50) + return; + } + + /* Get the screen (window relative) coordinates of the event. */ + sx = event_x(event) + pw_rect.r_left; + sy = event_y(event) + pw_rect.r_top; + + } else { + sx = last_sx + pw_rect.r_left; + sy = last_sy + pw_rect.r_top; + } + + /* Get frame buffer pixel value. */ + fb = (unsigned char *) mpr_d (df_p->fb_pr)->md_image; + fb_x = max(0, min(Fb_width, sx/zoom)); + fb_y = max(0, min(Fb_height, sy/zoom)); + sz = fb[fb_y*Fb_width+fb_x]; + if (sz < CMS_DATASTART || sz > CMS_DATAEND) + sz = 0; + + /* Compute the world coordinates of the event. */ + ct = wcs_update (df_p); + + if (ct->valid) { + wx = ct->a * sx + ct->c * sy + ct->tx; + wy = ct->b * sx + ct->d * sy + ct->ty; + + if (sz == 0) + wz = 0.0; + else { + switch (ct->zt) { + case W_LINEAR: + wz = ((sz - CMS_DATASTART) * (ct->z2 - ct->z1) / + (CMS_DATARANGE-1)) + ct->z1; + break; + default: + wz = sz; + break; + } + } + + } else { + wx = sx; + wy = sy; + wz = sz; + } + + /* Get the font to be used. */ + if (wc_font == NULL) { + static char fontname[] = TEXT_FONT; + if ((wc_font = pf_open (fontname)) == NULL) + fprintf (stderr, "cannot open %s\n", fontname); + wc_xoff = wc_yoff = 0; + } + + ch = ' '; + if (sz && ct->valid) { + if (ct->z1 < ct->z2) { + if (wz < (ct->z1 + 0.01)) + ch = '-'; + else if (wz > (ct->z2 - 0.01)) + ch = '+'; + } else if (ct->z1 > ct->z2) { + if (wz < (ct->z2 + 0.01)) + ch = '-'; + else if (wz > (ct->z1 - 0.01)) + ch = '+'; + } + } + + set_wcsboxpos(); + sprintf (buf, ct->format, wx, wy, wz, ch); + strncpy (wc_text, buf, SZ_WCTEXT); + pw_text (gio_pw, wc_xoff, wc_yoff + wc_font->pf_defaultsize.y, + PIX_NOT(PIX_SRC), wc_font, wc_text); + + if (event) + o_tv = n_tv; +} + + +/* MARK_OBJECT -- Called when the user has clicked on the position of an + * object to be marked and/or added to the output coordinate list. + */ +static +mark_object (event) +Event *event; +{ + register struct ctran *ct; + char tx_buf[SZ_FNAME]; + char fname[SZ_FNAME]; + int sx, sy, newset; + float wx, wy; + FILE *fp; + + ct = wcs_update (df_p); + + /* Get name of coordinate output file for the current frame. */ + sprintf (tx_buf, o_fname, df_p->fb_frameno, df_p->fb_imageno); + strcpy (fname, getfname(tx_buf, 0)); + + /* Append to the existing coordinate list, if any. If appending + * to an existing coordinate list, the existing list is displayed + * and the objno counter is left set to the next object to be added. + */ + if (newset = (df_p->fb_objno <= 1)) + remark_objects (fname); + if ((fp = fopen (fname, "a")) == NULL) { + fprintf (stderr, "cannot open %s for appending\n", fname); + return; + } + + /* Timestamp the first entry in the output file. */ + if (newset) + timestamp (fp); + + /* Get the screen (window relative) coordinates of the event. */ + sx = event_x(event) + pw_rect.r_left; + sy = event_y(event) + pw_rect.r_top; + + /* Compute the world coordinates of the event. */ + if (ct->valid) { + wx = ct->a * sx + ct->c * sy + ct->tx; + wy = ct->b * sx + ct->d * sy + ct->ty; + } else { + wx = sx; + wy = sy; + } + + /* Mark the object position on the screen. */ + sprintf (tx_buf, "%d", df_p->fb_objno++); + draw_text (sx - pw_rect.r_left, sy - pw_rect.r_top, tx_buf); + + fprintf (fp, "%g %g\n", wx, wy); + fclose (fp); +} + + +/* REMARK_OBJECTS -- Read a object list file and mark the numbered objects + * therein. + */ +static +remark_objects (fname) +char *fname; +{ + register struct ctran *ct; + register char *ip; + char lbuf[SZ_LINE], tx_buf[SZ_FNAME]; + int sx, sy, objno=1; + float wx, wy; + char *fgets(); + FILE *fp; + + gclear_proc(); + window_set (gio_frame, FRAME_LABEL, framelabel(), 0); + if ((fp = fopen (fname, "r")) == NULL) + return; + + while (fgets (lbuf, SZ_LINE, fp) != NULL) { + /* Skip comment lines and blank lines. */ + for (ip=lbuf; *ip == ' ' || *ip == '\t'; ip++) + ; + if (*ip == '\n' || *ip == '#') + continue; + if (!isdigit (*ip) && *ip != '-') + continue; + if (sscanf (ip, "%f%f", &wx, &wy) < 2) + continue; + + sx = wx; + sy = wy; + + /* Compute the world coordinates of the event if we have a valid + * WCS transform (rotations not permitted)/ + */ + ct = wcs_update (df_p); + if (ct->valid) { + if (abs(ct->a) > .001) + sx = (wx - ct->tx) / ct->a; + if (abs(ct->d) > .001) + sy = (wy - ct->ty) / ct->d; + } + + /* Mark the object position on the screen. */ + sprintf (tx_buf, "%d", objno++); + draw_text (sx - pw_rect.r_left, sy - pw_rect.r_top, tx_buf); + } + + fclose (fp); + + /* If we are updating an existing coordinate list from a newly + * displayed frame, timestamp the new section of the list. + */ + if (df_p->fb_objno <= 1) + if ((fp = fopen (fname, "a")) != NULL) { + timestamp (fp); + fclose (fp); + } + + df_p->fb_objno = objno; +} + + +/* TIMESTAMP -- Timestamp the output stream. + */ +static +timestamp (fp) +FILE *fp; +{ + register char *op; + char obuf[SZ_LINE]; + long clock; + + clock = time(0); + fprintf (fp, "# %s", asctime(localtime(&clock))); + + sprintf (obuf, "# %s", df_p->fb_label); + for (op=obuf; *op && *op != '\n'; op++) + ; + *op++ = '\n'; + *op = '\0'; + fputs (obuf, fp); +} + + +/* DRAW_TEXT -- Draw some text on the frame at the indicated position. + */ +static +draw_text (x, y, text) +int x, y; /* position where text is to be drawn */ +char *text; /* the text */ +{ + static struct pixfont *font = NULL; + + /* Get the screen font to be used. */ + if (font == NULL) { + static char fontname[] = MARK_FONT; + if ((font = pf_open (fontname)) == NULL) + fprintf (stderr, "cannot open %s\n", fontname); + } + + /* Draw the text. */ + if (o_revtext) + pw_text (gio_pw, x, y, PIX_NOT(PIX_SRC) & PIX_DST, font, text); + else + pw_text (gio_pw, x, y, PIX_SRC | PIX_DST, font, text); +} + + +/* WCS_UPDATE -- Load the screen WCS, if not yet validated, from the user + * wcs file, if any. + * + * File format (two lines): + * + * image title (imtool header label string)\n + * a b c d tx ty z1 z2 zt + * + * NOTE: the WCS text is now passed in via the data stream as a write to the + * subunit WCS and left in the buffer "wcsbuf", rather than being passed via + * a text file. + */ +static struct ctran * +wcs_update (fr) +struct framebuf *fr; +{ + register struct ctran *ct = &fr->fb_ctran; + char buf[1024], *format; + + /* Get the new WCS. */ + if (!ct->valid) { + fr->fb_label[0] = '\0'; + ct->zt = W_UNITARY; + + /* Attempt to read the WCS file and set up a unitary transformation + * if the file cannot be read. + */ + if (sscanf (wcsbuf[fr->fb_frameno-1], "%[^\n]\n%f%f%f%f%f%f%f%f%d", + buf, &ct->a, &ct->b, &ct->c, &ct->d, &ct->tx, &ct->ty, + &ct->z1, &ct->z2, &ct->zt) < 7) { + + if (wcsbuf[fr->fb_frameno-1][0]) + fprintf (stderr, "imtool: error reading WCS file\n"); + + strncpy (ct->imtitle, "[NO WCS]\n", SZ_IMTITLE); + ct->a = ct->d = 1; + ct->b = ct->c = 0; + ct->tx = ct->ty = 0; + ct->zt = W_UNITARY; + + } else + strncpy (ct->imtitle, buf, SZ_IMTITLE); + + /* Correct for the current zoom factor, if any. */ + if (fr->fb_xzoom > 1) { + if (abs(ct->a) < 1.01) + ct->tx += (ct->a > 0) ? -0.5 : 0.5; + if (abs(ct->d) < 1.01) + ct->ty += (ct->d > 0) ? -0.5 : 0.5; + ct->a = ct->a / fr->fb_xzoom; + ct->d = ct->d / fr->fb_xzoom; + } + + window_set (gio_frame, FRAME_LABEL, framelabel(), 0); + ct->valid++; + } + + /* Determine best format for wcs output. */ + if (ct->valid && ct->zt == W_LINEAR) { + float z1, z2, zrange; + z1 = ct->z1; + z2 = ct->z2; + zrange = (z1 > z2) ? z1 - z2 : z2 - z1; + if (zrange < 100.0 && (abs(z1) + abs(z2)) / 2.0 < 200.0) + format = " %7.2f %7.2f %7.3f%c"; + else if (zrange > 99999.0 || (abs(z1) + abs(z2)) / 2.0 > 99999.0) + format = " %7.2f %7.2f %7.3g%c"; + else + format = W_DEFFORMAT; + } else + format = " %7.2f %7.2f %7.0f%c"; + + strcpy (ct->format, format); + return (ct); +} + + +/* SET_WCSBOXPOS -- Set the position of the WCS output box. + */ +static +set_wcsboxpos() +{ + /* Compute offset to coordinate output box. */ + if ((wc_xoff + wc_yoff) == 0) { + wc_width = wc_font->pf_defaultsize.x * 25; + wc_height = wc_font->pf_defaultsize.y + 5; + wc_xoff = max (0, min (Fb_width, pw_rect.r_width) - wc_width + - TOOL_BORDERWIDTH); + wc_yoff = max (0, pw_rect.r_height - cb_height - wc_height + - TOOL_BORDERWIDTH); + } +} + + +/* FRAMELABEL -- Return a pointer to the frame label string for the current + * frame. + */ +static char * +framelabel() +{ + char fname[SZ_FNAME]; + char label[SZ_LABEL*2]; + + sprintf (fname, o_fname, df_p->fb_frameno, df_p->fb_imageno); + sprintf (label, "[%d] %s: %s", df_p->fb_frameno, fname, + df_p->fb_ctran.imtitle); + strncpy (df_p->fb_label, label, SZ_LABEL); + + return (df_p->fb_label); +} + + +/* GETFNAME -- Construct the pathname of a user datafile. One optional + * integer argument is permitted. + */ +static char * +getfname (rootname, arg) +char *rootname; /* root filename (printf style format) */ +int arg; +{ + static char pathname[SZ_FNAME]; + char fmt[SZ_LINE], *udir; + + /* Were we passed an absolute pathname as input? */ + if (*rootname == '/') { + strcpy (pathname, rootname); + return (pathname); + } + + if ((udir = getenv ("WCSDIR")) == NULL) + if ((udir = getenv ("wcsdir")) == NULL) + if ((udir = getenv ("HOME")) == NULL) + udir = "/tmp"; + + sprintf (fmt, "%s/%s", udir, rootname); + sprintf (pathname, fmt, arg); + + return (pathname); +} + + +/* GIO_SETCURSOR -- Set graphics frame cursor options. + */ +static +gio_setcursor (op1, op2) +int op1, op2; +{ + Cursor cursor; + int option[2], i; + int blink=cursor_blink, show=cursor_show; + + /* Normalize the argument list. */ + for (option[0]=op1, option[1]=op2, i=0; i < 2; i++) + switch (option[i]) { + case BLINK_OFF: + case BLINK_ON: + blink = option[i]; + break; + case CURSOR_OFF: + case CURSOR_ON: + show = option[i]; + break; + } + + /* Do we need to change anything? */ + if (blink == cursor_blink && show == cursor_show) + return; + + /* Modify the cursor attributes. */ + if (show == CURSOR_ON && reading_imcursor) + gio_readcursor (imcursor_wcs); + else { + cursor = window_get (gio_canvas, WIN_CURSOR); + cursor_set (cursor, + CURSOR_SHOW_CURSOR, FALSE, + CURSOR_SHOW_CROSSHAIRS, (show == CURSOR_ON), + CURSOR_CROSSHAIR_THICKNESS, 1, + CURSOR_CROSSHAIR_LENGTH, 20, + CURSOR_CROSSHAIR_GAP, 6, + +#ifdef sparc + /* This is a kludge to work around a bug with the + * sparcstation 1 under 4.0.3. */ + CURSOR_CROSSHAIR_OP, PIX_SRC ^ PIX_DST, +#else + CURSOR_CROSSHAIR_OP, PIX_SRC, +#endif + + CURSOR_CROSSHAIR_COLOR, CMS_CURSOR, + 0); + window_set (gio_canvas, WIN_CURSOR, cursor, 0); + } + + cursor_blink = blink; + cursor_show = show; +} + + +/* GIO_SETCURSORPOS -- Set the position of the graphics cursor within the + * graphics frame. + */ +static +gio_setcursorpos (x, y) +int x, y; /* pixwin pixel coords */ +{ + if (window_open) + window_set (gio_canvas, WIN_MOUSE_XY, last_bx=x, last_by=y, 0); +} + + +/* RESET_PROC -- Called from the setup panel to reset the state of the + * display. + */ +static +reset_proc() +{ + register struct pixrect *pr = get_screen_rect(); + register struct framebuf *fb; + register int i; + + stop_pan(); + blink = 0; + display_coords = 0; + setup_xoff = 4; + setup_yoff = 18; + wc_xoff = wc_yoff = 0; + state = TRACK_CURSOR; + + for (i=0; i < fb_nframes; i++) { + fb = &frames[i]; + fb->fb_xoff = 0; + fb->fb_yoff = 0; + fb->fb_xzoom = fb->fb_yzoom = 1; + fb->fb_center = fb_ngrey / 2.0; + fb->fb_slope = (float)white / (float)(fb_ngrey - 1); + fb->fb_maptype = MONO; + fb->fb_objno = 1; + fb->fb_imageno = 0; + fb->fb_frameno = i + 1; + } + + gio_xsize = initial_gio_xsize; + gio_ysize = initial_gio_ysize; + + gio_xsize = min (pr->pr_width - TOOL_BORDERWIDTH * 2, gio_xsize); + gio_ysize = min (pr->pr_height + - tool_headerheight ((int)window_get(gio_frame,FRAME_SHOW_LABEL)) + - TOOL_BORDERWIDTH, gio_ysize); + + window_set (gio_canvas, + WIN_WIDTH, gio_xsize, + WIN_HEIGHT, gio_ysize, + 0); + + window_fit (gio_canvas); + window_fit (gio_frame); + + set_frame (1); +} + + +/* MAPRECT -- Compute the intersection of the given subrect of the first rect + * with the second rect, in the coordinate system of the second. The rects + * are defined in screen coordinates, the subrects relative to their parent + * rects. + */ +maprect (r1, s1, r2, s2) +BRect *r1, *s1; /* source rect and subrect */ +BRect *r2, *s2; /* destination rect and subrect */ +{ + int xoff, yoff; + int x0, y0, x1, y1; + + /* Compute offset of second rect from the first. */ + xoff = r2->r_left - r1->r_left; + yoff = r2->r_top - r1->r_top; + + /* Translate the first subrect into the coordinate system of the + * second rect. + */ + x0 = s1->r_left - xoff; + y0 = s1->r_top - yoff; + x1 = x0 + s1->r_width - 1; + y1 = y0 + s1->r_height - 1; + + /* Does the new subrect totally miss the second rect? + */ + if (x1 < 0 || x0 >= r2->r_width || y1 < 0 || y0 >= r2->r_height) { + *s2 = *r2; + s2->r_width = s2->r_height = 0; + } else { + /* Clip the new subrect to the boundary of the second rect. + */ + if (x0 < 0) + x0 = 0; + else if (x0 >= r2->r_width) + x0 = r2->r_width - 1; + + if (x1 < 0) + x1 = 0; + else if (x1 >= r2->r_width) + x1 = r2->r_width - 1; + + if (y0 < 0) + y0 = 0; + else if (y0 >= r2->r_height) + y0 = r2->r_height - 1; + + if (y1 < 0) + y1 = 0; + else if (y1 >= r2->r_height) + y1 = r2->r_height - 1; + + /* Compute the new subrect. + */ + s2->r_left = x0; + s2->r_top = y0; + s2->r_width = x1 - x0 + 1; + s2->r_height = y1 - y0 + 1; + } + + return (s2->r_width > 0 && s2->r_height > 0); +} + + +/* BPW_GET_REGION_RECT -- Get pw_rect, transforming a Rect to a BRect. + */ +static +Bpw_get_region_rect (pw, br) +Pixwin *pw; +BRect *br; +{ + Rect r; + + pw_get_region_rect (pw, &r); + br->r_left = r.r_left; + br->r_top = r.r_top; + br->r_width = r.r_width; + br->r_height = r.r_height; +} + + +/* BPW_LOCK -- Lock a big pixwin. + */ +static +Bpw_lock (pw, br) +Pixwin *pw; +BRect *br; +{ + Rect r; + + r.r_left = br->r_left; + r.r_top = br->r_top; + r.r_width = br->r_width; + r.r_height = br->r_height; + + pw_lock (pw, &r); +} + + +/* BPW_UNLOCK -- Unlock a big pixwin. + */ +static +Bpw_unlock (pw) +Pixwin *pw; +{ + pw_unlock (pw); +} + + +/* IMAGECOPY_PROC -- Make a hardcopy of the image window on the laserwriter. + * We don't do this immediately, but rather after a delay of a few milliseconds + * to allow the window system to restore the imtool window lookup table after + * the mouse button is released. + */ +static +imagecopy_proc() +{ + static Notify_value ev_screendump(); + + window_set (gio_frame, WIN_SHOW, TRUE, 0); + imt_pause (100, ev_screendump); +} + + +/* EV_SCREENDUMP -- Called after the specified interval has passed to carry out + * the actual screendump operation. + */ +static Notify_value +ev_screendump() +{ + int depth = 8; + + edit_colormap(); + + if (snap_frame_too) { + screendump ( + (int) window_get (gio_canvas, WIN_FD), + win_get_pixwin (gio_canvas), + (int) window_get (gio_frame, WIN_WIDTH), + (int) window_get (gio_frame, WIN_HEIGHT), + (int) window_get (gio_frame, WIN_X), + (int) window_get (gio_frame, WIN_Y), + depth); + } else { + screendump ( + (int) window_get (gio_canvas, WIN_FD), + win_get_pixwin (gio_canvas), + (int) window_get (gio_frame, WIN_WIDTH) - TOOL_BORDERWIDTH * 2, + (int) window_get (gio_frame, WIN_HEIGHT) - + HEIGHTADJUST - cb_height, + (int) window_get (gio_frame, WIN_X) + TOOL_BORDERWIDTH, + (int) window_get (gio_frame, WIN_Y) + HEIGHTADJUST - + TOOL_BORDERWIDTH, + depth); + } + + return (NOTIFY_DONE); +} + + +/* IMT_PAUSE -- Suspend output for the indicated number of milliseconds, to + * allow other event processing to catch up. + */ +imt_pause (msec, ufcn) +int msec; +Notify_value (*ufcn)(); +{ + static struct itimerval itimer_delay; + + itimer_delay.it_interval.tv_usec = 0; + itimer_delay.it_interval.tv_sec = 0; + itimer_delay.it_value.tv_usec = (msec % 1000) * 1000; + itimer_delay.it_value.tv_sec = (msec / 1000); + + notify_set_itimer_func ((int)ufcn, ufcn, ITIMER_REAL, + &itimer_delay, NULL); +} + + +/* PRINT_USAGE -- Print instructions on how to use this window tool. + */ +static +print_usage (toolname) +char *toolname; +{ + printf ("no on-line help text yet for IMTOOL\n"); +} diff --git a/unix/sun/imtool.cross b/unix/sun/imtool.cross new file mode 100644 index 00000000..2e1b3532 --- /dev/null +++ b/unix/sun/imtool.cross @@ -0,0 +1,4 @@ +/* Format_version=1, Width=16, Height=16, Depth=1, Valid_bits_per_item=16 + */ + 0x0000,0x0000,0x0000,0x0000,0x0000,0x0000,0x0240,0x0180, + 0x0180,0x0240,0x0000,0x0000,0x0000,0x0000,0x0000,0x0000 diff --git a/unix/sun/imtool.cursor b/unix/sun/imtool.cursor new file mode 100644 index 00000000..b1041fe9 --- /dev/null +++ b/unix/sun/imtool.cursor @@ -0,0 +1,4 @@ +/* Format_version=1, Width=16, Height=16, Depth=1, Valid_bits_per_item=16 + */ + 0x0000,0x03E0,0x0FF8,0x1C1C,0x380E,0x3006,0x6003,0x6003, + 0x6003,0x6003,0x6003,0x3006,0x380E,0x1C1C,0x0FF8,0x03E0 diff --git a/unix/sun/imtool.h b/unix/sun/imtool.h new file mode 100644 index 00000000..e0048a28 --- /dev/null +++ b/unix/sun/imtool.h @@ -0,0 +1,13 @@ +/* IMTOOL.H -- Global definitions for IMTOOL. + */ +#define CURSOR_OFF 3 /* turn cursor off entirely */ +#define CURSOR_ON 4 /* turn it back on */ + +struct fonttab { /* Imtool font descriptor. */ + short pointsize; + char ch_xsize, ch_ysize; + short win_xsize, win_ysize; + struct pixfont *pixfont; + char *path; + char *label; +}; diff --git a/unix/sun/imtool.icon b/unix/sun/imtool.icon new file mode 100644 index 00000000..5857c1d0 --- /dev/null +++ b/unix/sun/imtool.icon @@ -0,0 +1,66 @@ +/* Format_version=1, Width=64, Height=64, Depth=1, Valid_bits_per_item=16 + */ + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000, + 0x0FFF,0xFFFF,0xFFFF,0xFFF0, + 0x0AAA,0xAAAA,0xAAAA,0xAAB0, + 0x0D55,0x5555,0x5555,0x5550, + 0x0AAA,0xAAAA,0xAAAA,0xAAB0, + 0x0D55,0x5555,0x5555,0x5550, + 0x0AAA,0xAAAA,0xAAAA,0xAAB0, + 0x0D55,0xFFFF,0xFFD5,0x5550, + 0x0AAE,0x0000,0x003A,0xBEB0, + 0x0D58,0x0000,0x0015,0x6350, + 0x0AB0,0x0000,0x000A,0xC1B0, + 0x0D50,0x0000,0x000D,0x4150, + 0x0AA7,0xE7C1,0x07E6,0xC1B0, + 0x0D61,0x8663,0x8605,0x6350, + 0x0AA1,0x8663,0x8606,0xBEB0, + 0x0D61,0x8666,0xC605,0x5550, + 0x0AA1,0x87C6,0xC7C6,0xAAB0, + 0x0D61,0x86CC,0x6605,0x5550, + 0x0AA1,0x866F,0xE606,0xBEB0, + 0x0D61,0x866C,0x6605,0x6350, + 0x0AA7,0xE66C,0x6606,0xC1B0, + 0x0D60,0x0000,0x0005,0x4150, + 0x0AA0,0x0000,0x0006,0xC1B0, + 0x0D60,0x0000,0x0005,0x6350, + 0x0AA0,0x07E6,0x6006,0xBEB0, + 0x0D60,0x0186,0x6005,0x5550, + 0x0AA0,0x0186,0x6106,0xAAB0, + 0x0D60,0x0182,0x4105,0x5550, + 0x0AA0,0x0183,0xC7C6,0xAAB0, + 0x0D60,0x0183,0xC105,0x5550, + 0x0AA0,0x0181,0x8106,0xAAB0, + 0x0D60,0x0181,0x8005,0xF7D0, + 0x0AB0,0x0181,0x8007,0x1C70, + 0x0D50,0x0000,0x000D,0x1450, + 0x0AA8,0x0000,0x001B,0x1C70, + 0x0D56,0x0000,0x0035,0xF7D0, + 0x0AAB,0xFFFF,0xFFEA,0xAAB0, + 0x0D55,0x5555,0x5555,0x5550, + 0x0AAA,0xAAAA,0xAAAA,0xAAB0, + 0x0D55,0x5555,0x5555,0x5550, + 0x0AAA,0xAAAA,0xAAAA,0xAAB0, + 0x0D55,0x5555,0x5555,0x5550, + 0x0FFF,0xFFFF,0xFFFF,0xFFF0, + 0x0001,0x8000,0x0000,0x6000, + 0x0001,0x8000,0x0000,0x6000, + 0x0001,0x8000,0x0000,0x6000, + 0x0003,0x0000,0x0000,0x3000, + 0x0003,0x0000,0x0000,0x3000, + 0x0006,0x0000,0x0000,0x1800, + 0x0006,0x0000,0x0000,0x1800, + 0x000C,0x0000,0x0000,0x0C00, + 0x000C,0x0000,0x0000,0x0C00, + 0x0018,0x0000,0x0000,0x0600, + 0x0018,0x0000,0x0000,0x0600, + 0x0038,0x0000,0x0000,0x0700, + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000, + 0x0000,0x0000,0x0000,0x0000 diff --git a/unix/sun/imtool.icon.NEW b/unix/sun/imtool.icon.NEW new file mode 100644 index 00000000..2eff06f0 --- /dev/null +++ b/unix/sun/imtool.icon.NEW @@ -0,0 +1,34 @@ +/* Format_version=1, Width=64, Height=64, Depth=1, Valid_bits_per_item=16 + */ + 0xFFFF,0xFFFF,0xFFFF,0xFFFF,0x88D5,0x5555,0x5555,0x5509, + 0xA2BF,0xFFFF,0xFFFF,0xFEA3,0xA260,0x0000,0x0000,0x0523, + 0x88A7,0xFE00,0xFFFF,0xF689,0x8864,0x0200,0xFFFE,0xF509, + 0xA2A7,0xFE00,0xF80F,0xB6A3,0xA260,0x0000,0xEBFF,0xF523, + 0x88A0,0x1FFF,0xF7E1,0xF689,0x8860,0x1000,0xF61E,0xF509, + 0xA2A0,0x17FE,0xF6FD,0x36A3,0xA260,0x1000,0xE6FF,0xB523, + 0x88A0,0x17FF,0xEE47,0xB689,0x886F,0xF000,0xE711,0xB509, + 0xA2A8,0x17FC,0xB3FD,0x96A3,0xA268,0x1000,0xFBFD,0xD523, + 0x88A8,0x37E0,0xFDB9,0x9689,0x8868,0x7000,0xEEFB,0xB509, + 0xA2A8,0x57FE,0xE607,0xB6A3,0xA268,0x5000,0xFBFF,0x7523, + 0x88A8,0x5400,0xFC6C,0x7689,0x8868,0x5400,0xDFC9,0xF509, + 0xA2A8,0x5000,0xFFFF,0xF6A3,0xA268,0x5000,0x0800,0x0523, + 0x88A8,0x5FFF,0xF800,0x0689,0x8868,0x441D,0x0000,0x7589, + 0xA2A8,0x8275,0x0000,0x56A3,0xA268,0x81C1,0x0000,0x7563, + 0x88A8,0x8081,0x0000,0x06B9,0x886B,0x8001,0x0007,0x750F, + 0xA2A8,0x0001,0x0005,0x56A3,0xA26F,0xFFFF,0x0007,0x7523, + 0x88A0,0x0000,0x0000,0x068B,0x887F,0xFFFF,0xFFFF,0xFD0F, + 0xA2AA,0xAAAA,0xAAAA,0xAAAF,0xA255,0x5555,0x5555,0x5533, + 0x88AA,0xAAAA,0xAAAA,0xAAA9,0x8848,0x8895,0x5548,0x88E9, + 0xA222,0x222A,0xAAA2,0x2263,0xA222,0x2215,0x5562,0x22A3, + 0x8888,0xAAAA,0xAAAA,0x8FFD,0x8888,0x5555,0x5555,0x0DB7, + 0xA222,0xAAAA,0xAAAA,0xADB7,0xA222,0x2222,0x2222,0x2B6F, + 0x8888,0x8888,0x8888,0x9B6D,0x8888,0x8888,0x8888,0x9FF9, + 0xA222,0x2222,0x2222,0x3FFB,0xA222,0x2222,0x2222,0x3FFB, + 0x8888,0x8888,0x8888,0xBFF9,0x8000,0x0000,0x0000,0xBFF9, + 0xA100,0x0000,0x00C2,0x3FF3,0xA000,0x0800,0x0042,0x2223, + 0x830D,0x9E1C,0x3840,0x8889,0x810A,0x8822,0x4440,0x8889, + 0xA10A,0x8822,0x4442,0x2223,0xA10A,0x8822,0x4442,0x2223, + 0x810A,0x8922,0x4440,0x8889,0x810A,0x861C,0x3840,0x8889, + 0xA000,0x0000,0x0002,0x2223,0xA000,0x0000,0x0002,0x2223, + 0x8888,0x8888,0x8888,0x8889,0x8888,0x8888,0x8888,0x8889, + 0xA222,0x2222,0x2222,0x2223,0xFFFF,0xFFFF,0xFFFF,0xFFFF diff --git a/unix/sun/imtool.man b/unix/sun/imtool.man new file mode 100644 index 00000000..f4af4d1c --- /dev/null +++ b/unix/sun/imtool.man @@ -0,0 +1,713 @@ +.\" @(#)imtool.1 1.1 14-Aug-87 DCT +.TH IMTOOL 1 "29 June 1989" +.SH NAME +imtool \- image display server for the SunView environment +.SH SYNOPSIS +.B imtool +[ +.B \-fbconfig \fIN\fP +] +[ +.B \-raster \fIfilename\fP +] +.ti +0.5i +[ +.B \-maptype +\fB\fR(\fPmono \fR|\fP linear \fR|\fP random \fR|\fP crandom\fR) +] +.ti +0.5i +[ +.B \-\fR[\fPno\fR]\fPcolorbar\fR +] +[ +.B \-white \fR|\fP \-black\fR +] +[ +\fIframeargs\fR +] +.SH OPTIONS +.TP +\fB\-fbconfig \fIN\fP +Specifies the initial frame buffer configuration (specifying the number and +size of the internal frame buffers) for the server. +The set of acceptable frame buffer configurations is defined in a private +or public \fIimtoolrc\fR file (discussed below). +.TP +\fB\-raster \fIfilename\fP +Specifies that the server is to start up with the image in the standard +Sun raster format file \fIfilename\fR already loaded into frame buffer 1. +The size of the specified raster need not match the size of the frame +buffer configuration specified with the \fI\-fbconfig\fR argument. +.TP +\fB\-maptype \fR(\fPmono \fR|\fP linear \fR|\fP random \fR|\fP crandom\fR)\fP +Specifies the type of greyscale mapping to be used. +\fBmono\fR means render the image in black and white (shades of gray). +\fBlinear\fR means render the image in linear pseudocolor, with the range of +displayed pixel values corresponding to a range of colors from black to blue +to green to red to white. +\fBrandom\fR means render the image in random pseudocolor, with a random +color being assigned to each greyscale value. +\fBcrandom\fR means render the image in random pseudocolor, updating the +colortable every second or so while the mouse is in the display window. +.TP +\fB\-\fR[\fPno\fR]\fPcolorbar\fR +Specifies whether or not a colorbar is to be displayed at the bottom of the +display window. The colorbar graphically illustrates the relationship between +pixel intensity and displayed color or greylevel, and is particularly useful +with pseudocolor, or when windowing the display. The minimum pixel intensity +(1) is at the left and the maximum (200) is at the right. +.TP +[\fB\-white\fR |\fP \-black\fR] +Specifies whether the image is to be displayed on a white (default) or black +background. +.TP +[\fIframeargs\fR] +\fIimtool\fR also takes generic tool arguments, used to set the position, +size, etc. of the display window; see \fIsuntools\fR(1) for a list of these +arguments. +.if t .sp 0.08i +.SH DESCRIPTION +.SS Image Display Server +.LP +\fIimtool\fR implements a simple image display server for the SunView window +environment. The server runs as an independent process, managing the display +window and listening for connections on a pseudodevice entry in \fB/dev\fR. +All communications with the server are via a simple data stream protocol +described below. +.if t .sp 0.05i +.SS Prototype Status +.LP +The current implementation of the imtool image display server is a limited +prototype, and can be expected to change substantially in the future as the +prototype continues to evolve. The main capabilities lacking in the current +version are flexibility in lookup table control, overlaid graphics and text, +miscellaneous functions such as split screen, and a fully interactive interface +to applications programs. +.if t .sp 0.05i +.SS Basic Concepts +.LP +The display server consists of a set of N \fBframe buffers\fR and a single +\fBdisplay window\fR. A frame buffer is a two dimensional array in memory +into which the image to be displayed is loaded, and which is used to refresh +the display window when portions of the window are uncovered. +In the current prototype display server only 8 bit deep frame buffers are +supported, but the number and size of the frame buffers is user configurable. +.PP +The display window is literally a window into the image stored in the frame +buffer. While the size of the frame buffer is fixed (subject to periodic +reconfiguration), the display window may be any size, and the size may be +changed at any time without affecting the contents of the frame buffer. +Likewise, the position of a small display window upon a larger frame buffer +is arbitrary and may be changed at any time by \fBpanning\fR the window +across the image. While there may be multiple frame buffers, there is only +a single display window, and only a single image may be displayed at any one +time, although a single keystroke suffices to change the frame being viewed. +.PP +With few exceptions, all display server functions are both \fIindependent\fR +and \fIasynchronous\fR. Hence, one can display one frame while another is +being loaded, or even resize or pan the display window and adjust the greyscale +mapping of a frame while the frame is being loaded. +.PP +The primary function of the display server is to provide image display and +interactive image oriented user interface capabilities to a concurrently +executing client program via a bidirectional datastream interface. +Hence, to make use of the display server for image display one also needs an +applications program capable of talking to the server, and sending it image +data to be displayed (a rudimentary builtin capability for displaying Sun +raster files is however provided). The \fBdisplay\fR program in the IRAF +\fBimages.tv\fR package is an example of such a client program. +.if t .sp 0.05i +.SS The Frame Menu +The imtool frame menu provides the following selections: +.if t .sp .05i +.if n .sp +.RS +.IP \fBFrame\fR 15 +Displays the standard SunView frame menu. +.IP \fBSetup\fR +Displays (or hides) the imtool interactive setup panel. +.IP \fBRegister\fR +Adjusts the pan offset of all frame buffers to match that of the image +currently being displayed. Normally, the individual frame buffers are +independently panned. +.IP "\fBBlink \fR[\fPon\fR|\fPoff\fR]" +Turns frame blink (alternate display of a series of frames) on or off. +Alternatively the \fBctrl/B\fR key may be used to manually cycle through +the blink frames. +.IP \fBFitFrame\fR +Adjusts the size of the display window to display the entire frame buffer. +.IP \fBNextFrame\fR +Displays the next frame buffer in sequence. +Used to cycle through and alternately display all frames +(the \fBalternate\fR or \fBctrl/F\fR and \fBctrl/R\fR keys may also be used +to cycle forward or reverse through the frames). +.IP \fBGclear\fR +Clear the graphics overlay of the frame currently being displayed. +.IP \fBIclear\fR +Clear the image, i.e., frame buffer, currently being displayed. +.IP \fBImcopy\fR +Make a hardcopy of the image window. +.RE +.if t .sp .05i +.if n .sp +.LP +The image hardcopy output function is an entry point to the general screen +capture facility, discussed in the next section. This is the same facility +used by the \fIgterm\fR program. +.if t .sp 0.05i +.SS Hardcopy Output +.LP +The image hardcopy function produces a "what you see is what you get" bitmap +of the rectangular region of the screen occupied by the display window. +If the region of interest is partially covered by another window, then the +hardcopy will be a picture of a partially covered window. Any interactive +adjustment of the grayscale mapping will be reflected in the hardcopy output. +.LP +The screen capture software reads out the full memory of the workstation in +the region of interest, and in the case of a color workstation, processes the +screen pixels through the colortable to produce an image corresponding to what +appears on the screen. No full color output options are currently provided, +hence the average of the red, green, and blue color values is next computed. +If rasterfile output is being generated, the raw pixel values and RGB color +table entries are saved directly in the rasterfile, rather than applying the +tables in software to produce a monochrome or bitmap image. +.LP +Two output options are currently provided, i.e., \fBPostscript\fR output +suitable for output directly to a laser writer to produce the final graphics +hardcopy, or \fBSun rasterfile\fR output. The default action is to output a +Postscript program to the device "lw", e.g., the Apple Laserwriter +(any 300 dpi Postscript device should do), using the dithering capability of +Postscript to produce a pseudogreyscale representation of the 8 bit output +image. These defaults may be changed by defining the following environment +variables: +.IP R_RASTERFILE +If this variable is defined a Sun rasterfile will be generated, otherwise a +Postscript plotfile is generated. The string value of the variable is a +\fIprintf\fR style format string to be used to generate the filename of +the rasterfile. If multiple rasterfiles are to be generated, the format +string may contain a decimal integer field (e.g., "\fLframe.%d\fR") to be +replaced by the \fIfile number\fR of the current rasterfile. The first file +generated will be number zero, with the file number being incremented once +for every rasterfile produced. If Postscript plotfile output is desired, +the plotfile will be a uniquely named temporary file in \fB/tmp\fR. +(Postscript output is text and you can read this file if you are curious what +it looks like). +.IP R_DISPOSE +The string value of this variable is a \fIprintf\fR style format string with +one string valued subfield to be replaced by the plotfile or rasterfile name, +to be used to generate the command used to dispose of the output file. +If this variable is not defined and the output file is a Postscript plotfile, +the default format string \fL"lpr -Plw -r -s %s"\fR will be used. +If the variable is not defined and the output file is a rasterfile, +no action is taken. It is the responsibility of the dispose command to +delete the output file. +.LP +It should only take several seconds to capture the screen and produce the +output rasterfile or queue the Postscript job to the printer. The screen +is flashed to indicated when the operation has completed (provided the user +has not turned off the \fIvisible bell\fR feature in their SunView defaults +startup file). +.PP +The Postscript processing time is usually several minutes (of laserwriter time). +Since most Postscript printers are interfaced via a serial interface at 9600 +baud, data compression is used to reduce the amount of data to be transmitted, +and the current bottleneck is the processing speed of the Postscript engine +itself, which does all the dithering and coordinate transformations. +(This is true for bitmaps, but the data compression algorithm used is not +very effective for 8 bit image data, and the serial interface can still be +a bottleneck in this case). +.if t .sp 0.05i +.SS The Setup Panel +.LP +The setup panel is used to interactively modify imtool options. +Two types of selections are provided, \fImultiple choice\fR selections, +and \fIpush button\fR selections. Clicking on a multiple choice selection +cycles through the choices (left mouse button) or displays the choices as +a menu (right mouse button). +String valued options are modified by clicking on the old value, rubbing out +all or part of the old value if necessary, and then typing in a new value +followed by return. If there several string valued fields in a panel, +return may be used to cycle through the fields. +Clicking on a push button (use the left mouse button) "pushes" the button, +causing the action indicated on the button to be executed. +.LP +The multiple choice options in the setup panel are the following: +.IP "\fBNumber of frame buffers\fR" +Specifies the number of frame buffers for which space is currently allocated. +The number of frame buffers may be changed at any time. If a client program +references a frame which does not yet exist, the number of frame buffers will +automatically be increased, hence it is not necessary to preallocate space +for the frame buffers. +.IP "\fBGreyscale mapping\fR" +Specifies the method to be used to map pixel intensity values to RGB color +intensity values. +\fBmono\fR specifies that the image is to be rendered in shades of grey. +\fBlinear pseudocolor\fR specifies that the image is to be rendered in +pseudocolor, with pixel intensities mapped into the range of colors from +black to blue to green to red to white. +\fBrandom pseudocolor\fR assigns a random color to each possible pixel +greylevel. +\fBcontinuous random pseudocolor\fR is like random pseudocolor, +but the colors are changed every few seconds, where the interval +between color changes is specified by the \fBrate\fR option below. +.IP "\fBRate (sec) for Crandom Option\fR +Specifies the frequency (1 to 32 seconds) with which new colors are to be +assigned for the continuous random pseudocolor option. +.IP "\fBBackground color\fR +Specifies the frame background color, i.e., the color to which the frame +will be set when cleared (black or white), or when displaying an image which +fills only part of the frame, the color of the portion of the frame buffer +which has not been written into. +.IP "\fBInclude Frame Border in Imcopy\fR +Specifies whether the frame border, including the frame label, is to be +included in image hardcopies. By default the frame border is included since +the frame label is often used to identify the displayed image. +If the frame border is excluded then so is the colormap, if any. +.IP "\fBShow colorbar\fR +Specifies whether or not a colorbar is to be shown at the bottom of the +display window. +.IP "\fBBlink rate (sec)\fR +When blink is enabled, specifies the amount of time a single frame is to +be displayed. The value may range from 1/2 second to 32 seconds. +The maximum blink rate may be achieved by holding down the \fBalternate\fR +key long enough to cause autorepeat. +.IP "\fBFrames to be blinked\fR +The string value of this parameter specifies the list of frames to be blinked. +The special value "all" may be specified to blink all frames in sequence. +If the frames are explicitly listed, the same frame may appear in the list +multiple times. +.IP "\fBZoom factors\fR +Specifies the positive integer zoom factors to be used for the zoom and pan +function. Up to eight zoom factors may be specified (more would +be undesirable due to the time required to cycle through the zooms to get +back to an unzoomed image). The default zoom factors are "1 2 4 8"; +depending upon the application, one might want to add, e.g., a zoom factor +of 3, or a large zoom factor of 32 or 64 to make it easy to identify +individual pixels. +.IP "\fBCoordinate list output file\fR +Specifies the name of the file to be used for cursor lists (text files +containing lists of object coordinates - see below). +.IP "\fBRaster filename (load/save)\fR +Specifies the filename of the Sun rasterfile to be loaded into the current +frame buffer (\fBload\fR push button, below), or the filename into which +to current frame is to be written (\fBsave\fR push button). +.LP +The following "push buttons" are also provided in the setup panel. +Many of these are equivalent to the comparable selections in the frame menu. +.RS +.IP "\fBRegister Frames\fR" 15 +Adjust the pan offset of all frames to match that of the current frame. +.IP "\fBFit Window\fR" +Adjust the size of the display window to match that of the frame buffer. +.IP \fBReset\fR +Reset the display. The mapping type, transfer function, and pan offsets are +restored to their initial values, but the contents of the frames are not +affected. +.IP \fBIclear\fR +Clear the frame buffer currently being displayed. +.IP \fBGclear\fR +Clear the graphics overlay (may also be cleared whenever the display window +is refreshed). +.IP \fBLoad\fR +Load the Sun rasterfile named by the \fIRaster filename\fR panel string +parameter into the frame buffer currently being displayed. +If the rasterfile is smaller than +the frame buffer the raster will be loaded into the upper left corner of +the frame buffer. If the rasterfile is larger than the frame buffer part of +the raster will be discarded. Any colortable information present in the +rasterfile is ignored. +.IP \fBSave\fR +Save the contents of the frame buffer currently being displayed in the +Sun rasterfile named by the \fIRaster filename\fR panel string parameter. +The new raster will be the same size as the frame buffer. No colortable, +WCS, or any information other than the pixel values is saved in the rasterfile. +.IP \fBBlink\fR +Turn frame blink on or off. +.IP \fBFrame\fR +Display the next frame in sequence. Equivalent to the \fBNextFrame\fR frame +menu selection, and to the \fBalternate\fR and \fBctrl/F\fR keys. +.IP \fBQuit\fR +Close the setup panel. +.RE + +.if t .sp 0.05i +.SS Function Keys +.LP +The following function keys have special significance to \fIimtool\fR: +.RS +.IP F4 15 +Calls up the setup panel, or closes it if already displayed. +.IP F5 15 +Causes the current cursor list file to be rewound and reread, marking all +objects on the cursor list by drawing a number beside each object in the +display window. Each object is marked by its ordinal number in the cursor +list, ignoring comment lines and blank lines. The precise object position +is at the lower left corner of the first digit. +Each time the cursor list is redrawn the color of the digits toggles between +black and white, making it possible for the user to manually "blink" the +object numbers, or select the representation which provides the best visibility +for their data. Note that objects are marked only in the display window, +i.e., the frame buffer is not modified, hence the numerals will be lost +whenever the display is refreshed. +.IP F6 +Enables and disables \fBcursor readout mode\fR. While cursor readout mode is +in effect a box is displayed in the lower right corner of the display window, +in which the coordinates and corresponding pixel intensity at the position of +the the mouse cursor are continuously updated as the mouse is moved. +The cursor coordinates are given in \fIworld coordinates\fR if a WCS (world +coordinate system) has been defined for the frame, otherwise display window +relative pixel coordinates and display pixel intensity values are given. +If the pixel intensity is saturated (set to the extreme high or low value), +a + or - is appended to the printed value to flag the value as saturated. +.IP F7 +Hitting this key while the mouse is in the display window causes an image +hardcopy to be generated. This is equivalent to selecting the \fBimagecopy\fR +item in the frame menu, except that it can be done without moving the mouse. +This may be important to avoid changing the greyscale mapping, which also +depends upon the mouse position. +.RE +.LP +Note that the mouse must be in the display window for these function keys to +have any effect. +.if t .sp 0.05i +.SS Mouse Buttons +.LP +The mouse buttons are used with \fIimtool\fR as follows: +.RS +.IP "Left Button" 15 +In cursor readout mode, used to mark objects, adding each object to the cursor +list for the current frame. Ignored when not in cursor readout mode. + +.IP "Middle Button" +The middle button on the mouse is the \fBpan/zoom\fR button. +If the pan button is held down and released at a position in the display +window, the object under the cursor will be moved to the center of the +display. \fBcontrol-pan\fR is the same except that the image will pan +smoothly to the new position, rather than all at once. \fBshift-pan\fR +causes the image to be panned in the indicated direction in large steps. +Shift and control may be combined to smoothly pan in large steps. +.IP +The \fBzoom\fR function is also controlled by the middle mouse button. +Placing the mouse on an object and pressing pan/zoom once causes the object +to be moved to the center of the display; pressing the button again causes +the image to be zoomed about the mouse position. Repeated presses without +moving the mouse cycle through the predefined set of zoom factors until the +cycle wraps around and the unzoomed image is restored. Zoom is almost as +fast as a normal unzoomed window refresh, so there is no problem with, +for example, panning on a zoomed image. +.IP +If the middle button is held down while in cursor readout mode the mouse may +be moved without updating the displayed cursor coordinates. This is useful +when moving the mouse to a different window, e.g., to type the displayed +object coordinates into an application running in some other window. +An attempt to pan while already at the edge of the frame is ignored. +.IP "Right Button" +Used to interactively adjust the greyscale mapping (colortable) for the window. +.RE +.LP +To window the display, i.e., adjust the \fBtransfer function\fR for the +window, hold the right mouse button down and move the cursor about within the +window. Zero contrast (one greylevel) is at the center of the window, +with positive contrast above, negative contrast below, +and contrast increasing the further the mouse is moved from the centerline. +Moving the mouse to the left or right adjusts the greyscale range to lower +or higher intensities. The colorbar provides a graphic display of the effect +of the transfer function. If the right mouse button is pressed and then +released without moving the mouse the transfer function will be adjusted +according to the position of the mouse. By alternately displaying several +frames and tapping the right mouse button for each frame without moving the +mouse, the transfer functions of several frames may be matched. +.if t .sp 0.05i +.SS Frame Buffer Configuration Files +.LP +While the prototype display server does support dynamic reconfiguration of +the frame buffers, allowing multiple frame buffers of virtually any size, +it is currently necessary to define the possible frame buffer configurations +at startup time. This is done via a table file called the \fBimtoolrc\fR +file. An example illustrating the contents of such a file is shown below. +Note that this may differ from the default configuration file used at your +site. +.sp +.nf + 1 2 512 512 # imt1|imt512 + 2 2 800 800 # imt2|imt800 + 3 2 1024 1024 # imt3|imt1024 + 4 1 1600 1600 # imt4|imt1600 + 5 1 2048 2048 # imt5|imt2048 + 6 1 4096 4096 # imt6|imt4096 + 7 1 4096 1024 # imt7|imt4x1 + 8 1 1024 4096 # imt8|imt1x4 + 9 2 1144 880 # imt9|imtfs full screen (1152x900 minus frame) + 10 2 1144 764 # imt10|imtfs35 full screen at 35mm film aspect ratio + 11 2 128 128 # imt11|imt128 + 12 2 256 256 # imt12|imt256 + + 20 2 388 576 # imt20|imtgec GEC CCD detector format + 21 1 3040 976 # imt21|imtkpca KPCA detector format (also 2D-Frutti) + 22 1 128 1520 # imt22|imt2df1 2D-Frutti + 23 1 256 1520 # imt23|imt2df2 2D-Frutti + 24 1 512 1520 # imt24|imt2df5 2D-Frutti + 25 1 960 1520 # imt25|imt2df9 2D-Frutti + 26 1 512 800 # imt26|imtcryo Cryogenic Camera + 27 1 348 800 # imt27|imtgcam Gold Camera + 28 1 976 3040 # imt28|imt2df9x3 2D-Frutti +.fi +.LP +Each entry in the file contains four numbers, the configuration number +(e.g., as used in \fI\-fbconfig N\fR), the number of frames to be created +initially (frames may be added or deleted once the configuration is +specified), and the width and height of the frame in screen pixels. +Blank lines and comments are ignored. +Note that \fIthe frame width must evenly divisible by 4\fR, +due to alignment restrictions on memory pixrects in SunView. +.LP +Selection of the frame buffer configuration to be used is done at run time +by the client application program when a frame is loaded. Since the frame +buffer size to be used is controlled by the client application program rather +than by the server, there is no entry in the setup panel for changing the +configuration. Rather, it is expected that a command will be provided +at the applications level for specifying the frame buffer size to be used. +In the case of IRAF, this is done with a command such as +\fBreset stdimage = imt800\fR, where the logical device name used on the right +is given in the comments in the configuration table above, and must +correspond to an equivalent entry in the IRAF \fBgraphcap\fR file. +The imtoolrc file may be customized by the user for special applications, +if desired, but a custom version of the graphcap file will be required too. +.LP +The frame buffer configuration file may be located in a default public +directory, e.g., \fB/usr/local/lib/imtoolrc\fR, or the user may have a +private version of the file, e.g., \fB.imtoolrc\fR. During startup, imtool +looks first for an environment variable IMTOOLRC defining the pathname of +the imtoolrc file, then it checks for a .imtoolrc file in the user's login +directory, and finally it checks for the file /usr/local/lib/imtoolrc. +If none of these are found, a default configuration of a single 512 square +frame buffer is used. +.if t .sp 0.05i +.SS World Coordinate Systems +.LP +\fIimtool\fR provides a simple mechanism for associating a linear \fBworld +coordinate system\fR (WCS) with the displayed image. A WCS consists of an +image title string to be displayed in the frame label, a rotation matrix +expressing the translation from window pixel coordinates (zero-indexed, origin +in the upper left corner of the display window) to \fIworld coordinates\fR, +e.g., the image pixel coordinates of the displayed image, and a pair of +image intensity values defining the transformation between display server +pixel intensity units (range 1-200 currently) and image pixel intensity units. +.LP +The WCS for a frame is passed to imtool as a set-WCS command in the datastream +input from the client process (applications display program). +A sample WCS descriptor is shown below. +.if t .sp 0.03i +.if n .sp +.RS +.nf +dev$pix - m51 B 600s +.br +1. 0. 0. -1. 1. 512. 0. 1481.635 1 +.fi +.RE +.if t .sp 0.03i +.if n .sp +.LP +The first line is simply a line of text to be displayed in the frame label +when the WCS is read. This should normally contain the name of the image +and a few words describing the image being displayed. +.LP +The first six numbers in the second line define a rotation matrix specifying +the translation from window pixel coordinates to world coordinates, according +to the following relations: +.if t .sp 0.03i +.if n .sp +.RS +.nf +x' = ax + cy + tx +.br +y' = bx + dy + ty +.fi +.RE +.if t .sp 0.03i +.if n .sp +The coefficients of the transformation matrix are given in the order +\fBa b c d tx ty\fR. The example defines the image pixel coordinates for a +512 square image, displayed with the origin at [1,1] in the lower left corner +of the display window. Note that the world coordinates are flipped in Y +and shifted to an origin at [1,1]. +.LP +The final three numbers on the second line define the transformation from +display pixel intensity units to image pixel intensity units. The first two +values specify the image pixel intensities corresponding to display pixel +intensities 1 and 200. The third number is an integer defining the type +of transformation used; currently the value must be 1, indicating a linear +transformation. +.LP +The WCS is initially undefined when a new frame is created. +The first cursor or function key event thereafter +which attempts to use WCS information will cause the WCS information to be +interpreted if it has been passed in via the set-WCS datastream command. +You will know if the server succeeds in reading the WCS because the +\fBframe label\fR will change when the WCS is read. +The first field of the frame label is the frame name, which will be the +filename of any cursor list files created for the frame. +.if t .sp 0.05i +.SS Coordinate List Files +.LP +Cursor readout mode provides a convenient means of displaying the cursor +coordinates, but the coordinates are lost as soon as the cursor is moved. +To permanently record the positions of objects of interest one may generate +a \fIcoordinate list file\fR by marking objects with the mouse. +The contents of existing list files may also be displayed, and one may append +to an existing list. List files generated by foreign programs may easily +be displayed. +.LP +A coordinate list file is a simple text file with the X-Y coordinate pairs of +objects recorded on successive lines in the file. +The object number is not recorded explicitly, but is determined by the +relative position of a coordinate pair within the file, ignoring comment +lines (#...) and blank lines. List files may be edited and redisplayed if +desired, and although the object numbers may change they will always agree +with whatever is shown on the screen. A hardcopy of the screen may be made +to provide a pictorial record of the contents of a list file, e.g., so that +objects may be referred to by number if the list is used as input to another +program. +.LP +The filename of the list file associated with the displayed frame is shown in +the frame label, e.g., "frame.1". By default the list file will be created +in the WCSDIR, i.e., in the directory defined by the user environment variable +WCSDIR. +.PP +These defaults may be overridden by entering via the setup panel the +\fIprintf\fR style format string to be used to construct the filename of the +list file. If the name given begins with a / an absolute pathname is assumed +and the filename is not modified in any way. Otherwise, a directory prefix +is prepended, e.g., "$wcsdir/frame.\fIN\fP". +The directory prefix is specified by the value of the WCSDIR environment +variable if defined, otherwise the user's UNIX login directory is assumed. +The frame number will appear in the generated filename only if a numeric +format is included in the format string, e.g., \fBframe.%d\fR to specify +a frame number file extension. +.if t .sp 0.05i +.SS Colortable Usage +.LP +To permit simultaneous viewing of both the display window and any other +windows under SunView, \fIimtool\fR uses only a portion of the 256 element +hardware colortable. Image pixels range in value from 1 to 200 (colortable +entry 0 is reserved for the background or foreground color by SunView). +Additional colortable entries are used for the cursor color and a set of +graphics overlay colors, reserving 50 or so colortable entries for use by +other windows. The graphics colortable entries are in the range 202-217. +These are assigned predefined colors, which are unaffected by windowing the +display. The graphics colortable assignments are summarized below. +.if t .sp 0.03i +.RS +.nf +202 black 206 blue 210 coral 214 orchid +203 white 207 yellow 211 maroon 215 turquoise +204 red 208 cyan 212 orange 216 violet +205 green 209 magenta 213 khaki 217 wheat +.fi +.RE +.if t .sp 0.03i +.PP +When imtool is started it reads the hardware color table, which is assumed to +contain the entries for the other windows on the screen, replaces entries +1 through 200+, and uses the resultant table to update the hardware colortable +thereafter at a rate of twice a second. It is necessary to continuously +update the hardware colortable to permit image display while the mouse is not +in the display window, however, this scheme will cause colortable conflicts +f one attempts to run a second window tool which also uses a large number of +colortable entries. +.if t .sp 0.05i +.SS Hints for Blinking Frames +.LP +Blink is most effective when used to compare two or more frames which are very +similar, e.g., a frame and an edited version of the same frame. For blink to +be most effective the images should be displayed as similarly as possible. +Start by loading the two frames using the same spatial and greyscale +transformation for both frames (IRAF users should use the \fBrepeat\fR +option to the \fIdisplay\fR task). Select one of the frames and adjust the +window size, pan offset, and greyscale mapping as desired. After adjusting +the greyscale with the mouse, repeatedly hit the \fBalternate\fR key followed +by the right mouse button to match the greyscale mapping of the first frame to +the remaining frames. Then select \fBregister\fR in the frame menu or setup +panel to register all the frames, followed by \fBblink\fR to blink the frames. +Blink works best if the display window is not too large, e.g., a 400 or 500 +pixel square window is fine. +.if t .sp 0.05i +.SS Data Stream Protocol +.LP +The display server is started like any other SunView tool by executing the +\fIimtool\fR command either directly or indirectly via the \fB.suntools\fR +file or via the mouse from the \fBrootmenu\fR. When first started a checkered +test pattern is displayed, and the display server opens the pseudodevice +files \fB/dev/imt1o\fR (used by the client to send commands and data to the +display server) and \fB/dev/imt1i\fR (for data read back from the display +server) and begins listening for commands from client programs. +All commands and data are passed to the display server as a data stream by +applications writing directly to /dev/imt1o. +.LP +The data stream protocol used +in the prototype server (this will change) mimics that of the IIS Model 70 +image display, with an extension added for specifying the frame buffer +configuration to be used. The server will automatically sense if the +datastream is byte swapped, allowing use of the server with, for example, +IRAF running on a large VAX compute server. Only byte packed data is +supported. +.LP +Note that any process may write to the server, but if more +than one process writes to the server at the same time, the output may be +garbled. Also, multiple display servers may be spawned, but since only a +single pseudodevice entry is currently supported, all such servers would be +trying to read from the same input stream. +.SH SEE ALSO +suntools(1), gterm(1), images.tv.display(IRAF) +.br +\fIWindows and Window-Based Tools: Beginner's Guide\fR +.SH ENVIRONMENT +.IP IMTOOLRC 15 +The full pathname of the \fIimtoolrc\fR (frame buffer configuration) file +to be used (optional). +.IP WCSDIR +The full pathname of the user directory +into which imtool will write any files it creates that are +not specified by a full pathname (alias \fBwcsdir\fR also permitted). +.IP R_RASTERFILE +If defined, a Sun rasterfile rather than Postscript file is generated by +the \fIimcopy\fR function. The string value is a format used to generate +the filename of the rasterfile. +.IP R_DISPOSE +The command to be executed to dispose of the Sun rasterfile or Postscript +output file created by \fIimcopy\fR. If not defined and Postscript output is +indicated (R_RASTERFILE also not defined), then the Postscript output file +is disposed of via \fIlpr\fR to device \fIlw\fR. +.SH FILES +.LP +.nf +/dev/imt1[io] +$WCSDIR/frame.* +/usr/bin/suntools +/usr/lib/rootmenu +$iraf/local/sun/imtool.c +.fi +.SH BUGS +.IP (1) +The display server is continuously updating the hardware colortable even while +the mouse is not in the display window. This is necessary to be able to see +the image while the mouse is not in the window, but may interfere with other +windows which also use many colortable entries. Under normal circumstances +(only one greyscale window) this should not be a problem. If it is a problem, +close the display window when not in use; updating of the hardware colortable +is disabled while the display window is closed. +.IP (2) +Only a single display server should be used at any one time. +Only a single client process should write to the server at any one time. +.IP (3) +The environment variables affecting IMTOOL operation must be defined before +starting suntools if they are to have any effect. +.IP (4) +An error message is printed if imtool encounters a bad data header checksum, +e.g., if synchronization is lost on the input datastream or if illegal data +is input. Recovery from such an error can be difficult, possibly requiring +killing the imtool and starting a new one. This error should not occur if the +software (i.e., the client applications program) is functioning properly. +.SH AUTHOR +Doug Tody, National Optical Astronomy Observatories (NOAO), IRAF project. diff --git a/unix/sun/imtool.square b/unix/sun/imtool.square new file mode 100644 index 00000000..cb54f6eb --- /dev/null +++ b/unix/sun/imtool.square @@ -0,0 +1,4 @@ +/* Format_version=1, Width=16, Height=16, Depth=1, Valid_bits_per_item=16 + */ + 0x0000,0x0000,0x0000,0x0000,0x0000,0x0000,0x03C0,0x03C0, + 0x03C0,0x03C0,0x0000,0x0000,0x0000,0x0000,0x0000,0x0000 diff --git a/unix/sun/imtoolrc b/unix/sun/imtoolrc new file mode 100644 index 00000000..b20a9544 --- /dev/null +++ b/unix/sun/imtoolrc @@ -0,0 +1,48 @@ +# IMTOOL -- Defined frame buffer configurations. Note that the given nframes +# is only a starting point, and may be modified during execution, hence smaller +# values are preferred. The configuration numbers may be given in any order, +# but must be unique and in the range 1-128. NOTE - corresponding entries must +# be present in the dev$graphcap file, for use with IRAF. +# +# Format: configno nframes width height + + 1 2 512 512 # imt1|imt512 + 2 2 800 800 # imt2|imt800 + 3 2 1024 1024 # imt3|imt1024 + 4 1 1600 1600 # imt4|imt1600 + 5 1 2048 2048 # imt5|imt2048 + 6 1 4096 4096 # imt6|imt4096 + 7 1 4096 1024 # imt7|imt4x1 + 8 1 1024 4096 # imt8|imt1x4 + 9 2 1144 880 # imt9|imtfs full screen (1152x900 minus frame) +10 2 1144 764 # imt10|imtfs35 full screen at 35mm film aspect ratio +11 2 128 128 # imt11|imt128 +12 2 256 256 # imt12|imt256 +13 2 128 1056 # imt13|imttall128 tall & narrow for spectro. +14 2 256 1056 # imt14|imttall256 tall & wider for spectro. +15 2 1056 128 # imt15|imtwide128 wide & thin for spectro. +16 2 1056 256 # imt16|imtwide256 wide & fatter for spectro. + +# Some site specific formats for NOAO. +20 2 388 576 # imt20|imtgec GEC CCD detector format +21 1 3040 976 # imt21|imtkpca KPCA detector format (also 2D-Frutti) +22 1 128 1520 # imt22|imt2df1 2D-Frutti +23 1 256 1520 # imt23|imt2df2 2D-Frutti +24 1 512 1520 # imt24|imt2df5 2D-Frutti +25 1 960 1520 # imt25|imt2df9 2D-Frutti +26 1 512 800 # imt26|imtcryo Cryogenic Camera +27 1 348 800 # imt27|imtgcam Gold Camera +28 1 976 3040 # imt28|imt2df9x3 2D-Frutti +29 1 800 256 # imt29|imtgong Gong Cache Monitor +30 1 256 800 # imt30|imtgong Gong Cache Monitor +31 1 1240 400 # imt31|imtret Reticon CCD detector format +32 2 832 800 # imt32|imtti|imtti2|imtti3 +33 2 544 512 # imt33|imtt5ha|imttek2 +34 1 1056 1024 # imt34|imtt1ka|imtte1k|imtst1k +35 1 2080 2048 # imt35|imts2ka|imtt2kb|imtst2k|imtt2k2 +36 1 2048 2080 # imt36|imtt2ka|imtte2k +37 1 3104 1024 # imt37|imtf3ka|imtfo3k + +# User added formats. (start with #64) +# (add here) + diff --git a/unix/sun/mksuntool.csh b/unix/sun/mksuntool.csh new file mode 100755 index 00000000..0c7a4175 --- /dev/null +++ b/unix/sun/mksuntool.csh @@ -0,0 +1,39 @@ +#! /bin/csh +# MKSUNTOOL -- Configure the suntool subdirectory, used to link the suntools +# executable. (Only used for SunOS versions prior to 4.0). + +# set echo + +unset noclobber +unalias cd cmp echo ln mv rm sed set + +set OBJS = "imtool.o gterm.o gtermio.o screendump.o arrow.o notify_read.o" +set sundir = /usr/src/sun/suntool + +if (! -e ./suntool) then + mkdir suntool +endif +cd suntool + +cmp -s Makefile $sundir/Makefile +if ($status == 0 && `grep gterm basetools.h` != "") then + echo "suntool build directory is up to date" + exit 0 +else if (! -e $sundir/Makefile) then + echo "$sundir not found" + exit 1 +else + echo "rebuilding suntool subdirectory" +endif + +set files = "`ls`" +if ("$files" != "") then + rm -rf * +endif +(cd $sundir; tar -cf - . ) | tar -xpf - +echo '"gterm",gterm_main,' >> basetools.h +echo '"imtool",imtool_main', >> basetools.h +echo '/cmdtool_main/i\' > Temp +echo 'extern imtool_main();\' >> Temp +echo 'extern gterm_main();' >> Temp +sed -f Temp toolmerge.c > Temp2; mv -f Temp2 toolmerge.c; rm Temp diff --git a/unix/sun/mouse.c b/unix/sun/mouse.c new file mode 100644 index 00000000..a7d4b538 --- /dev/null +++ b/unix/sun/mouse.c @@ -0,0 +1,47 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include + +/* MOUSE.C -- Routines for saving and restoring the mouse position. These + * are used by a window which needs to grab the mouse and set it to a specific + * position, e.g., because the user has entered a command in to another window + * requesting a cursor read by the process running in the current window. + * (It was NOT easy to figure out how to do this in SunView, but at least I + * was able to do it...). + */ + +/* GET_ABSMOUSEPOS -- Get the current position of the mouse in absolute screen + * coordinates. + */ +get_absmousepos (mywinfd, x, y) +int mywinfd; /* any window on current screen will do */ +int *x, *y; /* mouse position (output) */ +{ + struct screen rootscreen; + int rootfd; + + win_screenget (mywinfd, &rootscreen); + rootfd = open (rootscreen.scr_rootname, 0); + + *x = win_get_vuid_value (rootfd, LOC_X_ABSOLUTE); + *y = win_get_vuid_value (rootfd, LOC_Y_ABSOLUTE); + + close (rootfd); +} + + +/* SET_ABSMOUSEPOS -- Set the mouse position in absolute screen coordinates. + */ +set_absmousepos (mywinfd, x, y) +int mywinfd; /* any window on current screen will do */ +int x, y; /* desired mouse position */ +{ + struct screen rootscreen; + int rootfd; + + win_screenget (mywinfd, &rootscreen); + rootfd = open (rootscreen.scr_rootname, 0); + win_setmouseposition (rootfd, x, y); + close (rootfd); +} diff --git a/unix/sun/notify_read.c b/unix/sun/notify_read.c new file mode 100644 index 00000000..b02913c9 --- /dev/null +++ b/unix/sun/notify_read.c @@ -0,0 +1,85 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +static int (*u_fcn)(); /* user functions to process read */ +static int u_fd; /* fd to be monitored */ + +/* NOTIFY_READ -- This is a customized version of the SunView 3.2 notify_read + * primitive, the notifier's version of the UNIX read() system call (when + * the notifier is used, read() is a high level function, not a system call). + * The function of this special version of notify_read is to intercept kernel + * read calls made by the notifier for the purposes of monitoring, and + * possibly filtering, low level input from a file descriptor. + */ +notify_read (fd, buf, maxch) +int fd; +char *buf; +int maxch; +{ + register int n; + + /* This is a bit of a kludge, but lacking the shelltool source it + * was difficult to do better. The 18 is the size of the tty packet + * echoed by the driver when a character is typed; this is not part + * of the normal output stream so we exclude these events. The buf+1 + * business is to hide the packet mode nature of the stream from the + * gtermio code; the first byte of each packet indicates the packet + * type. These details could change in a future Sun release in which + * case this code would have to be modified. + */ + if (u_fcn && fd == u_fd && maxch != 18) { + n = syscall (SYS_read, fd, buf, maxch); + if (n > 0 && *buf == TIOCPKT_DATA) + return ((*u_fcn)(buf+1, n-1, maxch-1) + 1); + else + return (n); + } else + return (syscall (SYS_read, fd, buf, maxch)); +} + + +/* READV -- This is a customized version of the readv system call, used in + * the Release 3.4 version of ttysw to read from the pty. Usage is (appears + * to be) identical to the old notify_read, except that the TIOCPKT byte is + * returned separately from the data. + */ +readv (fd, iov, iovcnt) +register int fd; +register struct iovec *iov; +int iovcnt; +{ + register int n; + + if (u_fcn && fd == u_fd && iovcnt == 2 && iov[0].iov_len == 1) { + n = syscall (SYS_readv, fd, iov, iovcnt); + if (n > 0 && *(iov[0].iov_base) == TIOCPKT_DATA) + return ((*u_fcn)(iov[1].iov_base, n-1, iov[1].iov_len) + 1); + else + return (n); + } else + return (syscall (SYS_readv, fd, iov, iovcnt)); +} + + +/* NOTIFY_READ_POST_MONITOR_FCN -- Post a user data monitor/filter function + * to process the input on the specified file descriptor. Only one file + * descriptor can be monitored at present. + */ +notify_read_post_monitor_fcn (fd, fcn) +int fd; +int (*fcn)(); +{ + if (u_fcn && !fcn) + return (-1); + else { + u_fcn = fcn; + u_fd = fd; + return (0); + } +} diff --git a/unix/sun/screendump.c b/unix/sun/screendump.c new file mode 100644 index 00000000..a3582e57 --- /dev/null +++ b/unix/sun/screendump.c @@ -0,0 +1,549 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include +#include +#include +#include +#include + +#define SEGSIZE 16 /* output segment size (bytes) */ +#define SEGBITS (SEGSIZE*8) +#define BITFLIP 0 /* bit-flip each byte for P.S.? */ +#define NGREY 256 /* max color table size */ +#define PAGE_WIDTH 2550 /* 8.5x11, 300 dpi */ +#define PAGE_HEIGHT 3300 /* 8.5x11, 300 dpi */ +#define PAGE_XOFFSET 0 /* offset to drawing area */ +#define PAGE_YOFFSET 0 /* offset to drawing area */ +#define MARGIN 150 /* 1/2 inch margin */ +#define MAXGROUPS (PIXPG_OVERLAY+1) + +#define RT_DATA 'a' /* record type codes */ +#define RT_ZERO 'b' +#define RT_FULL 'c' +#define RT_BKG1 'd' +#define RT_BKG2 'e' +#define BKGPAT_1 "22" /* atom for stipple pattern */ +#define BKGPAT_2 "88" /* atom for stipple pattern */ + +/* The following are provided by the calling program and specify what type + * of output is desired. + */ +extern int r_type; /* 0=postscript, 1=rasterfile */ +extern char r_dispose[]; /* dispose command */ +extern char r_filename[]; /* output file template */ + +int gt_bitflip_postscript = BITFLIP; +static unsigned char red[NGREY], green[NGREY], blue[NGREY]; +static void bitmap_to_postscript(); +static char *make_label(); + + +/* SCREENDUMP -- Make a hardcopy of the indicated region of the screen on a + * hardcopy device. Currently only two output formats are supported, Sun + * rasterfile output, or Postscript. A dispose command may be given to + * postprocess the output file, e.g., send it to the printer. + */ +screendump (win_fd, pw, width, height, left, top, nbits_out) +int win_fd; /* window fd, for bell */ +struct pixwin *pw; /* arbitrary pixwin, used to lock display */ +int width, height; /* region to be printed: size, */ +int left, top; /* origin */ +int nbits_out; /* output 1 bit or 8 bit postscript image? */ +{ + register int v, i, j; + register unsigned char *ip, *op; + unsigned char *pr_data, *obuf, *zero; + + struct rect pw_r; + struct timeval tv_bell; + struct pixrect *screen, *s_pr, *o_pr, *m_pr; + static int filenum = 0; + + float scale, xs, ys; + int overlay, ngroups; + char groups[MAXGROUPS]; + char tempfile[80], dispose[80]; + int depth, cache_v, cache_greyval, rasterout; + int status=0, bit, byte, pr_linebytes, ob_linebytes, fd; + char *str, *getenv(); + FILE *fp; + + /* Open the hardware frame buffer, create a memory pixrect to hold user + * specified rect, lock the display and read in the data and colormap. + * The Sun 3-110, 3/60, etc., have separate monochrome and color + * planes plus an overlay-enable plane, whereas the older frame buffers + * have only a single monochrome or color plane. + */ + screen = pr_open ("/dev/fb"); + + depth = screen->pr_depth; + ngroups = pr_available_plane_groups (screen, MAXGROUPS, groups); + overlay = (ngroups >= PIXPG_OVERLAY); + + /* Get memory pixrects to hold frame buffer data. */ + zero = (unsigned char *) malloc (height); + s_pr = mem_create (width, height, depth); + if (overlay) { + o_pr = mem_create (width, height, 1); + m_pr = mem_create (width, height, 1); + } + + /* Lock the frame buffer to avoid edits during readout. */ + pw_get_region_rect (pw, &pw_r); + pw_lock (pw, &pw_r); + + /* Get the color map and the main frame buffer pixrect. */ + pr_getcolormap (screen, 0, NGREY, red, green, blue); + pr_set_plane_group (s_pr, PIXPG_8BIT_COLOR); + pr_rop (s_pr, 0, 0, width, height, PIX_SRC, screen, left, top); + + /* If the device has an overlay plane, readout it out as well as the + * enable plane. + */ + if (overlay) { + int o_pg; + o_pg = pr_get_plane_group (screen); + pr_set_plane_group (screen, PIXPG_OVERLAY); + pr_rop (o_pr,0,0, width, height, + PIX_SRC, screen, left, top); + pr_set_plane_group (screen, PIXPG_OVERLAY_ENABLE); + pr_rop (m_pr,0,0, width, height, + PIX_SRC, screen, left, top); + pr_set_plane_group (screen, o_pg); + } + + pw_unlock (pw); + pr_close (screen); + + /* Combine the color plane and overlay plane to produce a single + * color plane. Use only those overlay plane pixels which have their + * bit set in the enable plane. + */ + if (overlay) { + pr_stencil (s_pr,0,0, width, height, + PIX_COLOR(255) | PIX_SRC | PIX_DONTCLIP, m_pr,0,0, o_pr,0,0); + pr_close (m_pr); + pr_close (o_pr); + } + + /* Output can be either Postscript or a Sun rasterfile. Rasterfile + * output is handled here. + */ + if (rasterout = (r_type && r_filename[0])) { + colormap_t cmap; + + /* Setup colormap descriptor. */ + cmap.type = RMT_EQUAL_RGB; + cmap.length = NGREY; + cmap.map[0] = red; + cmap.map[1] = green; + cmap.map[2] = blue; + + /* Open raster file. */ + sprintf (tempfile, r_filename, filenum++); + if ((fp = fopen (tempfile, "w")) == NULL) { + fprintf (stderr, "cannot create %s\n", tempfile); + return (-1); + } + + pr_dump (s_pr, fp, &cmap, RT_STANDARD, 0); + + fclose (fp); + pr_close (s_pr); + goto dispose_; + } + + /* If the frame buffer is only 1 bit deep we can set obuf to point + * to the pixrect data and we are done. Otherwise we must process + * the image pixels through the color table and convert the output + * into a monochrome pixrect. NOTE: the bits may need to be flipped + * in the monochrome pixrect to satisfy Postscript; I wasn't sure. + */ + if (depth == 1) { + /* This option is currently untested. */ + obuf = (unsigned char *) mpr_d(s_pr)->md_image; + ob_linebytes = mpr_d(s_pr)->md_linebytes; + + if (gt_bitflip_postscript) { + unsigned char flip[256]; + + /* Set up lookup table. */ + for (j=0; j < 256; j++) { + for (v=0, i=0; i < 8; i++) + v |= (((j >> i) & 1) << (7-i)); + flip[j] = v; + } + + /* Bitflip and set the zero-line vector. */ + for (j=0; j < height; j++) { + v = 1; + for (op=obuf+j*ob_linebytes, i=ob_linebytes; --i >= 0; ) { + if (v && *op) + v = 0; + *op++ = flip[*op]; + } + zero[j] = v; + } + } else { + /* Set the zero-line vector for the pixrect. */ + for (j=0; j < height; j++) { + v = 1; + for (op=obuf+j*ob_linebytes, i=ob_linebytes; --i >= 0; ) { + if (v && *op) { + v = 0; + break; + } + } + zero[j] = v; + } + } + + } else if (nbits_out == 1) { + ob_linebytes = (width + 7) / 8; + obuf = (unsigned char *) calloc (ob_linebytes * height, 1); + if (obuf == NULL) { + fprintf (stderr, "out of memory\n"); + return (-1); + } + pr_data = (unsigned char *) mpr_d(s_pr)->md_image; + pr_linebytes = mpr_d(s_pr)->md_linebytes; + + for (j=0, cache_v=(-1); j < height; j++) { + ip = pr_data + j * pr_linebytes; + op = obuf + j * ob_linebytes; + + for (byte=(-1), i=0; i < width; i++) { + if ((v = ip[i]) == cache_v) + v = cache_greyval; + else { + cache_v = v; + v = cache_greyval = (red[v] + green[v] + blue[v]) / 3; + } + if (v <= NGREY/2) { + byte = i / 8; + bit = 8 - (i % 8) - 1; + op[byte] |= (1 << bit); + } + } + + /* Set flag if entire line is zero. */ + zero[j] = (byte < 0); + } + + pr_close (s_pr); + + } else if (nbits_out == 8 && depth == 8) { + /* Eight bits out; transform the image in place in the input + * pixrect to save memory. + */ + obuf = pr_data = (unsigned char *) mpr_d(s_pr)->md_image; + ob_linebytes = pr_linebytes = mpr_d(s_pr)->md_linebytes; + + for (j=0, cache_v=(-1); j < height; j++) { + ip = pr_data + j * pr_linebytes; + op = obuf + j * ob_linebytes; + + for (i=0; i < width; i++) { + if ((v = ip[i]) == cache_v) + v = cache_greyval; + else { + cache_v = v; + v = cache_greyval = (red[v] + green[v] + blue[v]) / 3; + } + op[i] = v; + } + + /* Set flag if entire line is zero. */ + zero[j] = 0; + } + + } else { + fprintf (stderr, "can only create 1 bit or 8 bit output image\n"); + return (-1); + } + + /* Create the output file to hold postscript program. If no filename + * has been specified create a unique file in /tmp. + */ + if (!r_filename[0]) { + strcpy (tempfile, "/tmp/psXXXXXX"); + if ((fd = mkstemp (tempfile)) == -1) { + fprintf (stderr, "cannot create temporary file %s\n", tempfile); + return (-1); + } else + fp = fdopen (fd, "a"); + } else { + sprintf (tempfile, r_filename, filenum++); + if ((fp = fopen (tempfile, "w")) == NULL) { + fprintf (stderr, "cannot create %s\n", tempfile); + return (-1); + } + } + + /* Scale to fit output page. */ + xs = (PAGE_WIDTH - MARGIN*2) / (float)width; + ys = (PAGE_HEIGHT - MARGIN*2) / (float)height; + scale = (xs < ys) ? xs : ys; + + /* Translate the bitmap into a postscript program. */ + bitmap_to_postscript (fp, + obuf, width, height, nbits_out, ob_linebytes, zero, scale); + + free ((char *)zero); + if (depth == 1 || (depth == 8 && nbits_out == 8)) + pr_close (s_pr); + else + free ((char *)obuf); + + fclose (fp); + close (fd); + + /* Dispose of tempfile to the printer. We leave it up to the dispose + * command to delete the temporary file when finished. + */ +dispose_: + if (r_dispose[0]) { + sprintf (dispose, r_dispose, tempfile); + if ((status = system (dispose)) != 0) + fprintf (stderr, "screendump: exit status %d\n", status); + } + + /* Flash the screen to signal the user that we are done. */ + tv_bell.tv_usec = 0*1000; tv_bell.tv_sec = 0; + win_bell (win_fd, tv_bell, pw); + + return (status); +} + + +/* BITMAP_TO_POSTSCRIPT -- Translate a memory bitmap into a postscript program + * using image compression where regions of the image are all zeroes. This is + * done as follows: [1] lines of the bitmap are divided into segments of N + * bytes, [2] if all N bytes are zero a single zero byte is transmitted, + * otherwise a byte with the value one is transmitted, followed by N bytes of + * literal data. Lines which are entirely zero are not transmitted at all. + * The goal is to significantly reduce the amount of data to be pushed through + * the laserwriter serial interface while keeping things simple enough that + * postscript will hopefully be able to process the bitmap efficiently. + * + * NOTE: Postscript is supposed to be able to copy bitmaps directly without + * any transformations if all the right conditions are met, e.g., unitary + * matrices, pixrect resolution matches device resolution, etc. We do not + * make use of this here due to the great volume of data which would have to + * pushed through the laserwriter serial interface at 9600 baud to transmit + * a fully resolved bitmap. If a parallel interface were available, e.g., + * if the laserwriter is on the ethernet, then this would be the way to go. + */ +static void +bitmap_to_postscript (fp, bitmap, width, height, depth, linebytes, zero, scale) +register FILE *fp; +unsigned char *bitmap; +int width, height, depth; +int linebytes; +unsigned char *zero; +float scale; +{ + register unsigned char *ip; + register char *op, *hp; + register int n; + unsigned char *segp; + char hbuf[NGREY*2]; + char obuf[SEGSIZE*2]; + char rt_full[SEGSIZE*2+1]; + char bkg_1[SEGSIZE*2+1]; + char bkg_2[SEGSIZE*2+1]; + int partseg, seg, nsegs, allzeroes, i, j, last_j; + + /* Initialize the hbuf array, which contains the hex encoded + * representations of the NGREY possible binary byte values. + */ + for (n=0, op=hbuf; n < NGREY; n++) { + i = ((n >> 4) & 017); + *op++ = (i < 10) ? i + '0' : (i-10) + 'A'; + i = (n & 017); + *op++ = (i < 10) ? i + '0' : (i-10) + 'A'; + } + + /* Set up the background (stipple) pattern arrays, used to represent + * the Sunview background pattern outside of windows. + */ + for (op=bkg_1, hp=BKGPAT_1, n=SEGSIZE; --n >= 0; ) { + *op++ = hp[0]; + *op++ = hp[1]; + } *op++ = '\0'; + for (op=bkg_2, hp=BKGPAT_2, n=SEGSIZE; --n >= 0; ) { + *op++ = hp[0]; + *op++ = hp[1]; + } *op++ = '\0'; + + /* RT_FULL is a solid line, another common pattern. */ + for (op=rt_full, n=SEGSIZE*2; --n >= 0; ) + *op++ = 'F'; + *op++ = '\0'; + + /* Initialize obuf, in case a partseg call causes the full buffer to + * be written out before the garbage elements at the end have been + * initialized to legal values. + */ + bcopy (rt_full, obuf, SEGSIZE*2); + + /* Define the postscript necessary to receive and output the lines + * of the pixrect with image compression. + */ + fprintf (fp, "%%! GTERM screendump\n"); + fprintf (fp, "erasepage initgraphics\n"); + + /* fprintf (fp, "[%6.3f 0 0 %6.3f 2350 3180] setmatrix\n", + -scale, -scale); */ + fprintf (fp, "initmatrix\n"); + fprintf (fp, "%6.3f 72 mul 300 div\n", -scale); + fprintf (fp, "%6.3f 72 mul 300 div scale\n", scale); + fprintf (fp, "%f %f translate\n", 2409/(-scale), (-88)/(-scale)); + + fprintf (fp, "%d %d translate\n", PAGE_XOFFSET, PAGE_YOFFSET); + fprintf (fp, "/r_data %d string def\n", SEGSIZE); + fprintf (fp, "/r_zero %d string def\n", SEGSIZE); + fprintf (fp, "/r_full %d string def\n", SEGSIZE); + fprintf (fp, "/r_bkg1 %d string def\n", SEGSIZE); + fprintf (fp, "/r_bkg2 %d string def\n", SEGSIZE); + fprintf (fp, "currentfile r_full readhexstring %s\n", rt_full); + fprintf (fp, "currentfile r_bkg1 readhexstring %s\n", bkg_1); + fprintf (fp, "currentfile r_bkg2 readhexstring %s\n", bkg_2); + fprintf (fp, "clear\n"); + + if (depth == 8) { + fprintf (fp, + "/dline {0 exch translate %d %d 8 matrix\n", width, 1); + } else { + fprintf (fp, + "/dline {0 exch translate %d %d true matrix\n", width, 1); + } + + fprintf (fp, " { currentfile read pop dup %d eq\n", RT_DATA); + fprintf (fp, " { pop currentfile r_data readhexstring pop }\n"); + fprintf (fp, " { dup %d eq\n", RT_ZERO); + fprintf (fp, " { pop r_zero }\n"); + fprintf (fp, " { dup %d eq\n", RT_FULL); + fprintf (fp, " { pop r_full }\n"); + fprintf (fp, " { %d eq\n", RT_BKG1); + fprintf (fp, " { r_bkg1 }\n"); + fprintf (fp, " { r_bkg2 }\n"); + fprintf (fp, " ifelse }\n"); + fprintf (fp, " ifelse }\n"); + fprintf (fp, " ifelse }\n"); + fprintf (fp, " ifelse\n"); + + if (depth == 8) + fprintf (fp, " } image} def\n"); + else + fprintf (fp, " } imagemask} def\n"); + + nsegs = width / (SEGBITS / depth); + partseg = linebytes - (nsegs * SEGSIZE); + + /* Output successive lines of the pixrect. All zero lines are omitted + * and data compression is used for large regions of zeroes embedded + * within a line. + */ + for (j=0, last_j=0; j < height; j++) { + if (zero[j]) + continue; + + fprintf (fp, "\n%d dline\n", j - last_j); + last_j = j; + + /* Output an integral number of line segments in hexstring format, + * i.e., two hex digits output per binary input byte. + */ + segp = bitmap + j*linebytes; + for (seg=0; seg < nsegs; seg++, segp += SEGSIZE) { + /* Quick scan of the data to see if it is all zeroes. */ + allzeroes = 1; + for (ip=segp, n=SEGSIZE; --n >= 0; ) + if (*ip++) { + allzeroes = 0; + break; + } + + if (allzeroes) { + putc (RT_ZERO, fp); + } else { + /* Encode the data segment in hex format. */ + for (ip=segp, op=obuf, n=SEGSIZE; --n >= 0; ) { + hp = hbuf + (*ip++ * 2); + *op++ = *hp++; + *op++ = *hp++; + } + + if (obuf[0] == rt_full[0] && + strncmp (obuf, rt_full, SEGSIZE*2) == 0) { + putc (RT_FULL, fp); + } else if (obuf[0] == bkg_1[0] && + strncmp (obuf, bkg_1, SEGSIZE*2) == 0) { + putc (RT_BKG1, fp); + } else if (obuf[0] == bkg_2[0] && + strncmp (obuf, bkg_2, SEGSIZE*2) == 0) { + putc (RT_BKG2, fp); + } else { + putc (RT_DATA, fp); + fwrite (obuf, SEGSIZE*2, 1, fp); + } + } + } + + /* Write out any partial segment at the end of the line. We must + * always write a full segment, even if the data at the end is + * garbage, else synchronization will be lost. + */ + if (partseg) { + for (op=obuf, n=partseg; --n >= 0; ) { + hp = hbuf + (*ip++ * 2); + *op++ = *hp++; + *op++ = *hp++; + } + putc (RT_DATA, fp); + fwrite (obuf, SEGSIZE*2, 1, fp); + } + } + + /* Add the NOAO logo and timestamp at the bottom of the page and + * output the page. + */ + fprintf (fp, "\n"); + fprintf (fp, "/Times-Roman findfont 24 scalefont setfont\n"); + + /* fprintf (fp, "[-1 0 0 -1 2350 3180] setmatrix\n"); */ + fprintf (fp, "initmatrix\n"); + fprintf (fp, "-1 72 mul 300 div 1 72 mul 300 div scale\n"); + fprintf (fp, "-2409 88 translate\n"); + + fprintf (fp, "%d %d moveto\n", 1600, 3150); + fprintf (fp, "[1 0 0 -1 0 0] concat\n"); + fprintf (fp, "(%s) show\n", make_label()); + fprintf (fp, "showpage\n"); +} + + +/* MAKE_LABEL -- Generate the label for the output printer page. + */ +static char * +make_label() +{ + static char buf[128]; + char hostname[32]; + char username[32]; + struct passwd *pw; + long clock; + + clock = time(0); + gethostname (hostname, 32); + pw = getpwuid (getuid()); + strcpy (username, pw->pw_name); + endpwent(); + + sprintf (buf, "NOAO/IRAF %s@%s %s", + username, hostname, asctime(localtime(&clock))); + + return (buf); +} diff --git a/unix/sun/ss1.patch b/unix/sun/ss1.patch new file mode 100644 index 00000000..dcd0ce15 --- /dev/null +++ b/unix/sun/ss1.patch @@ -0,0 +1,31 @@ +This is to fix the "chicken scratches" bug that occurs with IMTOOL on a +sparcstation. The problem occurs due to a bug in the SunOS kernel for the +sparcstation. The patch given here is a workaround to avoid the problem +until Sun fixes the bug. + +To patch the imtool executable, login as iraf, then make a backup copy of +the imtool.e executable and patch the online one, as follows (be sure to +get the case of the ?X and ?W right): + + % cd $iraf/unix/bin.sparc + % cp imtool.e imtool.e.OLD + % + % adb -w imtool.e + 0xc2a0?X +* 0xc2a0: ac102018 + 0xc2a0?W0xac10200c +* 0xc2a0: 0xac102018 = 0xac10200c + $q + % + +In the sequence shown above, the lines marked * are adb output. If the old +value of location 0xc2a0 is not ac102018 (hex) as shown, then you have an +old or otherwise unusual version of IMTOOL and the patch should not be +applied. Once the executable has been patched, either copy the new executable +to /usr/bin/imtool (or wherever imtool lives on your system) or rerun the +INSTALL script in $hlib. + +The fix changes the rasterop used to draw the IMTOOL crosshair cursor from +a copy-source-to-destination to an xor-source-and-destination. This results +in a less visible cursor, but avoids the bug that leaves the scratches all +over the IMTOOL window. -- cgit