From f627f77f23d1497c9e1f4269b5c8812d12b42f18 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Mon, 28 Jan 2013 19:02:21 +0000 Subject: Imported Upstream version 9.5.0 --- ipl/BuildExe | 2 +- ipl/CheckAll | 20 +- ipl/Makefile | 6 +- ipl/README | 9 +- ipl/cfuncs/Makefile | 5 +- ipl/cfuncs/external.c | 154 ++ ipl/cfuncs/fpoll.c | 3 +- ipl/cfuncs/icall.h | 46 +- ipl/cfuncs/mklib.sh | 12 +- ipl/gincl/keysyms.icn | 2 + ipl/gpacks/weaving/Makefile | 4 +- ipl/gpacks/weaving/htweav.icn | 396 +++ ipl/gpacks/xtiles/README | 4 +- ipl/gprogs/breakout.icn | 24 +- ipl/gprogs/gallery.icn | 29 +- ipl/gprogs/kaleid.icn | 3 +- ipl/gprogs/spider.icn | 104 +- ipl/gprogs/trkvu.icn | 58 +- ipl/gprogs/tron.icn | 191 ++ ipl/mincl/etdefs.icn | 39 - ipl/mincl/evdefs.icn | 191 -- ipl/mprocs/colormap.icn | 232 -- ipl/mprocs/colortyp.icn | 44 - ipl/mprocs/em_setup.icn | 101 - ipl/mprocs/emutils.icn | 508 ---- ipl/mprocs/evaltree.icn | 106 - ipl/mprocs/evinit.icn | 89 - ipl/mprocs/evnames.icn | 174 -- ipl/mprocs/evsyms.icn | 160 -- ipl/mprocs/evtmap.icn | 181 -- ipl/mprocs/evutils.icn | 94 - ipl/mprocs/hexlib.icn | 146 -- ipl/mprocs/loadfile.icn | 64 - ipl/mprocs/opname.icn | 129 - ipl/mprocs/typebind.icn | 56 - ipl/mprocs/typesyms.icn | 71 - ipl/mprocs/viewpack.icn | 329 --- ipl/mprogs/alcscope.icn | 312 --- ipl/mprogs/alcview.icn | 258 -- ipl/mprogs/algae.icn | 356 --- ipl/mprogs/allocwrl.icn | 167 -- ipl/mprogs/anim.icn | 254 -- ipl/mprogs/callcnt.icn | 122 - ipl/mprogs/cmpsum.icn | 106 - ipl/mprogs/cnvsum.icn | 117 - ipl/mprogs/cvtsum.icn | 79 - ipl/mprogs/events.icn | 59 - ipl/mprogs/evstream.icn | 60 - ipl/mprogs/evsum.icn | 107 - ipl/mprogs/exprsum.icn | 162 -- ipl/mprogs/listev.icn | 46 - ipl/mprogs/locus.icn | 126 - ipl/mprogs/memsum.icn | 158 -- ipl/mprogs/mmm.icn | 139 - ipl/mprogs/mtutils.icn | 40 - ipl/mprogs/napoleon.icn | 168 -- ipl/mprogs/novae.icn | 93 - ipl/mprogs/numsum.icn | 103 - ipl/mprogs/opersum.icn | 200 -- ipl/mprogs/ostrip.icn | 71 - ipl/mprogs/playev.icn | 59 - ipl/mprogs/program.icn | 138 - ipl/mprogs/recordev.icn | 69 - ipl/mprogs/roll.icn | 103 - ipl/mprogs/scat.icn | 143 -- ipl/mprogs/scater.icn | 183 -- ipl/mprogs/strsum.icn | 100 - ipl/mprogs/strucget.icn | 68 - ipl/mprogs/vc.icn | 616 ----- ipl/mprogs/vmsum.icn | 62 - ipl/packs/README | 4 + ipl/packs/ibpag2/Makefile | 4 +- ipl/packs/ibpag2/README | 15 +- ipl/packs/icondb/Makefile | 41 + ipl/packs/icondb/cgi.icn | 43 + ipl/packs/icondb/icondb.icn | 105 + ipl/packs/icondb/mysqldb.c | 289 +++ ipl/packs/loadfunc/Makefile | 5 +- ipl/packs/loadfuncpp/Makefile | 107 + ipl/packs/loadfuncpp/doc/Makefile | 51 + ipl/packs/loadfuncpp/doc/Makefile.mak | 34 + ipl/packs/loadfuncpp/doc/bang.cpp | 35 + ipl/packs/loadfuncpp/doc/bang.icn | 10 + ipl/packs/loadfuncpp/doc/compile.htm | 57 + ipl/packs/loadfuncpp/doc/divide.cpp | 20 + ipl/packs/loadfuncpp/doc/divide.icn | 10 + ipl/packs/loadfuncpp/doc/divide2.cpp | 20 + ipl/packs/loadfuncpp/doc/divide2.icn | 10 + ipl/packs/loadfuncpp/doc/dull.cpp | 15 + ipl/packs/loadfuncpp/doc/dull.icn | 9 + ipl/packs/loadfuncpp/doc/examples.txt | 10 + ipl/packs/loadfuncpp/doc/generator.cpp | 31 + ipl/packs/loadfuncpp/doc/generator.icn | 9 + ipl/packs/loadfuncpp/doc/hello.php | 10 + ipl/packs/loadfuncpp/doc/icall.txt | 140 + ipl/packs/loadfuncpp/doc/index.htm | 87 + ipl/packs/loadfuncpp/doc/isexternal.cpp | 31 + ipl/packs/loadfuncpp/doc/isexternal.icn | 14 + ipl/packs/loadfuncpp/doc/iterate.cpp | 34 + ipl/packs/loadfuncpp/doc/iterate.icn | 13 + ipl/packs/loadfuncpp/doc/keyword.cpp | 16 + ipl/packs/loadfuncpp/doc/keyword.icn | 10 + ipl/packs/loadfuncpp/doc/loadfuncpp.css | 41 + ipl/packs/loadfuncpp/doc/loadfuncpp.h | 470 ++++ ipl/packs/loadfuncpp/doc/loadfuncpp.htm | 42 + ipl/packs/loadfuncpp/doc/makelist.cpp | 16 + ipl/packs/loadfuncpp/doc/makelist.icn | 10 + ipl/packs/loadfuncpp/doc/manual.htm | 1558 ++++++++++++ ipl/packs/loadfuncpp/doc/object.cpp | 15 + ipl/packs/loadfuncpp/doc/object.icn | 23 + ipl/packs/loadfuncpp/examples/Makefile | 51 + ipl/packs/loadfuncpp/examples/Makefile.mak | 34 + ipl/packs/loadfuncpp/examples/arglist.cpp | 18 + ipl/packs/loadfuncpp/examples/arglist.icn | 7 + ipl/packs/loadfuncpp/examples/callicon.cpp | 18 + ipl/packs/loadfuncpp/examples/callicon.icn | 24 + ipl/packs/loadfuncpp/examples/carl.icn | 50 + ipl/packs/loadfuncpp/examples/coexp.cpp | 20 + ipl/packs/loadfuncpp/examples/coexp.icn | 15 + ipl/packs/loadfuncpp/examples/compare.icn | 7 + ipl/packs/loadfuncpp/examples/examples.txt | 12 + ipl/packs/loadfuncpp/examples/extwidget.cpp | 35 + ipl/packs/loadfuncpp/examples/extwidget.icn | 14 + ipl/packs/loadfuncpp/examples/factorials.icn | 27 + ipl/packs/loadfuncpp/examples/hello.icn | 3 + ipl/packs/loadfuncpp/examples/hexwords.icn | 18 + ipl/packs/loadfuncpp/examples/hexwords_oneline.icn | 8 + ipl/packs/loadfuncpp/examples/iterate.cpp | 26 + ipl/packs/loadfuncpp/examples/iterate.icn | 13 + ipl/packs/loadfuncpp/examples/iterate2.cpp | 31 + ipl/packs/loadfuncpp/examples/iterate2.icn | 13 + ipl/packs/loadfuncpp/examples/iterate3.cpp | 32 + ipl/packs/loadfuncpp/examples/iterate3.icn | 9 + ipl/packs/loadfuncpp/examples/jmexample.cpp | 52 + ipl/packs/loadfuncpp/examples/jmexample.icn | 8 + ipl/packs/loadfuncpp/examples/kwd_vbl.cpp | 17 + ipl/packs/loadfuncpp/examples/kwd_vbl.icn | 10 + ipl/packs/loadfuncpp/examples/loadfuncpp.h | 481 ++++ ipl/packs/loadfuncpp/examples/methodcall.cpp | 18 + ipl/packs/loadfuncpp/examples/methodcall.icn | 23 + ipl/packs/loadfuncpp/examples/mkexternal.cpp | 15 + ipl/packs/loadfuncpp/examples/mkexternal.icn | 14 + ipl/packs/loadfuncpp/examples/newprimes.icn | 4 + ipl/packs/loadfuncpp/examples/numbernamer.icn | 61 + ipl/packs/loadfuncpp/examples/primes.icn | 26 + ipl/packs/loadfuncpp/examples/runerr.cpp | 31 + ipl/packs/loadfuncpp/examples/runerr.icn | 32 + ipl/packs/loadfuncpp/examples/stop.cpp | 16 + ipl/packs/loadfuncpp/examples/stop.icn | 10 + ipl/packs/loadfuncpp/examples/sums.icn | 8 + ipl/packs/loadfuncpp/examples/sums2.icn | 6 + ipl/packs/loadfuncpp/hex.txt | 1 + ipl/packs/loadfuncpp/iexample.cpp | 27 + ipl/packs/loadfuncpp/iexample.icn | 37 + ipl/packs/loadfuncpp/iload.cpp | 2669 ++++++++++++++++++++ ipl/packs/loadfuncpp/iload.h | 342 +++ ipl/packs/loadfuncpp/iloadgpx.cpp | 64 + ipl/packs/loadfuncpp/iloadnogpx.cpp | 63 + ipl/packs/loadfuncpp/loadfuncpp.h | 481 ++++ ipl/packs/loadfuncpp/loadfuncpp.icn | 241 ++ ipl/packs/loadfuncpp/loadfuncpp_build.sh | 32 + ipl/packs/loadfuncpp/savex.icn | 41 + ipl/packs/loadfuncpp/xfload.cpp | 239 ++ ipl/packs/loadfuncpp/xinterp.cpp | 1647 ++++++++++++ ipl/packs/loadfuncpp/xinterp64.cpp | 1642 ++++++++++++ ipl/procs/calls.icn | 4 +- ipl/procs/echo.icn | 227 ++ ipl/procs/printf.icn | 133 +- ipl/procs/random.icn | 11 +- ipl/progs/diffsum.icn | 16 +- ipl/progs/hebeng.icn | 4 +- ipl/progs/lindsys.icn | 4 +- ipl/progs/unclog.icn | 3 +- ipl/progs/weblinks.icn | 32 +- 174 files changed, 13599 insertions(+), 7772 deletions(-) create mode 100644 ipl/cfuncs/external.c create mode 100644 ipl/gpacks/weaving/htweav.icn create mode 100644 ipl/gprogs/tron.icn delete mode 100644 ipl/mincl/etdefs.icn delete mode 100644 ipl/mincl/evdefs.icn delete mode 100644 ipl/mprocs/colormap.icn delete mode 100644 ipl/mprocs/colortyp.icn delete mode 100644 ipl/mprocs/em_setup.icn delete mode 100644 ipl/mprocs/emutils.icn delete mode 100644 ipl/mprocs/evaltree.icn delete mode 100644 ipl/mprocs/evinit.icn delete mode 100644 ipl/mprocs/evnames.icn delete mode 100644 ipl/mprocs/evsyms.icn delete mode 100644 ipl/mprocs/evtmap.icn delete mode 100644 ipl/mprocs/evutils.icn delete mode 100644 ipl/mprocs/hexlib.icn delete mode 100644 ipl/mprocs/loadfile.icn delete mode 100644 ipl/mprocs/opname.icn delete mode 100644 ipl/mprocs/typebind.icn delete mode 100644 ipl/mprocs/typesyms.icn delete mode 100644 ipl/mprocs/viewpack.icn delete mode 100644 ipl/mprogs/alcscope.icn delete mode 100644 ipl/mprogs/alcview.icn delete mode 100644 ipl/mprogs/algae.icn delete mode 100644 ipl/mprogs/allocwrl.icn delete mode 100644 ipl/mprogs/anim.icn delete mode 100644 ipl/mprogs/callcnt.icn delete mode 100644 ipl/mprogs/cmpsum.icn delete mode 100644 ipl/mprogs/cnvsum.icn delete mode 100644 ipl/mprogs/cvtsum.icn delete mode 100644 ipl/mprogs/events.icn delete mode 100644 ipl/mprogs/evstream.icn delete mode 100644 ipl/mprogs/evsum.icn delete mode 100644 ipl/mprogs/exprsum.icn delete mode 100644 ipl/mprogs/listev.icn delete mode 100644 ipl/mprogs/locus.icn delete mode 100644 ipl/mprogs/memsum.icn delete mode 100644 ipl/mprogs/mmm.icn delete mode 100644 ipl/mprogs/mtutils.icn delete mode 100644 ipl/mprogs/napoleon.icn delete mode 100644 ipl/mprogs/novae.icn delete mode 100644 ipl/mprogs/numsum.icn delete mode 100644 ipl/mprogs/opersum.icn delete mode 100644 ipl/mprogs/ostrip.icn delete mode 100644 ipl/mprogs/playev.icn delete mode 100644 ipl/mprogs/program.icn delete mode 100644 ipl/mprogs/recordev.icn delete mode 100644 ipl/mprogs/roll.icn delete mode 100644 ipl/mprogs/scat.icn delete mode 100644 ipl/mprogs/scater.icn delete mode 100644 ipl/mprogs/strsum.icn delete mode 100644 ipl/mprogs/strucget.icn delete mode 100644 ipl/mprogs/vc.icn delete mode 100644 ipl/mprogs/vmsum.icn create mode 100644 ipl/packs/icondb/Makefile create mode 100644 ipl/packs/icondb/cgi.icn create mode 100644 ipl/packs/icondb/icondb.icn create mode 100644 ipl/packs/icondb/mysqldb.c create mode 100644 ipl/packs/loadfuncpp/Makefile create mode 100644 ipl/packs/loadfuncpp/doc/Makefile create mode 100644 ipl/packs/loadfuncpp/doc/Makefile.mak create mode 100644 ipl/packs/loadfuncpp/doc/bang.cpp create mode 100644 ipl/packs/loadfuncpp/doc/bang.icn create mode 100644 ipl/packs/loadfuncpp/doc/compile.htm create mode 100644 ipl/packs/loadfuncpp/doc/divide.cpp create mode 100644 ipl/packs/loadfuncpp/doc/divide.icn create mode 100644 ipl/packs/loadfuncpp/doc/divide2.cpp create mode 100644 ipl/packs/loadfuncpp/doc/divide2.icn create mode 100644 ipl/packs/loadfuncpp/doc/dull.cpp create mode 100644 ipl/packs/loadfuncpp/doc/dull.icn create mode 100644 ipl/packs/loadfuncpp/doc/examples.txt create mode 100644 ipl/packs/loadfuncpp/doc/generator.cpp create mode 100644 ipl/packs/loadfuncpp/doc/generator.icn create mode 100644 ipl/packs/loadfuncpp/doc/hello.php create mode 100644 ipl/packs/loadfuncpp/doc/icall.txt create mode 100644 ipl/packs/loadfuncpp/doc/index.htm create mode 100644 ipl/packs/loadfuncpp/doc/isexternal.cpp create mode 100644 ipl/packs/loadfuncpp/doc/isexternal.icn create mode 100644 ipl/packs/loadfuncpp/doc/iterate.cpp create mode 100644 ipl/packs/loadfuncpp/doc/iterate.icn create mode 100644 ipl/packs/loadfuncpp/doc/keyword.cpp create mode 100644 ipl/packs/loadfuncpp/doc/keyword.icn create mode 100644 ipl/packs/loadfuncpp/doc/loadfuncpp.css create mode 100644 ipl/packs/loadfuncpp/doc/loadfuncpp.h create mode 100644 ipl/packs/loadfuncpp/doc/loadfuncpp.htm create mode 100644 ipl/packs/loadfuncpp/doc/makelist.cpp create mode 100644 ipl/packs/loadfuncpp/doc/makelist.icn create mode 100644 ipl/packs/loadfuncpp/doc/manual.htm create mode 100644 ipl/packs/loadfuncpp/doc/object.cpp create mode 100644 ipl/packs/loadfuncpp/doc/object.icn create mode 100644 ipl/packs/loadfuncpp/examples/Makefile create mode 100644 ipl/packs/loadfuncpp/examples/Makefile.mak create mode 100644 ipl/packs/loadfuncpp/examples/arglist.cpp create mode 100644 ipl/packs/loadfuncpp/examples/arglist.icn create mode 100644 ipl/packs/loadfuncpp/examples/callicon.cpp create mode 100644 ipl/packs/loadfuncpp/examples/callicon.icn create mode 100644 ipl/packs/loadfuncpp/examples/carl.icn create mode 100644 ipl/packs/loadfuncpp/examples/coexp.cpp create mode 100644 ipl/packs/loadfuncpp/examples/coexp.icn create mode 100644 ipl/packs/loadfuncpp/examples/compare.icn create mode 100644 ipl/packs/loadfuncpp/examples/examples.txt create mode 100644 ipl/packs/loadfuncpp/examples/extwidget.cpp create mode 100644 ipl/packs/loadfuncpp/examples/extwidget.icn create mode 100644 ipl/packs/loadfuncpp/examples/factorials.icn create mode 100644 ipl/packs/loadfuncpp/examples/hello.icn create mode 100644 ipl/packs/loadfuncpp/examples/hexwords.icn create mode 100644 ipl/packs/loadfuncpp/examples/hexwords_oneline.icn create mode 100644 ipl/packs/loadfuncpp/examples/iterate.cpp create mode 100644 ipl/packs/loadfuncpp/examples/iterate.icn create mode 100644 ipl/packs/loadfuncpp/examples/iterate2.cpp create mode 100644 ipl/packs/loadfuncpp/examples/iterate2.icn create mode 100644 ipl/packs/loadfuncpp/examples/iterate3.cpp create mode 100644 ipl/packs/loadfuncpp/examples/iterate3.icn create mode 100644 ipl/packs/loadfuncpp/examples/jmexample.cpp create mode 100644 ipl/packs/loadfuncpp/examples/jmexample.icn create mode 100644 ipl/packs/loadfuncpp/examples/kwd_vbl.cpp create mode 100644 ipl/packs/loadfuncpp/examples/kwd_vbl.icn create mode 100644 ipl/packs/loadfuncpp/examples/loadfuncpp.h create mode 100644 ipl/packs/loadfuncpp/examples/methodcall.cpp create mode 100644 ipl/packs/loadfuncpp/examples/methodcall.icn create mode 100644 ipl/packs/loadfuncpp/examples/mkexternal.cpp create mode 100644 ipl/packs/loadfuncpp/examples/mkexternal.icn create mode 100644 ipl/packs/loadfuncpp/examples/newprimes.icn create mode 100644 ipl/packs/loadfuncpp/examples/numbernamer.icn create mode 100644 ipl/packs/loadfuncpp/examples/primes.icn create mode 100644 ipl/packs/loadfuncpp/examples/runerr.cpp create mode 100644 ipl/packs/loadfuncpp/examples/runerr.icn create mode 100644 ipl/packs/loadfuncpp/examples/stop.cpp create mode 100644 ipl/packs/loadfuncpp/examples/stop.icn create mode 100644 ipl/packs/loadfuncpp/examples/sums.icn create mode 100644 ipl/packs/loadfuncpp/examples/sums2.icn create mode 100644 ipl/packs/loadfuncpp/hex.txt create mode 100644 ipl/packs/loadfuncpp/iexample.cpp create mode 100644 ipl/packs/loadfuncpp/iexample.icn create mode 100644 ipl/packs/loadfuncpp/iload.cpp create mode 100644 ipl/packs/loadfuncpp/iload.h create mode 100644 ipl/packs/loadfuncpp/iloadgpx.cpp create mode 100644 ipl/packs/loadfuncpp/iloadnogpx.cpp create mode 100644 ipl/packs/loadfuncpp/loadfuncpp.h create mode 100644 ipl/packs/loadfuncpp/loadfuncpp.icn create mode 100755 ipl/packs/loadfuncpp/loadfuncpp_build.sh create mode 100644 ipl/packs/loadfuncpp/savex.icn create mode 100644 ipl/packs/loadfuncpp/xfload.cpp create mode 100644 ipl/packs/loadfuncpp/xinterp.cpp create mode 100644 ipl/packs/loadfuncpp/xinterp64.cpp create mode 100644 ipl/procs/echo.icn (limited to 'ipl') diff --git a/ipl/BuildExe b/ipl/BuildExe index 8082b9c..05800d9 100755 --- a/ipl/BuildExe +++ b/ipl/BuildExe @@ -2,7 +2,7 @@ # # BuildExe -- build executables in ./iexe # -# Includes programs from pack directories, but excludes mprogs. +# Includes programs from pack directories. # Assumes that ../bin and ../lib have been built. set -x diff --git a/ipl/CheckAll b/ipl/CheckAll index 0a3da38..621610b 100755 --- a/ipl/CheckAll +++ b/ipl/CheckAll @@ -49,7 +49,6 @@ done (echo cfuncs:; cd cfuncs; LPATH= make -s cfunc.u2) (echo procs:; cd procs; LPATH="../incl" icont -usc *icn) (echo gprocs:; cd gprocs; LPATH="../incl ../gincl" icont -usc *icn) -# (echo mprocs:; cd mprocs; LPATH="../incl ../gincl ../mincl" icont -usc *icn) # Check for undeclared identifiers or insufficient links in the core modules. @@ -88,18 +87,19 @@ export LPATH="../incl ../gincl" export IPATH="../procs ../cfuncs ../gprocs" (echo gprogs:; cd gprogs; for f in *.icn; do compile $f; done) -# Skip mprogs, which requires a specially build MT-Icon version -# export LPATH="../incl ../gincl ../mincl" -# export IPATH="../procs ../cfuncs ../gprocs ../mprocs" -# (echo mprogs:; cd mprogs; for f in *.icn; do compile $f; done) - - -# Test-build all the packages +# Test-build most of the packages (skipping GNU-only packs) # Allow use of graphics within packs, because one loadfunc example needs it export LPATH="../../incl ../../gincl" export IPATH="../../cfuncs ../../procs ../../gprocs" for d in *packs/[a-z]*; do - echo $d: - (cd $d; make -s Clean; make -s) + case $d in + packs/icondb | packs/loadfuncpp) + echo $d skipped + ;; + *) + echo $d: + (cd $d; make -s Clean; make -s) + ;; + esac done diff --git a/ipl/Makefile b/ipl/Makefile index a438946..fc01edf 100644 --- a/ipl/Makefile +++ b/ipl/Makefile @@ -65,7 +65,6 @@ ZipFiles: Ilib rm -rf ilib *.zip zip -qrX9 bipl.zip docs incl procs progs packs data cfuncs -x '*/CVS/*' zip -qrX9 gipl.zip gdocs gincl gprocs gprogs gpacks gdata -x '*/CVS/*' - zip -qrX9 mipl.zip mincl mprocs mprogs -x '*/CVS/*' mkdir ilib cp ../lib/*.* ilib zip -qrX9 ilib.zip ilib @@ -75,7 +74,8 @@ ZipFiles: Ilib # Clean up. Clean Pure: - -rm -rf ilib iexe *.zip */*.u[12] */*.zip */*.so + -rm -rf ilib iexe *.zip */*.u[12] */*.zip */*.so *packs/*/*.exe -rm -f xx `find *procs *progs -type f -perm -100 -print` for d in cfuncs *packs/[abcdefghijklmnopqrstuvwxyz]*; do \ - (cd $$d; $(MAKE) Clean); done + echo "+ cd ipl/$$d"; \ + (cd $$d; $(MAKE) Clean 2>/dev/null) || echo "[not cleaned]"; done diff --git a/ipl/README b/ipl/README index 6230ebb..654a3c1 100644 --- a/ipl/README +++ b/ipl/README @@ -1,9 +1,6 @@ -This is Version 9.4.3 of the Icon Program Library. +This is Version 9.5.0 of the Icon Program Library. For on-line documentation, see - http://www.cs.arizona.edu/icon/v943/library/ipl.htm + http://www.cs.arizona.edu/icon/v950/library/ipl.htm Unix users should generally not try to build the library separately, but -instead should install Icon 9.4.3 as a whole, which includes the library. - -The MT-Icon portions of the library (the m*) directories are for use with -specially configured versions of Icon, for which no support is provided. +instead should install Icon 9.5.0 as a whole, which includes the library. diff --git a/ipl/cfuncs/Makefile b/ipl/cfuncs/Makefile index d8b1ba2..802e85b 100644 --- a/ipl/cfuncs/Makefile +++ b/ipl/cfuncs/Makefile @@ -14,7 +14,7 @@ FUNCLIB = libcfunc.so .SUFFIXES: .c .o .c.o: ; $(CC) $(CFLAGS) $(CFDYN) -c $< -FUNCS = bitcount.o files.o fpoll.o internal.o lgconv.o osf.o \ +FUNCS = bitcount.o external.o files.o fpoll.o internal.o lgconv.o osf.o \ pack.o ppm.o process.o tconnect.o CSRC = $(FUNCS:.o=.c) @@ -25,7 +25,8 @@ default: cfunc.u2 $(FUNCLIB) # library $(FUNCLIB): $(FUNCS) mklib.sh - CC="$(CC)" CFLAGS="$(CFLAGS)" sh mklib.sh $(FUNCLIB) $(FUNCS) + CC="$(CC)" CFLAGS="$(CFLAGS)" BIN="../../bin" \ + sh mklib.sh $(FUNCLIB) $(FUNCS) $(FUNCS): icall.h diff --git a/ipl/cfuncs/external.c b/ipl/cfuncs/external.c new file mode 100644 index 0000000..afb96fa --- /dev/null +++ b/ipl/cfuncs/external.c @@ -0,0 +1,154 @@ +/* +############################################################################ +# +# File: external.c +# +# Subject: Functions to demonstrate Icon external values +# +# Author: Gregg M. Townsend +# +# Date: October 29, 2009 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These functions demonstrate the use of external values. +# +# extxmin() creates a minimal external type +# extxstr(s) creates an external hold a string and trivial checksum +# extxreal(r) creates a fully customized external type holding a real value +# +############################################################################ +# +# Requires: Dynamic loading +# +############################################################################ +*/ + +#include +#include "icall.h" + +/* + * minimal external type with no parameters + */ +int extxmin(int argc, descriptor argv[]) /*: create minimal external value */ + { + RetExternal(alcexternal(0, 0, 0)); + } + +/* + * custom external holding a string and a trivial checksum + */ + +/* custom external data block extends the standard block */ +typedef struct sblock { + externalblock eb; + unsigned short cksum; + char string[]; + } sblock; + +/* type name returns "xstr" */ +static int sname(int argc, descriptor argv[]) { + RetConstStringN("xstr", 4); + } + +/* image returns "xstr_N(cksum:string)" with no special string escapes */ +static int simage(int argc, descriptor argv[]) { + sblock *b = (sblock*)ExternalBlock(argv[1]); + char buffer[1000]; /* not robust against huge strings */ + RetStringN(buffer, + sprintf(buffer, "xstr_%ld(%05d:%s)", b->eb.id, b->cksum, b->string)); + } + +/* list of custom functions for constructor */ +static funclist sfuncs = { + NULL, /* cmp */ + NULL, /* copy */ + sname, /* name */ + simage, /* image */ + }; + +/* finally, the exported constructor function, extxstr(s) */ +int extxstr(int argc, descriptor argv[]) /*: create string-valued external */ + { + sblock *new; + char *p; + int slen; + + ArgString(1); + slen = StringLen(argv[1]); + new = (sblock *)alcexternal(sizeof(sblock) + slen + 1, &sfuncs, 0); + memcpy(new->string, StringAddr(argv[1]), slen); + new->string[slen] = '\0'; + int cksum = 0; + for (p = new->string; *p; p++) + cksum = 37 * cksum + (unsigned char) *p; + new->cksum = cksum; + RetExternal((externalblock*)new); + } + + +/* + * custom real-valued external with lots of trimmings + */ + +/* custom external data block extends the standard block */ +typedef struct rblock { + externalblock eb; + float value; + } rblock; + +/* comparison function for sorting */ +static int rcmp(int argc, descriptor argv[]) { + rblock *eb1 = (rblock*)ExternalBlock(argv[1]); + rblock *eb2 = (rblock*)ExternalBlock(argv[2]); + if (eb1->value < eb2->value) RetInteger(-1); + if (eb1->value > eb2->value) RetInteger(+1); + if (eb1->eb.id < eb2->eb.id) RetInteger(-1); + if (eb1->eb.id > eb2->eb.id) RetInteger(+1); + RetInteger(0); + } + +/* copy function duplicates block, getting new serial number */ +static int rcopy(int argc, descriptor argv[]) { + externalblock *b = ExternalBlock(argv[1]); + rblock *old = (rblock*)b; + rblock *new = (rblock *)alcexternal(sizeof(rblock), b->funcs, 0); + new->value = old->value; + RetExternal((externalblock*)new); + } + +/* type name returns "xreal" */ +static int rname(int argc, descriptor argv[]) { + RetConstStringN("xreal", 5); + } + +/* image returns "xreal_N(V)" */ +static int rimage(int argc, descriptor argv[]) { + rblock *b = (rblock*)ExternalBlock(argv[1]); + char buffer[100]; + RetStringN(buffer, + sprintf(buffer, "xreal_%ld(%.1f)", b->eb.id, b->value)); + } + +/* list of custom functions for constructor */ +static funclist rfuncs = { + rcmp, /* cmp */ + rcopy, /* copy */ + rname, /* name */ + rimage, /* image */ + }; + +/* finally, the exported constructor function, extxreal(r) */ +int extxreal(int argc, descriptor argv[]) /*: create real-valued external */ + { + rblock *new; + + ArgReal(1); + float v = RealVal(argv[1]); + new = (rblock *)alcexternal(sizeof(rblock), &rfuncs, &v); + RetExternal((externalblock*)new); + } diff --git a/ipl/cfuncs/fpoll.c b/ipl/cfuncs/fpoll.c index f209e0d..9230e18 100644 --- a/ipl/cfuncs/fpoll.c +++ b/ipl/cfuncs/fpoll.c @@ -7,7 +7,7 @@ # # Author: Gregg M. Townsend # -# Date: November 27, 2001 +# Date: October 27, 2009 # ############################################################################ # @@ -29,6 +29,7 @@ */ #include +#include /* for memset call from FD_ZERO (solaris gcc) */ #include #include diff --git a/ipl/cfuncs/icall.h b/ipl/cfuncs/icall.h index 2718dfa..14089a5 100644 --- a/ipl/cfuncs/icall.h +++ b/ipl/cfuncs/icall.h @@ -7,7 +7,7 @@ # # Author: Gregg M. Townsend # -# Date: November 17, 2004 +# Date: October 29, 2009 # ############################################################################ # @@ -15,7 +15,7 @@ # ############################################################################ # -# Contributor: Kostas Oikonomou +# Contributors: Kostas Oikonomou, Carl Sturtivant # ############################################################################ # @@ -38,14 +38,14 @@ # ############################################################################ # -# IconType(d) returns one of the characters {cfinprsCILRST} indicating -# the type of a value according to the key on page 247 of the Red Book -# or page 273 of the Blue Book (The Icon Programming Language). +# IconType(d) returns one of the characters {cfinprsCEILRST} indicating +# the type of a value based on the key on page 273 of the Blue Book (The +# Icon Programming Language). The character E indicates external data; # The character I indicates a large (multiprecision) integer. # -# Only a few of these types (i, r, f, s) are easily manipulated in C. +# Only a few of these types (i, r, f, s, E) are easily manipulated in C. # Given that the type has been verified, the following macros return -# the value of a descriptor in C terms: +# a value from a descriptor in C terms: # # IntegerVal(d) value of a integer (type 'i') as a C long # RealVal(d) value of a real (type 'r') as a C double @@ -58,6 +58,7 @@ # StringLen(d) length of string # # ListLen(d) length of list +# ExternalBlock(d) address of heap block for external data # # These macros check the type of an argument, converting if necessary, # and returning an error code if the argument is wrong: @@ -66,6 +67,7 @@ # ArgReal(i) check that argv[i] is a real number # ArgString(i) check that argv[i] is a string # ArgList(i) check that argv[i] is a list +# ArgExternal(i,f) check that argv[i] is an external w/ funcblock f # # Caveats: # Allocation failure is not detected. @@ -80,6 +82,7 @@ # RetInteger(i) return integer value i # RetReal(v) return real value v # RetFile(fp,status,name) return (newly opened) file +# RetExternal(e) return block at addr e made by alcexternal() # RetString(s) return null-terminated string s # RetStringN(s, n) return string s whose length is n # RetAlcString(s, n) return already-allocated string @@ -121,11 +124,13 @@ #define T_Integer 1 /* integer */ #define T_Real 3 /* real number */ #define T_File 5 /* file, including window */ +#define T_External 19 /* externally defined data */ #define D_Null (T_Null | D_Typecode) #define D_Integer (T_Integer | D_Typecode) #define D_Real (T_Real | D_Typecode | F_Ptr) #define D_File (T_File | D_Typecode | F_Ptr) +#define D_External (T_External | D_Typecode | F_Ptr) #define Fs_Read 0001 /* file open for reading */ #define Fs_Write 0002 /* file open for writing */ @@ -139,10 +144,25 @@ typedef struct { word title; double rval; } realblock; typedef struct { word title; FILE *fp; word stat; descriptor fname; } fileblock; typedef struct { word title, size, id; void *head, *tail; } listblock; +typedef struct externalblock { + word title, size, id; + struct funclist *funcs; + word data[]; +} externalblock; + +typedef struct funclist { + int (*extlcmp) (int argc, descriptor argv[]); + int (*extlcopy) (int argc, descriptor argv[]); + int (*extlname) (int argc, descriptor argv[]); + int (*extlimage)(int argc, descriptor argv[]); +} funclist; + char *alcstr(char *s, word len); realblock *alcreal(double v); fileblock *alcfile(FILE *fp, int stat, descriptor *name); +externalblock *alcexternal(long nbytes, funclist *f, void *data); + int cnv_c_str(descriptor *s, descriptor *d); int cnv_int(descriptor *s, descriptor *d); int cnv_real(descriptor *s, descriptor *d); @@ -152,7 +172,7 @@ double getdbl(descriptor *d); extern descriptor nulldesc; /* null descriptor */ -#define IconType(d) ((d).dword>=0 ? 's' : "niIrcfpRL.S.T.....C"[(d).dword&31]) +#define IconType(d) ((d).dword>=0 ? 's' : "niIrcfpRL.S.T.....CE"[(d).dword&31]) #define IntegerVal(d) ((d).vword) @@ -170,6 +190,8 @@ extern descriptor nulldesc; /* null descriptor */ #define ListLen(d) (((listblock *)((d).vword))->size) +#define ExternalBlock(d) ((externalblock *)(d).vword) + #define ArgInteger(i) do { if (argc < (i)) Error(101); \ if (!cnv_int(&argv[i],&argv[i])) ArgError(i,101); } while (0) @@ -184,6 +206,12 @@ if (!cnv_str(&argv[i],&argv[i])) ArgError(i,103); } while (0) do {if (argc < (i)) Error(108); \ if (IconType(argv[i]) != 'L') ArgError(i,108); } while(0) +#define ArgExternal(i,f) \ +do {if (argc < (i)) Error(131); \ +if (IconType(argv[i]) != 'E') ArgError(i,131); \ +if (ExternalBlock(argv[i])->funclist != (f)) ArgError(i,132); \ +} while(0) + #define RetArg(i) return (argv[0] = argv[i], 0) @@ -198,6 +226,8 @@ do { descriptor dd; dd.vword = (word)alcstr(name, dd.dword = strlen(name)); \ argv->dword = D_File; argv->vword = (word)alcfile(fp, stat, &dd); \ return 0; } while (0) +#define RetExternal(e) return (argv->dword=D_External, argv->vword=(word)(e), 0) + #define RetString(s) \ do { word n = strlen(s); \ argv->dword = n; argv->vword = (word)alcstr(s,n); return 0; } while (0) diff --git a/ipl/cfuncs/mklib.sh b/ipl/cfuncs/mklib.sh index 533af0b..4caeca4 100755 --- a/ipl/cfuncs/mklib.sh +++ b/ipl/cfuncs/mklib.sh @@ -3,6 +3,7 @@ # mklib libname.so obj.o ... CC=${CC-cc} +BIN=${BIN-../../bin} LIBNAME=${1?"usage: $0 libname obj..."} shift @@ -11,9 +12,16 @@ SYS=`uname -s` set -x case "$SYS" in Linux*|*BSD*|GNU*) - gcc -shared -o $LIBNAME -fPIC "$@";; + $CC -shared -o $LIBNAME -fPIC "$@";; + CYGWIN*) + # move the win32 import library for iconx.exe callbacks + # created when iconx.exe was built + if [ -e $BIN/../src/runtime/iconx.a ]; then + mv $BIN/../src/runtime/iconx.a $BIN + fi + $CC -shared -Wl,--enable-auto-import -o $LIBNAME "$@" $BIN/iconx.a;; Darwin*) - cc -bundle -undefined suppress -flat_namespace -o $LIBNAME "$@";; + $CC -bundle -undefined suppress -flat_namespace -o $LIBNAME "$@";; SunOS*) $CC $CFLAGS -G -o $LIBNAME "$@" -lc -lsocket;; HP-UX*) diff --git a/ipl/gincl/keysyms.icn b/ipl/gincl/keysyms.icn index 7b0c6a5..b9d316b 100644 --- a/ipl/gincl/keysyms.icn +++ b/ipl/gincl/keysyms.icn @@ -97,6 +97,7 @@ $define Key_Up 65362 $endif $ifdef _MS_WINDOWS +$ifndef _X_WINDOW_SYSTEM $define Key_Down 40 $define Key_End 35 $define Key_ScrollLock 145 @@ -136,6 +137,7 @@ $define Key_Right 39 $define Key_Select 41 $define Key_Up 38 $endif +$endif $ifdef _JAVA $define Key_PrSc 154 diff --git a/ipl/gpacks/weaving/Makefile b/ipl/gpacks/weaving/Makefile index e415e99..9604e8e 100644 --- a/ipl/gpacks/weaving/Makefile +++ b/ipl/gpacks/weaving/Makefile @@ -6,8 +6,8 @@ PROCS = cells.u2 tdialog.u2 tieutils.u2 tpath.u2 \ weavegif.u2 weavutil.u2 wifcvt.u2 -PROGS = comb draw2gmr drawdown drawup gif2geom gif2html heddle lindpath \ - mtrxedit pfd2gif pfd2gmr pfd2ill pfd2wif plexity randweav \ +PROGS = comb draw2gmr drawdown drawup gif2geom gif2html heddle htweav \ + lindpath mtrxedit pfd2gif pfd2gmr pfd2ill pfd2wif plexity randweav \ seqdraft shadow shadpapr showrav tieimage unravel wallpapr weaver wif2pfd diff --git a/ipl/gpacks/weaving/htweav.icn b/ipl/gpacks/weaving/htweav.icn new file mode 100644 index 0000000..351ce50 --- /dev/null +++ b/ipl/gpacks/weaving/htweav.icn @@ -0,0 +1,396 @@ +############################################################################ +# +# File: htweav.icn +# +# Subject: Program to display images as weavable halftones +# +# Author: Gregg M. Townsend +# +# Date: March 20, 2006 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: htweav [winoptions] imagefile... +# +# Htweav reads one or more images and displays modified grayscale versions +# that are "weavable" in the sense that warp and weft colors are assignable +# as in the unravel.icn program. +# +# The display is a fixed 4 x 3 grid of twelve copies of an input image. +# One copy is a dithered, grayscale version of the original. The others +# are weavable patterns based on the dithered image. +# +# The program is controlled by keypresses in the display window. +# Keyboard commands are as follows: +# +# 0 to 9 +# sets the amount of dithering, from none (0) to maximum (9) +# +# R or r +# selects randomized dithering +# +# G or g +# selects "golden" dithering, a regular dithering involving +# use of the golden ratio +# +# S or s +# brings up a dialog box for saving the displayed results +# as a family of GIF files named by extending the entered string +# +# or +# advances to the next input image, if more than one was given +# +# or +# goes back to the previous input image +# +# Q or q +# exits the program +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics +# +############################################################################ + +# TO DO: +# +# The choices of warp and weft threads should be controllable somehow +# without having to edit and recompile the source code. +# +# The hardwired layout of 4 x 3 images should also be adjustable. +# +# There might be other dithering approaches that would work better. +# In particular, consider dithering with error diffusion. +# +# Some sort of dithering that takes the varying thread colors into +# account might do better yet. +# +# Dithering should be done in a linear color space, not a gamma=2.2 +# colorspace. This is tricky because the code is already working +# around Icon's assumption that an input image has a gamma of 1.0 +# instead of the 2.2 that has become nearly universal today. + + +link graphics + + +$define DEFPROC "r" # default dithering procedure +$define DEFNOISE 4 # default dithering level (empirical) + +# display layout +$define NWIDE 4 +$define NHIGH 3 +$define MARGIN 3 + +# program constants (some are not easily changed) +$define ALPHABET "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" # weaving alphabet +$define IPALETTE "g256" # input palette +$define OPALETTE "g64" # output palette + + +# general globals + +global dchar # current dithering procedure selection character +global noise # current noise factor + +global texth # text height for labeling +global row, col # current position for next image to exhibit + +global svname # basename for file saving, if requested + + +# current image globals + +global iname # current image name +global istring # current image string +global iwidth, iheight # current image height +global tmpwin # temporary scratch window, sized for current image + + + +# main procedure + +procedure main(args) + local e + + Window("fg=black", "bg=white", "gamma=1.0", "font=sans,10", + args, "canvas=hidden") + if *args = 0 then stop("usage: ", &progname, " file.gif...") + + dchar := DEFPROC + noise := DEFNOISE + + texth := WAttrib("ascent") + + load(!args) + exhibit() + + while e := Event() do case e of { + QuitEvents(): { break } + !"\n\r ": { put(args, get(args)); load(!args); exhibit(); } + !"\b\d": { push(args, pull(args)); load(!args); exhibit(); } + !"0123456789": { noise := ord(e) - ord(0); exhibit(); } + !"sS": { save() } + !"gGrR": { dchar := map(e); exhibit(); } + } +end + + +# load(fname) -- read image and set global variables + +procedure load(fname) + WClose(\tmpwin) + tmpwin := WOpen("image=" || fname, "gamma=1.0", "canvas=hidden") | + stop("cannot open ", fname) + iname := fname + istring := Capture(tmpwin, IPALETTE) + iwidth := WAttrib(tmpwin, "width") + iheight := WAttrib(tmpwin, "height") + return +end + + +# save() -- save results as a family of GIF images +# +# Gets a basename using a dialog box. +# Saves each image with a different suffix reflecting its parameters. +# Actual work is done as a side effect of draw() calls from exhibit(). + +procedure save() + dialog_value := "" + while *dialog_value = 0 do + case SaveDialog("Save to file names beginning with") of { + "Yes": { + svname := dialog_value + write(&errout, " Saving to ", + svname, ".warp.weft.", dchar, noise, ".gif") + EraseArea() + exhibit() + svname := &null + } + "No": + return + "Cancel": + fail + } +end + + +# exhibit() -- build a windowful of images +# +# Runs through a hardwired sequence of parameter sets, +# displaying all variations. + +procedure exhibit() + local dstring, label + + # configure the display window + WAttrib("width=" || (MARGIN + NWIDE * (iwidth + MARGIN)), + "height=" || (MARGIN + NHIGH * (iheight + texth + MARGIN))) + WAttrib("canvas=normal") # keep this separate (work around iconx bug) + label := iname || " " || dchar || noise # make a label + WAttrib("label=" || label) # label the window + row := col := 0 # initialize posn in window + + # dither the grayscale image + case dchar of { + "g": dstring := goldither(istring) + "r": dstring := randither(istring) + } + + # first row + draw(dstring, label) # original grayscale image + drawweave(dstring, "01", "23") # 2x2 dark x light + drawweave(dstring, "03", "12") # 2x2 interleaved + drawweave(dstring, "0", "1") # simple binary threshold + + # second row + drawweave(dstring, "475869", "ADBECF") # 6x6 dark x light + drawweave(dstring, "012", "345") # 3x3 dark x light + drawweave(dstring, "024", "135") # 3x3 interleaved + drawweave(dstring, "123", "123") # 3x3 all x all + + # third row + drawweave(dstring, "0213", "4657") # 4x4 dark x light + drawweave(dstring, "0102", "5453") # 4x4 alt extremes + drawweave(dstring, "010203", "646566") # 6x6 alt extremes + drawweave(dstring, "14253", "06") # 5x2 mids x extremes + + # not currently displayed + # drawweave(dstring, "0426", "1537") # 4x4 interleaved + # drawweave(dstring, "02413", "57968") # 5x5 dark x light + # drawweave(dstring, "04826", "15937") # 5x5 interleaved + + return +end + + +# drawweave(dstring, warp, weft) -- weave, draw, and label + +procedure drawweave(dstring, warp, weft) + draw(weave(dstring, warp, weft), warp || "." || weft) + return +end + + +# goldither(istring) -- apply golden dithering to image string +# +# Dithering d changes from one pixel to the next by approximately +# d := fractpart(d + &phi) +# +# The actual amount is very slightly different so that the offset +# from one row to the text is independent of the row length. +# Empirically, an offset angle that is arctan(7) seems to work best. + +procedure goldither(istring) + local s, c, i, v, dv + + dv := (integer(iwidth * &phi) + (1./7.)) / iwidth # 7 is relatively prime + istring ? { + s := tab(upto(',') + 1) || tab(upto(',') + 1) # width and palette + v := 0.0 + while c := move(1) do { + v := v + dv + v := v - integer(v) + i := ord(c) + 16 * noise * (v - 0.5) + i <:= 0 + i >:= 255 + s ||:= char(i) + } + return s + } +end + + +# randither(istring) -- apply random dithering to image string + +procedure randither(istring) + local s, c, i + + istring ? { + s := tab(upto(',') + 1) || tab(upto(',') + 1) # width and palette + while c := move(1) do { + i := ord(c) + 16 * noise * (?0 - 0.5) + i <:= 0 + i >:= 255 + s ||:= char(i) + } + return s + } +end + + +# draw(istring, label) -- draw image at next open position + +procedure draw(istring, label) + local x, y + + x := MARGIN + col * (iwidth + MARGIN) + y := MARGIN + row * (iheight + MARGIN + texth) + EraseArea(x + iwidth, y, MARGIN, iheight + MARGIN) + EraseArea(x, y + iheight, iwidth + MARGIN, texth + MARGIN) + DrawImage(x, y, istring) + DrawString(x, y + iheight + texth, \label) + col +:= 1 + if col >= NWIDE then { + col := 0 + row +:= 1 + } + return +end + + +# weave(istring, warp, weft) -- produce a weavable version of an image string +# +# The warp and weft arguments are implicitly replicated as needed to match +# the width and height of the image. Each is a string from the alphabet +# 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +# where the smallest and largest characters used by either string are +# taken to stand for black and white respectively, with uniform gradation +# for any characters between. + +procedure weave(istring, warp, weft) + local maps, row, m, i, s, n, svfile + + warp := map(warp, &lcase, &ucase) + weft := map(weft, &lcase, &ucase) + maps := mappings(warp, weft) + n := *(warp ++ weft) + + s := iwidth || "," || OPALETTE || "," + istring ? { + tab(upto(',') + 1) # skip width + tab(upto(',') + 1) # skip palette + while row := move(iwidth) do { + put(maps, m := get(maps)) # rotate mappings to next row + every i := 1 to *row do + s ||:= m[(i - 1) % *m + 1][ord(row[i]) + 1] + } + } + + if \svname then { + svfile := svname || + "." || warp || "." || weft || "." || dchar || noise || ".gif" + DrawImage(tmpwin, 0, 0, s) + WriteImage(tmpwin, svfile) + } + + return s +end + + +# mappings(warp, weft) -- produce mappings to output characters +# +# Returns a 2-D list of mappings that translate input indexes from the +# g256 palette to output palette (OPALETTE=g64) indexes. + +procedure mappings(warp, weft) + local pmap, all, mlist, row, c + + all := warp ++ weft + mlist := [] + every c := !weft do { + put(mlist, row := []) + every put(row, onemap(all, !warp, c)) + } + return mlist +end + + +# onemap(all, warpc, weftc) -- produce one mapping to warpc and weftc. +# +# Generates a mapping from input graylevel to one of two output graylevels, +# warpc and weftc, which are chosen from the range in the first argument. + +procedure onemap(all, warpc, weftc) + local c1, c2, g1, g2, n, s + + g1 := grayval(all, warpc) + g2 := grayval(all, weftc) + if g1 > g2 then g1 :=: g2 + c1 := PaletteKey(OPALETTE, g1 || "," || g1 || "," || g1) + c2 := PaletteKey(OPALETTE, g2 || "," || g2 || "," || g2) + n := (g1 + g2) / 512 + s := repl(c1, n) || repl(c2, 256 - n) + return s +end + + +# grayval(all, c) -- return value of c in the range specified by all. + +procedure grayval(all, c) + local a, b + + a := find(all[1], ALPHABET) + b := find(all[-1], ALPHABET) + c := find(c, ALPHABET) + return integer(65535 * (c - a) / real(b - a) + 0.5) +end diff --git a/ipl/gpacks/xtiles/README b/ipl/gpacks/xtiles/README index c735eda..7668421 100644 --- a/ipl/gpacks/xtiles/README +++ b/ipl/gpacks/xtiles/README @@ -8,9 +8,7 @@ Installation first. Confere ftp://ftp.cs.arizona.edu/pub/Icon for that. Tiles should work as-is with Icon v9.0 and higher. - Compile X-Tiles with either icont/iconc as you wish. - - Check that it works. + Compile X-Tiles and check that it works. Copy the executable and the man page where you want. diff --git a/ipl/gprogs/breakout.icn b/ipl/gprogs/breakout.icn index 28559f1..56b0551 100644 --- a/ipl/gprogs/breakout.icn +++ b/ipl/gprogs/breakout.icn @@ -6,7 +6,7 @@ # # Author: Nathan J. Ranks # -# Date: September 3, 2000 +# Date: November 22, 2009 # ############################################################################ # @@ -49,13 +49,21 @@ procedure main() WOpen("size=293,320") | stop("can't open window") - sphere := "3,g16,~0~_ - 000_ - ~0~" #black sphere - - blank := "3,g16,~F~_ - FFF_ - ~F~" #white sphere to erase + sphere := "7,g16,~~000~~_ + ~00000~_ + 0000000_ + 0000000_ + 0000000_ + ~00000~_ + ~~000~~" #black sphere + + blank := "7,g16,~~FFF~~_ + ~FFFFF~_ + FFFFFFF_ + FFFFFFF_ + FFFFFFF_ + ~FFFFF~_ + ~~FFF~~" #white sphere to erase level := 1 #default start level create_blocks() #as the name suggests diff --git a/ipl/gprogs/gallery.icn b/ipl/gprogs/gallery.icn index 4dcd0a7..2379f99 100644 --- a/ipl/gprogs/gallery.icn +++ b/ipl/gprogs/gallery.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: August 3, 2005 +# Date: May 27, 2008 # ############################################################################ # @@ -35,11 +35,10 @@ # The right mouse button activates the same popup momentarily until # the button is released. # -# -wnnn sets the maximum width for displaying an image; -# -hnnn sets the maximum height. -snnn sets both. -# By default, sizes are chosen automatically, subject to a minimum -# size of 32x32, to allow all images to fit in a single window. -# +# -wnnn sets the minimum thumbnail width. The default is 32. +# -hnnn sets the minimum thumbnail height. The default is 32. +# -snnn sets the minimum height and width together. +# # -r arranges images in rows instead of columns. # -m maximizes the window size before displaying images. # -t trims file names of leading path components and extensions. @@ -124,13 +123,11 @@ procedure main(args) else fh := WAttrib("fheight") fw := WAttrib("fwidth") - maxw := \opts["w"] | \opts["s"] | 2 * \opts["h"] - maxh := \opts["h"] | \opts["s"] | 2 * \opts["w"] - - # If no image size specified, try to guess to fill the window - if /maxw then - layout(*args) + # Determine thumbnail sizes. + layout(*args) + maxw <:= \opts["w"] | \opts["s"] | 2 * \opts["h"] + maxh <:= \opts["h"] | \opts["s"] | 2 * \opts["w"] aspmax := real(maxw) / real(maxh) # Display the files. @@ -149,7 +146,7 @@ procedure main(args) return # Get the next file and translate its image. - f := open(fname) | + f := open(fname, "ru") | { write(&errout, fname, ": can't open"); next } # Read the image, full sized, into a scratch canvas @@ -345,7 +342,7 @@ end procedure popinfo(a, e, w, h) local f, i, n, x, y - f := open(a.fname) + f := open(a.fname, "ru") seek(f, 0) n := where(f) seek(f, 1) @@ -445,7 +442,7 @@ procedure mkgif(cmd, fname) if \opts["d"] then write(&errout, "+ ", cmd) system(cmd) - f := open(tempname) | fail + f := open(tempname, "ru") | fail win := load(tempname) close(f) remove(tempname) @@ -486,7 +483,7 @@ procedure jsize(irec, fname) local s, p, line, w, h s := "" - p := open("rdjpgcom -verbose " || fname, "p") | fail + p := open("rdjpgcom -verbose \"" || fname || "\"", "p") | fail while line := read(p) do line ? { ="JPEG image is " | next w := tab(many(&digits)) | next diff --git a/ipl/gprogs/kaleid.icn b/ipl/gprogs/kaleid.icn index 11b3ed9..cfb825d 100644 --- a/ipl/gprogs/kaleid.icn +++ b/ipl/gprogs/kaleid.icn @@ -6,7 +6,7 @@ # # Author: Stephen B. Wampler # -# Date: May 2, 2001 +# Date: November 22, 2009 # ############################################################################ # @@ -218,6 +218,7 @@ local radius, xoff, yoff # draw it in kaleidoscopic form draw_circle(mid_win-yoff, mid_win+xoff, radius) draw_circle(mid_win-yoff, mid_win-xoff, radius) + WDelay(10) return end diff --git a/ipl/gprogs/spider.icn b/ipl/gprogs/spider.icn index 0c25529..10ed22a 100644 --- a/ipl/gprogs/spider.icn +++ b/ipl/gprogs/spider.icn @@ -6,7 +6,9 @@ # # Author: William S. Evans # -# Date: February 19, 2002 +# Contributor: Gregg M. Townsend +# +# Date: September 6, 2009 # ############################################################################ # @@ -45,6 +47,11 @@ # 's' Save the current game to a file. # 'r' Read a game from a file. # '1234567890' Move run from indicated pile. +# 'bfhptvwxyz' Move run from indicated pile. +# +# If $HOME/.spdhist exists and is writable at the start of the run, a +# single history record is written to it for each 'n' or 'q' or 'r' +# command, unless no cards have been moved. # ############################################################################ # @@ -52,15 +59,20 @@ # ############################################################################ # -# Links: drawcard, graphics, random +# Links: datetime, drawcard, graphics, random # ############################################################################ +link datetime link drawcard link graphics link random $define SPIDER_VERSION "spider-0.3" # version of spider +$define HISTORY_FILE ".spdhist" # name of history file in $HOME + +$define NUM_LABELS "1234567890" # numeric column labels +$define LTR_LABELS "bfhptvwxyz" # alphabetic column labels global cardw, cardh # card width and height global ymargin, xmargin, xgap # margins, gap between cards @@ -74,6 +86,8 @@ global nextCard # an integer global undoStack # list of integers global currentFile # filename to store/retrieve a game global readingGame # =1 if reading game from file =0 o.w. +global startTime # start time of this game +global histfile # appendable history file, if any, else null procedure main(args) local fromPile,maxCards,e,p @@ -82,6 +96,7 @@ procedure main(args) newgame() repeat case e := Event() of { !"qQ": { + report() exit() } "d": { @@ -94,26 +109,29 @@ procedure main(args) message(hiddenNames(1+(&x-xmargin+xgap/2)/(cardw+xgap))) } "n": { + report() newgame() } "u": { undo() | beep() } "r": { + report() readingGame := 1 WAttrib("bg=pale gray","fg=black") readFile() readingGame := 0 WAttrib("bg=deep moderate green","fg=white") drawBoard() + startTime := &null # unknown original start time } "s": { WAttrib("bg=pale gray","fg=black") saveFile() WAttrib("bg=deep moderate green","fg=white") } - !"1234567890": { - p := 0 < ord(e)-ord("0") | 10 + !(NUM_LABELS | LTR_LABELS): { + p := find(e, NUM_LABELS | LTR_LABELS) click(13,p,p) | beep() } &lpress | &rpress: { @@ -138,6 +156,7 @@ procedure main(args) end procedure initialize(args) + local hfname currentFile := "game1.spd" readingGame := 0 @@ -171,6 +190,10 @@ procedure initialize(args) ymargin <:= fheight + hfname := (getenv("HOME") | "?noHOME?") || "/" || HISTORY_FILE + if close(open(hfname)) then # if file already exists + histfile := open(hfname, "wa") # may fail leaving null if not writable + return end @@ -205,12 +228,19 @@ procedure newgame(initialDeck) up[11] := 0 drawBoard() + + startTime := &clock return end procedure drawPiles(p[]) local i,j,n,x,y,ht,mlap,upstart,yposns + if *pile[11] = 104 then { + drawWin() + return + } + if readingGame = 0 then { every i := 1 <= 10 >= !p do { @@ -219,8 +249,8 @@ procedure drawPiles(p[]) yoff[i] := yposns := list(0) x := xmargin + (i-1) * (cardw + xgap) EraseArea(x,ymargin,cardw,height-2*ymargin) - GotoXY(x+cardw/2,ymargin-descent) - WWrites(10 > i | 0) + GotoXY(x+cardw/2-10,ymargin-descent) + WWrites(LTR_LABELS[i], " ", NUM_LABELS[i]) n := *(pile[i]) mlap := lap if n > 1 then @@ -247,9 +277,28 @@ procedure drawPiles(p[]) return end +procedure drawWin() + local i, j, s, x, y, suits + + EraseArea() + suits := [ + "MLKJIHGFEDCBA", "mlkjihgfedcba", "zyxwvutsrqpon", "ZYXWVUTSRQPON" ] + every i := 1 to 4 do { + s := suits[i] + y := 125 * (i - 1) + every x := 20 | 400 do { + every j := 1 to 13 do { + drawcard(x + 24 * j, y, s[j]) + WDelay(5) + } + } + } + return +end procedure drawBoard() if readingGame = 0 then { + EraseArea() WAttrib("label=Spider Deck "||104-nextCard+1) drawPiles(1,2,3,4,5,6,7,8,9,10) } @@ -424,8 +473,8 @@ procedure succ(c) end procedure beep() - writes("\^g") - flush(&output) + writes(&errout, "\^g") + flush(&errout) return end @@ -505,6 +554,7 @@ procedure saveFile() write(output,deck) every writes(output,!undoStack," ") write(output,"") + close(output) return } else { Notice("Cannot open file for writing.") @@ -565,3 +615,41 @@ procedure doAll() } return end + +procedure report() + local i, u, s, stopTime, elapsed, nmoves, undealt, cardsleft + + if *undoStack = 0 then return # don't report if no moves made + + stopTime := &clock + elapsed := ClockToSec(stopTime,0) - (ClockToSec(\startTime,0)|-1) + if elapsed < 0 then # if wraparound crossing midnight + elapsed +:= 24 * 60 * 60 + elapsed >:= 9999 # 9999 sec means unknown or bogus time + + nmoves := *undoStack/3 + undealt := 104 - nextCard + 1 + cardsleft := 0 + every cardsleft +:= *pile[1 to 10] + write(nmoves, " moves in ", elapsed, " seconds, leaving ", + cardsleft + undealt, " cards") + + if /histfile then return # if no history file, nothing more to do + + writes(histfile, &date, " ", stopTime[1+:5]) # date and time at quit + writes(histfile, right(elapsed, 5), "s") # elapsed time in sec + writes(histfile, right(nmoves, 4), "m") # moves made + writes(histfile, right(undealt, 3), "c") # undealt cards + + every i := 1 to 10 do { + s := pile[i] + u := up[i] + if *s = 0 then + writes(histfile, " -") + else + writes(histfile, " ", s[1+:u], repl("?", *s-u)) + } + + write(histfile) + return +end diff --git a/ipl/gprogs/trkvu.icn b/ipl/gprogs/trkvu.icn index 9cd3c36..18c9f39 100644 --- a/ipl/gprogs/trkvu.icn +++ b/ipl/gprogs/trkvu.icn @@ -6,7 +6,7 @@ # # Authors: Gregg M. Townsend # -# Date: October 1, 2005 +# Date: April 3, 2010 # ############################################################################ # @@ -34,7 +34,7 @@ # # Track log colorings are selected by pressing a key: # -# F color by File +# F color by File (restricting legend to files in view) # A color by Age # O color by Orientation (direction of travel) # V color by Velocity @@ -105,7 +105,7 @@ record view( # one view of data record point( # one point along a track t, # time at point (real days & fraction since epoch) x, y, # coordinates of point (longitude, latitude) - fhue) # hue assigned to original source file + f) # file index global viewlist # list of views (view records) @@ -208,13 +208,10 @@ end procedure load(fname) # load data from one file local f, h, p, w, t, x, y, a, line, ptlist - static n - initial n := 0 f := open(fname) | stop("cannot open ", fname) - h := huenum(n +:= 1) put(fnlist, fname) - put(fhlist, h) + put(fhlist, huenum(*fnlist)) while line := read(f) do { every put(w := [], words(line)) if -90.0 <= numeric(w[-3]) <= 90.0 then @@ -222,7 +219,7 @@ procedure load(fname) # load data from one file if x := numeric(w[-1]) & y := numeric(w[-2]) then { t := tcrack(w[-4], w[-3]) | &null /ptlist := [] - put(ptlist, p := point(t, x, y, h)) + put(ptlist, p := point(t, x, y, *fnlist)) } else { put(seglist, \ptlist) @@ -245,7 +242,7 @@ procedure tcrack(date, time) # translate date + time into real value if date[3] == "/" then date := map("CcYy/Mm/Dd", "Mm/Dd/CcYy", date) - if date == ("1989/12/31" | "1990/01/01") then + if date <<= "1990/01/01" then # if indicator of missing date return &null *time = 8 | fail *date = 10 | fail @@ -387,7 +384,7 @@ procedure draw(win, pjn, a) # display map using curview GotoXY(2 * BORDER, lbase) ltext(curview.ltitle) ltext(": ") - curview.lproc() + curview.lproc(pjn) Clip ! mclip every ptlist := !seglist do { @@ -460,17 +457,48 @@ end # F: color segments by source file, using colors set at load time +# +# show in the legend only those files containing a point in view +# (note: won't show legend for tracks that "just pass through") + +procedure flegend(pjn) + local winlim, viewlim, fset, vset, i, seg, pt, x0, x1, y0, y1 + + fset := set() # set of potential file source indices + every insert(fset, 1 to *fnlist) + vset := set() # set of indices of files in view + + # find limits of the current field of view + winlim := [mclip[1], mclip[2] + mclip[4], mclip[1] + mclip[3], mclip[2]] + viewlim := project(invp(pjn), winlim) + x0 := get(viewlim) + y0 := get(viewlim) + x1 := get(viewlim) + y1 := get(viewlim) + + # find files in view + every seg := !seglist do { + pt := !seg # first pt + if member(fset, pt.f) then { + every pt := !seg do { + if x0 <= pt.x <= x1 & y0 <= pt.y <= y1 then { + delete(fset, pt.f) + insert(vset, pt.f) + if *fset = 0 then + break break + } + } + } + } -procedure flegend() - local i - - every i := 1 to *fnlist do + # now, finally draw the legend + every i := !sort(vset) do lhue(fhlist[i], fnlist[i] || " ") return end procedure byfile(p, q) - return q.fhue + return fhlist[q.f] end diff --git a/ipl/gprogs/tron.icn b/ipl/gprogs/tron.icn new file mode 100644 index 0000000..7fefc04 --- /dev/null +++ b/ipl/gprogs/tron.icn @@ -0,0 +1,191 @@ +############################################################################ +# +# File: tron.icn +# +# Subject: Program to play a Tron-like video game +# +# Author: Eduardo Ochs +# +# Date: November 18, 2009 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Rules: You're yellow, and you leave a yellow trail when you walk. +# You never stop until you die. You die when you hit something +# yellow. Use the arrow keys to change your direction. Try to make +# the best score you can before you die. You only live once. +# +# In the beginning it's a black arena with yellow walls and a red +# 3x3 pixel square somewhere. Walking over a red pixel gives you +# one point and makes another 3x3 square appear somewhere. So, +# crossing a 3x3 red square from one side to another gives you +# three points and makes three other squares appear in random +# positions. +# +# Walking over black pixels is harmless. +# +# Sometimes the red squares will appear over your trail. Then some +# pixels of your trail will become red and you'll be able to cross. +# +# The game loop and the outer loop: typing "Q" or Esc or losing when +# you're playing makes you go to the outer loop; in the outer loop +# typing "P" or Enter or space restarts the game, and typing "Q" or +# Esc leaves the program. +# +# Source: +# Htmlized: +# Screenshot: +# See also: +# +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics, random +# +############################################################################ + +link graphics +link random + +$include "keysyms.icn" + +global actions, direction +global x, y, dx, dy +global score +global pixels + +procedure prepare_vars() + actions := table() + actions[Key_Down] := ["v", +1] + actions[Key_Up] := ["v", -1] + actions[Key_Right] := ["h", +1] + actions[Key_Left] := ["h", -1] + every actions["q" | "Q" | "\e"] := "quit" + set_direction(["h", +1]) + x := 150 + y := 90 + score := 0 + pixels := table() + every pixels[0 to 199] := table(0) +end + +procedure set_color(n) + if n == 0 then WAttrib("fg=black") + if n == 1 then WAttrib("fg=red") + if n == 3 then WAttrib("fg=yellow") +end + +procedure pset(x, y, color) + set_color(color) + pixels[y][x] := color + FillRectangle(x*2, y*2, 2, 2) +end + +procedure point(x, y) + return pixels[y][x] +end + +procedure draw_red_square() + local x, y + x := ?316 + y := ?188 + every pset(x to x+2, y to y+2, 1) +end + +procedure is_direction(action) + return type(action) == "list" +end + +procedure ignored_turn(newdirection) + return newdirection[1] == direction[1] +end + +procedure set_direction(newdirection) + direction := newdirection + if direction[1] == "h" then { + dx := direction[2]; dy := 0 + } else { + dy := direction[2]; dx := 0 + } +end + +procedure process_events() + local e, action + while *Pending() > 0 do { + e := Event() + # w(e) + action := actions[e] + if is_direction(action) then { + if not ignored_turn(action) then { + set_direction(action) + return + } + } + if action === "quit" then + fail + } + return +end + +procedure prepare_walls() + every pset(0 to 319, 0, 3) + every pset(0 to 319, 191, 3) + every pset(0, 0 to 191, 3) + every pset(319, 0 to 191, 3) +end + +procedure draw_score() + GotoXY(6, 396) + set_color(3) + WWrites("Score: " || score) +end + +procedure play() + prepare_vars() + set_color(0) + FillRectangle(0, 0, 640, 400) + prepare_walls() + pset(x, y, 3) + draw_red_square() + draw_score() + + WDelay(1000) + + while process_events() do { + x +:= dx + y +:= dy + if point(x, y) == 3 then break + if point(x, y) == 1 then { + draw_red_square(); score +:= 1; draw_score() + pset(x, y, 3) + WDelay(50) + } + pset(x, y, 3) + WDelay(50) + } +end + +procedure main(args) + local e + + # w(actions) + WOpen("size=640,400", "fg=yellow", "bg=black") + WAttrib("font=Helvetica,12,bold") + + randomize() + while 1 do { + play() + while e := Event() do { + if e === ("q" | "Q" | "\e") then return + if e === ("p" | "P" | " " | "\r" | "\n") then break + } + } +end diff --git a/ipl/mincl/etdefs.icn b/ipl/mincl/etdefs.icn deleted file mode 100644 index 7634a74..0000000 --- a/ipl/mincl/etdefs.icn +++ /dev/null @@ -1,39 +0,0 @@ -############################################################################ -# -# File: etdefs.icn -# -# Subject: Definitions for artificial event codes -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This file contains definitions for event codes. -# -# This file is intended for use with event monitors running under -# MT Icon. -# -############################################################################ - -$define T_01 "A" -$define T_02 "B" -$define T_03 "C" -$define T_04 "D" -$define T_05 "E" -$define T_06 "F" -$define T_07 "G" -$define T_08 "H" -$define T_09 "I" -$define T_10 "J" -$define T_11 "K" -$define T_12 "L" -$define T_13 "M" -$define T_14 "N" - -$define T_Mask1 cset("ABCDEFGHIJKLM") diff --git a/ipl/mincl/evdefs.icn b/ipl/mincl/evdefs.icn deleted file mode 100644 index 4f76077..0000000 --- a/ipl/mincl/evdefs.icn +++ /dev/null @@ -1,191 +0,0 @@ -############################################################################ -# -# File: evdefs.icn -# -# Subject: Definitions for event codes -# -# Author: Ralph E. Griswold -# -# Date: February 28, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This file contains definitions for event codes. -# -# This file is intended for use with event monitors running under -# MT Icon. -# -############################################################################ -# -# This file is generated automatically from monitor.h. -# -############################################################################ - -$define T_Coexpr 19 -$define T_Cset 5 -$define T_External 20 -$define T_File 6 -$define T_Integer 2 -$define T_Kywdevent 26 -$define T_Kywdint 21 -$define T_Kywdpos 22 -$define T_Kywdstr 25 -$define T_Kywdsubj 23 -$define T_Kywdwin 24 -$define T_Lelem 10 -$define T_List 9 -$define T_Lrgint 3 -$define T_Null 1 -$define T_Proc 7 -$define T_Real 4 -$define T_Record 8 -$define T_Refresh 18 -$define T_Selem 12 -$define T_Set 11 -$define T_Slots 16 -$define T_String 0 -$define T_Table 13 -$define T_Telem 14 -$define T_Tvsubs 17 -$define T_Tvtbl 15 -$define E_Aconv "\111" # Conversion attempt -$define E_Alien "\172" # Alien allocation -$define E_Assign "\347" # Assignment -$define E_BlkDeAlc "\055" # Block deallocation -$define E_Bsusp "\142" # Suspension from operation -$define E_Coact "\101" # Co-expression activation -$define E_Coexpr "\170" # Co-expression allocation -$define E_Cofail "\104" # Co-expression failure -$define E_Collect "\107" # Garbage collection -$define E_Coret "\102" # Co-expression return -$define E_Cset "\145" # Cset allocation -$define E_Ecall "\143" # Call of operation -$define E_Efail "\146" # Failure from expression -$define E_EndCollect "\360" # End of garbage collection -$define E_Erem "\166" # Removal of a suspended generator -$define E_Eresum "\165" # Resumption of expression -$define E_Error "\105" # Run-time error -$define E_Esusp "\141" # Suspension from alternation -$define E_Exit "\130" # Program exit -$define E_External "\152" # External allocation -$define E_Fcall "\072" # Function call -$define E_Fconv "\112" # Conversion failure -$define E_Ffail "\115" # Function failure -$define E_File "\147" # File allocation -$define E_Free "\132" # Free region -$define E_Frem "\133" # Function suspension removal -$define E_Fresum "\131" # Function resumption -$define E_Fret "\120" # Function return -$define E_Fsusp "\127" # Function suspension -$define E_Intcall "\351" # interpreter call -$define E_Integer "\100" # Integer value pseudo-event -$define E_Intret "\352" # interpreter return -$define E_Kywdint "\136" # Integer keyword value pseudo-event -$define E_Kywdpos "\046" # Position value pseudo-event -$define E_Kywdsubj "\052" # Subject value pseudo-event -$define E_Lbang "\301" # List generation -$define E_Lcreate "\302" # List creation -$define E_Lelem "\155" # List element allocation -$define E_Lget "\356" # List get/pop -- only E_Lget used -$define E_Line "\355" # Line change -$define E_List "\153" # List allocation -$define E_Loc "\174" # Location change -$define E_Lpop "\356" # List get/pop -$define E_Lpull "\304" # List pull -$define E_Lpush "\305" # List push -$define E_Lput "\306" # List put -$define E_Lrand "\307" # List random reference -$define E_Lref "\310" # List reference -$define E_Lrgint "\114" # Large integer allocation -$define E_Lsub "\311" # List subscript -$define E_Lsusp "\154" # Suspension from limitation -$define E_MXevent "\370" # monitor input event -$define E_Nconv "\116" # Conversion not needed -$define E_Null "\044" # Null value pseudo-event -$define E_Ocall "\134" # Operator call -$define E_Ofail "\135" # Operator failure -$define E_Opcode "\117" # Virtual-machine instruction -$define E_Orem "\177" # Operator suspension removal -$define E_Oresum "\175" # Operator resumption -$define E_Oret "\140" # Operator return -$define E_Osusp "\173" # Operator suspension -$define E_Pcall "\103" # Procedure call -$define E_Pfail "\106" # Procedure failure -$define E_Prem "\126" # Suspended procedure removal -$define E_Presum "\125" # Procedure resumption -$define E_Pret "\122" # Procedure return -$define E_Proc "\045" # Procedure value pseudo-event -$define E_Psusp "\123" # Procedure suspension -$define E_Rbang "\312" # Record generation -$define E_Rcreate "\313" # Record creation -$define E_Real "\144" # Real allocation -$define E_Record "\150" # Record allocation -$define E_Refresh "\171" # Refresh allocation -$define E_Rrand "\314" # Record random reference -$define E_Rref "\315" # Record reference -$define E_Rsub "\316" # Record subscript -$define E_Sbang "\317" # Set generation -$define E_Sconv "\121" # Conversion success -$define E_Screate "\320" # Set creation -$define E_Sdelete "\321" # Set deletion -$define E_Selem "\164" # Set element allocation -$define E_Set "\161" # Set allocation -$define E_Sfail "\341" # Scanning failure -$define E_Sinsert "\322" # Set insertion -$define E_Slots "\167" # Hash header allocation -$define E_Smember "\323" # Set membership -$define E_Snew "\340" # Scanning environment creation -$define E_Spos "\346" # Scanning position -$define E_Srand "\336" # Set random reference -$define E_Srem "\344" # Scanning environment removal -$define E_Sresum "\343" # Scanning resumption -$define E_Ssasgn "\354" # Sub-string assignment -$define E_Ssusp "\342" # Scanning suspension -$define E_Stack "\353" # stack depth -$define E_StrDeAlc "\176" # String deallocation -$define E_String "\163" # String allocation -$define E_Sval "\324" # Set value -$define E_Table "\156" # Table allocation -$define E_Tbang "\325" # Table generation -$define E_Tconv "\113" # Conversion target -$define E_Tcreate "\326" # Table creation -$define E_Tdelete "\327" # Table deletion -$define E_Telem "\157" # Table element allocation -$define E_TenureBlock "\362" # Tenure a block region -$define E_TenureString "\361" # Tenure a string region -$define E_Tick "\056" # Clock tick -$define E_Tinsert "\330" # Table insertion -$define E_Tkey "\331" # Table key generation -$define E_Tmember "\332" # Table membership -$define E_Trand "\337" # Table random reference -$define E_Tref "\333" # Table reference -$define E_Tsub "\334" # Table subscript -$define E_Tval "\335" # Table value -$define E_Tvsubs "\151" # Substring tv allocation -$define E_Tvtbl "\160" # Table-element tv allocation -$define E_Value "\350" # Value assigned -$define E_Disable 1000000 -$define E_Enable 1000001 -$define E_Quit 1000002 -$define E_ALoc 2000000 -$define E_Spoof 1728345 -$define AllocMask cset(E_List || E_Lelem || E_File || E_Lrgint || E_Real || E_Record || E_Selem || E_Set || E_Slots || E_Table || E_Telem || E_Tvsubs || E_Tvtbl || E_Cset || E_Refresh || E_String || E_Coexpr) -$define AssignMask cset(E_Assign || E_Value) -$define TypeMask AllocMask ++ (E_Integer || E_Null || E_Proc) -$define ConvMask cset(E_Aconv || E_Tconv || E_Sconv || E_Nconv || E_Fconv) -$define ProcMask cset(E_Pcall || E_Pfail || E_Pret || E_Psusp || E_Presum || E_Prem) -$define FncMask cset(E_Fcall || E_Ffail || E_Fret || E_Fsusp || E_Fresum || E_Frem) -$define OperMask cset(E_Ocall || E_Ofail || E_Oret || E_Osusp || E_Oresum || E_Orem) -$define EvalMask (FncMask ++ ProcMask ++ OperMask) -$define ListMask cset(E_Lbang || E_Lcreate || E_Lpop || E_Lpull || E_Lpush || E_Lput || E_Lrand || E_Lsub) -$define RecordMask cset(E_Rbang || E_Rcreate || E_Rrand || E_Rsub) -$define ScanMask cset(E_Snew || E_Sfail || E_Spos || E_Ssusp || E_Sresum || E_Srem) -$define SetMask cset(E_Sbang || E_Screate || E_Sdelete || E_Sinsert || E_Smember || E_Sval) -$define TableMask cset(E_Tbang || E_Tcreate || E_Tdelete || E_Tinsert || E_Tkey || E_Tmember || E_Trand || E_Tsub) -$define StructMask ListMask ++ RecordMask ++ SetMask ++TableMask -$define EmptyMask '' -$define AllMask &cset diff --git a/ipl/mprocs/colormap.icn b/ipl/mprocs/colormap.icn deleted file mode 100644 index 2bfcd70..0000000 --- a/ipl/mprocs/colormap.icn +++ /dev/null @@ -1,232 +0,0 @@ -############################################################################ -# -# File: colormap.icn -# -# Subject: Procedures to map type event to color -# -# Author: Ralph E. Griswold -# -# Date: July 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# colormap(palette) returns a table that maps event-monitoring codes -# for allocation events into RGB specifications for Icon. The -# argument is the name of a palette, as given in the MemMon -# system. The default for palette is "standard". -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -procedure colormap(palette) - static maps - local x - - initial { - maps := table() - -# Color map for doc.clr - - x := table() - - x[E_Coexpr] := "18724,18724,18724" - x[E_String] := "65535,65535,65535" - x[E_Tvsubs] := "65535,65535,65535" - x[E_File] := "56172,56172,56172" - x[E_Refresh] := "18724,18724,18724" - x[E_Lrgint] := "65535,65535,65535" - x[E_Real] := "65535,65535,65535" - x[E_Record] := "28086,28086,28086" - x[E_Set] := "28086,28086,28086" - x[E_Selem] := "46810,46810,46810" - x[E_List] := "18724,18724,18724" - x[E_Lelem] := "37448,37448,37448" - x[E_Table] := "18724,18724,18724" - x[E_Telem] := "56172,56172,56172" - x[E_Tvtbl] := "37448,37448,37448" - x[E_Slots] := "28086,28086,28086" - x[E_Cset] := "46810,46810,46810" - - maps["doc"] := x - -# Color map for lw.clr - - x := table() - - x[E_Coexpr] := "28086,28086,28086" - x[E_String] := "65535,65535,65535" - x[E_Tvsubs] := "65535,65535,56172" - x[E_File] := "09362,00000,00000" - x[E_Refresh] := "09362,00000,00000" - x[E_Lrgint] := "65535,65535,65535" - x[E_Real] := "65535,65535,65535" - x[E_Record] := "65535,65535,65535" - x[E_Set] := "09362,18724,18724" - x[E_Selem] := "09362,18724,18724" - x[E_List] := "37448,37448,37448" - x[E_Lelem] := "37448,37448,37448" - x[E_Table] := "65535,65535,56172" - x[E_Telem] := "65535,65535,56172" - x[E_Tvtbl] := "65535,65535,56172" - x[E_Slots] := "18724,18724,18724" - x[E_Cset] := "09362,09362,09362" - - maps["lw"] := x - -# Color map for pastel.clr - - x := table() - - x[E_Coexpr] := "65535,46810,28086" # peach - x[E_String] := "56172,28086,09362" # reddish brown - x[E_Tvsubs] := "56172,28086,09362" # reddish brown - x[E_File] := "00000,00000,28086" # dark blue - x[E_Refresh] := "37448,00000,00000" # dark red - x[E_Lrgint] := "65535,65535,00000" # yellow - x[E_Real] := "65535,28086,28086" # salmon - x[E_Record] := "65535,46810,28086" # peach - x[E_Set] := "56172,46810,65535" # light purple - x[E_Selem] := "56172,28086,65535" # medium purple - x[E_List] := "18724,37448,56172" # medium blue - x[E_Lelem] := "18724,56172,65535" # pastel blue - x[E_Table] := "46810,65535,37448" # light yellow-green - x[E_Telem] := "18724,56172,18724" # light green - x[E_Tvtbl] := "09362,37448,09362" # dark green - x[E_Slots] := "37448,65535,65535" # light blue - x[E_Cset] := "65535,65535,46810" # ivory - - maps["pastel"] := x - -# Color map for qms.clr - - x := table() - - x[E_Coexpr] := "37448,18724,00000" # brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,65535,46810" # ivory - x[E_File] := "56172,65535,00000" # light green - x[E_Refresh] := "37448,18724,00000" # brown - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "56172,00000,65535" # magenta - x[E_Set] := "37448,00000,00000" # medium red - x[E_Selem] := "65535,00000,00000" # red - x[E_List] := "00000,46810,46810" # medium cyan - x[E_Lelem] := "00000,65535,65535" # cyan - x[E_Table] := "00000,37448,00000" # dark green - x[E_Telem] := "00000,65535,00000" # green - x[E_Tvtbl] := "28086,65535,00000" # light green - x[E_Slots] := "37448,00000,56172" # purple - x[E_Cset] := "65535,56172,00000" # yellow orange - - maps["qms"] := x - -# Color map for qmscomb.clr - - x := table() - - x[E_Coexpr] := "37448,18724,00000" # brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,65535,46810" # ivory - x[E_File] := "56172,65535,00000" # light green - x[E_Refresh] := "37448,18724,00000" # brown - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "56172,00000,65535" # magenta - x[E_Set] := "65535,00000,00000" # red - x[E_Selem] := "65535,00000,00000" # red - x[E_List] := "00000,65535,65535" # cyan - x[E_Lelem] := "00000,65535,65535" # cyan - x[E_Table] := "00000,65535,00000" # green - x[E_Telem] := "00000,65535,00000" # green - x[E_Tvtbl] := "00000,65535,00000" # green - x[E_Slots] := "37448,00000,56172" # purple - x[E_Cset] := "65535,56172,00000" # yellow orange - - maps["qmscomb"] := x - -# Color map for rt.clr - - x := table() - - x[E_Coexpr] := "37448,28086,18724" # light brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,28086,56172" # pink - x[E_File] := "37448,00000,56172" # purple - x[E_Refresh] := "00000,00000,37448" # navy blue - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "65535,37448,00000" # orange - x[E_Set] := "37448,00000,00000" # dark red - x[E_Selem] := "56172,00000,00000" # red - x[E_List] := "18724,46810,65535" # pastel blue - x[E_Lelem] := "09362,28086,46810" # medium blue - x[E_Table] := "00000,28086,00000" # dark green - x[E_Telem] := "00000,46810,00000" # medium green - x[E_Tvtbl] := "28086,65535,28086" # light green - x[E_Slots] := "37448,28086,18724" # light brown - x[E_Cset] := "46810,28086,00000" # reddish brown - - maps["rt"] := x - -# Color map for sun.clr - - x := table() - - x[E_Coexpr] := "37448,28086,18724" # light brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,28086,56172" # pink - x[E_File] := "37448,00000,56172" # purple - x[E_Refresh] := "00000,00000,37448" # navy blue - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "65535,37448,00000" # orange - x[E_Set] := "46810,00000,00000" # dark red - x[E_Selem] := "56172,00000,00000" # red - x[E_List] := "18724,46810,65535" # pastel blue - x[E_Lelem] := "09362,28086,46810" # medium blue - x[E_Table] := "00000,28086,00000" # dark green - x[E_Telem] := "00000,37448,00000" # medium green - x[E_Tvtbl] := "00000,65535,00000" # light green - x[E_Slots] := "37448,28086,18724" # light brown - x[E_Cset] := "46810,28086,00000" # reddish brown - - maps["sun"] := x - -# Color map for standard colors - - x := table() - - x[E_Coexpr] := "deep gray" - x[E_String] := "pale yellow" - x[E_Tvsubs] := "yellow" - x[E_File] := "pale gray" - x[E_Refresh] := "deep gray" - x[E_Lrgint] := "pale brown" - x[E_Real] := "pale purple" - x[E_Record] := "magenta" - x[E_Set] := "dark red" - x[E_Selem] := "red" - x[E_List] := "dark blue green" - x[E_Lelem] := "blue green" - x[E_Table] := "dark green" - x[E_Telem] := "green" - x[E_Tvtbl] := "light green" - x[E_Slots] := "purple" - x[E_Cset] := "orange" - - maps["standard"] := x - } - - return \maps[\palette | "standard"] - -end diff --git a/ipl/mprocs/colortyp.icn b/ipl/mprocs/colortyp.icn deleted file mode 100644 index 2592e0f..0000000 --- a/ipl/mprocs/colortyp.icn +++ /dev/null @@ -1,44 +0,0 @@ -############################################################################ -# -# File: colortyp.icn -# -# Subject: Procedure to produce table of colors for Icon types -# -# Author: Ralph E. Griswold -# -# Date: July 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Links: typecode -# -############################################################################ - -# Color table for Icon type codes - -procedure colortyp() - local x - - x := table() - - x["C"] := "deep gray" - x["s"] := "pale yellow" - x["r"] := "pale purple" - x["R"] := "magenta" - x["S"] := "dark red" - x["L"] := "dark blue green" - x["T"] := "dark green" - x["c"] := "orange" - x["f"] := "pink" - x["i"] := "white" - x["n"] := "gray" - x["p"] := "red viole" - x["w"] := "deep blue" - - return x - -end diff --git a/ipl/mprocs/em_setup.icn b/ipl/mprocs/em_setup.icn deleted file mode 100644 index c915fd8..0000000 --- a/ipl/mprocs/em_setup.icn +++ /dev/null @@ -1,101 +0,0 @@ -############################################################################ -# -# File: em_setup.icn -# -# Subject: Procedures to set up execution monitors -# -# Author: Ralph E. Griswold -# -# Date: March 3, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# These procedures provide support for the routine parts of building -# Icon execution monitors, including what's necessary for them to -# run stand-alone as well as under the control of monitor coordinators -# like eve and vc. -# -# vis_setup(args[]) opens a window with attributes given -# by args[] -# -# em_setup(sp) loads sp as the program to be monitored -# -# context_setup(mask) returns table of graphics context for -# mask -# -# prog_name() returns the name of the source program -# for the SP set up by em_setup() -# -# em_end() hold visualization window open if (a) -# there is one and (b) monitoring is -# stand alone -# -############################################################################ -# -# Requires: Version 9 MT Icon, instrumentation, and graphics -# -############################################################################ -# -# Links: evinit, interact, typebind, graphics -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link interact -link typebind -link graphics - -$include "evdefs.icn" - -global Coordination # if nonnull, vc is in charge -global Visualization # visualization window -global EventSource # vc's event source - -procedure vis_setup(args[]) #: set up visualization window - - Visualization := (WOpen ! args) | - stop("*** cannot open window for visualization") - - return Visualization - -end - -procedure em_setup(sp) #: set up program to be monitored - local trash - - trash := open("/dev/null", "w") | - stop("*** cannot open /dev/null") - - EvInit(sp, , trash, trash) | stop("*** cannot load SP") - - return - -end - -procedure context_setup(mask) #: table of graphics contexts for mask - - return typebind(Visualization, mask) - -end - -procedure prog_name() #: name of monitored source program - - return variable("&progname", EventSource) || ".icn" - -end - -procedure em_end() #: hold event monitoring for event at end - local back - - back := WOpen("canvas=hidden", "bg=light gray") - if /Coordination then ExitNotice(back, "Normal termination of SP") - -end diff --git a/ipl/mprocs/emutils.icn b/ipl/mprocs/emutils.icn deleted file mode 100644 index 322815f..0000000 --- a/ipl/mprocs/emutils.icn +++ /dev/null @@ -1,508 +0,0 @@ -############################################################################ -# -# File: emutils.icn -# -# Subject: Procedures to support MT-Icon monitors -# -# Author: Ralph E. Griswold -# -# Date: April 16, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evname(s) maps the event code to a standard descriptive phrases and vice -# versa. -# -############################################################################ -# -# Links: convert, tables -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link convert -link tables - -$include "evdefs.icn" - -procedure evname(s) - local result - static namemap - - initial { - namemap := table() - - namemap[E_Aconv] := "conversion attempt" - namemap[E_Argp] := "argument pointer" - namemap[E_Alien] := "alien allocation" - namemap[E_Assign] := "assignment" -# namemap[E_Base] := "base address of storage region" - namemap[E_BlkDeAlc] := "block deallocation" - namemap[E_Bsusp] := "suspension from operation" - namemap[E_Coact] := "co-expression activation" - namemap[E_Cocreate] := "co-expression creation" - namemap[E_Coexpr] := "co-expression allocation" - namemap[E_Cofail] := "co-expression failure" - namemap[E_Collect] := "garbage collection" -# namemap[E_Comment] := "comment" - namemap[E_Coret] := "co-expression return" - namemap[E_Cset] := "cset allocation" - namemap[E_Deref] := "variable dereference" - namemap[E_Ecall] := "call of operation" - namemap[E_Efail] := "failure from expression" - namemap[E_Efp] := "expression frame pointer" - namemap[E_EndCollect] := "end of garbage collection" - namemap[E_Erem] := "removal of a suspended generator" - namemap[E_Eresum] := "resumption of expression" -# namemap[E_Eret] := "return from expression" - namemap[E_Error] := "run-time error" - namemap[E_Esusp] := "suspension from alternation" - namemap[E_Exit] := "program exit" - namemap[E_External] := "external allocation" - namemap[E_Fcall] := "function call" - namemap[E_Fclose] := "file close" - namemap[E_Fconv] := "conversion failure" - namemap[E_Ffail] := "function failure" - namemap[E_File] := "file allocation" - namemap[E_Floc] := "file location" - namemap[E_Fmode] := "file open mode" - namemap[E_Fopen] := "file open" - namemap[E_Fread] := "file read" - namemap[E_Freads] := "file reads" - namemap[E_Free] := "free region" - namemap[E_Frem] := "function suspension removal" - namemap[E_Fresum] := "function resumption" - namemap[E_Fret] := "function return" - namemap[E_Fseek] := "file seek" - namemap[E_Fstring] := "string read or written" - namemap[E_Fsusp] := "function suspension" - namemap[E_Fwhere] := "file location" - namemap[E_Fwrite] := "function write" - namemap["\223"] := "function writes" - namemap[E_Gfp] := "generator frame pointer" -# namemap[E_Highlight] := "allocation highlight" - namemap[E_Ilevel] := "interpreter call level" - namemap[E_Intcall] := "interpreter call" - namemap[E_Integer] := "integer value pseudo-event" - namemap[E_Intret] := "interpreter return" - namemap[E_Ipc] := "interpreter program counter" - namemap[E_Kywdint] := "integer keyword value pseudo-event" - namemap[E_Kywdpos] := "position value pseudo-event" - namemap[E_Kywdsubj] := "subject value pseudo-event" - namemap[E_Lbang] := "list generation" - namemap[E_Lcreate] := "list creation" - namemap[E_Lelem] := "list element allocation" - namemap[E_Lget] := "list get" - namemap[E_Line] := "line change" - namemap[E_List] := "list allocation" - namemap[E_Loc] := "location change" - namemap[E_Lpop] := "list pop" - namemap[E_Lpull] := "list pull" - namemap[E_Lpush] := "list push" - namemap[E_Lput] := "list put" - namemap[E_Lrand] := "list random reference" -# namemap[E_Lref] := "list reference" - namemap[E_Lrgint] := "large integer allocation" - namemap[E_Lsub] := "list subscript" - namemap[E_Lsusp] := "suspension from limitation" - namemap[E_MXevent] := "monitor input event" - namemap[E_Nconv] := "conversion not needed" - namemap[E_NewRegion] := "new storage region" - namemap[E_Null] := "null value value pseudo-event" - namemap[E_Ocall] := "operator call" - namemap[E_Ofail] := "operator failure" -# namemap[E_Offset] := "address offset" -# namemap[E_Op] := "interpreter operation" - namemap[E_Opcode] := "virtual-machine instruction" - namemap[E_Orem] := "operator suspension removal" - namemap[E_Oresum] := "operator resumption" - namemap[E_Oret] := "operator return" - namemap[E_Osusp] := "operator suspension" -# namemap[E_Pause] := "memory monitoring comment" - namemap[E_Pcall] := "procedure call" - namemap[E_Pfail] := "procedure failure" - namemap[E_Pfp] := "procedure frame pointer" -# namemap[E_Pid] := "symbol name" - namemap[E_Prem] := "suspended procedure removal" - namemap[E_Presum] := "procedure resumption" - namemap[E_Pret] := "procedure return" - namemap[E_Proc] := "procedure value pseudo-event" - namemap[E_Psusp] := "procedure suspension" - namemap[E_Rbang] := "record generation" - namemap[E_Rcreate] := "record creation" - namemap[E_Real] := "real allocation" - namemap[E_Record] := "record allocation" - namemap[E_Refresh] := "refresh allocation" -# namemap[E_Region] := "region" - namemap[E_Rrand] := "record random reference" -# namemap[E_Rref] := "record reference" - namemap[E_Rsub] := "record subscript" - namemap[E_Sbang] := "set generation" - namemap[E_Sconv] := "conversion success" - namemap[E_Screate] := "set creation" - namemap[E_Sdelete] := "set deletion" - namemap[E_Selem] := "set element allocation" - namemap[E_Set] := "set allocation" - namemap[E_Sfail] := "scanning failure" - namemap[E_Sinsert] := "set insertion" -# namemap[E_Size] := "region size" - namemap[E_Slots] := "hash header allocation" - namemap[E_Smember] := "set membership" - namemap[E_Snew] := "scanning environment creation" - namemap[E_Spos] := "scanning position" - namemap[E_Srand] := "set random reference" - namemap[E_Srem] := "scanning environment removal" - namemap[E_Sresum] := "scanning resumption" - namemap[E_Ssasgn] := "substring assignment" - namemap[E_Ssusp] := "scanning suspension" - namemap[E_Stack] := "stack depth" - namemap[E_StrDeAlc] := "string deallocation" - namemap[E_String] := "string allocation" - namemap[E_Sval] := "set value" -# namemap[E_Sym] := "symbol table entry" - namemap[E_Table] := "table allocation" - namemap[E_Tbang] := "table generation" - namemap[E_Tconv] := "conversion target" - namemap[E_Tcreate] := "table creation" - namemap[E_Tdelete] := "table deletion" - namemap[E_Telem] := "table element allocation" - namemap[E_TenureBlock] := "tenure a block region" - namemap[E_TenureString] := "tenure a string region" - namemap[E_Tick] := "clock tick" - namemap[E_Tinsert] := "table insertion" - namemap[E_Tkey] := "table key generation" - namemap[E_Tmember] := "table membership" - namemap[E_Trand] := "table random reference" -# namemap[E_Tref] := "table reference" - namemap[E_Tsub] := "table subscript" -# namemap[E_Tval] := "table value" - namemap[E_Tvsubs] := "substring trapped variable allocation" - namemap[E_Tvtbl] := "table-element trapped variable allocation" -# namemap[E_Used] := "space used" - namemap[E_Value] := "value assigned" - namemap[E_Fterm] := "write terminator" - -# namemap := twt(namemap) - } - - result := namemap[s] - /result := "E_\\" || exbase10(find(s, &cset) - 1, 8) - - return result - -end - -############################################################################ -# -# evsym() maps event codes to the symbolic names for the codes and vice -# versa. -# -############################################################################ - -procedure evsym(s) - local result - static symmap - - initial { - symmap := table() - - symmap[E_Aconv] := "E_Aconv" - symmap[E_Argp] := "E_Argp" - symmap[E_Alien] := "E_Alien" - symmap[E_Assign] := "E_Assign" - symmap[E_BlkDeAlc] := "E_BlkDeAlc" - symmap[E_Bsusp] := "E_Bsusp" - symmap[E_Coact] := "E_Coact" - symmap[E_Cocreate] := "E_Cocreate" - symmap[E_Coexpr] := "E_Coexpr" - symmap[E_Cofail] := "E_Cofail" - symmap[E_Cofree] := "E_Cofree" - symmap[E_Collect] := "E_Collect" - symmap[E_Coret] := "E_Coret" - symmap[E_Cset] := "E_Cset" - symmap[E_Deref] := "E_Deref" - symmap[E_Ecall] := "E_Ecall" - symmap[E_Efail] := "E_Efail" - symmap[E_Efp] := "E_Efp" - symmap[E_Eresum] := "E_Eresum" - symmap[E_Error] := "E_Error" - symmap[E_Esusp] := "E_Esusp" - symmap[E_Erem] := "E_Erem" - symmap[E_Exit] := "E_Exit" - symmap[E_External] := "E_External" - symmap[E_Fcall] := "E_Fcall" - symmap[E_Fclose] := "E_Fclose" - symmap[E_Fconv] := "E_Fconv" - symmap[E_Ffail] := "E_Ffail" - symmap[E_File] := "E_File" - symmap[E_Floc] := "E_Loc" - symmap[E_Fmode] := "E_Fmode" - symmap[E_Fopen] := "E_Fopen" - symmap[E_Fread] := "E_Fread" - symmap[E_Freads] := "E_Freads" - symmap[E_Free] := "E_Free" - symmap[E_Frem] := "E_Frem" - symmap[E_Fresum] := "E_Fresum" - symmap[E_Fret] := "E_Fret" - symmap[E_Fseek] := "E_Fseek" - symmap[E_Fstring] := "E_Fstring" - symmap[E_Fsusp] := "E_Fsusp" - symmap[E_Fwhere] := "E_Fwhere" - symmap[E_Fwrite] := "E_Fwrite" - symmap[E_Fterm] := "E_Fterm" - symmap[E_Gfp] := "E_Gfp" - symmap[E_Ilevel] := "E_Ilevel" - symmap[E_Intcall] := "E_Intcall" - symmap[E_Integer] := "E_Integer" - symmap[E_Intret] := "E_Intret" - symmap[E_Ipc] := "E_Ipc" - symmap[E_Kywdint] := "E_Kywdint" - symmap[E_Kywdpos] := "E_Kywdpos" - symmap[E_Kywdsubj] := "E_Kywdsubj" - symmap[E_Lbang] := "E_Lbang" - symmap[E_Lcreate] := "E_Lcreate" - symmap[E_Lelem] := "E_Lelem" - symmap[E_Line] := "E_Line" - symmap[E_List] := "E_List" - symmap[E_Loc] := "E_Loc" - symmap[E_Lpop] := "E_Lpop" - symmap[E_Lpull] := "E_Lpull" - symmap[E_Lpush] := "E_Lpush" - symmap[E_Lput] := "E_Lput" - symmap[E_Lrand] := "E_Lrand" - symmap[E_Lref] := "E_Lref" - symmap[E_Lrgint] := "E_Lrgint" - symmap[E_Lsub] := "E_Lsub" - symmap[E_Lsusp] := "E_Lsusp" - symmap[E_Nconv] := "E_Nconv" - symmap[E_NewRegion]:= "E_NewRegion" - symmap[E_Null] := "E_Null" - symmap[E_Ocall] := "E_Ocall" - symmap[E_Ofail] := "E_Ofail" - symmap[E_Op] := "E_Op" - symmap[E_Opcode] := "E_Opcode" - symmap[E_Oresum] := "E_Oresum" - symmap[E_Oret] := "E_Oret" - symmap[E_Osusp] := "E_Osusp" - symmap[E_Orem] := "E_Orem" - symmap[E_Pcall] := "E_Pcall" - symmap[E_Pfail] := "E_Pfail" - symmap[E_Pfp] := "E_Pfp" - symmap[E_Presum] := "E_Presum" - symmap[E_Pret] := "E_Pret" - symmap[E_Proc] := "E_Proc" - symmap[E_Psusp] := "E_Psusp" - symmap[E_Prem] := "E_Prem" - symmap[E_Rbang] := "E_Rbang" - symmap[E_Rcreate] := "E_Rcreate" - symmap[E_Real] := "E_Real" - symmap[E_Record] := "E_Record" - symmap[E_Refresh] := "E_Refresh" - symmap[E_Rrand] := "E_Rrand" - symmap[E_Rref] := "E_Rref" - symmap[E_Rsub] := "E_Rsub" - symmap[E_Sbang] := "E_Sbang" - symmap[E_Sconv] := "E_Sconv" - symmap[E_Screate] := "E_Screate" - symmap[E_Sdelete] := "E_Sdelete" - symmap[E_Selem] := "E_Selem" - symmap[E_Set] := "E_Set" - symmap[E_Sfail] := "E_Sfail" - symmap[E_Sinsert] := "E_Sinsert" - symmap[E_Slots] := "E_Slots" - symmap[E_Smember] := "E_Smember" - symmap[E_Snew] := "E_Snew" - symmap[E_Spos] := "E_Spos" - symmap[E_Srand] := "E_Srand" - symmap[E_Sresum] := "E_Sresum" - symmap[E_Ssasgn] := "E_Ssasgn" - symmap[E_Ssusp] := "E_Ssusp" - symmap[E_Stack] := "E_Stack" - symmap[E_StrDeAlc] := "E_StrDeAlc" - symmap[E_String] := "E_String" - symmap[E_Sval] := "E_Sval" - symmap[E_Srem] := "E_Srem" - symmap[E_Table] := "E_Table" - symmap[E_Tbang] := "E_Tbang" - symmap[E_Tconv] := "E_Tconv" - symmap[E_Tcreate] := "E_Tcreate" - symmap[E_Tdelete] := "E_Tdelete" - symmap[E_Telem] := "E_Telem" - symmap[E_Tick] := "E_Tick" - symmap[E_Tinsert] := "E_Tinsert" - symmap[E_Tkey] := "E_Tkey" - symmap[E_Tmember] := "E_Tmember" - symmap[E_Trand] := "E_Trand" - symmap[E_Tref] := "E_Tref" - symmap[E_Tsub] := "E_Tsub" - symmap[E_Tval] := "E_Tval" - symmap[E_Tvsubs] := "E_Tvsubs" - symmap[E_Tvtbl] := "E_Tvtbl" - symmap[E_Value] := "E_Value" - - twt(symmap) - } - - result := symmap[s] - /result := "E_\\" || exbase10(find(s, &cset), 8) - - return result - -end - -procedure allocode(s) - static allocmap - - initial { - allocmap := table("unknown code") - - allocmap[E_Coexpr] := "co-expression" - allocmap[E_Cset] := "cset" - allocmap[E_File] := "file" - allocmap[E_List] := "list" - allocmap[E_Real] := "real" - allocmap[E_Record] := "record" - allocmap[E_Set] := "set" - allocmap[E_String] := "string" - allocmap[E_Table] := "table" - - twt(allocmap) - } - - return allocmap[s] - -end - -# Turn off output in SP. - -procedure kill_output() - - variable("write", EventSource) := -1 - variable("writes", EventSource) := -1 - - return - -end - -############################################################################ -# -# opname() maps a virtual-machine instruction number to a symbolic name. -# -############################################################################ - -procedure opname(i) #: map virtual-machine code to name - static opmap - - initial { - opmap := table("") - - opmap[1] := "Asgn" - opmap[2] := "Bang" - opmap[3] := "Cat" - opmap[4] := "Compl" - opmap[5] := "Diff" - opmap[6] := "Div" - opmap[7] := "Eqv" - opmap[8] := "Inter" - opmap[9] := "Lconcat" - opmap[10] := "Lexeq" - opmap[11] := "Lexge" - opmap[12] := "Lexgt" - opmap[13] := "Lexle" - opmap[14] := "Lexlt" - opmap[15] := "Lexne" - opmap[16] := "Minus" - opmap[17] := "Mod" - opmap[18] := "Mult" - opmap[19] := "Neg" - opmap[20] := "Neqv" - opmap[21] := "Nonnull" - opmap[22] := "Null" - opmap[23] := "Number" - opmap[24] := "Numeq" - opmap[25] := "Numge" - opmap[26] := "Numgt" - opmap[27] := "Numle" - opmap[28] := "Numlt" - opmap[29] := "Numne" - opmap[30] := "Plus" - opmap[31] := "Power" - opmap[32] := "Random" - opmap[33] := "Rasgn" - opmap[34] := "Refresh" - opmap[35] := "Rswap" - opmap[36] := "Sect" - opmap[37] := "Size" - opmap[38] := "Subsc" - opmap[39] := "Swap" - opmap[40] := "Tabmat" - opmap[41] := "Toby" - opmap[42] := "Unions" - opmap[43] := "Value" - opmap[44] := "Bscan" - opmap[45] := "Ccase" - opmap[46] := "Chfail" - opmap[47] := "Coact" - opmap[48] := "Cofail" - opmap[49] := "Coret" - opmap[50] := "Create" - opmap[51] := "Cset" - opmap[52] := "Dup" - opmap[53] := "Efail" - opmap[54] := "Eret" - opmap[55] := "Escan" - opmap[56] := "Esusp" - opmap[57] := "Field" - opmap[58] := "Goto" - opmap[59] := "Init" - opmap[60] := "Int" - opmap[61] := "Invoke" - opmap[62] := "Keywd" - opmap[63] := "Limit" - opmap[64] := "Line" - opmap[65] := "Llist" - opmap[66] := "Lsusp" - opmap[67] := "Mark" - opmap[68] := "Pfail" - opmap[69] := "Pnull" - opmap[70] := "Pop" - opmap[71] := "Pret" - opmap[72] := "Psusp" - opmap[73] := "Push1" - opmap[74] := "Pushn1" - opmap[75] := "Real" - opmap[76] := "Sdup" - opmap[77] := "Str" - opmap[78] := "Unmark" - opmap[80] := "Var" - opmap[81] := "Arg" - opmap[82] := "Static" - opmap[83] := "Local" - opmap[84] := "Global" - opmap[85] := "Mark0" - opmap[86] := "Quit" - opmap[87] := "FQuit" - opmap[88] := "Tally" - opmap[89] := "Apply" - opmap[90] := "Acset" - opmap[91] := "Areal" - opmap[92] := "Astr" - opmap[93] := "Aglobal" - opmap[94] := "Astatic" - opmap[95] := "Agoto" - opmap[96] := "Amark" - opmap[98] := "Noop" - opmap[100] := "SymEvents" - opmap[108] := "Colm" - } - - return opmap[i] - -end diff --git a/ipl/mprocs/evaltree.icn b/ipl/mprocs/evaltree.icn deleted file mode 100644 index c007dca..0000000 --- a/ipl/mprocs/evaltree.icn +++ /dev/null @@ -1,106 +0,0 @@ -############################################################################ -# -# File: evaltree.icn -# -# Subject: Procedures to maintain activation tree -# -# Author: Clinton Jeffery -# -# Date: June 19, 1994 -# -########################################################################### -# -# This file is in the public domain. -# -############################################################################ -# -# Usage: evaltree(cset, procedure, record constructor) -# -# The record type must have fields node, parent, children -# -# See "A Framework for Monitoring Program Execution", Clinton L. Jeffery, -# TR 93-21, Department of Computer Science, The University of Arizona, -# July 30, 1993. -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ - -$include "evdefs.icn" - -record __evaltree_node(node,parent,children) - -global CallCodes, - SuspendCodes, - ResumeCodes, - ReturnCodes, - FailCodes, - RemoveCodes - -procedure evaltree(mask, callback, activation_record) - local c, current, p, child - - - /activation_record := __evaltree_node - CallCodes := string(mask ** cset(E_Pcall || E_Fcall || E_Ocall || E_Snew)) - SuspendCodes := string(mask ** cset(E_Psusp || E_Fsusp || - E_Osusp || E_Ssusp)) - ResumeCodes := string(mask ** cset(E_Presum || E_Fresum || E_Oresum || - E_Sresum)) - ReturnCodes := string(mask ** cset(E_Pret || E_Fret || E_Oret)) - FailCodes := string(mask ** cset(E_Pfail || E_Ffail || E_Ofail || E_Sfail)) - RemoveCodes := string(mask ** cset(E_Prem || E_Frem || E_Orem || E_Srem)) - - current := activation_record() - current.parent := activation_record() - current.children := [] - current.parent.children := [] - - while EvGet(mask) do { - case &eventcode of { - !CallCodes: { - c := activation_record() - c.node := &eventvalue - c.parent := current - c.children := [] - put(current.children, c) - current := c - callback(current, current.parent) - } - !ReturnCodes | !FailCodes: { - p := pull(current.parent.children) - current := current.parent - callback(current, p) - } - !SuspendCodes: { - current := current.parent - callback(current, current.children[-1]) - } - !ResumeCodes: { - current := current.children[-1] - callback(current, current.parent) - } - !RemoveCodes: { - if child := pull(current.children) then { - while put(current.children, pop(child.children)) - callback(current, child) - } - else { - if current === current.parent.children[-1] then { - p := pull(current.parent.children) - current := current.parent - callback(current, p) - next - } - else stop("evaltree: unknown removal") - } - } - default: { - callback(current, current) - } - } - } -end - diff --git a/ipl/mprocs/evinit.icn b/ipl/mprocs/evinit.icn deleted file mode 100644 index 09a2ee6..0000000 --- a/ipl/mprocs/evinit.icn +++ /dev/null @@ -1,89 +0,0 @@ -############################################################################ -# -# File: evinit.icn -# -# Subject: Procedures for event monitoring -# -# Author: Ralph E. Griswold -# -# Date: November 5, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This file provides initialization for event monitors. -# -# This file is intended for use with event monitors running under -# MT Icon. -# -############################################################################ - -$include "evdefs.icn" - -procedure EvInit(f,input,output,error) - if not MTEvInit(f,input,output,error) then fail - return -end - -procedure EvTerm(win) - if &eventsource === (Monitored | EventSource) then { - if type(win) == "window" then - Event(win) - } -end -# -# MultiThread EventMon support, from file mtsupport.icn -# - -global Monitored, EventSource, MTEventMask - -# -# If EvInit is called with a string or a list, run as a standalone MT-based -# event monitor -- load the icode file and overload certain EvMon symbols. -# -# This operation is skipped if &eventsource has already been initialized, -# presumably by some event broker such as Eve. -# -procedure MTEvInit(f,input,output,error) - - if \&eventsource then return - - if type(f) == "string" then { - &eventsource := EventSource := Monitored := load(f,,input,output,error) | fail - EvGet :=: MTEvGet - } - else if type(f) == "list" then { - &eventsource := EventSource := Monitored := load(f[1],f[2:0],input,output,error) | fail - EvGet :=: MTEvGet - } - return &eventsource -end - -procedure MTEvGet(c,flag) - static lastcset - initial { - lastcset := '' - } - - if c ~=== lastcset then { - lastcset := c - eventmask(\(Monitored | EventSource) ,\c | &cset,&main) - } - return MTEvGet(c,flag) -end - -# -# Eve-specific extensions to the general model -# -procedure EvQuit() - EvSignal("quit") -end - -procedure EvSignal(x) - if type(x) == "cset" then - write(&errout, "EvSignal(", image(x), ") is ambiguous.") - return x @ &eventsource -end diff --git a/ipl/mprocs/evnames.icn b/ipl/mprocs/evnames.icn deleted file mode 100644 index 046b4a3..0000000 --- a/ipl/mprocs/evnames.icn +++ /dev/null @@ -1,174 +0,0 @@ -############################################################################ -# -# File: evnames.icn -# -# Subject: Procedures to map between event codes and names -# -# Author: Ralph E. Griswold -# -# Date: December 26, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evnames(x) creates a two-way table. Indexed by an event code, it -# produces a descriptive phrase for the code. Indexed by the descriptive -# phrase it produces the event code. It returns the value for key x. -# -############################################################################ -# -# Links: tables -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link tables - -$include "evdefs.icn" - -procedure evnames(e) - static namemap - - initial { - namemap := table("unknown event") - - namemap[E_Aconv] := "conversion attempt" - namemap[E_Alien] := "alien allocation" - namemap[E_Assign] := "assignment" - namemap[E_Base] := "base address of storage region" - namemap[E_BlkDeAlc] := "block deallocation" - namemap[E_Bsusp] := "suspension from operation" - namemap[E_Coact] := "co-expression activation" - namemap[E_Coexpr] := "co-expression allocation" - namemap[E_Cofail] := "co-expression failure" - namemap[E_Collect] := "garbage collection" - namemap[E_Comment] := "comment" - namemap[E_Coret] := "co-expression return" - namemap[E_Cset] := "cset allocation" - namemap[E_Ecall] := "call of operation" - namemap[E_Efail] := "failure from expression" - namemap[E_EndCollect] := "end of garbage collection" - namemap[E_Erem] := "removal of a suspended generator" - namemap[E_Eresum] := "resumption of expression" - namemap[E_Eret] := "return from expression" - namemap[E_Error] := "run-time error" - namemap[E_Esusp] := "suspension from alternation" - namemap[E_Exit] := "program exit" - namemap[E_External] := "external allocation" - namemap[E_Fcall] := "function call" - namemap[E_Fconv] := "conversion failure" - namemap[E_Ffail] := "function failure" - namemap[E_File] := "file allocation" - namemap[E_Free] := "free region" - namemap[E_Frem] := "function suspension removal" - namemap[E_Fresum] := "function resumption" - namemap[E_Fret] := "function return" - namemap[E_Fsusp] := "function suspension" - namemap[E_Highlight] := "allocation highlight" - namemap[E_Intcall] := "interpreter call" - namemap[E_Integer] := "integer value pseudo-event" - namemap[E_Intret] := "interpreter return" - namemap[E_Kywdint] := "integer keyword value pseudo-event" - namemap[E_Kywdpos] := "position value pseudo-event" - namemap[E_Kywdsubj] := "subject value pseudo-event" - namemap[E_Lbang] := "list generation" - namemap[E_Lcreate] := "list creation" - namemap[E_Lelem] := "list element allocation" - namemap[E_Lget] := "list get" - namemap[E_Line] := "line change" - namemap[E_List] := "list allocation" - namemap[E_Loc] := "location change" - namemap[E_Lpop] := "list pop" - namemap[E_Lpull] := "list pull" - namemap[E_Lpush] := "list push" - namemap[E_Lput] := "list put" - namemap[E_Lrand] := "list random reference" - namemap[E_Lref] := "list reference" - namemap[E_Lrgint] := "large integer allocation" - namemap[E_Lsub] := "list subscript" - namemap[E_Lsusp] := "suspension from limitation" - namemap[E_MXevent] := "monitor input event" - namemap[E_Nconv] := "conversion not needed" - namemap[E_Null] := "null value value pseudo-event" - namemap[E_Ocall] := "operator call" - namemap[E_Ofail] := "operator failure" - namemap[E_Offset] := "address offset" - namemap[E_Opcode] := "virtual-machine instruction" - namemap[E_Orem] := "operator suspension removal" - namemap[E_Oresum] := "operator resumption" - namemap[E_Oret] := "operator return" - namemap[E_Osusp] := "operator suspension" - namemap[E_Pause] := "memory monitoring comment" - namemap[E_Pcall] := "procedure call" - namemap[E_Pfail] := "procedure failure" - namemap[E_Pid] := "symbol name" - namemap[E_Prem] := "suspended procedure removal" - namemap[E_Presum] := "procedure resumption" - namemap[E_Pret] := "procedure return" - namemap[E_Proc] := "procedure value pseudo-event" - namemap[E_Psusp] := "procedure suspension" - namemap[E_Rbang] := "record generation" - namemap[E_Rcreate] := "record creation" - namemap[E_Real] := "real allocation" - namemap[E_Record] := "record allocation" - namemap[E_Refresh] := "refresh allocation" - namemap[E_Region] := "region" - namemap[E_Rrand] := "record random reference" - namemap[E_Rref] := "record reference" - namemap[E_Rsub] := "record subscript" - namemap[E_Sbang] := "set generation" - namemap[E_Sconv] := "conversion success" - namemap[E_Screate] := "set creation" - namemap[E_Sdelete] := "set deletion" - namemap[E_Selem] := "set element allocation" - namemap[E_Set] := "set allocation" - namemap[E_Sfail] := "scanning failure" - namemap[E_Sinsert] := "set insertion" - namemap[E_Size] := "region size" - namemap[E_Slots] := "hash header allocation" - namemap[E_Smember] := "set membership" - namemap[E_Snew] := "scanning environment creation" - namemap[E_Spos] := "scanning position" - namemap[E_Srand] := "set random reference" - namemap[E_Srem] := "scanning environment removal" - namemap[E_Sresum] := "scanning resumption" - namemap[E_Ssasgn] := "substring assignment" - namemap[E_Ssusp] := "scanning suspension" - namemap[E_Stack] := "stack depth" - namemap[E_StrDeAlc] := "string deallocation" - namemap[E_String] := "string allocation" - namemap[E_Sval] := "set value" - namemap[E_Sym] := "symbol table entry" - namemap[E_Table] := "table allocation" - namemap[E_Tbang] := "table generation" - namemap[E_Tconv] := "conversion target" - namemap[E_Tcreate] := "table creation" - namemap[E_Tdelete] := "table deletion" - namemap[E_Telem] := "table element allocation" - namemap[E_TenureBlock] := "tenure a block region" - namemap[E_TenureString] := "tenure a string region" - namemap[E_Tick] := "clock tick" - namemap[E_Tinsert] := "table insertion" - namemap[E_Tkey] := "table key generation" - namemap[E_Tmember] := "table membership" - namemap[E_Trand] := "table random reference" - namemap[E_Tref] := "table reference" - namemap[E_Tsub] := "table subscript" - namemap[E_Tval] := "table value" - namemap[E_Tvsubs] := "substring trapped variable allocation" - namemap[E_Tvtbl] := "table-element trapped variable allocation" - namemap[E_Used] := "space used" - namemap[E_Value] := "value assigned" - - twt(namemap) - } - - return namemap[e] - -end diff --git a/ipl/mprocs/evsyms.icn b/ipl/mprocs/evsyms.icn deleted file mode 100644 index 8ccc705..0000000 --- a/ipl/mprocs/evsyms.icn +++ /dev/null @@ -1,160 +0,0 @@ -############################################################################ -# -# File: evsyms.icn -# -# Subject: Procedures to produce table of event codes and symbols -# -# Author: Ralph E. Griswold -# -# Date: October 3, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evsyms() returns returns a two-way table. Indexed by an event code, it -# produces the symbol (global identifier name) for the code. Indexed by the -# symbol of the code, it produces the event code. -# -# This procedure is intended for use in event monitors under MT Icon. -# -############################################################################ -# -# Links: tables -# -############################################################################ -# -# Includes: "evdefs.icn" -# -############################################################################ - -link tables - -$include "evdefs.icn" - -procedure evsyms() - static symmap - - initial { - symmap := table("E_????") - - symmap[E_Aconv] := "E_Aconv" - symmap[E_Alien] := "E_Alien" - symmap[E_Assign] := "E_Assign" - symmap[E_BlkDeAlc] := "E_BlkDeAlc" - symmap[E_Bsusp] := "E_Bsusp" - symmap[E_Coact] := "E_Coact" - symmap[E_Coexpr] := "E_Coexpr" - symmap[E_Cofail] := "E_Cofail" - symmap[E_Collect] := "E_Collect" - symmap[E_Coret] := "E_Coret" - symmap[E_Cset] := "E_Cset" - symmap[E_Ecall] := "E_Ecall" - symmap[E_Efail] := "E_Efail" - symmap[E_Eresum] := "E_Eresum" - symmap[E_Error] := "E_Error" - symmap[E_Esusp] := "E_Esusp" - symmap[E_Erem] := "E_Erem" - symmap[E_Exit] := "E_Exit" - symmap[E_External] := "E_External" - symmap[E_Fcall] := "E_Fcall" - symmap[E_Fconv] := "E_Fconv" - symmap[E_Ffail] := "E_Ffail" - symmap[E_File] := "E_File" - symmap[E_Free] := "E_Free" - symmap[E_Fresum] := "E_Fresum" - symmap[E_Fret] := "E_Fret" - symmap[E_Fsusp] := "E_Fsusp" - symmap[E_Frem] := "E_Frem" - symmap[E_Intcall] := "E_Intcall" - symmap[E_Integer] := "E_Integer" - symmap[E_Intret] := "E_Intret" - symmap[E_Kywdint] := "E_Kywdint" - symmap[E_Kywdpos] := "E_Kywdpos" - symmap[E_Kywdsubj] := "E_Kywdsubj" - symmap[E_Lbang] := "E_Lbang" - symmap[E_Lcreate] := "E_Lcreate" - symmap[E_Lelem] := "E_Lelem" - symmap[E_Line] := "E_Line" - symmap[E_List] := "E_List" - symmap[E_Loc] := "E_Loc" - symmap[E_Lpop] := "E_Lpop" - symmap[E_Lpull] := "E_Lpull" - symmap[E_Lpush] := "E_Lpush" - symmap[E_Lput] := "E_Lput" - symmap[E_Lrand] := "E_Lrand" - symmap[E_Lref] := "E_Lref" - symmap[E_Lrgint] := "E_Lrgint" - symmap[E_Lsub] := "E_Lsub" - symmap[E_Lsusp] := "E_Lsusp" - symmap[E_Nconv] := "E_Nconv" - symmap[E_Null] := "E_Null" - symmap[E_Ocall] := "E_Ocall" - symmap[E_Ofail] := "E_Ofail" - symmap[E_Opcode] := "E_Opcode" - symmap[E_Oresum] := "E_Oresum" - symmap[E_Oret] := "E_Oret" - symmap[E_Osusp] := "E_Osusp" - symmap[E_Orem] := "E_Orem" - symmap[E_Pcall] := "E_Pcall" - symmap[E_Pfail] := "E_Pfail" - symmap[E_Presum] := "E_Presum" - symmap[E_Pret] := "E_Pret" - symmap[E_Proc] := "E_Proc" - symmap[E_Psusp] := "E_Psusp" - symmap[E_Prem] := "E_Prem" - symmap[E_Rbang] := "E_Rbang" - symmap[E_Rcreate] := "E_Rcreate" - symmap[E_Real] := "E_Real" - symmap[E_Record] := "E_Record" - symmap[E_Refresh] := "E_Refresh" - symmap[E_Rrand] := "E_Rrand" - symmap[E_Rref] := "E_Rref" - symmap[E_Rsub] := "E_Rsub" - symmap[E_Sbang] := "E_Sbang" - symmap[E_Sconv] := "E_Sconv" - symmap[E_Screate] := "E_Screate" - symmap[E_Sdelete] := "E_Sdelete" - symmap[E_Selem] := "E_Selem" - symmap[E_Set] := "E_Set" - symmap[E_Sfail] := "E_Sfail" - symmap[E_Sinsert] := "E_Sinsert" - symmap[E_Slots] := "E_Slots" - symmap[E_Smember] := "E_Smember" - symmap[E_Snew] := "E_Snew" - symmap[E_Spos] := "E_Spos" - symmap[E_Srand] := "E_Srand" - symmap[E_Sresum] := "E_Sresum" - symmap[E_Ssasgn] := "E_Ssasgn" - symmap[E_Ssusp] := "E_Ssusp" - symmap[E_Stack] := "E_Stack" - symmap[E_StrDeAlc] := "E_StrDeAlc" - symmap[E_String] := "E_String" - symmap[E_Sval] := "E_Sval" - symmap[E_Srem] := "E_Srem" - symmap[E_Table] := "E_Table" - symmap[E_Tbang] := "E_Tbang" - symmap[E_Tconv] := "E_Tconv" - symmap[E_Tcreate] := "E_Tcreate" - symmap[E_Tdelete] := "E_Tdelete" - symmap[E_Telem] := "E_Telem" - symmap[E_Tick] := "E_Tick" - symmap[E_Tinsert] := "E_Tinsert" - symmap[E_Tkey] := "E_Tkey" - symmap[E_Tmember] := "E_Tmember" - symmap[E_Trand] := "E_Trand" - symmap[E_Tref] := "E_Tref" - symmap[E_Tsub] := "E_Tsub" - symmap[E_Tval] := "E_Tval" - symmap[E_Tvsubs] := "E_Tvsubs" - symmap[E_Tvtbl] := "E_Tvtbl" - symmap[E_Value] := "E_Value" - - symmap := twt(symmap) - } - - return symmap - -end diff --git a/ipl/mprocs/evtmap.icn b/ipl/mprocs/evtmap.icn deleted file mode 100644 index 255adae..0000000 --- a/ipl/mprocs/evtmap.icn +++ /dev/null @@ -1,181 +0,0 @@ -############################################################################ -# -# File: evtmap.icn -# -# Subject: Procedure to map event code names to values -# -# Author: Ralph E. Griswold -# -# Date: July 15, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evtmap(s) returns the event-code value for the event string name s. It -# fails is s is not the name of an event value. -# -############################################################################ -# -# Includes: evdefs.icn, etdefs.icn -# -############################################################################ - -$include "evdefs.icn" -$include "etdefs.icn" - -procedure evtmap(s) #: map event code name to event value - static maptbl - - initial { - maptbl:= table() - - maptbl["E_Aconv"] := "I" - maptbl["E_Alien"] := "z" - maptbl["E_Assign"] := "\347" - maptbl["E_Base"] := "<" - maptbl["E_BlkDeAlc"] := "-" - maptbl["E_Bsusp"] := "b" - maptbl["E_Coact"] := "A" - maptbl["E_Coexpr"] := "x" - maptbl["E_Cofail"] := "D" - maptbl["E_Collect"] := "G" - maptbl["E_Comment"] := "#" - maptbl["E_Coret"] := "B" - maptbl["E_Cset"] := "e" - maptbl["E_Ecall"] := "c" - maptbl["E_Efail"] := "f" - maptbl["E_EndCollect"] := "\360" - maptbl["E_Erem"] := "v" - maptbl["E_Eresum"] := "u" - maptbl["E_Eret"] := "r" - maptbl["E_Error"] := "E" - maptbl["E_Esusp"] := "a" - maptbl["E_Exit"] := "X" - maptbl["E_External"] := "j" - maptbl["E_Fcall"] := ":" - maptbl["E_Fconv"] := "J" - maptbl["E_Ffail"] := "M" - maptbl["E_File"] := "g" - maptbl["E_Free"] := "Z" - maptbl["E_Frem"] := "[" - maptbl["E_Fresum"] := "Y" - maptbl["E_Fret"] := "P" - maptbl["E_Fsusp"] := "W" - maptbl["E_Highlight"] := "H" - maptbl["E_Intcall"] := "\351" - maptbl["E_Integer"] := "@" - maptbl["E_Intret"] := "\352" - maptbl["E_Kywdint"] := "^" - maptbl["E_Kywdpos"] := "&" - maptbl["E_Kywdsubj"] := "*" - maptbl["E_Lbang"] := "\301" - maptbl["E_Lcreate"] := "\302" - maptbl["E_Lelem"] := "m" - maptbl["E_List"] := "k" - maptbl["E_Loc"] := "|" - maptbl["E_Lpop"] := "\303" - maptbl["E_Lpull"] := "\304" - maptbl["E_Lpush"] := "\305" - maptbl["E_Lput"] := "\306" - maptbl["E_Lrand"] := "\307" - maptbl["E_Lref"] := "\310" - maptbl["E_Lrgint"] := "L" - maptbl["E_Lsub"] := "\311" - maptbl["E_Lsusp"] := "l" - maptbl["E_MXevent"] := "\370" - maptbl["E_Nconv"] := "N" - maptbl["E_Null"] := "$" - maptbl["E_Ocall"] := "\\" - maptbl["E_Ofail"] := "]" - maptbl["E_Offset"] := "+" - maptbl["E_Opcode"] := "O" - maptbl["E_Orem"] := "\177" - maptbl["E_Oresum"] := "}" - maptbl["E_Oret"] := "`" - maptbl["E_Osusp"] := "{" - maptbl["E_Pause"] := ";" - maptbl["E_Pcall"] := "C" - maptbl["E_Pfail"] := "F" - maptbl["E_Pid"] := "." - maptbl["E_Prem"] := "V" - maptbl["E_Presum"] := "U" - maptbl["E_Pret"] := "R" - maptbl["E_Proc"] := "%" - maptbl["E_Psusp"] := "S" - maptbl["E_Rbang"] := "\312" - maptbl["E_Rcreate"] := "\313" - maptbl["E_Real"] := "d" - maptbl["E_Record"] := "h" - maptbl["E_Refresh"] := "y" - maptbl["E_Region"] := "?" - maptbl["E_Rrand"] := "\314" - maptbl["E_Rref"] := "\315" - maptbl["E_Rsub"] := "\316" - maptbl["E_Ssasgn"] := "\354" - maptbl["E_Sbang"] := "\317" - maptbl["E_Sconv"] := "Q" - maptbl["E_Screate"] := "\320" - maptbl["E_Sdelete"] := "\321" - maptbl["E_Selem"] := "t" - maptbl["E_Set"] := "q" - maptbl["E_Sfail"] := "\341" - maptbl["E_Sinsert"] := "\322" - maptbl["E_Size"] := ">" - maptbl["E_Slots"] := "w" - maptbl["E_Smember"] := "\323" - maptbl["E_Snew"] := "\340" - maptbl["E_Spos"] := "\346" - maptbl["E_Srand"] := "\336" - maptbl["E_Srem"] := "\344" - maptbl["E_Sresum"] := "\343" - maptbl["E_Ssusp"] := "\342" - maptbl["E_Stack"] := "\353" - maptbl["E_StrDeAlc"] := "~" - maptbl["E_String"] := "s" - maptbl["E_Sval"] := "\324" - maptbl["E_Sym"] := "T" - maptbl["E_Table"] := "n" - maptbl["E_Tbang"] := "\325" - maptbl["E_Tconv"] := "K" - maptbl["E_Tcreate"] := "\326" - maptbl["E_Tdelete"] := "\327" - maptbl["E_Telem"] := "o" - maptbl["E_TenureBlock"] := "\362" - maptbl["E_TenureString"] := "\361" - maptbl["E_Tick"] := "." - maptbl["E_Tinsert"] := "\330" - maptbl["E_Tkey"] := "\331" - maptbl["E_Tmember"] := "\332" - maptbl["E_Trand"] := "\337" - maptbl["E_Tref"] := "\333" - maptbl["E_Tsub"] := "\334" - maptbl["E_Tval"] := "\335" - maptbl["E_Tvsubs"] := "i" - maptbl["E_Tvtbl"] := "p" - maptbl["E_Used"] := "=" - maptbl["E_Value"] := "\350" - - maptbl["T_01"] := "A" - maptbl["T_02"] := "B" - maptbl["T_03"] := "C" - maptbl["T_04"] := "D" - maptbl["T_05"] := "E" - maptbl["T_06"] := "F" - maptbl["T_07"] := "G" - maptbl["T_08"] := "H" - maptbl["T_09"] := "I" - maptbl["T_10"] := "J" - maptbl["T_11"] := "K" - maptbl["T_12"] := "L" - maptbl["T_13"] := "M" - maptbl["T_14"] := "N" - -$define T_Mask1 cset("ABCDEFGHIJKLM") - } - - return \maptbl[s] - -end diff --git a/ipl/mprocs/evutils.icn b/ipl/mprocs/evutils.icn deleted file mode 100644 index c1c847e..0000000 --- a/ipl/mprocs/evutils.icn +++ /dev/null @@ -1,94 +0,0 @@ -############################################################################ -# -# File: evutils.icn -# -# Subject: Procedures to support event monitoring -# -# Author: Clinton L. Jeffery -# -# Date: November 23, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This may not be the latest version of this file, despite the date. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -# -# location() - encodes a two-dimensional location in an integer -# -procedure location(x, y) - return ishift(x, 16) + y -end - -# -# vertical() - returns the y/line/row component of a location -# -procedure vertical(Loc) - return iand(Loc, 65535) # 16 least-significant bits -end - -# -# horizontal - returns the x/column component of a location -# -procedure horizontal(Loc) - return ishift(Loc, -16) # 16 most-significant bits -end - -# -# prog_len() return the number of lines in TP -# Don't call until EvInit() has been called. -# -procedure prog_len() - local basename, fname, f, count - # - # Extract TP's &file keyword - # - basename := fname := keyword("file", EventSource) - if (not (f := open(fname))) & lpath := getenv("LPATH") || " " then { - # - # Search LPATH for the file if it wasn't in the current directory. - # - lpath ? { - while dir := tab(find(" ")) do { - if fname := dir || "/" || basename & (f := open(fname)) then break - } - if /f then fail - } - } - count := 0 - every !f do count +:= 1 - close(f) - return count -end - -# -# procedure_name() - return the name of a procedure -# -procedure procedure_name(p) - return image(p)[10:0] # strip off "procedure " prefix of image -end - -# -# XHeight(w) - return window height in pixels -# -procedure XHeight(w) - /w := &window - return WAttrib(w, "height") -end - -# -# XWidth(w) - return window width in pixels -# -procedure XWidth(w) - /w := &window - return WAttrib(w, "width") -end diff --git a/ipl/mprocs/hexlib.icn b/ipl/mprocs/hexlib.icn deleted file mode 100644 index 4b7d5b9..0000000 --- a/ipl/mprocs/hexlib.icn +++ /dev/null @@ -1,146 +0,0 @@ -############################################################################ -# -# File: hexlib.icn -# -# Subject: Procedures for hexagons -# -# Author: Clinton Jeffery -# -# Date: August 12, 1994 -# -######################################################################### -# -# This file is in the public domain. -# -############################################################################ -# -# This file is used by algae but is not finished or supported. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -global scale,scale2,scale4,scale5,numrows,numcols,drawsegs,drawlefts,drawrights -global drawesegs, q, qq, wHexOutline - -procedure starthex(w) - /scale := 10 - /numrows := 10 - /numcols := 10 - scale2 := 2*scale - scale4 := 4*scale - scale5 := 5*scale - if (numcols % 2) = 0 then numcols +:= 1 - every col := 0 to numcols-1 by 2 do oddcol(w,col*scale4) - every col := 1 to numcols-1 by 2 do evencol(w,col*scale4) -# DrawSegment ! drawsegs -end - -procedure oddcol(w,x) - initial { - i := numrows+1 - i6 := i * 6 - drawlefts := list(i6+1) - drawrights := list(i6+1) - drawsegs := list(i*8+1) - drawlefts[1] := drawrights[1] := drawsegs[1] := w - q := qq := 2 - every i := 0 to numrows do hex(x,i*scale4) - DrawLine ! drawlefts - DrawLine ! drawrights - DrawSegment ! drawsegs - return - } - q := 2 - qq := 2 - every i := 0 to numrows do rehex(x,i*scale4) - DrawLine ! drawlefts - DrawLine ! drawrights - DrawSegment ! drawsegs -end - -procedure evencol(w,x) - initial { - drawesegs := list(numrows*8+1) - drawesegs[1] := w - q := 2 - every i := 0 to numrows-1 do parthex(x,i*scale4+scale2) - DrawSegment ! drawesegs - return - } - q := 2 - every i := 0 to numrows-1 do reparthex(x,i*scale4+scale2) - DrawSegment ! drawesegs -end - -procedure parthex(x,y) - y4 := y + scale4 - drawesegs[q+1] := y4 - drawesegs[q+3] := y4 - drawesegs[q+5] := y - drawesegs[q+7] := y - reparthex(x,y) -end -procedure reparthex(x,y) - x1 := x + scale - x4 := x + scale4 - drawesegs[q ] := x1 - drawesegs[q+2] := x4 - drawesegs[q+4] := x1 - drawesegs[q+6] := x4 - q +:= 8 -end -procedure hex(x,y) - y2 := y + scale2 - y4 := y + scale4 - drawlefts[qq+1] := y - drawlefts[qq+3] := y2 - drawlefts[qq+5] := y4 - drawrights[qq+1] := y - drawrights[qq+3] := y2 - drawrights[qq+5] := y4 - drawsegs[q+1] := y4 - drawsegs[q+3] := y4 - drawsegs[q+5] := y - drawsegs[q+7] := y - rehex(x,y) -end -procedure rehex(x,y) - x1 := x + scale - x4 := x + scale4 - drawlefts[qq] := x1 - drawlefts[qq+2] := x - drawlefts[qq+4] := x1 - drawrights[qq] := x4 - drawrights[qq+2] := x+scale5 - drawrights[qq+4] := x4 - drawsegs[q] := x1 - drawsegs[q+2] := x4 - drawsegs[q+4] := x1 - drawsegs[q+6] := x4 - q +:= 8 - qq +:= 6 -end - -procedure hex_spot(w, row, col) - x := (col-1)*scale4 - y := (row-1)*scale4 - if col % 2 = 0 then y +:= scale2 - x1 := x + scale - x4 := x + scale4 - x5 := x + scale5 - y2 := y + scale2 - y4 := y + scale4 - FillPolygon(w, x1, y, x, y2, x1, y4, x4, y4, x5, y2, x4, y) - DrawLine(wHexOutline, x1, y, x, y2, x1, y4, x4, y4, x5, y2, x4, y, x1, y) -end - -procedure hex_mouse(y,x) - if x % scale4 = 0 then fail - col := x / scale4 + 1 - if col % 2 = 0 then row := (y - scale2) / scale4 + 1 - else row := y / scale4 + 1 - return ishift(col, 16) + row -end diff --git a/ipl/mprocs/loadfile.icn b/ipl/mprocs/loadfile.icn deleted file mode 100644 index 28cd0b2..0000000 --- a/ipl/mprocs/loadfile.icn +++ /dev/null @@ -1,64 +0,0 @@ -############################################################################ -# -# File: loadfile.icn -# -# Subject: Procedure to produce and load program on the fly -# -# Author: Ralph E. Griswold -# -# Date: November 21, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# loadfile(exp, link, ...) produces and loads a program that generates -# the results of exp. The trailing arguments name link -# files needed for the expression. loadfile() returns a procedure -# that generates the results. -# -############################################################################ -# -# Requires: MT-Icon, system(), pipes, /tmp -# -############################################################################ -# -# Links: io -# -############################################################################ - -link io - -procedure loadfile(exp, links[]) #: produce and load program - local output, prog - static name - - output := tempfile("load", ".icn", "/tmp") - - image(output) ? { - ="file(" - name := tab(find(".icn")) - } - - write(output, "invocable all") - every write(output, "link ", image(!links)) - write(output, "procedure main(args)") - write(output, " suspend ", exp) - write(output, "end") - - close(output) - - if system("mticont -o " || name || " -s " || name || - " >/dev/null 2>/dev/null") ~= 0 then fail - - remove(name || ".icn") # remove source code file - - # Load the program - - prog := load(name) | stop("*** load failure in loadfile") - - return variable("main", prog) - -end diff --git a/ipl/mprocs/opname.icn b/ipl/mprocs/opname.icn deleted file mode 100644 index 9c87667..0000000 --- a/ipl/mprocs/opname.icn +++ /dev/null @@ -1,129 +0,0 @@ -############################################################################ -# -# File: opname.icn -# -# Subject: Procedure to map VM opcodes to their names -# -# Author: Ralph E. Griswold -# -# Date: August 8, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# opnames() maps the virtual-machine instruction numbers to symbolic names. -# -############################################################################ - -procedure opname(i) #: map virtual-machine code to name - static opmap - - initial { - opmap := table("") - - opmap[1] := "Asgn" - opmap[2] := "Bang" - opmap[3] := "Cat" - opmap[4] := "Compl" - opmap[5] := "Diff" - opmap[6] := "Div" - opmap[7] := "Eqv" - opmap[8] := "Inter" - opmap[9] := "Lconcat" - opmap[10] := "Lexeq" - opmap[11] := "Lexge" - opmap[12] := "Lexgt" - opmap[13] := "Lexle" - opmap[14] := "Lexlt" - opmap[15] := "Lexne" - opmap[16] := "Minus" - opmap[17] := "Mod" - opmap[18] := "Mult" - opmap[19] := "Neg" - opmap[20] := "Neqv" - opmap[21] := "Nonnull" - opmap[22] := "Null" - opmap[23] := "Number" - opmap[24] := "Numeq" - opmap[25] := "Numge" - opmap[26] := "Numgt" - opmap[27] := "Numle" - opmap[28] := "Numlt" - opmap[29] := "Numne" - opmap[30] := "Plus" - opmap[31] := "Power" - opmap[32] := "Random" - opmap[33] := "Rasgn" - opmap[34] := "Refresh" - opmap[35] := "Rswap" - opmap[36] := "Sect" - opmap[37] := "Size" - opmap[38] := "Subsc" - opmap[39] := "Swap" - opmap[40] := "Tabmat" - opmap[41] := "Toby" - opmap[42] := "Unions" - opmap[43] := "Value" - opmap[44] := "Bscan" - opmap[45] := "Ccase" - opmap[46] := "Chfail" - opmap[47] := "Coact" - opmap[48] := "Cofail" - opmap[49] := "Coret" - opmap[50] := "Create" - opmap[51] := "Cset" - opmap[52] := "Dup" - opmap[53] := "Efail" - opmap[54] := "Eret" - opmap[55] := "Escan" - opmap[56] := "Esusp" - opmap[57] := "Field" - opmap[58] := "Goto" - opmap[59] := "Init" - opmap[60] := "Int" - opmap[61] := "Invoke" - opmap[62] := "Keywd" - opmap[63] := "Limit" - opmap[64] := "Line" - opmap[65] := "Llist" - opmap[66] := "Lsusp" - opmap[67] := "Mark" - opmap[68] := "Pfail" - opmap[69] := "Pnull" - opmap[70] := "Pop" - opmap[71] := "Pret" - opmap[72] := "Psusp" - opmap[73] := "Push1" - opmap[74] := "Pushn1" - opmap[75] := "Real" - opmap[76] := "Sdup" - opmap[77] := "Str" - opmap[78] := "Unmark" - opmap[80] := "Var" - opmap[81] := "Arg" - opmap[82] := "Static" - opmap[83] := "Local" - opmap[84] := "Global" - opmap[85] := "Mark0" - opmap[86] := "Quit" - opmap[87] := "FQuit" - opmap[88] := "Tally" - opmap[89] := "Apply" - opmap[90] := "Acset" - opmap[91] := "Areal" - opmap[92] := "Astr" - opmap[93] := "Aglobal" - opmap[94] := "Astatic" - opmap[95] := "Agoto" - opmap[96] := "Amark" - opmap[98] := "Noop" - opmap[100] := "SymEvents" - opmap[108] := "Colm" - } - - return opmap[i] - -end diff --git a/ipl/mprocs/typebind.icn b/ipl/mprocs/typebind.icn deleted file mode 100644 index 84bf9ec..0000000 --- a/ipl/mprocs/typebind.icn +++ /dev/null @@ -1,56 +0,0 @@ -############################################################################ -# -# File: typebind.icn -# -# Subject: Procedures to produce table of graphic contexts for type -# -# Author: Ralph E. Griswold and Clinton L. Jeffery -# -# Date: March 4, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# typebind(window, codes, opts) returns a table of graphic contexts bound to -# window with foreground colors keyed by type in the string of event codes. -# -# Codes for which there is no corresponding color are ignored. -# -# Note: Event monitoring global identifiers must be linked by the program -# that uses this procedure. -# -############################################################################ -# -# Links: colormap -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -link colormap - -procedure typebind(window, codes, opts) - local code, context - static contexts, color - - initial { - contexts := table() - if /opts then color := colormap("standard") - else color := colormap(opts["p"]) - } - - if /contexts[window] := table() then { - context := contexts[window] - every code := !codes do - context[code] := Clone(window, , "fg=" || \color[code]) - } - contexts[window]["bg"] := Clone(window, "fg=" || WAttrib(window,"bg")) - return contexts[window] - -end - diff --git a/ipl/mprocs/typesyms.icn b/ipl/mprocs/typesyms.icn deleted file mode 100644 index 04dee72..0000000 --- a/ipl/mprocs/typesyms.icn +++ /dev/null @@ -1,71 +0,0 @@ -############################################################################ -# -# File: typesyms.icn -# -# Subject: Procedure to map type codes to event codes -# -# Author: Ralph E. Griswold -# -# Date: June 8, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# typesyms() returns a table that maps type codes to event codes. The -# table can be subscripted either by one-character strings in the style -# of typecode() or by the integer values given by T_type globals. -# -# This procedure is intended for use with event monitors running under -# MT Icon. -# -############################################################################ -# -# See also: typecode.icn -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -procedure typesyms() - static typetable - - initial { - typetable := table() - - typetable["L"] := E_List - typetable["S"] := E_Set - typetable["T"] := E_Table - typetable["R"] := E_Record - typetable["s"] := E_String - typetable["c"] := E_Cset - typetable["i"] := E_Integer - typetable["r"] := E_Real - typetable["f"] := E_File - typetable["n"] := E_Null - typetable["p"] := E_Proc - typetable["C"] := E_Coexpr - - typetable[T_List] := E_List - typetable[T_Set] := E_Set - typetable[T_Table] := E_Table - typetable[T_Record] := E_Record - typetable[T_String] := E_String - typetable[T_Cset] := E_Cset - typetable[T_Integer] := E_Integer - typetable[T_Real] := E_Real - typetable[T_File] := E_File - typetable[T_Null] := E_Null - typetable[T_Proc] := E_Proc - typetable[T_Coexpr] := E_Coexpr - } - - return typetable - -end diff --git a/ipl/mprocs/viewpack.icn b/ipl/mprocs/viewpack.icn deleted file mode 100644 index 1797fd1..0000000 --- a/ipl/mprocs/viewpack.icn +++ /dev/null @@ -1,329 +0,0 @@ -############################################################################ -# -# File: viewpack.icn -# -# Subject: Procedures to visualize color streams -# -# Author: Ralph E. Griswold -# -# Date: May 2, 2001 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# These procedures provide various ways of visualizing a stream of colors. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -$define Hold 300 - -# blinking light - -procedure beacon(win, color, value) #: 1C visualization as blinking light - - Fg(win, color) - FillCircle(win, width / 2, height / 2, width / 2) - WDelay(win, Hold) - -end - -# random curves - -procedure curves(win, color, value) #: 1C visualization as random curves - local x0, y0 - - Fg(win, color) - DrawCurve ! [ - win, - x0 := ?width, y0 := ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - .x0, .y0 - ] - - WDelay(win, Hold) - - return - -end - -# "haystack" - -procedure haystack(win, color, value) #: 2CS visualization as "haystack" - static angle, xcenter, ycenter, xorg, yorg, fullcircle - - initial { - fullcircle := 2 * &pi - ycenter := height / 2 - xcenter := width / 2 - } - - Fg(win, color) - angle := ?0 * fullcircle # angle for locating starting point - xorg := xcenter + ?xcenter * cos(angle) - yorg := ycenter + ?ycenter * sin(angle) - angle := ?0 * fullcircle # angle for locating end point - DrawLine(win, xorg, yorg, value * cos(angle) + - xorg, value * sin(angle) + yorg) - - return - -end - -# "nova" - -$define Scale 1.5 -$define Rays 360 - -procedure nova(win, color, value) #: 1C visualization as exploding star - local clear, xorg, yorg, radius, arc, oldlength, length - static fullcircle, radians, advance, erase - - initial { - fullcircle := 2 * &pi - radians := 0 - advance := fullcircle / Rays # amount to advance - erase := list(Rays) - } - - Fg(win, color) - xorg := width / 2 - yorg := height / 2 - radius := ((height < width) | height) / 2.0 - - length := value * Scale - put(erase, length) - oldlength := get(erase) - -# The following are to erase old ray at that angle - -# DrawLine(Background, xorg, yorg, \oldlength * cos(radians) + xorg, -# oldlength * sin(radians) + yorg) - - DrawLine(win, xorg, yorg, length * cos(radians) + - xorg, length * sin(radians) + yorg) - - radians +:= advance - radians %:= fullcircle - - return - -end - -# "pinwheel" - -$define Sectors 240 - -procedure pinwheel(win, color, value) #: 1C visualization as radar sweep - static clear, xorg, yorg, radius, offset - static arc, advance, blank, max, xratio, yratio - static fullcircle, background - - initial { - fullcircle := 2 * &pi - max := real((width < height) | width) - xratio := width / max - yratio := height / max - offset := 0 - advance := fullcircle / Sectors - blank := 2 * advance - xorg := width / 2 - yorg := height / 2 - radius := max / 2 - - # This belongs elsewhere - - background := Clone(win, "bg=" || default_color) - - } - - Fg(win, color) - FillArc(background, 0, 0, width, height, offset + advance, blank) - FillArc(win, 0, 0, width, height, offset, advance) - DrawLine(background, xorg, yorg, xratio * radius * cos(offset) + - xorg, yratio * radius * sin(offset) + yorg) - - offset +:= advance - offset %:= fullcircle - - return - -end - -# random polygons - -procedure polygons(win, color, value) #: 1C visualization as random polygons - local x0, y0 - - Fg(win, color) - FillPolygon ! [ - win, - x0 := ?width, y0 := ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - .x0, .y0 - ] - - WDelay(win, Hold) - - return - -end - -# random dots - -procedure splatter(win, color, value) #: 2CS visualization as random dots - local radius, xplace, yplace - - Fg(win, color) - radius := sqrt(value) - xplace := ?width - 1 - (radius / 2) - yplace := ?height - 1 - (radius / 2) - FillCircle(win, xplace, yplace, radius) - - return - -end - -# scrolling strip - -procedure strip(win, color, value) #: 2CS visualization as scrolling lines - local count - - Fg(win, color) | "black" - if /value | (value = 0) then return - count := log(value, 10) + 1 - every 1 to count do { - CopyArea(win, 1, 0, width - 1, height, 0, 0) - EraseArea(win, width - 1, 0, width - 1, height) - FillRectangle(win, width - 1, 0, 1, height) - } - - return - -end - -procedure symdraw(W, mid, x, y, r) - - FillCircle(W, mid + x, mid + y, r) - FillCircle(W, mid + x, mid - y, r) - FillCircle(W, mid - x, mid + y, r) - FillCircle(W, mid - x, mid - y, r) - - FillCircle(W, mid + y, mid + x, r) - FillCircle(W, mid + y, mid - x, r) - FillCircle(W, mid - y, mid + x, r) - FillCircle(W, mid - y, mid - x, r) - - return - -end - -# symmetric random dots - -procedure symsplat(win, color, value) #: 2CS visualization as symmetric random dots - local radius - static xplace, yplace, oscale - - Fg(win, color) - radius := sqrt(value) - xplace := ?width - 1 - yplace := ?height - 1 - symdraw(win, width / 2, xplace, yplace, radius) - - return - -end - -# evolving vortex - -procedure vortex(win, color, value) #: 1C visualization as an aspirating vortex - local count - static x1, x2, y1, y2 - - initial { - x1 := y1 := 0 - x2 := width - y2 := height - } - - Fg(win, color) - if value = 0 then return - count := log(value, 10) + 1 - every 1 to count do { - if (x2 | y2) < 0 then { - x1 := y1 := 0 - x2 := width - y2 := height - } - DrawRectangle(win, x1, y1, x2 - x1, y2 - y1) - x1 +:= 1 - x2 -:= 1 - y1 +:= 1 - y2 -:= 1 - } - - return - -end - -# random walk -# -# This procedure is suspect -- it seems to wander off the display area. - -$define Delta 30 - -procedure web(win, color, value) #: 2CS visualization as a random walk - static xorg, yorg, x, y, angle, degrees, radians, resid - - initial { - resid := 0 - xorg := ?(width - 1) # starting point - yorg := ?(height - 1) - } - - Fg(win, color) - if resid <= 1 then { - angle := ?0 * 2 * &pi # initial direction for new walk - resid := value - } - - x := xorg + resid * cos(angle) - y := yorg + resid * sin(angle) - - if x > width then { - x := width - } - if y > height then { - y := height - } - if x < 0 then { - x := 0 - } - if y < 0 then { - y := 0 - } - DrawLine(win, xorg, yorg, x, y) - resid -:= sqrt((x - xorg) ^ 2 + (y - yorg) ^ 2) - xorg := x # move to new point - yorg := y - angle := -angle # reflect - - return - -end diff --git a/ipl/mprogs/alcscope.icn b/ipl/mprogs/alcscope.icn deleted file mode 100644 index 2629cf6..0000000 --- a/ipl/mprogs/alcscope.icn +++ /dev/null @@ -1,312 +0,0 @@ -############################################################################ -# -# File: alcscope.icn -# -# Subject: Program to visualize allocation as a kaleidoscopic display -# -# Author: Ralph E. Griswold -# -# Date: July 14, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program displays kaleidoscopic images. The controls on the -# user interface are relatively intuitive -- trying them will give -# a better idea of what's possible than a prose description here. -# -# This program is based on an earlier one by Steve Wampler, which in -# turn was based on a C program by Lorraine Callahan. -# -# This version is adapted to visualize storage management. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: interact, random, vsetup -# -############################################################################ - -link interact -link vsetup -link colormap -link evinit - -# Interface globals - -global vidgets # table of vidgets -global root # the root vidget -global size # size of view area (width & height) -global half # half size of view area -global pane # graphics context for viewing - -# Parameters that can be set from the interface - -global delayval # delay between drawing circles -global density # number of circles in steady state -global draw_proc # drawing procedure -global max_off # maximum offset of circle -global min_off # minimum offset of circle -global scale # scaling factor for sizes -global color # color table - -# State information - -global draw_list # list of pending drawing parameters -global reset # nonnull when view area needs resetting -global state # nonnull when display paused - -$include "evdefs.icn" - -procedure main(args) - - init(args) - - kaleidoscope() - -end - -procedure init(args) - - color := colormap() - - vidgets := ui() - - root := vidgets["root"] - size := vidgets["region"].uw - if vidgets["region"].uh ~= size then stop("*** improper interface layout") - -# Set initial values. - - draw_proc := FillCircle - - state := &null - -# Initialize vidget values. - - density := VGetState(vidgets["density"]) - delayval := VGetState(vidgets["speed"]) - scale := VGetState(vidgets["scale"]) - VSetState(vidgets["shape"], "rings") - -# Get graphics context for drawing. - - half := size / 2 - - pane := Clone("bg=black", "dx=" || (vidgets["region"].ux + half), - "dy=" || (vidgets["region"].uy + half), "drawop=reverse") - Clip(pane, -half, -half, size, size) - - EvInit(args) | ExitNotice("Cannot load SP.") - - every variable("write" | "writes", &eventsource) := -1 - - return - -end - -procedure kaleidoscope() - - # Each time through this loop, the display is cleared and a - # new drawing is started. - - repeat { - - EraseArea(pane, -half, -half, size, size) # clear display - draw_list := [] # new drawing list - reset := &null - - # In this loop a new circle is drawn and an old one erased, once the - # specified density has been reached. This maintains a steady state. - - repeat { - while (*Pending() > 0) | \state do { - ProcessEvent(root, , shortcuts) - if \reset then break break next - } - putcircle() - WDelay(delayval) - - # Don't start clearing circles until the specified density has - # reached. (The drawing list has four elements for each circle.) - - if *draw_list > (4 * density) then clrcircle() - } - } - -end - -procedure putcircle() - local off1, off2, radius, fg - - EvGet(AllocMask) | ExitNotice("SP terminated.") - - fg := color[&eventcode] - radius := sqrt(&eventvalue * scale) - - # get a random center point and radius - - off1 := ?size % half - off2 := ?size % half - - put(draw_list, off1, off2, radius, fg) - - outcircle(off1, off2, radius, fg) - - return - -end - -procedure clrcircle() - - outcircle( - get(draw_list), # off1 - get(draw_list), # off2 - get(draw_list), # radius - get(draw_list) # color - ) - - return - -end - -procedure outcircle(off1, off2, radius, color) - - Fg(pane, color) - - # Draw in symmetric positions. - - draw_proc(pane, off1, off2, radius) - draw_proc(pane, off1, -off2, radius) - draw_proc(pane, -off1, off2, radius) - draw_proc(pane, -off1,-off2, radius) - draw_proc(pane, off2, off1, radius) - draw_proc(pane, off2, -off1, radius) - draw_proc(pane, -off2, off1, radius) - draw_proc(pane, -off2,-off1, radius) - - return - -end - -procedure density_cb(vidget, value) - - density := value - - reset := 1 - -end - -procedure speed_cb(vidget, value) - - delayval := value - - return - -end - -procedure file_cb(vidget, value) - - case value[1] of { - "snapshot @S": snapshot(pane, -half, -half, size, size) - "quit @Q": exit() - } - - return - -end - -procedure scale_cb(vidget, value) - - scale := value - - return - -end - -procedure pause_cb(vidget, value) - - state := value - - return - -end - -procedure reset_cb(vidget, value) - - reset := 1 - - return - -end - -procedure shape_cb(vidget, value) - - draw_proc := case value of { - "discs": FillCircle - "rings": DrawCircle - } - - reset := 1 - - return - -end - -procedure shortcuts(e) - - if &meta then - case map(e) of { # fold case - "q": exit() - "s": snapshot(pane, -half, -half, size, size) - } - - return - -end - -#===<>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=600,455", "bg=gray-white", "label=kaleido"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,600,455:kaleido",], - ["density:Slider:h:1:41,171,100,15:10,100,50",density_cb], - ["file:Menu:pull::12,3,36,21:File",file_cb, - ["snapshot @S","quit @Q"]], - ["label07:Label:::7,120,28,13:slow",], - ["label08:Label:::151,120,28,13:fast",], - ["label10:Label:::64,270,7,13:1",], - ["label11:Label:::124,270,7,13:5",], - ["label12:Label:::47,200,14,13:10",], - ["label13:Label:::116,200,21,13:100",], - ["label14:Label:::78,200,14,13:50",], - ["label9:Label:::43,270,14,13:.2",], - ["lbl_density:Label:::67,151,49,13:density",], - ["lbl_scale:Label:::74,220,35,13:scale",], - ["lbl_speed:Label:::74,100,35,13:speed",], - ["line:Line:::0,30,600,30:",], - ["line1:Line:::68,256,68,266:",], - ["line2:Line:::128,256,128,266:",], - ["line3:Line:::54,256,54,266:",], - ["line4:Line:::128,186,128,196:",], - ["line5:Line:::55,186,55,196:",], - ["line6:Line:::86,186,86,196:",], - ["pause:Button:regular:1:33,55,45,20:pause",pause_cb], - ["reset:Button:regular::111,55,45,20:reset",reset_cb], - ["scale:Slider:h:1:42,240,100,15:0.1,5,1",scale_cb], - ["shape:Choice::2:64,330,64,42:",shape_cb, - ["discs","rings"]], - ["speed:Slider:h:1:41,121,100,15:100,0,0",speed_cb], - ["region:Rect:raised::187,42,400,400:",], - ) -end -#===<>=== end of section maintained by vib diff --git a/ipl/mprogs/alcview.icn b/ipl/mprogs/alcview.icn deleted file mode 100644 index 85a007a..0000000 --- a/ipl/mprogs/alcview.icn +++ /dev/null @@ -1,258 +0,0 @@ -########################################################################### -# -# File: alcview.icn -# -# Subject: Program to display allocation events in various ways -# -# Author: Ralph E. Griswold -# -# Date: February 16, 1998 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program maps allocation events into colors and provides various -# abstract visualizations of them. -# -# Several visualizations are available: -# -# beacon blinking light -# curves random closed curves -# haystack* randomly oriented lines -# nova* radiating lines -# pinwheel revolving sequence of sectors in a circle -# polygons random polygons -# splatter* randomly placed dots -# strip scrolling strip of vertical lines -# symplat as splatter, but in symmetric pattern -# vortex* expanding/contracting square vortex -# web* random walk -# -# The visualizations marked with asterisks use the size information. The -# others do not. -# -# In terms of the monitoring framework terminology, this program -# provides abstract visualizations for in an event space consisting -# of category/size pairs -- 2CS -- in which the categories are colors. -# -# The interface controls provide for: -# -# control of the display speed -# pausing the display -# resetting the display -# setting the period between automatic resetting -# changing the view -# -############################################################################ -# -# Requires: MT Icon, event monitoring, Version 9 graphics -# -############################################################################ -# -# Links: colormap, evinit, interact, viewpack, vsetup -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link colormap -link evinit -link interact -link viewpack -link vsetup - -$include "evdefs.icn" - -global color -global vidgets -global viewer -global root -global pane -global state -global reset # vidget for resetting callback -global snap -global name -global point -global count # drawing count -global done -global default_color # default in case of bad color specification -global draw # drawing procedure for visualization -global width -global height -global period # automatic resetting count -global refresh # resetting switch - -# Prevent linker from deleting procedures that are not explicitly referenced. -invocable "beacon" -invocable "curves" -invocable "haystack" -invocable "nova" -invocable "pinwheel" -invocable "polygons" -invocable "splatter" -invocable "strip" -invocable "symsplat" -invocable "vortex" -invocable "web" - -# Main procedure - -procedure main(args) - - init(args) - - display() - -end - -# Initialization - -procedure init(args) - - EvInit(args) | stop("*** cannot load SP.") - - vidgets := ui() - - root := vidgets["root"] - reset := vidgets["reset"] - - state := &null - - width := vidgets["pane"].uw - height := vidgets["pane"].uh - - default_color := "black" - - refresh := period := -1 - count := 0 - done := &null - - viewer := "symsplat" - - color := colormap() - - draw := proc(viewer) | stop("*** internal inconsistency") - - pane := Clone("dx=" || vidgets["pane"].ux, "dy=" || vidgets["pane"].uy, - "bg=" || default_color) - Clip(pane, 0, 0, width, height) - - reset_cb() - -end - -# Display driver - -procedure display() - - repeat { - if period = 0 then reset_cb() - while (*Pending() > 0) | \state do - ProcessEvent(root, , shortcuts) - EvGet(AllocMask) | exit() - draw(pane, color[&eventcode], &eventvalue) - period -:= 1 - } - -end - -# Callbacks - -procedure quit_cb() - - exit() - -end - -procedure snapshot_cb() - - snapshot(pane, 0, 0, width, height) - - return - -end - -procedure period_cb() - - repeat { - if TextDialog("Reset period (negative value disables _ - automatic resetting:", , refresh, 6) == "Cancel" then fail - if refresh := period := integer(dialog_value[1]) then return - else { - Notice("Invalid period specification.") - next - } - } - -end - -procedure reset_cb() - - EraseArea(pane, 0, 0, width, height) - - period := refresh - - return - -end - -procedure view_cb() - static views - - initial { - views := [ - "beacon", - "curves", - "haystack", - "nova", - "pinwheel", - "polygons", - "splatter", - "strip", - "symsplat", - "vortex", - "web" - ] - } - - if SelectDialog("Select viewer:", views, viewer) == "Cancel" then fail - viewer := dialog_value - draw := proc(viewer) | - return FailNotice("Internal inconsistency; viewer not found.") - reset_cb() - - return - -end - -procedure shortcuts(e) - - if &meta then - case map(e) of { - "q": exit() - "r": reset_cb() - } - -end - -#===<>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=311,210", "bg=pale gray"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,311,210:",], - ["period:Button:regular::11,96,91,20:reset period",period_cb], - ["quit:Button:regular::34,19,42,20:quit",quit_cb], - ["reset:Button:regular::34,55,42,20:reset",reset_cb], - ["view:Button:regular::15,133,84,20:select view",view_cb], - ["pane:Rect:grooved::113,9,190,190:",], - ) -end -#===<>=== end of section maintained by vib diff --git a/ipl/mprogs/algae.icn b/ipl/mprogs/algae.icn deleted file mode 100644 index 1a92952..0000000 --- a/ipl/mprogs/algae.icn +++ /dev/null @@ -1,356 +0,0 @@ -######################################################################### -# -# File: algae.icn -# -# Subject: Program to show expression evaluation as ``algae'' -# -# Author: Clinton Jeffery -# -# Date: November 22, 1997 -# -######################################################################### -# -# This file is in the public domain. -# -############################################################################ -# -# Press ESC or q to quit -# Left mouse assigns specific (row,column) break "points" -# Middle mouse assigns absolute depth and width break lines -# Right button erases assigned break "points" -# -# When paused due to a break, you can: -# -# c to continue -# s to single step -# C to clear one point and continue -# " " to clear everything and continue -# -######################################################################### -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link evutils -link options -link optwindw -link hexlib -link evaltree - -global scale, # cell (hexagon or square) size - step, # single step mode - numrows, # number of cell rows - numcols, # number of cell columns - spot, # cell-fill procedure (hex or square) - mouse, # cell-mouse-locator procedure - Visualization, # the window - wHexOutline, # binding for drawing cell outlines - depthbound, # call-depth on which to break - breadthbound, # suspension-width on which to break - hotspots # table of individual cells on which to break - -record algae_activation(node, row, column, parent, children, color) - - -# -# main() - program entry point. The main loop is in evaltree(). -# -procedure main(av) - local codes, algaeoptions - # - # pull off algae options (don't consume child's options in this call - # to options()). - # - algaeoptions := [] - while av[1][1] == "-" do { - put(algaeoptions, pop(av)) - if algaeoptions[-1] == "-f" then put(algaeoptions, pop(av)) - } - EvInit(av) | stop("Can't EvInit ",av[1]) - codes := algae_init(algaeoptions) - evaltree(codes, algae_callback, algae_activation) - WAttrib("windowlabel=Algae: finished") - EvTerm(&window) -end - -# -# algae_init() - initialization and command-line processing. -# This procedure supplies default behavior and handles options. -# -procedure algae_init(algaeoptions) - local t, position, geo, codes, i, cb, coord, e, s, x, y, m, row, column - t := options(algaeoptions, - winoptions() || "P:S:-geo:-square!-func!-scan!-op!-noproc!") - /t["L"] := "Algae" - /t["B"] := "cyan" - scale := \t["S"] | 12 - if \t["square"] then { - spot := square_spot - mouse := square_mouse - } - else { - scale /:= 4 - spot := hex_spot - mouse := hex_mouse - } - codes := cset(E_MXevent) - if /t["noproc"] then codes ++:= ProcMask - if \t["scan"] then codes ++:= ScanMask - if \t["func"] then codes ++:= FncMask - if \t["op"] then codes ++:= OperMask - hotspots := table() - &window := Visualization := optwindow(t) | stop("no window") - numrows := (XHeight() / (scale * 4)) - numcols := (XWidth() / (scale * 4)) - wHexOutline := Color("white") # used by the hexagon library - if /t["square"] then starthex(Color("black")) - return codes -end - -# -# algae_callback() - evaltree callback procedure for algae. -# Called for each event, it updates the screen to correspond -# to the change in the activation tree. -# -procedure algae_callback(new, old) - local coord, e - initial { - old.row := old.parent.row := 0; old.column := old.parent.column := 1 - } - case &eventcode of { - !CallCodes: { - new.column := (old.children[-2].column + 1 | computeCol(old)) | stop("eh?") - new.row := old.row + 1 - new.color := Color(&eventcode) - spot(\old.color, old.row, old.column) - } - !ReturnCodes | - !FailCodes: spot(Color("light blue"), old.row, old.column) - !SuspendCodes | - !ResumeCodes: spot(old.color, old.row, old.column) - !RemoveCodes: { - spot(Color("black"), old.row, old.column) - WFlush(Color("black")) - delay(100) - spot(Color("light blue"), old.row, old.column) - } - E_MXevent: do1event(&eventvalue, new) - } - spot(Color("yellow"), new.row, new.column) - coord := location(new.column, new.row) - if \step | (\breadthbound <= new.column) | (\depthbound <= new.row) | - \ hotspots[coord] then { - step := &null - WAttrib("windowlabel=Algae stopped: (s)tep (c)ont ( )clear ") - while e := Event() do - if do1event(e, new) then break - WAttrib("windowlabel=Algae") - if \ hotspots[coord] then spot(Color("light blue"), new.row, new.column) - } -end - - -# -# procedures for the "-square" option, display Algae using squares -# instead of hexagons. -# - -# Draw a square at (row, column) -procedure square_spot(w, row, column) - FillRectangle(w, (column - 1) * scale, (row - 1) * scale, scale, scale) -end - - -# encode a location value (base 1) for a given x and y pixel -procedure square_mouse(y, x) - return location(x / scale + 1, y / scale + 1) -end - -# -# clearspot() removes a "breakpoint" at (x,y) -# -procedure clearspot(spot) - local x, y, s2, x2, y2 - - hotspots[spot] := &null - y := vertical(spot) - x := horizontal(spot) - every s2 := \!hotspots do { - x2 := horizontal(s2) - y2 := vertical(s2) - } - spot(Visualization, y, x) -end - -# -# setspot() sets a breakpoint at (x,y) and marks it orange -# -procedure setspot(loc) - local x, y - - hotspots[loc] := loc - y := vertical(loc) - x := horizontal(loc) - spot(Color("orange"), y, x) -end - -# -# do1event() processes a single user input event. -# -procedure do1event(e, new) - local m, xbound, ybound, row, column, x, y, s, p - - case e of { - "q" | - "\e": exit() - "s": { # execute a single step - step := 1 - return - } - "C": { # clear a single break point - clearspot(location(new.column, new.row)) - return - } - " ": { # space character: clear all break points - if \depthbound then { - every y := 1 to numcols do { - if not who_is_at(depthbound, y, new) then - spot(Visualization, depthbound, y) - } - } - if \breadthbound then { - every x := 1 to numrows do { - if not who_is_at(x, breadthbound, new) then - spot(Visualization, x, breadthbound) - } - } - every s := \!hotspots do { - x := horizontal(s) - y := vertical(s) - spot(Visualization, y, x) - } - hotspots := table() - depthbound := breadthbound := &null - return - } - &mpress | &mdrag: { # middle button: set bound box break lines - if m := mouse(&y, &x) then { - row := vertical(m) - column := horizontal(m) - if \depthbound then { # erase previous bounding box, if any - every spot(Visualization, depthbound, 1 to breadthbound) - every spot(Visualization, 1 to depthbound, breadthbound) - } - depthbound := row - breadthbound := column - # - # draw new bounding box - # - every x := 1 to breadthbound do { - if not who_is_at(depthbound, x, new) then - spot(Color("orange"), depthbound, x) - } - every y := 1 to depthbound - 1 do { - if not who_is_at(y, breadthbound, new) then - spot(Color("orange"), y, breadthbound) - } - } - } - &lpress | &ldrag: { # left button: toggle single cell breakpoint - if m := mouse(&y, &x) then { - xbound := horizontal(m) - ybound := vertical(m) - if hotspots[m] === m then - clearspot(m) - else - setspot(m) - } - } - &rpress | &rdrag: { # right button: report node at mouse location - if m := mouse(&y, &x) then { - column := horizontal(m) - row := vertical(m) - if p := who_is_at(row, column, new) then - WAttrib("windowlabel=Algae " || image(p.node)) - } - } - } -end - -# -# who_is_at() - find the activation tree node at a given (row, column) location -# -procedure who_is_at(row, col, node) - while node.row > 1 & \node.parent do - node := node.parent - return sub_who(row, col, node) # search children -end - -# -# sub_who() - recursive search for the tree node at (row, column) -# -procedure sub_who(row, column, p) - local k - if p.column === column & p.row === row then return p - else { - every k := !p.children do - if q := sub_who(row, column, k) then return q - } -end - -# -# computeCol() - determine the correct column for a new child of a node. -# -procedure computeCol(parent) - local col, x, node - node := parent - while \node.row > 1 do # find root - node := \node.parent - if node === parent then return parent.column - if col := subcompute(node, parent.row + 1) then { - return max(col, parent.column) - } - else return parent.column -end - -# -# subcompute() - recursive search for the leftmost tree node at depth row -# -procedure subcompute(node, row) - # check this level for correct depth - if \node.row = row then return node.column + 1 - # search children from right to left - return subcompute(node.children[*node.children to 1 by -1], row) -end - -# -# Color(s) - return a binding of &window with foreground color s; -# allocate at most one binding per color. -# -procedure Color(s) - static t, magenta - initial { - magenta := Clone(&window, "fg=magenta") | stop("no magenta") - t := table() - /t[E_Fcall] := Clone(&window, "fg=red") | stop("no red") - /t[E_Ocall] := Clone(&window, "fg=chocolate") | stop("no chocolate") - /t[E_Snew] := Clone(&window, "fg=purple") | stop("no purple") - } - if *s > 1 then - / t[s] := Clone(&window, "fg=" || s) | stop("no ",image(s)) - else - / t[s] := magenta - return t[s] -end - -procedure max(x,y) - if x < y then return y else return x -end diff --git a/ipl/mprogs/allocwrl.icn b/ipl/mprogs/allocwrl.icn deleted file mode 100644 index 8521a8f..0000000 --- a/ipl/mprogs/allocwrl.icn +++ /dev/null @@ -1,167 +0,0 @@ -############################################################################ -# -# File: allocwrl.icn -# -# Subject: Program to display storage allocation in VRML -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program produces VRML 1.0 worlds with shapes representing storage -# allocation in the program it monitors. -# -# The structures normally are laid out in the x-z plane along a path with -# the shapes rising in the y direction. The size of the allocation -# determines the size of the shapes. The same shape is used for all -# allocations, but the color indicates the type of allocation. -# -# The kinds of allocation modeled are given by masks: -# -# structs only allocation related to Icon's structure types -# blocks all allocations in the block region -# non-structs all allocations except for structures -# -# The supported shapes are: -# -# cylinder -# cuboid -# cone -# -# In this version, if the path file is exhausted before the SP terminates, -# the path file is closed and reopened. -# -############################################################################ -# -# Requires: MT Icon -# -############################################################################ -# -# Links: colormap, dialog, emutils, evinit, interact, options, vrml, -# vrml1lib -# -############################################################################ - -link colormap -link dialog -link emutils -link evinit -link interact -link vrml -link vrml1lib - -$include "evdefs.icn" - -procedure main(args) - local model, color_table, code, object_list, trans, mask, object - local path, input, scale, steps, symbol, hfactor, color, shape - local ashape, output - - if TextDialog("Configuration:", - ["SP", "path file", "coordinate scale", "shape scale", - "number of events", "mask", "shape", "world file"], - ["structalc", "line.path", 10.0, 0.2, - 200, "structs", "cylinder", "alloc.wrl"], - [15, 30, 5, 5, 5, 10, 10, 20] - ) == "Cancel" then exit() - - args := [dialog_value[1]] - path := dialog_value[2] - scale := dialog_value[3] - hfactor := dialog_value[4] - steps := dialog_value[5] - mask := case dialog_value[6] of { - "structs" | &null: cset(E_List || E_Lelem || E_Record || E_Selem || - E_Set || E_Slots || E_Table || E_Telem || E_Tvtbl) - "blocks": AllocMask -- (E_String || E_Coexpr) - "strings": cset(E_String) - default: ExitNotice("Invalid mask.") - } - ashape := case dialog_value[7] of { - "cylinder" | &null: Cylinder(2, 2) - "cuboid": Cube(4, 2, 4) - "cone": Cone(2, 2) - default: ExitNotice("Invalid shape.") - } - output := open(dialog_value[8], "w") | - ExitNotice("Cannot open " || dialog_value[8]) - - EvInit(args) | ExitNotice("Cannot load SP.") - - variable("write", &eventsource) := -1 # turn off output in SP - variable("writes", &eventsource) := -1 - - model := [] # list of children - - color_table := colormap() # standard colors - - every code := key(color_table) do { # convert colors to shapes - color := vrml_color(color_table[code]) # standard color - symbol := evsym(code) # use event code name - shape := Separator([ - Material(color), # diffuse color only - Translation("0 1 0"), - ashape, - Translation("0 -1 0") - ]) - - color_table[code] := USE(symbol) # put USE node in table - put(model, DEF(symbol, shape)) # create DEF node - } - - model := [Switch(-1, model)] - - input := open(path) | ExitNotice("Cannot open path file.") - - trans := "0 0 0" # initial "translation" - - every 1 to steps do { - EvGet(mask) | { # get allocation event - write(&errout, "*** event stream terminated") - break - } - object := \color_table[&eventcode] | { # get shape - write(&errout, "*** no entry for ", evsym(&eventcode)) - next - } - trans := Translation(scale_translate(read(input), scale)) | { - Notice("Path ended.") - break - } - put( - model, - Separator([ - trans, - Transform(, , "1.0 " || (&eventvalue * hfactor) || " 1.0"), - object - ]) - ) - } - - vrml1(Group(model), output) # generate world - -end - -procedure scale_translate(s, n) - local x, y, z - - s ? { - x := tab(find(" ")) - move(1) - y := tab(find(" ")) - move(1) - z := tab(0) - } - - return (x * n) || " " || (y * n) || " " || (z * n) - -end - - - diff --git a/ipl/mprogs/anim.icn b/ipl/mprogs/anim.icn deleted file mode 100644 index 604acca..0000000 --- a/ipl/mprogs/anim.icn +++ /dev/null @@ -1,254 +0,0 @@ -############################################################################ -# -# File: anim.icn -# -# Subject: Program to show animated display of Icon source code -# -# Author: Gregg M. Townsend, modified by Ralph E. Griswold -# -# Date: February 28, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# anim displays a miniaturized program listing, highlighting each -# line as it is executed. -# -# Two accompanying barcharts display execution profiles. The one on -# the extreme left shows the number of clock ticks attributable to each -# source line. The second chart shows the number of times each line was -# executed. -# -# A chart to the right of the listing displays a time-based history -# similar to that of the "roll" program (q.v.). -# -# usage: anim [options] [arg...] -# -# -d n decay after n new line events -# -b n length of barcharts (0 to disable) -# -z n length of history (0 to disable) -# -t n ticks per history pixel -# -# -s n vertical line spacing, in pixels -# -w n width of one character, in pixels -# -h n height of one character, in pixels -# -p n set in pointsize n (OpenWindows only; overrides -w and -h) -# -# -P x program text color -# -C x comment color -# -A x active text color -# -O x old-text color (after fading) -# -R x background color for barcharts and history -# -S n spacing between sections of the display -# -# plus standard options from optwindow.icn -# (-F sets the color used for the barcharts and history) -# -# Setting -s or -p establishes good defaults for the other sizes. -# -# It is assumed that the program source file can be found by appending -# ".icn" to the icode file name. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, evinit, evmux, barchart, decay, options, optwindw, -# strpchrt -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link evinit -link evmux -link barchart -link decay -link options -link optwindw -link strpchrt - -global progname, opttab, ifile, font -global gcP, gcC, gcA, gcO, gcR -global margin, gutter, textx -global code, pos1, pos2 -global xsiz, ysiz, spacing, dp - -procedure main(args) - local win, len, lno, cs, i, maxlines, lifetime - local hchart, hlength, hscale - local barlength, barwidth, linescale, linecount, linebars - local nticks, tickscale, tickcount, tickbars - local src, linemask - - linemask := 2 ^ 16 -1 - progname := "anim" - maxlines := 1000 - opttab := options (args, winoptions() || "d+b+z+t+s+w+h+p+P:C:A:O:R:S:") - lifetime := \opttab["d"] | 3 - barlength := \opttab["b"] | 40 - hlength := \opttab["z"] | 90 - tickscale := 1.00 - linescale := 0.25 - hscale := \opttab["t"] | 10 - gutter := \opttab["S"] | 10 - - # default to tiny-text mode under OpenWindows - if (not \opttab[!"swhp"]) & getenv ("NEWSSERVER") then - opttab["p"] := 6 - - if i := \opttab["p"] then { - i >:= 13 # maximum size - font := "lucidasanstypewriter-" || i - # -p 1 2 3 4 5 6 7 8 9 10 11 12 13 - xsiz := [1,1,2,2,3,4,4, 5, 5 ,6, 7, 7, 8] [i] - ysiz := [2,3,4,5,7,8,9,10,11,11,12,13,14] [i] - spacing := \opttab["s"] | i - } - else { - spacing := \opttab["s"] | \opttab["h"] + 1 | 4 - xsiz := \opttab["w"] | 0 < integer (0.6 * spacing + 0.5) | 1 - ysiz := \opttab["h"] | 0 < spacing - 1 | 1 - } - - EvInit (args) | stop ("can't load icode file") - - # read source file into memory - - src := prog_name() - ifile := open(src) | stop (progname, ": can't open ", src) - every put(code := [], detab(trim(!ifile \ maxlines))) - - pos1 := list(*code) - pos2 := list(*code) - every i := 1 to *code do - code[i] ? { - tab(many(' ')) - if pos(0) | ="#" then next - pos1[i] := &pos - pos2[i] := pos1[i] + *trim(tab(upto('#')|0)) - } - - if /opttab["W"] then { # calculate window width if not specified - len := 0 - every len <:= *!code - len *:= xsiz - if barlength > 0 then - len +:= 2 * barlength + 2 * gutter - if hlength > 0 then - len +:= gutter + hlength - opttab["W"] := len - } - - /opttab["H"] := spacing * *code - /opttab["L"] := "Anim" - /opttab["F"] := "goldenrod" - /opttab["R"] := "floralwhite" - /opttab["M"] := -1 - win := optwindow (opttab, "cursor=off", "echo=off") - if \font then - Font (win, font) | stop ("can't set font ", font) - margin := opttab["M"] - - Bg (gcR := Clone(win), opttab["R"]) - - if barlength = 0 then - textx := margin - else { - barwidth := spacing - 1 - if barwidth = 0 then - barwidth := 1 - tickcount := list (*code, 0) - tickbars := barchart (gcR, margin+barlength-1, margin, - 0, spacing, -tickscale, *code, barlength, barwidth) - linecount := list (*code, 0) - linebars := barchart (gcR, margin+barlength+gutter+barlength-1, margin, - 0, spacing, -linescale, *code, barlength, barwidth) - textx := margin + 2 * gutter + 2 * barlength - } - - if hlength > 0 then { - hchart := stripchart (gcR, margin + opttab["W"] - hlength, margin, - hlength, spacing * *code) - } - - if \font then { - Fg (gcP := Clone(win), \opttab["P"] | "gray70") - Fg (gcC := Clone(win), \opttab["C"] | "gray90") - Fg (gcO := Clone(win), \opttab["O"] | "black") - Bg (gcA := Clone(gcO), \opttab["A"] | "red") - } - else { - Fg (gcP := Clone(win), \opttab["P"] | "gray70") - Fg (gcC := Clone(win), \opttab["C"] | "gray90") - Fg (gcA := Clone(win), \opttab["P"] | "indianred") - Fg (gcO := Clone(win), \opttab["O"] | "peachpuff") - } - - every i := 1 to *code do { - docmt (gcC, i) # show comments - docode (gcP, i) # show initial code listing - } - - dp := dpipe (docode, lifetime, gcA, gcO) # initialize decay pipe - cs := E_Loc ++ E_Tick - nticks := 0 - - while EvGet (cs) do # for each line event - if &eventcode === E_Loc then { - decay (dp, lno := iand(&eventvalue, linemask)) # mark line - setbar (\linebars, lno, linecount[lno] +:= 1) - smark (\hchart, margin + spacing * (lno-1), margin + spacing * lno - 1) - } - else if &eventcode === E_Tick then { - setbar (\tickbars, \lno, tickcount[\lno] +:= 1) - if (nticks +:= 1) % hscale = 0 then - sadvance (\hchart) - } - - every 1 to lifetime do - decay (dp) # flush decay pipe - quitsensor (win, 1) # wait for quit signal - end - -procedure docode (gc, lno) - doblock (gc, lno, \pos1[lno], pos2[lno]); - return - end - -procedure docmt (gc, lno) - local p - code[lno] ? { - tab(upto('#')) | return - while not pos(0) do { - p := &pos - doblock (gc, lno, p, tab(upto(' ')|0) & &pos) - tab(many(' ')) - } - } - return - end - -procedure doblock (gc, lno, pos1, pos2) - local x - - x := textx + xsiz * (pos1 - 1) - if \font then { - GotoXY(gc, x, margin + spacing * lno - 1) - writes(gc, code[lno][pos1:pos2]) - } - else { - FillRectangle(gc, x, margin + spacing*(lno-1), xsiz*(pos2-pos1), ysiz) - } - return - end diff --git a/ipl/mprogs/callcnt.icn b/ipl/mprogs/callcnt.icn deleted file mode 100644 index c4063cf..0000000 --- a/ipl/mprogs/callcnt.icn +++ /dev/null @@ -1,122 +0,0 @@ -############################################################################ -# -# File: callcnt.icn -# -# Subject: Program to count calls -# -# Author: Ralph E. Griswold -# -# Date: June 8, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program tabulates calls in a monitored program. -# -############################################################################ -# -# Links: evinit, opsyms -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link opsyms - -$include "evdefs.icn" - -procedure main(args) - local opertable, fnctable, rectable, proctable, opmap, output, mask, oper - local count, fnc - - EvInit(args) - - opertable := table(0) - fnctable := table(0) - proctable := table(0) - - opmap := opsyms() - - output := open("callcnt", "x", "height=800", # If this fails, output goes to - "width=200") # standard output - - write(output, " Tabulating calls for ", args[1]) - - mask := E_Ocall ++ E_Fcall ++ E_Pcall - - while EvGet(mask) do - case &eventcode of { - E_Ocall: opertable[&eventvalue] +:= 1 - E_Fcall: fnctable[&eventvalue] +:= 1 - E_Pcall: proctable[&eventvalue] +:= 1 - } - - opertable := sort(opertable,3) - fnctable := sort(fnctable,3) - rectable :=copy(fnctable) - proctable := sort(proctable,3) - - write(output, "\n operation calls\n") - while oper := get(opertable) do { - count := get(opertable) - write(output, " ", left(\opmap[oper], 20), right(count, 7)) - } - - write(output, "\n function calls\n") - while fnc := get(fnctable) do { - count := get(fnctable) - write(output, " ", left(fname(fnc), 20), right(count, 7)) - } - - write(output, "\n record constructor calls\n") - while fnc := get(rectable) do { - count := get(rectable) - write(output, " ", left(cname(fnc), 20), right(count, 7)) - } - - write(output, "\n procedure calls\n") - while write(output, " ", left(pname(get(proctable)), 20), - right(get(proctable), 7)) - - Event(\output) # wait for event if window - -end - -procedure cname(f) - - return image(f) ? { - ="function " - if ="record constructor " then return tab(0) - else fail - } - -end - -procedure fname(f) - - return image(f) ? { - ="function " - if ="record constructor " then fail - else tab(0) - } - -end - -procedure pname(p) - - return image(p) ? { - ="procedure " - tab(0) - } - -end diff --git a/ipl/mprogs/cmpsum.icn b/ipl/mprogs/cmpsum.icn deleted file mode 100644 index 79fdf8f..0000000 --- a/ipl/mprogs/cmpsum.icn +++ /dev/null @@ -1,106 +0,0 @@ -############################################################################ -# -# File: cmpsum.icn -# -# Subject: Program to tabulate comparisons -# -# Author: Ralph E. Griswold -# -# Date: September 27, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates comparisons. It is called as -# -# cmpsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, output, succtbl, failtbl, cmask, rmask, cmplist, op - local greater, greatereq, noteql, eql, less, lesseq, valeql, valnoteql - local strgreater, strgreatereq, strnoteql, streql, strless, strlesseq - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - succtbl := table(0) - failtbl := table(0) - - cmask := E_Ocall - rmask := E_Oret ++ E_Ofail - - eql := proc("=", 2) - less := proc("<", 2) - lesseq := proc("<=", 2) - greater := proc(">", 2) - greatereq := proc(">=", 2) - noteql := proc("~=", 2) - streql := proc("==", 2) - strless := proc("<<", 2) - strlesseq := proc("<<=", 2) - strgreater := proc(">>", 2) - strgreatereq := proc(">>=", 2) - strnoteql := proc("~==", 2) - valeql := proc("===", 2) - valnoteql := proc("~===", 2) - - while EvGet(cmask) do { - if (op := &eventvalue) === ( - eql | less | lesseq | greater | greatereq | noteql | - streql | strless | strlesseq | strgreater | strgreatereq | strnoteql | - valeql | valnoteql - ) then { - EvGet(rmask) - if &eventcode === E_Oret then succtbl[op] +:= 1 - else failtbl[op] +:= 1 - } - } - - write(output, "\nSuccessful comparisons:\n") - cmplist := sort(succtbl, 3) - while write(output, left(procname(get(cmplist)), 6), right(get(cmplist), 7)) - - write(output, "\nFailed comparisons:\n") - cmplist := sort(failtbl, 3) - while write(output, left(procname(get(cmplist)), 6), right(get(cmplist), 7)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/cnvsum.icn b/ipl/mprogs/cnvsum.icn deleted file mode 100644 index b5e446a..0000000 --- a/ipl/mprogs/cnvsum.icn +++ /dev/null @@ -1,117 +0,0 @@ -############################################################################ -# -# File: cnvsum.icn -# -# Subject: Program to tabulate type-conversion activity -# -# Author: Ralph E. Griswold -# -# Date: August 13, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates type-conversion activity. It is called as -# -# cnvsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname, typecode -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname -link typecode - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, cnvlist, esucctbl, efailtbl, isucctbl, ifailtbl, output - local mmask, cmask, in, pair, name - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - esucctbl := table(0) - efailtbl := table(0) - isucctbl := table(0) - ifailtbl := table(0) - - mmask := E_Fcall ++ E_Aconv - cmask := E_Fconv ++ E_Sconv ++ E_Nconv - - while EvGet(mmask) do { - case &eventcode of { - E_Fcall: { - if (name := procname(&eventvalue)) == - ("integer" | "string" | "cset" | "real") then { - in := name[1] - EvGet(E_Tconv) - pair := in || typecode(&eventvalue) - EvGet(cmask) - case &eventcode of { - E_Sconv: esucctbl[pair] +:= 1 - E_Fconv: efailtbl[pair] +:= 1 - } - } - } - E_Aconv: { - in := typecode(&eventvalue) - EvGet(E_Tconv) - pair := in || typecode(&eventvalue) - EvGet(cmask) - case &eventcode of { - E_Sconv: isucctbl[pair] +:= 1 - E_Fconv: ifailtbl[pair] +:= 1 - } - } - } - } - - cnvlist := sort(esucctbl, 3) - write(output, "\nExplicit successful conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - cnvlist := sort(efailtbl, 3) - write(output, "\nExplicit failed conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - cnvlist := sort(isucctbl, 3) - write(output, "\nImplicit successful conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - cnvlist := sort(ifailtbl, 3) - write(output, "\nImplicit failed conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/cvtsum.icn b/ipl/mprogs/cvtsum.icn deleted file mode 100644 index 9e6dfc8..0000000 --- a/ipl/mprogs/cvtsum.icn +++ /dev/null @@ -1,79 +0,0 @@ -############################################################################ -# -# File: cvtsum.icn -# -# Subject: Program to count conversion event tuples -# -# Author: Ralph E. Griswold -# -# Date: November 25, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program counts conversion events that occur during the monitoring -# of Icon program execution. -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link numbers -link typecode - -$include "evdefs.icn" - -procedure main(args) - local counts, total, futile, triple, target, value, failure - - EvInit(args) - - counts := table(0) - total := -1 # account for first vacuous entry - futile := 0 - failure := 0 - - while EvGet(ConvMask) do - case &eventcode of { - E_Aconv: { - total +:= 1 - if total % 1000 = 0 then writes(&errout, ".") - counts[triple] +:= 1 - target := typecode(&eventvalue) - triple := target - } - E_Tconv: { - value := typecode(&eventvalue) - if value == target then futile +:= 1 - triple ||:= value - } - E_Nconv: triple ||:= " S" - E_Sconv: triple ||:= " S" - E_Fconv: { - failure +:= 1 - triple ||:= " F" - } - default: stop("*** illegal event code") - } - - delete(counts,&null) - - counts := sort(counts, 3) - - while write(get(counts), right(get(counts),6)) - - write("\ntotal = ",total,"\n") - write(fix(futile / real(total), .01, 3, 2),"% futile") - write(fix(failure / real(total), .01, 3, 2),"% failed") - -end diff --git a/ipl/mprogs/events.icn b/ipl/mprogs/events.icn deleted file mode 100644 index 624c1cb..0000000 --- a/ipl/mprogs/events.icn +++ /dev/null @@ -1,59 +0,0 @@ -############################################################################ -# -# File: events.icn -# -# Subject: Program to show events -# -# Author: Ralph E. Griswold -# -# Date: September 20, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program lists the events that occur in the execution of the icode -# file given as the first argument on the command line. Any other command- -# line arguments are passed to the icode file. -# -# The image of the event code is given in the first column, its -# description is given in the second column, and an image of the -# event value is given in the third column. -# -# The following option is supported: -# -# -o s direct output to file named s; default &output -# -############################################################################ -# -# Requires: MT-Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, evsyms, options -# -############################################################################ - -link evinit -link evnames -link evsyms -link options - -procedure main(args) - local opts, output, symmap - - symmap := evsyms() - - opts := options(args, "o:") - output := open(\opts["o"], "w") | &output - - EvInit(args) | stop("*** cannot open icode file ***") - - - while EvGet() do - write(output, left(\symmap[&eventcode], 14), - left(evnames(&eventcode), 35), image(&eventvalue)) - -end diff --git a/ipl/mprogs/evstream.icn b/ipl/mprogs/evstream.icn deleted file mode 100644 index 4773b40..0000000 --- a/ipl/mprogs/evstream.icn +++ /dev/null @@ -1,60 +0,0 @@ -############################################################################ -# -# File: evstream.icn -# -# Subject: Program to show events -# -# Author: Ralph E. Griswold -# -# Date: June 8, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program lists the events that occur in the execution of the icode -# file given as the first argument on the command line. Any other command- -# line arguments are passed to the icode file. -# -# The image of the event code is given in the first column, its -# description is given in the second column, and an image of the -# event value is given in the third column. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, convert -# -############################################################################ - -link evinit -link evnames -link convert - -procedure main(args) - local name - - EvInit(args) | stop("*** cannot open icode file ***") - - name := evnames() - - while EvGet() do - write(left(rimage(&eventcode), 8), - left(\name[&eventcode] | "unknown event",35), image(&eventvalue)) - -end - -procedure rimage(s) - local i - - i := ord(s) - - if 32 <= i <= 126 then return image(s) - else return "\"\\" || exbase10(i, 8) || "\"" - -end diff --git a/ipl/mprogs/evsum.icn b/ipl/mprogs/evsum.icn deleted file mode 100644 index c5cf228..0000000 --- a/ipl/mprogs/evsum.icn +++ /dev/null @@ -1,107 +0,0 @@ -############################################################################ -# -# File: evsum.icn -# -# Subject: Program to tabulate event codes -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates event codes. It is called as -# -# evsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -m s sets the event mask named s. If no mask is specified, all -# events are tabulated. (See evdefs.icn for a list of event -# mask names.) -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, numbers, options -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link evnames -link numbers -link options - -$include "evdefs.icn" - -procedure main(args) - local summary, total, i, subscr, opts, mask, output, alltotal - local itime - - opts := options(args, "m:o:t") - - mask := &cset - mask := case \opts["m"] of { - "AllocMask": AllocMask - "AssignMask": AssignMask - "TypeMask": TypeMask - "ConvMask": ConvMask - "ProcMask": ProcMask - "FncMask": FncMask - "OperMask": OperMask - "ListMask": ListMask - "RecordMask": RecordMask - "ScanMask": ScanMask - "SetMask": SetMask - "TableMask": TableMask - "StructMask": StructMask - default: stop("*** invalid event mask name") - } - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - summary := table(0) - total := 0 - - while EvGet(mask) do - summary[&eventcode] +:= 1 - - every total +:= !summary - alltotal := total - total /:= 100.0 - - summary := sort(summary, 4) - - write(output, left("event",45), right("count",9), right("percent",10)) - write(output) - while i := pull(summary) do - write(output, left(evnames(pull(summary)), 45), - right(i, 9), " ", fix(i, total, 5, 2)) - - write(output, "\n", left("total:", 45), right(alltotal, 9)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/exprsum.icn b/ipl/mprogs/exprsum.icn deleted file mode 100644 index 802d3b6..0000000 --- a/ipl/mprogs/exprsum.icn +++ /dev/null @@ -1,162 +0,0 @@ -############################################################################ -# -# File: exprsum.icn -# -# Subject: Program to tabulate operator and function evaluation -# -# Author: Ralph E. Griswold -# -# Date: February 20, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates operator and function activity. It is called as -# -# exprsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: Version 9 MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evaltree # maintenance of call tree -link evinit # event monitoring initialization -link evnames # mapping of events to names -link options # command-line options -link procname # string name for procedure - -$include "evdefs.icn" # event code and mask definitions - -global callcount -global calltbl -global failtbl -global namemap -global names -global output -global remvtbl -global resmtbl -global retntbl -global susptbl - -$define NameColumn 14 -$define ValueColumn 10 - -procedure main(args) - local opts, itime - - namemap := evnames() - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - if \opts["t"] then itime := &time - - # Load and initialize the source program. - - EvInit(args) | stop("*** cannot load source program") - - # Assign tables to for the various kinds of activity. - - every calltbl | retntbl | susptbl | failtbl | resmtbl | remvtbl := table(0) - - # Process the events using the procedure note(). - - evaltree(FncMask ++ OperMask, note) - - # Format the results. - - format(output) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end - -procedure format(output) - - write(output, - left("name", NameColumn), - right("calls", ValueColumn), - right("returns", ValueColumn), - right("suspends", ValueColumn), - right("failures", ValueColumn), - right("resumps", ValueColumn), - right("removals", ValueColumn) - ) - write(output) - - # sort names by number of calls - - names := sort(calltbl, 4) - - while callcount := pull(names) do { - name := pull(names) - write(output, - left(name, NameColumn), - right(callcount, ValueColumn), - right(retntbl[name], ValueColumn), - right(susptbl[name], ValueColumn), - right(failtbl[name], ValueColumn), - right(resmtbl[name], ValueColumn), - right(remvtbl[name], ValueColumn) - ) - } - - write(output, - "\n", - left("total", NameColumn), - right(tblsum(calltbl), ValueColumn), - right(tblsum(retntbl), ValueColumn), - right(tblsum(susptbl), ValueColumn), - right(tblsum(failtbl), ValueColumn), - right(tblsum(resmtbl), ValueColumn), - right(tblsum(remvtbl), ValueColumn) - ) - -end - -procedure note(new, old) - - case &eventcode of { - !CallCodes: calltbl[procname(new.node, 1)] +:= 1 - !ReturnCodes: retntbl[procname(old.node, 1)] +:= 1 - !SuspendCodes: susptbl[procname(old.node, 1)] +:= 1 - !FailCodes: failtbl[procname(old.node, 1)] +:= 1 - !ResumeCodes: resmtbl[procname(new.node, 1)] +:= 1 - !RemoveCodes: remvtbl[procname(old.node, 1)] +:= 1 - } - - return - -end - -procedure tblsum(tbl) - local count - - count := 0 - every count +:= !tbl - - return count - -end diff --git a/ipl/mprogs/listev.icn b/ipl/mprogs/listev.icn deleted file mode 100644 index 6372ac0..0000000 --- a/ipl/mprogs/listev.icn +++ /dev/null @@ -1,46 +0,0 @@ -############################################################################ -# -# File: listev.icn -# -# Subject: Program to list events -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program list events. Event information is written -# by using image(). -# -# This program is called as -# -# listev tp args -# -############################################################################ -# -# Requires: Version 9.0 MT Icon with event monitoring -# -############################################################################ -# -# Links: evinit, options -# -############################################################################ - -$include "etdefs.icn" - -link evinit -link options - -procedure main(args) - - EvInit(args) | stop("*** cannot load TP") - - while EvGet(T_Mask1) do - write(image(&eventcode), " : ", image(&eventvalue)) - -end diff --git a/ipl/mprogs/locus.icn b/ipl/mprogs/locus.icn deleted file mode 100644 index 8e1581a..0000000 --- a/ipl/mprogs/locus.icn +++ /dev/null @@ -1,126 +0,0 @@ -############################################################################ -# -# File: locus.icn -# -# Subject: Program to trace execution locus -# -# Author: Ralph E. Griswold -# -# Date: March 4, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program traces the locus of program execution. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, evinit, xcompat, wopen -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link evinit -link wopen -link xcompat - -global Visualization, Limit - -procedure main(args) - local program_name, Width, Height, x, y, blowup, i, Context, value - local program, line, progarray, Color, ymul, maxheight - local colmask, linemask, mask - - colmask := 2 ^ 16 - linemask := colmask - 1 - - maxheight := 500 - - EvInit(args) | stop("*** cannot load program to monitor") - - program_name := prog_name() - - program := open(program_name) | stop("*** cannot open ", program_name) - - Height := 0 - Width := 0 - - while line := read(program) do { - Height +:= 1 - Width <:= *line - } - - if Height < maxheight / 2 then blowup := 4 - else if Height < maxheight / 4 then blowup := 2 - else blowup := 1 - - progarray := list(Height) - every !progarray := list(Width, 0) - - if Height > maxheight then { - ymul := real(maxheight) / Height - Height := maxheight - } - else ymul := 1 - - Width *:= blowup - Height *:= blowup - - close(program) - - Visualization := WOpen("label=locus", "bg=white", "width=" || Width, - "height=" || Height) | stop("*** cannot open window for visualization") - - Color := list(6) - Color[6] := XBind(Visualization, , "fg=red") - Color[5] := XBind(Visualization, , "fg=orange") - Color[4] := XBind(Visualization, , "fg=yellow") - Color[3] := XBind(Visualization, , "fg=green") - Color[2] := XBind(Visualization, , "fg=blue") - Color[1] := XBind(Visualization, , "fg=gray") - - mask := cset(E_Loc) - - x := y := -10 - - Limit := 10 - i := 0 - - repeat { - - i := (i + 1) % Limit - if i = 0 then { - while *Pending(Visualization) > 0 do - if Event(Visualization) === (&lpress | &mpress | &rpress) then { - event(E_ALoc, (&x / blowup + 1) * colmask + - (&y / blowup) / ymul + 1) - } - } - - EvGet(mask) | break - y := iand(&eventvalue, linemask) - x := &eventvalue / colmask - value := progarray[y, x] +:= 1 - value := integer(log(value, 6)) + 1 - Context := Color[value | *Color] - y := (y * ymul - 1) * blowup - x := (x - 1) * blowup - FillRectangle(Visualization, x, y, blowup, blowup) - FillRectangle(Context, x, y, blowup, blowup) - - } - -end diff --git a/ipl/mprogs/memsum.icn b/ipl/mprogs/memsum.icn deleted file mode 100644 index 95ef2c1..0000000 --- a/ipl/mprogs/memsum.icn +++ /dev/null @@ -1,158 +0,0 @@ -############################################################################ -# -# File: memsum.icn -# -# Subject: Program to tabulate memory allocation -# -# Author: Ralph E. Griswold -# -# Date: August 17, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates storage allocation. It is called as -# -# memsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, numbers, options -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link evnames -link numbers -link options - -$include "evdefs.icn" - -global highlights, alloccnt, alloctot, collections, output - -procedure main(args) - local opts, itime, mask - - opts := options(args, "to:") - output := open(\opts["o"], "w") | &output - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - alloccnt := table(0) # count of allocations - alloctot := table(0) # total allocation - collections := table(0) # garbage collection counts - - # Be sure all allocation types are listed even if there is no allocation - # for them. - - every alloccnt[!AllocMask] := 0 - every alloctot[!AllocMask] := 0 - - mask := AllocMask ++ E_Collect - - while EvGet(mask) do - if &eventcode === E_Collect then collections[&eventvalue] +:= 1 - else { - alloccnt[&eventcode] +:= 1 - alloctot[&eventcode] +:= &eventvalue - } - - report() - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end - -# Display a table of allocation data -# -procedure report() - local i, cnttotal, tottotal, cnt, tot, totalcoll - - static col1, col2, gutter # column widths - - initial { - col1 := 20 # name field - col2 := 10 # number field - gutter := " " - } - - write(output, "\n", # write column headings - left("type",col1), right("number",col2), gutter, - right("bytes",col2), gutter, right("average",col2), gutter, - right("% bytes",col2), "\n" - ) - - alloccnt := sort(alloccnt, 3) # get the data - alloctot := sort(alloctot, 3) - - cnttotal := 0 - tottotal := 0 - - every i := 2 to *alloccnt by 2 do { - cnttotal +:= alloccnt[i] - tottotal +:= alloctot[i] - } - - while write(output, # write the data - left(name(get(alloccnt)), col1), - right(cnt := get(alloccnt), col2), gutter, - get(alloctot) & right(tot := get(alloctot), col2), gutter, - fix(tot, cnt, col2, 2) | right("0.00", col2), gutter, - fix(100.0 * tot, tottotal, col2, 2) | right("0.00", col2) - ) - - write(output, "\n", # write totals - left("total:",col1), right(cnttotal,col2), gutter, right(tottotal,col2), - gutter, fix(tottotal,cnttotal,col2) | repl(" ",col2) - ) - - totalcoll := 0 # garbage collections - every totalcoll +:= !collections - write(output,"\n",left("collections:",col1),right(totalcoll,col2)) - if totalcoll > 0 then { - write(output,left(" static region:",col1),right(collections[1],col2)) - write(output,left(" string region:",col1),right(collections[2],col2)) - write(output,left(" block region:",col1),right(collections[3],col2)) - write(output,left(" no region:",col1),right(collections[0],col2)) - } - - return -end - -# Produce event name -# -procedure name(code) - local result - - result := evnames(code) - - result ?:= tab(find(" allocation")) - - result ?:= { - tab(find("trapped variable")) || "tv" - } - - return result - -end diff --git a/ipl/mprogs/mmm.icn b/ipl/mprogs/mmm.icn deleted file mode 100644 index a9688cd..0000000 --- a/ipl/mprogs/mmm.icn +++ /dev/null @@ -1,139 +0,0 @@ -############################################################################ -# -# File: mmm.icn -# -# Subject: Program to show allocation as a miniature "MemMon" -# -# Author: Clinton Jeffery -# -# Date: August 12, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Displays a tiny rendition of internal heap allocation. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: evinit, options, optwindw, typebind, colormap, wipe, xcompat -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link options -link optwindw -link typebind -link colormap -link wipe -link xcompat - -global Visualization, contexts -global t, sum, threesixty, wid, hei - -procedure main(av) - local c_string, lines, mymask, allocstr, blockall, sum1, sum2, row1, row2, - Regions, c, start, sum2div4, verbose - if *av>0 then - EvInit(av) | stop("EvInit() can't load ",av[1]) - else - EvInit() | stop("can't EvInit()") - - threesixty := 360 * 64 - t := options(av) - /t["W"] := 650 - /t["H"] := 50 - &window := optwindow(t) | stop("no window") - Visualization := &window - contexts := itypebind(&window) - c_string := contexts[E_String] | stop("eh?") - / contexts[E_Tvsubs] := c_string - - wid := WAttrib("width") - hei := WAttrib("height") - lines := WAttrib("lines") - - mymask := AllocMask ++ cset("\360"||E_Collect||E_BlkDeAlc||E_StrDeAlc) - allocstr := string(AllocMask) - blockall := 0 - - sum1 := 0 - sum2 := 0 - row1 := 0 - row2 := hei/2+1 - - Regions := [] - every put(Regions,keyword("regions",EventSource)) - pop(Regions) - - while EvGet(mymask) do { - if &eventcode === E_Lelem then &eventcode := E_List - if &eventcode === (E_Telem|E_Tvtbl|E_Slots) then &eventcode := E_Table - if &eventcode === E_Selem then &eventcode := E_Set - if &eventcode === E_Refresh then &eventcode := E_Coexpr - case &eventcode of { - E_Collect: { - wipe(&window) - sum1 := sum2 := 0 - row1 := 0 - row2 := hei/2+1 - } - E_EndCollect: { - } - E_String: { - DrawLine(c_string,sum1/4,row1,(sum1+&eventvalue)/4,row1) - sum1 +:= &eventvalue - while sum1/4 >= wid do { - sum1 -:= wid * 4 - row1 +:= 1 - if row1 > hei/2 then { - EraseArea(0,0,wid,hei/2) - row1 := 0 - } - DrawLine(c_string,0,row1,sum1/4,row1) - } - } - !.allocstr: { - c := \contexts[&eventcode] | stop("what is ",&eventcode) - start := sum2/4 - sum2 +:= &eventvalue - sum2div4 := sum2/4 - DrawLine(c,start,row2,sum2div4,row2) - while sum2div4 >= wid do { - sum2 -:= wid * 4 - sum2div4 := sum2/4 - row2 +:= 1 - DrawLine(c,0,row2,sum2div4,row2) - } - } - default: { - if \verbose then write("unknown event code ",&eventcode) - } - } - } - -end - -procedure itypebind(z) - static t - initial { - t := table() - } - /(t[z]):=typebind(z,E_Integer||E_Real||E_Record||E_Set||E_String||E_Cset|| - E_File||E_List||E_Null||E_Proc||E_Table,table()) -# if type(t[z][E_Proc])=="file" then close(t[z][E_Proc]) - t[z][E_Proc] := XBind(z,"fg=#999") - return t[z] -end diff --git a/ipl/mprogs/mtutils.icn b/ipl/mprogs/mtutils.icn deleted file mode 100644 index 3fe42ac..0000000 --- a/ipl/mprogs/mtutils.icn +++ /dev/null @@ -1,40 +0,0 @@ -############################################################################ -# -# File: mtutils.icn -# -# Subject: Program fpr MT Icon -# -# Author: Ralph E. Griswold -# -# Date: March 3, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Utility procedures for use with MT Icon programs (threads) -# -############################################################################ -# -# Requires: MT Icon -# -############################################################################ - -procedure root() - - C := &main - - while C := parent(C) - - return C - -end - -procedure main() - - if root(&main) === &main then write("safe to talk") - else write("someone may be listening") - -end diff --git a/ipl/mprogs/napoleon.icn b/ipl/mprogs/napoleon.icn deleted file mode 100644 index 026a2ea..0000000 --- a/ipl/mprogs/napoleon.icn +++ /dev/null @@ -1,168 +0,0 @@ -############################################################################ -# -# File: napoleon.icn -# -# Subject: Program to track memory usage by type -# -# Author: Clinton Jeffery -# -# Date: August 12, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Displays an animated chart showing recent memory usage by Icon type. -# -# Currently not interactive, hence, keys and clicks don't do anything. -# Resizes are handled. -# -# usage: napoleon [-r | -c] prog [args...] -# -# -r provides a regions view, separating the string and block regions -# and displaying memory quantities proportional to the total region size -# rather than the total amount allocated -# -# -c provides continuous updates on each allocation, instead of updating -# only when a change is significant (i.e. when proportions change by >= 1%). -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: evinit, options, optwindw, typebind -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link options -link optwindw -link typebind - -global Visualization, contexts -global t, sum, wid, hei, realhei, x, optable - -procedure main(av) - local lines, mymask, allocstr, p, update, e - optable := options(av,"c!r!") - - if *av>0 then - EvInit(av) | stop("EvInit() can't load ",av[1]) - else - EvInit() | stop("can't EvInit()") - - /optable["W"] := 100 - /optable["H"] := 400 - &window := optwindow(optable) | stop("no window") - - Visualization := &window - contexts := typebind(&window,E_Integer||E_Real||E_Record||E_Set||E_String|| - E_Cset||E_File||E_List||E_Null||E_Proc||E_Table|| - E_Tvsubs, table()) - - wid := WAttrib("width") - hei := WAttrib("height") - realhei := real(hei) - if \optable["r"] then { - realhei /:= 2 - sum := 65000 - } - else { - sum := 0 - } - - lines := WAttrib("lines") - - mymask := AllocMask ++ cset(E_EndCollect||E_Collect) - allocstr := string(AllocMask) - - t := table(0.0) - p := table(0) - - update := 1 - - while EvGet(mymask) do { - if &eventcode === E_Lelem then &eventcode := E_List - if &eventcode === (E_Telem|E_Tvtbl|E_Slots) then &eventcode := E_Table - if &eventcode === E_Selem then &eventcode := E_Set - if &eventcode === E_Refresh then &eventcode := E_Coexpr - case &eventcode of { - E_Collect: { - EraseArea(x,0) - every !t := 0.0 - if /optable["r"] then sum := 0 - update := &null - } - E_EndCollect: { - update := 1 - if sum=0 then sum := 1 - redraw() - } - !.allocstr: { - t[&eventcode] +:= &eventvalue - if /optable["r"] then sum +:= &eventvalue - if \optable["c"] | - p[&eventcode] ~=:= integer(t[&eventcode] / (0 wid then { - x := 0 - EraseArea(0,0,5) - } - EraseArea(x+3,0,1) -end diff --git a/ipl/mprogs/novae.icn b/ipl/mprogs/novae.icn deleted file mode 100644 index 71cd5d3..0000000 --- a/ipl/mprogs/novae.icn +++ /dev/null @@ -1,93 +0,0 @@ -############################################################################ -# -# File: novae.icn -# -# Subject: Program to show allocations as exploding stars -# -# Author: Ralph E. Griswold -# -# Date: June 25, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program shows allocation on two stars with radiating lines -# -# The tool-specific options are: -# -# -h i Height of panel, default 300 -# -w i Width of one panel, default 300 -# -s i number of lines, default 360 -# -d draw dot at end of line instead of full line -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, visprocs -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link visprocs - -$define Height 300 -$define Width 300 -$define Sectors 360 - -procedure main(args) - local clear, sdegrees, bdegrees - local degrees, arc, advance, fullcircle - local xorg, yorg, radius, radians, dots, sxorg, syorg, bxorg, byorg - - em_setup(args) - - fullcircle := 360 - sdegrees := bdegrees := 0 - radians := 0 - advance := fullcircle / Sectors # amount to advance - - sxorg := integer(Width / 2.0) - syorg := (Height / 2.0) - bxorg := sxorg + Width - byorg := syorg - radius := ((Height < Width) | Height) / 2.0 - - vis_setup("label=novae", "size=" || (2 * Width) || "," || Height, - "bg=black") - - Context := context_setup(AllocMask) - - while EvGet(AllocMask) do { - if &eventcode === E_String then { - xorg := sxorg - yorg := syorg - sdegrees +:= advance - sdegrees %:= fullcircle - radians := -dtor(sdegrees) - } - else { - xorg := bxorg - yorg := byorg - bdegrees +:= advance - bdegrees %:= fullcircle - radians := -dtor(bdegrees) - } - DrawLine(Context[&eventcode], xorg, yorg, &eventvalue * cos(radians) + - xorg, &eventvalue * sin(radians) + yorg) - } - - em_end() - -end diff --git a/ipl/mprogs/numsum.icn b/ipl/mprogs/numsum.icn deleted file mode 100644 index f08f15e..0000000 --- a/ipl/mprogs/numsum.icn +++ /dev/null @@ -1,103 +0,0 @@ -############################################################################ -# -# File: numsum.icn -# -# Subject: Program to tabulate numerical computation -# -# Author: Ralph E. Griswold -# -# Date: September 20, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates numerical-computation activity. It is called as -# -# numsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, output, inttbl, reltbl, cmask, rmask, numlist, op - local pos, neg, plus, minus, mpy, div, pwr, mod, count - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - inttbl := table(0) - reltbl := table(0) - - cmask := E_Fcall ++ E_Ocall - rmask := E_Fret ++ E_Oret ++ E_Ffail ++ E_Ofail - - pos := proc("+", 1) - neg := proc("-", 1) - plus := proc("+", 2) - minus := proc("-", 2) - mpy := proc("*", 2) - div := proc("/", 2) - mod := proc("%", 2) - pwr := proc("^", 2) - - while EvGet(cmask) do { - if (op := &eventvalue) === ( - plus | minus | mpy | div | neg | pwr | mod | - iand | ior | ixor | icom | ishift | pos - ) then { - EvGet(rmask) - if &eventcode === (E_Ofail | E_Ffail) then next - case type(&eventvalue) of { - "integer": inttbl[op] +:= 1 - "real": reltbl[op] +:= 1 - } - } - } - - write(output, "\nInteger computation:\n") - numlist := sort(inttbl, 4) - while count := pull(numlist) do - write(output, left(procname(pull(numlist)), 6), right(count, 9)) - - write(output, "\nReal computation:\n") - numlist := sort(reltbl, 4) - while count := pull(numlist) do - while write(output, left(procname(pull(numlist)), 6), right(count, 9)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/opersum.icn b/ipl/mprogs/opersum.icn deleted file mode 100644 index 3d6ffce..0000000 --- a/ipl/mprogs/opersum.icn +++ /dev/null @@ -1,200 +0,0 @@ -############################################################################ -# -# File: opersum.icn -# -# Subject: Program to tabulate operation activity -# -# Author: Ralph E. Griswold -# -# Date: March 10, 1998 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates operation activity. It is called as -# -# opersum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -m s sets the event mask named s. The supported masks are -# FncMask (the default), OperMask, ProcMask, ScanMask, -# and Oper+Mask, which includes both ScanMask and -# OperMask. -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evaltree -link evinit -link evnames -link options -link procname - -$include "evdefs.icn" - -global namemap, output, fncset, scan, fnames, mask -global calltbl, retntbl, susptbl, failtbl, resmtbl, remvtbl - -procedure main(args) - local opts, itime - - namemap := evnames() - - opts := options(args, "m:o:t") - - mask := FncMask - mask := case \opts["m"] of { - "ProcMask": ProcMask - "FncMask": FncMask - "OperMask": OperMask - "ScanMask": { - scan := 1 - ScanMask - } - "Oper+Mask": { - scan := 1 - OperMask ++ ScanMask - } - default: stop("*** invalid event mask name") - } - - if mask === FncMask then { # beware record constructors - fnames := set() # valid function names - every insert(fnames, function() || "()") - } - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - calltbl := table(0) - retntbl := table(0) - susptbl := table(0) - failtbl := table(0) - resmtbl := table(0) - remvtbl := table(0) - - fncset := set() - - EvInit(args) | stop("*** cannot load program") # initialize interface - - evaltree(mask, note) - - write(output, - left("name", 14), - right("calls", 10), - right("returns", 10), - right("suspends", 10), - right("failures", 10), - right("resumps", 10), - right("removals", 10) - ) - write(output) - - every name := !sort(fncset) do - write(output, - left(name, 14), - right(calltbl[name], 10), - right(retntbl[name], 10), - right(susptbl[name], 10), - right(failtbl[name], 10), - right(resmtbl[name], 10), - right(remvtbl[name], 10) - ) - - write(output, - "\n", - left("total", 14), - right(tblsum(calltbl), 10), - right(tblsum(retntbl), 10), - right(tblsum(susptbl), 10), - right(tblsum(failtbl), 10), - right(tblsum(resmtbl), 10), - right(tblsum(remvtbl), 10) - ) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end - -procedure note(new, old) - - case &eventcode of { - !CallCodes: { - name := ename(new.node) - if (mask === FncMask) & not(member(fnames, name)) then return - calltbl[name] +:= 1 - insert(fncset, name) - } - !ReturnCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - retntbl[name] +:= 1 - } - !SuspendCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - susptbl[name] +:= 1 - } - !FailCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - failtbl[name] +:= 1 - } - !ResumeCodes: { - name := ename(new.node) - if (mask === FncMask) & not(member(fnames, name)) then return - resmtbl[name] +:= 1 - } - !RemoveCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - remvtbl[name] +:= 1 - } - } - - return - -end - -procedure ename(x) - if /x then return "bogon" - else if \scan & not(proc(x)) then return "e1 ? e2" - else return procname(x, 1) # use the expanded form - -end - -procedure tblsum(tbl) - local count - - count := 0 - - every count +:= !tbl - - return count - -end diff --git a/ipl/mprogs/ostrip.icn b/ipl/mprogs/ostrip.icn deleted file mode 100644 index 44091a5..0000000 --- a/ipl/mprogs/ostrip.icn +++ /dev/null @@ -1,71 +0,0 @@ -############################################################################ -# -# File: ostrip.icn -# -# Subject: Program to show virtual-machine op-code strip -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program produces a listing of virtual machine codes and the events -# that occur between them. -# -# The following option is supported: -# -# -o s direct output to file s; default &output -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ -# -# Links: evinit, evsyms, opnames, options -# -############################################################################ - -link evinit -link evsyms -link opnames -link options - -$include "evdefs.icn" - -procedure main(args) - local codes, esmap, opmap, opcode, opts, output - - opts := options(args, "o:") - output := open(\opts["o"], "w") | &output - - EvInit(args) | stop("*** cannot load SP") - - opmap := opnames() - esmap := evsyms() - - opcode := cset(E_Opcode) - - while EvGet(opcode) do { # get to first "real" op-code - if opmap[integer(&eventvalue)] == "Invoke" then { - writes(output, "Invoke |") - break() - } - } - - while EvGet() do { - if &eventcode === E_Opcode then { - write(output) - writes(output, left(opmap[integer(&eventvalue)], 10), "|") - } - else writes(output, " ", esmap[&eventcode]) - } - - write(output) - -end diff --git a/ipl/mprogs/playev.icn b/ipl/mprogs/playev.icn deleted file mode 100644 index 7fdf595..0000000 --- a/ipl/mprogs/playev.icn +++ /dev/null @@ -1,59 +0,0 @@ -############################################################################ -# -# File: playev.icn -# -# Subject: Program to play back events -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program plays back events saved by recordev. Since recordev -# uses image() for recording, some information may be lost. -# -# This program is called as -# -# playev em := maxcols - mcols +:= ncols + 1 # space for line numbers and bar - -# Now create hidden canvases for the program and identifying line numbers. - - textmap := WOpen("canvas=hidden", "lines=" || mrows, - "columns=" || mcols) | stop("*** cannot hidden canvas for program") - - twidth := WAttrib(textmap, "width") - oheight := (WAttrib(textmap, "height") / mrows) / 2 + (hsize / 2) - -# Set positions in the pixmaps to leave space at the top and the bottom. - - GotoRC(textmap, vrows / 2, 1) - -# Put the text of the program into the canvas, while adding line -# numbers to the other canvas. - - input := open(SourceFile) | stop("*** cannot open ", SourceFile) - - line_no := 0 - - while write(textmap, right(line_no +:= 1, ncols - 1), " ", read(input)) - -# Draw a line in linemap to separate the line numbers from the -# program text when they get copied into the window. - - cwidth := TextWidth(textmap, repl("x", ncols + 1)) - x := cwidth - (cwidth / (2 * (ncols))) - 5 - - DrawLine(textmap, x, 0, x, WAttrib(textmap, "height")) - - vis_setup("label=" || basename(SourceFile), "lines=" || vrows, - "columns=80") - - highlight := Clone(Visualization, "fg=red") - - wwidth := WAttrib(Visualization, "width") - wheight := WAttrib(Visualization, "height") - - focus(1, 0) # start-up view - - while EvGet('', 1) do - if &eventcode === E_ALoc then { - line := iand(&eventvalue, linemask) - 1 # for positioning - column := &eventvalue / colmask - focus(line, column) - } - -end - -procedure focus(line, column) - local x, y - - y := (line - 1) * WAttrib("leading") # for positioning - CopyArea(textmap, Visualization, 0, y, twidth, wheight) - FillRectangle(highlight, 2, y := wheight / 2 - oheight, hsize, hsize) - if column > 0 then { - x := (column + ncols + 1) * WAttrib("fwidth") - FillRectangle(highlight, x, y + 10, 6, 1) - } - - return - -end diff --git a/ipl/mprogs/recordev.icn b/ipl/mprogs/recordev.icn deleted file mode 100644 index 4ad0f8f..0000000 --- a/ipl/mprogs/recordev.icn +++ /dev/null @@ -1,69 +0,0 @@ -############################################################################ -# -# File: recordev.icn -# -# Subject: Program to record events -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program records events in a file. Event information is stored -# by using image(), so some information may be lost. -# -# This program is called as -# -# recordev tp args -# -# The options supported are: -# -# -o s write event history to the file named s; default standard -# output. -# -# -c s prefix the event history with a comment event whose value -# is s. -# -# Warning: If -o is not given and tp also writes to standard output, -# the event history file will be corrupted. -# -# If args contains options, use -- to prevent recordev from consuming them, -# as in -# -# recordev -o history -- tp args -# -############################################################################ -# -# Requires: Version 9.0 MT Icon with event monitoring -# -############################################################################ -# -# Links: evinit, options -# -############################################################################ - -link evinit -link options - -procedure main(args) - local file, output, opts - - opts := options(args, "c:o:") - if file := \opts["o"] then { - output := open(file, "w") | stop("*** cannot open ", image(file)) - } - else output := &output - - write(output, image("#"), "\n", image(\opts["c"])) - - EvInit(args) | stop("*** cannot load TP") - - while EvGet() do - write(output, image(&eventcode), "\n", image(&eventvalue)) - -end diff --git a/ipl/mprogs/roll.icn b/ipl/mprogs/roll.icn deleted file mode 100644 index 0f1ea32..0000000 --- a/ipl/mprogs/roll.icn +++ /dev/null @@ -1,103 +0,0 @@ -############################################################################ -# -# File: roll.icn -# -# Subject: Program to display the program counter on a stripchart -# -# Author: Gregg M. Townsend and Ralph E. Griswold -# -# Date: June 25, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# roll displays a chart recording a time-history of program execution -# by line number. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, filedim, strpchrt -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link filedim -link strpchrt - -$define Width 500 -$define MaxHeight 500 - -global ifile, Limit -global maxln - -procedure main(args) - local fname, sc, h, t, y, mask, ymul, maxln - local size, i, linemask - - linemask := 2 ^ 16 - 1 - - em_setup(args) - - size := filedim(prog_name()) - maxln := size.rows - - if maxln > MaxHeight then { - ymul := real(MaxHeight) / maxln - maxln := MaxHeight - } - else ymul := 1 - - Limit := 10 - - vis_setup("size=" || Width || "," || maxln, "label=roll") - - sc := stripchart(Visualization, 0, 0, Width, maxln) - - t := 0 - i := 0 - - mask := E_Loc ++ E_Tick - - repeat { - - i := (i + 1) % Limit - - if i = 0 then { - while *Pending(Visualization) > 0 do - case Event(Visualization) of { - &lpress | &mpress | &rpress: { - event(E_ALoc, integer(&y / ymul) + 1, &eventsource) - } - } - } - - - EvGet(mask) | break - if &eventcode === E_Loc then { - y := ymul * iand(&eventvalue, linemask) - DrawPoint(sc.win, sc.x, y) - } - else if &eventcode === E_Tick then sadvance(sc, &eventvalue) - } - - sadvance(sc) - - Fg(sc.win, "red") - DrawLine(sc.win, sc.x, 0, sc.x, maxln) - - em_end() - -end diff --git a/ipl/mprogs/scat.icn b/ipl/mprogs/scat.icn deleted file mode 100644 index 631be9c..0000000 --- a/ipl/mprogs/scat.icn +++ /dev/null @@ -1,143 +0,0 @@ -############################################################################ -# -# File: scat.icn -# -# Subject: Program to produce call/result scatterplot -# -# Author: Clinton Jeffery -# -# Date: November 11, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Press the left mouse button atop any plotted point to see the list of -# procedures at that point. Execution (and point motion) is suspended -# until the mouse button is released. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: eemutils, vinit -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link emutils -link evinit - -global at, # table of counts of procedures at a given point - call, # table of call counts - rslt # table of result counts - -record activation (p, parent, children) - -procedure main(av) - local mask, maxmax, maxmatch, current_proc, L, max, i, k, child, e - - EvInit(av) | stop("*** cannot load SP") - - kill_output() - - &window := open("scat","x","geometry=150x180") | stop("can't open window") - current_proc := activation(,activation(,,,,[]),[]) - call := table(0) - rslt := table(0) - at := table(0) - mask := ProcMask ++ E_MXevent - maxmax := 0 - maxmatch := 0 - - while EvGet(mask) do { - case &eventcode of { - E_Pcall: { - move(&eventvalue, 1, 0) - current_proc := activation(&eventvalue, current_proc, []) - put(current_proc.parent.children, current_proc) - } - E_Psusp: { - move(current_proc.p, 0, 1) - current_proc := current_proc.parent - } - E_Presum: { - current_proc := current_proc.children[-1] - } - E_Pret: { - move(current_proc.p, 0, 1) - pull(current_proc.parent.children) - current_proc := current_proc.parent - } - E_Pfail: { - pull(current_proc.parent.children) - current_proc := current_proc.parent - } - E_Prem: { - child := pull(current_proc.children) - current_proc.children |||:= child.children - } - E_MXevent: { - case &eventvalue of { - "q" | "\033": stop("terminated") - &lpress | &ldrag : { - repeat { - L := [] - every k := key(call) do { - if -3 < 2*log(call[k]+2,1.25)+2 - &x < 3 & - -3 < 2*log(rslt[k]+2,1.25)+2 - &y < 3 then { - put(L, procedure_name(k)) - } - } - if max := * (L[1]) then { - every max <:= *( !L ) - maxmax <:= max - } - maxmatch <:= *L - &col := WAttrib("columns") - maxmax - &row := WAttrib("lines") - maxmatch - 1 - EraseArea(&x,&y) - if *L > 0 then { - every i := 1 to *L do { - GotoRC(WAttrib("lines")-*L+i,WAttrib("columns")-max) - writes(&window,L[i]) - } - e := Event() - every i := 1 to *L do { - GotoRC(WAttrib("lines")-*L+i,WAttrib("columns")-max) - writes(&window,L[i]) - } - } - else e := Event() - - if e === &lrelease then break - } - } - } - } - } - } - -end - -procedure procedure_name(p) - return image(p) ? { ="procedure "; tab(0) } -end - -procedure move(who, iscall, isrslt) - if (at[integer(2*log(call[who]+2,1.25)) || "," || integer(2*log(rslt[who]+2,1.25))] -:= 1) = 0 then - EraseArea(2*log(call[who]+2,1.25) + 2, 2*log(rslt[who]+2,1.25) + 2, 2, 2) - call[who] +:= iscall - rslt[who] +:= isrslt - if (at[integer(2*log(call[who]+2,1.25)) || "," || integer(2*log(rslt[who]+2,1.25))] +:= 1) = 1 then - FillRectangle(2*log(call[who]+2,1.25) + 2, 2*log(rslt[who]+2,1.25) + 2, 2, 2) -end diff --git a/ipl/mprogs/scater.icn b/ipl/mprogs/scater.icn deleted file mode 100644 index aad7502..0000000 --- a/ipl/mprogs/scater.icn +++ /dev/null @@ -1,183 +0,0 @@ -############################################################################ -# -# File: scater.icn -# -# Subject: Program to display visualize string concatenation -# -# Author: Ralph E. Griswold -# -# Date: March 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program displays successive numbers by lines of corresponding -# height. When the display area is full, it scrolls from right to -# left. -# -# In this version, input is piped in. -# -############################################################################ -# -# Requires: Version 9 graphics, MT Icon and instrumentation -# -############################################################################ -# -# Links: evinit, interact, vsetup -# -############################################################################ - -link evinit -link interact -link vsetup - -global vidgets -global root -global strip -global state -global gc_black -global reset -global scale - -global width -global height - -global window - -$include "evdefs.icn" - -procedure main(args) - - init(args) - - display() - -end - -procedure init(args) - - EvInit(args) | stop("*** cannot load SP.") - - /EventSource := &eventsource - - variable("write", EventSource) := -1 - variable("writes", EventSource) := -1 - - window := WOpen ! ui_atts() - - vidgets := ui() - - root := vidgets["root"] - - state := &null - scale := 1 - - width := vidgets["strip"].uw - height := vidgets["strip"].uh - - strip := Clone(window, "dx=" || vidgets["strip"].ux, "dy=" || - vidgets["strip"].uy) - Clip(strip, 0, 0, width, height) - gc_black := Clone(strip, "fg=black") - -end - -procedure display() - static cat, cmask, rmask - - initial { - cat := proc("||", 2) - cmask := cset(E_Ocall) - rmask := cset(E_Oret) - } - - repeat { - while (*Pending() > 0) | \state do - ProcessEvent(root, , shortcuts) - EvGet(cmask) | exit() - if &eventvalue === cat then { - EvGet(rmask) | exit() - &eventvalue := *&eventvalue - &eventvalue *:= scale - &eventvalue >:= height # Motif bug avoidance - CopyArea(strip, 1, 0, width - 1, height, 0, 0) - EraseArea(strip, width - 1, 0, width, height) - DrawLine(gc_black, width - 1, height - &eventvalue, width - 1, height) - } - } - -end - -procedure file_cb(vidget, value) - - case value[1] of { - "snapshot @S": return snapshot(strip, 0, 0, width, height) - "quit @Q": exit() - } - - fail - -end - -procedure configure_cb(vidget, value) - - case value[1] of { - "scale": { - repeat { - if TextDialog(, "scale", scale, 10) == "Okay" then { - scale := (0 < numeric(dialog_value[1])) | { - Notice("Invalid scale value.") - next - } - reset_cb() - return - } - else fail # user canceled - } - } - } - - fail - -end - -procedure reset_cb() - - EraseArea(strip) - - return - -end - -procedure shortcuts(e) - - if &meta then - case map(e) of { - "q": exit() - "s": return snapshot(strip, 0, 0, width, height) - } - else fail - -end - -#===<>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=477,255", "bg=gray-white"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,477,255:",], - ["configure:Menu:pull::36,0,71,21:Configure",configure_cb, - ["scale"]], - ["file:Menu:pull::0,1,36,21:File",file_cb, - ["snapshot @S","quit @Q"]], - ["line1:Line:::0,22,477,22:",], - ["reset:Button:regular::11,76,42,20:reset",reset_cb], - ["strip:Rect:grooved::63,37,400,200:",], - ) -end -#===<>=== end of section maintained by vib diff --git a/ipl/mprogs/strsum.icn b/ipl/mprogs/strsum.icn deleted file mode 100644 index 6160b13..0000000 --- a/ipl/mprogs/strsum.icn +++ /dev/null @@ -1,100 +0,0 @@ -############################################################################ -# -# File: strsum.icn -# -# Subject: Program to tabulate string computation -# -# Author: Ralph E. Griswold -# -# Date: August 14, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates string-computation activity. It is called as -# -# strsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, output, cnttbl, amttbl, cmask, rmask, numlist, op, cat - local subs - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - cnttbl := table(0) - amttbl := table(0) - - cat := proc("||", 2) - subs := proc("[]", 2) - - cmask := E_Fcall ++ E_Ocall ++ E_Ssasgn - rmask := E_Fret ++ E_Oret - - while EvGet(cmask) do { - case &eventcode of { - E_Fcall | E_Ocall: { - if (op := &eventvalue) === ( - cat | right | left | center | entab | detab | repl | - reverse | map - ) then { - EvGet(rmask) - cnttbl[op] +:= 1 - amttbl[op] +:= *&eventvalue - } - } - E_Ssasgn: { - cnttbl[subs] +:= 1 - amttbl[subs] +:= 1 - } - } - } - - write(output, "\nString operation count:\n") - numlist := sort(cnttbl, 3) - while write(output, left(procname(get(numlist)), 6), right(get(numlist), 8)) - - write(output, "\nString allocation:\n") - numlist := sort(amttbl, 3) - while write(output, left(procname(get(numlist)), 6), right(get(numlist), 8)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/strucget.icn b/ipl/mprogs/strucget.icn deleted file mode 100644 index f06ab44..0000000 --- a/ipl/mprogs/strucget.icn +++ /dev/null @@ -1,68 +0,0 @@ -############################################################################ -# -# File: strucget.icn -# -# Subject: Program to collect SP structures -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program collects the structures in an SP and when the SP -# terminates, it saves them as an xencoded file. Records are not -# collected because they cannot be decoded in the absence of the -# appropriate record declaration. -# -# By keeping pointers to the structures in an SP, it assures that -# all structures produced by that program are intact at the time -# the SP terminates. Be aware, however, that some structures may -# have been "emptied" by the time the SP terminates, for example, -# by get(L). -# -# Saving the SP structure prevents them from being collected, which may -# affect SP performance or even behavior. -# -# The xencoded file is named .xcode there is the name of the -# SP as given on the command line. -# -############################################################################ -# -# Requires: MT Icon and instrumentation -# -############################################################################ -# -# Links: evinit, xcodes -# -############################################################################ - -link evinit -link xcodes - -$include "evdefs.icn" - -procedure main(args) - local mask, structs, name - - name := args[1] | stop("*** no SP") - - EvInit(args) | stop("*** cannot open SP") - - variable("write", &eventsource) := -1 # turn off SP output - variable("writes", &eventsource) := -1 - - structs := set() - - mask := cset(E_Lcreate || E_Rcreate || E_Screate || E_Tcreate) - - while EvGet(mask) do - insert(structs, &eventvalue) # add new structure - - xencoden(sort(structs), name || ".xcode") # save SP structures - -end diff --git a/ipl/mprogs/vc.icn b/ipl/mprogs/vc.icn deleted file mode 100644 index 6e1e5e2..0000000 --- a/ipl/mprogs/vc.icn +++ /dev/null @@ -1,616 +0,0 @@ -############################################################################ -# -# File: vc.icn -# -# Subject: Program to coordinate visualization programs -# -# Author: Ralph E. Griswold -# -# Date: March 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program loads and runs multiple MPs. It is based on the original -# visualization coordinator, Eve, written by Clint Jeffery. -# -# This is a work in progress. At the moment, it works in demonstration -# mode with only hard-coded SPs and MPs available. -# -# The following interface features are provided: -# -# File menu -# -# snapshot @S take snapshot of selected visualization -# quit @Q exit from vc -# -# Pause toggle (@P) to stop and start visualization -# -# Speed control slider for SP events -# -# Display of clock ticks in SP -# -############################################################################ -# -# The following features remain to be implemented: -# -# disabling and enabling MPs -# adding and removing MPs -# specification of SPs and MPs not in hard-coded list -# specification of input data for SPs -# attempt to position MP windows in a useful way -# provide for changing SPs -# provide for continued visualization when SP terminates -# -# Also, there are numerous small problems that need to be fixed, as -# well as better documentation. -# -############################################################################ -# -# Requires: Version 9 MT Icon, event monitoring, and graphics -# -############################################################################ -# -# Links: basename, evutils, interact, lists, vsetup -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link basename -link evutils -link interact -link lists -link vsetup - -$include "evdefs.icn" - -$define EventIter 10 # number of SP events per check on interface - -$define BlkSize 500000 # region sizes for SP and MPs -$define StrSize 500000 -$define MstkSize 20000 - -$define On 1 # initial selection states for MPs -$define Off &null - -# vc's knowledge about MPs is stored in a list of records of type "mp_rec". - -record mp_rec(name, prog, mask, enabled) - -global mps # list of EMs -global mpath # path to MPs -global spath # path to SPs and data -global pause # pause vidget -global unioncset # union of MPs' csets -global root # root vidget -global EventCodeTable # table of MPs to call for each event -global delayval # amount of delay per event -global candidates # list of potential MPs to run -global ticksum # number of clock ticks elapsed in SP -global vc_handlers # procedures for each event vc handles itself -global vc_queue # queue used for MP-MP communication -global vidgets # table of vidgets -global state # paused/running toggle -global mps_names # MP names -global mps_selected # MPs selected -global program # SP - -global SourceProgram # source-code file for SP -global Coordination # indicate MPs are running under a coordinator - -procedure main() - - init() # initialize interface, SP, and MPs - - run() # process events - -end - -procedure able_mps() - local mp_names, mp_enabled, rec, i - - mp_names := [] - mp_enabled := [] - - every rec := !mps do { - put(mp_names, rec.name) - put(mp_enabled, rec.enabled) - } - - if ToggleDialog("MP state", mp_names, mp_enabled) == - "Cancel" then fail - - every i := 1 to *mps do - mps[i].enabled := dialog_value[i] - - union_mask() - - return - -end - -procedure add_mps() - local i - - if ToggleDialog( "Select monitoring programs:", mps_names, mps_selected) == - "Cancel" then fail - - mps_selected := candidates := dialog_value - - mps := [] - - every i := 1 to *candidates do { - if /candidates[i] then next # skip unselected MPs - else put(mps, mp(mpath || mps_names[i])) - } - - every i := 1 to *mps do - mps[i].mask := @mps[i].prog - - union_mask() - - return - -end - -# broadcast() - send event to interested MPs -# -procedure broadcast(x, except) - - /vc_queue := [] - - put(vc_queue, x, except) - - flush_queue() - - return - -end - -# Write the current elapsed SP clock ticks. -# -procedure drawtime(val) - static odo, odo_x, odo_y - - initial { - odo := vidgets["odometer"] - odo_x := vidgets["odometer"].ax - odo_y := vidgets["odometer"].ay + vidgets["odometer"].ah - 6 - } - - GotoXY(odo_x, odo_y) - WWrites(right(val, 6)) - -end - -# Handle file menu. -# -procedure file_cb(vidget, value) - - case value[1] of { - "quit @Q": exit() - "snapshot @S": snap_view() - } - - return - -end - -# Flush events produced during MP-MP communcation. This code is similar to -# vc's main loop. -# -procedure flush_queue() - local c, mask, x, except, monitor - - while *vc_queue > 0 do { - x := pop(vc_queue) - except := pop(vc_queue) | - ExitNotice("Malformed broadcast queue.") - every monitor := (except ~=== !mps) do - if mask := event( , , monitor.prog) then { - if mask ~=== monitor.mask then { - while type(mask) ~== "cset" do { - # - # An MP (probably) has raised a flag. - # Pass it on to all the others except the mp itself. - # - put(vc_queue, mask) - put(vc_queue, monitor) - if not (mask := event( , , monitor.prog)) then - unschedule(monitor) # MP terminated - break next - } - if monitor.mask ~===:= mask then - union_mask() - } - } - else { - unschedule(monitor) # MP terminated - break - } - } - -end - -# Initialize the vc, load SP, load MPs. -# -procedure init() - local i, attribs, info - - Coordination := 1 # post vc's presence - - mpath := "/home/ralph/ibin/" - spath := "/home/ralph/SVP/SPs/" - - attribs := ui_atts() # vc's window attributes - push(attribs, "posx=10", "posy=10") # add initial positioning - - (WOpen ! attribs) | stop("*** can't open window for vc") - - vidgets := ui() # table of vidgets - - root := vidgets["root"] # root vidget - - delayval := 0 # start at fastest speed - VSetState(vidgets["speed"], delayval) - - pause := vidgets["pause"] - VSetState(pause, 1) # start paused to allow setup - - ticksum := 0 - - load_prg() | ExitNotice("Monitoring cancelled in specifying SP.") - - vc_handlers := table() # procedures for events vc handles - - vc_handlers[E_Tick] := vc_tick - vc_handlers[E_Error] := vc_error - - mps_names := [ - "program", - "roll", - "algae", - "napoleon", - "allocviews", - "tinylist", - "scater", - "locus" - ] - mps_selected := [ - On, # program - On, # roll - Off, # algae - Off, # napoleon - Off, # allocviews - Off, # tinylist - Off, # scater - Off # locus - ] - - add_mps() | ExitNotice("Monitoring cancelled in specifying MPs.") - - info := WOpen("lines=" || *mps + 5, "columns=32", "bg=white-gray", - "label=monitoring") - - WWrite(info, " SP: ", basename(program)) - WWrite(info) - WWrite(info, " MPs:") - every WWrite(info, " ", basename((!mps).name)) - - Raise() # bring control window to the front (may not make active) - - return - -end - -# Load SP. - -procedure load_prg() - static input, sps - - initial { - sps := [ - "chess", # chess playing - "concord", # concordance - "macho", # recursive descent parsing - "sortnews", # news sorting - "pool", # population growth - "singles", # bridge tournamen scheduling -# "beards", # parser constructor -# "yhcheng", # line editor - "rsg" # random sentence generation - ] - } - - repeat { - SelectDialog( "Select source program:", sps, sps[1]) == "Okay" | fail - - program := spath || dialog_value - SourceProgram := program || ".icn" - - # Note: Currently, the input data for the SP must be in the same - # directory as the SP, have the same base name as the SP, and - # have the suffix ".dat". - - &eventsource := load( - program, - , - open(spath || dialog_value || ".dat"), - open("/dev/null", "w"), - open("/dev/null", "w"), - BlkSize, - StrSize, - MstkSize - ) | { - Notice("Can't load " || dialog_value || ".") - next - } - - return - - } - -end - -# mp() - create and initialize a mp_rec. -# -procedure mp(name) - local rec - - rec := mp_rec(name) - rec.prog := load( - rec.name, - , - &input, - &output, - &errout, - BlkSize, - StrSize, - MstkSize - ) | ExitNotice("Can't load " || image(rec.name) || ".") - - variable("&eventsource", rec.prog) := ¤t | - ExitNotice("Internal inconsistency; no event source.") - - every variable("Monitored" | "EventSource", rec.prog) := &eventsource - - /rec.mask := '' - /rec.enabled := 1 - - return rec - -end - -# Handle pause toggle. - -procedure pause_cb(vidget, value) - - state := value - - return - -end - -# vc's main loop -# -procedure run() - local monitor, mask - - repeat { - delay(delayval) - - # Process interface events before going on to SP events. - - while (*Pending() > 0) | \state do - ProcessEvent(root, , shortcuts) - - # Process several SP events before going back to check for - # interface events. - - every 1 to EventIter do { - EvGet(unioncset) | Exit() # exit on termination of SP - - # Call vc's own handler for this event, if there is one. - - (\vc_handlers[&eventcode])() - - # Forward the event to those MPs that want it. - - every monitor := !EventCodeTable[&eventcode] do { - if mask := event( , , monitor.prog) then { - if mask ~=== monitor.mask then { - while type(mask) ~== "cset" do { - - # The MP (probably) has raised a signal; pass it on, then - # return to the mp to get his next event request. - - broadcast(mask, monitor) - if not (mask := event( , , monitor.prog)) then { - unschedule(monitor) # MP terminated - break next - } - } - if monitor.mask ~===:= mask then union_mask() - } - } - else unschedule(monitor) # MP terminated - } - } - } - -end - -# Exit when SP is done. - -procedure Exit() - - ExitNotice("Source program terminated normally.") - -end - -# Handle keyboard shortcuts. - -procedure shortcuts(e) - - if &meta then - case map(e) of { # fold case - "s": snap_view() - "q": exit() - "p": VSetState(pause, if \state then &null else 1) - } - - return - -end - -# Take snapshot of MP's visualization window. - -procedure snap_view() - local mp_names, rec, win - - mp_names := [] - - every rec := !mps do - put(mp_names, basename(rec.name)) - - if SelectDialog("Select MP visualization:", mp_names) == "Cancel" then fail - - dialog_value := mpath || dialog_value - - every rec := !mps do - if rec.name == dialog_value then { - win := \variable("Visualization", rec.prog) | - return FailNotice("No image available from " || rec.name) - snapshot( - win, - 0, - 0, - \WAttrib(win, "clipw" | "width"), - \WAttrib(win, "cliph" | "height") - ) | return FailNotice("Cannot produce image file.") - return - } - - return FailNotice("MP not found.") - -end - -# Control speed of event stream. - -procedure speed_cb(vidget, value) - - delayval := sqrt(value) - - return - -end - -# Determine the set of events required by the union of all MPs, including -# vc's and user input needs. -# -procedure union_mask() - local monitor, c - static tickset - - initial tickset := E_Tick ++ E_Error - - # EventCodeTable is keyed by events. For each event, the corresponding - # value is a list of MPs that need that event. - - EventCodeTable := table() - EventCodeTable[E_Tick] := [] - EventCodeTable[E_Error] := [] - - unioncset := tickset - - # Go through the list of MPs, and for each one that is currently - # enabled, add it to the list for each of its event codes. - - every monitor := !mps do { - if \monitor.enabled then { - unioncset ++:= monitor.mask - every c := !monitor.mask do { - /EventCodeTable[c] := [] - put(EventCodeTable[c], monitor) - } - } - } - - return - -end - -# Remove MP from list of MPs. -# -procedure unschedule(MP) - local newmps, monitor - - mps := lremvals(mps, MP) # remove MP - - union_mask() # recompute the union mask - - return - -end - -# Handle run-time error in SP. -# -procedure vc_error() - - # If error conversion is on in the SP, ignore the error. - # Otherwise, display the error information and then terminate - # monitoring. - - if keyword("error", &eventsource) = 0 then - ExitNotice( - "run-time error " || image(&eventvalue), - "", - "file " || keyword("file", &eventsource) || - ", line " || keyword("line", &eventsource), - "", - keyword("errortext", &eventsource), - "", - "offending value: " || image(keyword("errorvalue", &eventsource)) - ) - - else return - -end - -# Handle clock tick events in the SP. -# -procedure vc_tick() - - drawtime(ticksum +:= &eventvalue) - - return - -end - -#===<>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=253,220", "bg=gray-white", "label=vc"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,253,220:visualization coordinator",], - ["elapsed:Label:::10,156,91,13:elapsed time:",], - ["fast:Label:::209,103,28,13:fast",], - ["file:Menu:pull::1,2,36,21:File",file_cb, - ["snapshot @S","quit @Q"]], - ["label1:Label:::151,156,77,13:clock ticks",], - ["line1:Line:::0,25,252,25:",], - ["pause:Button:regular:1:10,54,50,20:pause",pause_cb], - ["slow:Label:::10,103,28,13:slow",], - ["speed:Slider:h:1:48,103,150,15:100,0,0",speed_cb], - ["odometer:Rect:invisible::103,153,41,20:",], - ) -end -#===<>=== end of section maintained by vib diff --git a/ipl/mprogs/vmsum.icn b/ipl/mprogs/vmsum.icn deleted file mode 100644 index 2124325..0000000 --- a/ipl/mprogs/vmsum.icn +++ /dev/null @@ -1,62 +0,0 @@ -############################################################################ -# -# File: vmsum.icn -# -# Subject: Program to tabulate virtual-machine operations -# -# Author: Ralph E. Griswold -# -# Date: November 22, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates event codes. -# -############################################################################ -# -# Requires: Version 9 graphics and MT Icon -# -############################################################################ -# -# Links: evinit, numbers, opnames -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link numbers -link opnames - -procedure main(args) - local name, summary, total, i - - EvInit(get(args) | &null) # initialize interface - - name := opnames() - - summary := table(0) - total := 0 - - while EvGet(E_Opcode) do { - summary[&eventvalue] +:= 1 - total +:= 1 - } - - summary := sort(summary,4) - total /:= 100.0 - - write(left("code",10), right("count",8), right("percent",10)) - write() - while write(left(name[get(summary)],10), right(i := get(summary),8), - " ", fix(i, total, 5, 2)) - -end diff --git a/ipl/packs/README b/ipl/packs/README index 9dc760d..f067e91 100644 --- a/ipl/packs/README +++ b/ipl/packs/README @@ -1,7 +1,11 @@ +Contributed packages distributed with Icon: + euler Euler compiler and interpreter + icondb loadable C function for access to SQL database ibpag2 LR-based parser generator idol Idol; object-oriented Icon written in Icon itweak interactive debugger loadfunc C functions loaded dynamically + loadfuncpp interface for loading C++ functions skeem Scheme language, implemented in Icon tcll1 parser-generator and parser diff --git a/ipl/packs/ibpag2/Makefile b/ipl/packs/ibpag2/Makefile index 56d917e..d9c7d18 100644 --- a/ipl/packs/ibpag2/Makefile +++ b/ipl/packs/ibpag2/Makefile @@ -23,7 +23,7 @@ LIBDIR = /usr/local/lib/icon/data # # Name of your icon compiler and compiler flags. # -ICONC = icont +ICONT = icont IFLAGS = -u -s #-Sc 400 -Sg 400 -Si 2000 -Sn 4000 -SF 40 SHAR = /usr/local/bin/shar @@ -48,7 +48,7 @@ SHARFILES = $(SRC) $(PARSER) $(GLRPARSER) sample.ibp beta2ref.ibp \ all: $(PROGNAME) $(PROGNAME): $(SRC) - $(ICONC) $(IFLAGS) -o $(PROGNAME) $(SRC) + $(ICONT) $(IFLAGS) -o $(PROGNAME) $(SRC) ########################################################################## diff --git a/ipl/packs/ibpag2/README b/ipl/packs/ibpag2/README index c2f5d82..0accddd 100644 --- a/ipl/packs/ibpag2/README +++ b/ipl/packs/ibpag2/README @@ -997,10 +997,7 @@ do. Please be sure to read the directions in the makefile carefully, and set DESTDIR and LIBDIR to the directory where you want the executable and parser file to reside. Also, make sure the paths -you specify are correct for your Icon executables. Although Ibpag2 -will apparently compile using iconc, I would recommend using the -interpreter, icont, first, unless you are planning on working with a -large grammar. +you specify are correct for your Icon executables. If you are using some other system - one that lacks "make" - then shame on your manufacturer :-). You'll be a bit inconvenienced. @@ -1012,13 +1009,7 @@ Try typing: version.icn slshupto.icn The backslashes merely indicate that the next line is a continuation. -The whole thing should, in other words, be on a single line. As noted -above, you may compile rather than interpret - if your OS supports the -Icon compiler. Just replace "icont" above with "iconc." The -resulting executable will run considerably faster than with "icont," -although the time required to compile it may be large, and the (still -somewhat experimental) compiler may not work smoothly in all -environments. +The whole thing should, in other words, be on a single line. If your operating system support environment variables, and you have set up your LPATH according to the specifications in the Icon @@ -1050,7 +1041,7 @@ input and output redirection. Naturally, the above example assumes that Ibpag2 is in c:\ibpag2. Ibpag2 assumes the existence on your system, not only of an -Icon interpreter or compiler, but also of an up-to-date Icon Program +Icon interpreter, but also of an up-to-date Icon Program Library. There are several routines included in the IPL that Bibleref uses. Make sure you (or the local system administrators) have put the IPL online, and have translated the appropriate object modules. Set diff --git a/ipl/packs/icondb/Makefile b/ipl/packs/icondb/Makefile new file mode 100644 index 0000000..5e616c4 --- /dev/null +++ b/ipl/packs/icondb/Makefile @@ -0,0 +1,41 @@ +# icondb -- Icon database interface contributed by Carl Sturtivant. + +# Requires GNU make, gcc, mysql utilities, and mysql development package. + +ifndef TARGET + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +endif #TARGET + + +ICON_PATH=../../.. + + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +PIC_mac = -flat_namespace +PIC_other = -fPIC + +EXTRA_cygwin = $(ICON_PATH)/bin/iload.a -Wl,--enable-auto-import +EXTRA_other = -I./ + + +default: + icont -ucs icondb.icn + cp icondb.u1 icondb.u2 $(ICON_PATH)/lib + sh -c "gcc -I../../cfuncs $(SHARED_$(TARGET)) -o mysqldb.so $(PIC_$(TARGET)) `mysql_config --cflags` mysqldb.c `mysql_config --libs`" + cp mysqldb.so $(ICON_PATH)/bin + +clean Clean: + rm -f *.u? *.o *.so */*.o */*.u? */*.so diff --git a/ipl/packs/icondb/cgi.icn b/ipl/packs/icondb/cgi.icn new file mode 100644 index 0000000..2b47f9d --- /dev/null +++ b/ipl/packs/icondb/cgi.icn @@ -0,0 +1,43 @@ + +#everything needed for typical web form handling + +procedure cgiparms() #returns a table, mapping names to lists of values + local GET_data, POST_data, data, i, pname, pvalue, s + static result + initial { + result := table() + GET_data := trim(getenv("QUERY_STRING"))|"" + if *GET_data = 0 then GET_data := &null + POST_data := reads(&input, getenv("CONTENT_LENGTH")) + if \GET_data & \POST_data then + data := GET_data || "&" || POST_data + else + data := \GET_data | \POST_data + if /data then return result + data ? every i := upto('&')|0 do { + tab(i) ? { + pname := _urldecode( tab(upto('=')) ) + move(1) + pvalue := _urldecode( tab(0) ) + /result[pname] := [] + put( result[pname], pvalue ) + } + if pos(0) then break + move(1) + } + } + return result +end + +procedure _urldecode(url) + local s + s := "" + url ? repeat { + s ||:= tab(upto('%+')|0) + if pos(0) then return s + case move(1) of { + "%" : s ||:= char("16r" || map(move(2)) ) + "+" : s ||:= " " + } + } +end diff --git a/ipl/packs/icondb/icondb.icn b/ipl/packs/icondb/icondb.icn new file mode 100644 index 0000000..5cbc67b --- /dev/null +++ b/ipl/packs/icondb/icondb.icn @@ -0,0 +1,105 @@ + +#simulation of the real icondb.icn +#using the C mysql and postgresql interfaces for Icon 9.4. +#use with cgi.icn (instead of web.icn) +#until loadfuncpp becomes reliable + +#WARNING: can only connect to one mysql and one postgresql database at a time + +#CS 2008/7/27 + + +link io + +#the C interface +procedure _mysqldb(arg[]) + return ( _mysqldb := pathload("mysqldb.so","mysqldb") )!arg +end + +procedure _postgresqldb(arg[]) + return ( _postgresqldb := pathload("postgresqldb.so","postgresqldb") )!arg +end + +#simulated external value +record database_handle(connection, c_interface) + +#simulated mysql connection procedure +procedure _connectmysql(dbname, user, pwd, host, port) + local connection, result + icondb_error := &null + connection := [dbname, user, pwd] + if put(connection, \host) then put(connection, \port) + result := _mysqldb(connection) + if /result then return database_handle(connection, _mysqldb) + icondb_error := result + fail +end + +#simulated postgresql connection procedure +procedure _connectpostgresql(dbname, user, pwd, host, port) + local connection, result + icondb_error := &null + connection := [dbname, user, pwd] + if put(connection, \host) then put(connection, \port) + result := _postgresqldb(connection) + if /result then return database_handle(connection, _postgresqldb) + icondb_error := result + fail +end + +global icondb_error + +#icondb returns a connection procedure for a known kind of dbms +#which may then be called following the pattern +#dbhandle := connect(dbname, user, pwd, host, port) +#where host and port are optional + +procedure icondb(kind) + case kind of { + "mysql" : return _connectmysql + "postgresql" : return _connectpostgresql + default : stop("icondb: unknown dbms\nerror: ", image(kind)) | fail + } +end + +procedure dbclose(db) + if type(db) ~== "database_handle" then + stop("dbclose: not a database handle: ", image(db)) + icondb_error := &null + db.c_interface() + return +end + +procedure dbquery(db, query, constructor) + local result, rec + if type(db) ~== "database_handle" then + stop("dbquery: not a database handle: ", image(db)) + case type(constructor) of { + "null" : + &null + "procedure" : + image(constructor) ? { + ="record constructor" | + stop("dbquery: not a record constructor: ", image(constructor)) + } + default : + stop("dbquery: not a record constructor: ", image(constructor)) + } + icondb_error := &null + result := db.c_interface(query) + case type(result) of { + "integer" | "null" : return result + "list" : case type(result[1]) of { + "list": + if /constructor then + suspend !result + else { + if result[1] & *constructor() ~= *result[1] then + stop("dbquery: ",image(constructor)," needs at least ",*rec[1]," fields." ) + suspend constructor!!result + } + "integer" : icondb_error := result + } + } +end + diff --git a/ipl/packs/icondb/mysqldb.c b/ipl/packs/icondb/mysqldb.c new file mode 100644 index 0000000..06dc179 --- /dev/null +++ b/ipl/packs/icondb/mysqldb.c @@ -0,0 +1,289 @@ + +/*-----------------3/27/2007 11:23AM----------------- + * loadable C function mysqldb for icon access to + * a mySQL database from linux, by Carl Sturtivant. + * (This also built on solaris.) + * + * This should be Garbage Collection safe except + * under very extreme memory shortages. + * + * Requires a mySQL installation to build. + * I used the following from bash: + +CFG=/usr/bin/mysql_config +sh -c "gcc -shared -o mysqldb.so -fPIC `$CFG --cflags` mysqldb.c `$CFG --libs`" + + * for details about calling mysqldb, see below. + * --------------------------------------------------*/ + +#include +#include + +/* http://dev.mysql.com/doc/refman/5.0/en/c.html */ +/* #include "/usr/include/mysql/mysql.h" */ +#include + + +#include "icall.h" + + +/* macros obtained by modifying some from icall.h */ + +#define Mkinteger(i, dp) \ +do { (dp)->dword = D_Integer; (dp)->vword = (i); } while(0) + +#define Mkstring(s, dp) \ +do { word n = strlen(s); \ +(dp)->dword = n; (dp)->vword = (word)alcstr(s,n); } while(0) + +/* ensure that return to icon removes our tended descriptors from the list */ +#define ReturnDescriptor(d) do { gcu_aware_pop(); return ( argv[0] = (d), 0 ); } while(0) +#define ReturnError(d, n) do { gcu_aware_pop(); return ( argv[0] = (d), n ); } while(0) + + +/****************start of Garbage Collection Utilities****************/ + +/* Structure for chaining descriptors to be tended properly by GC (rstructs.h) */ +struct tend_desc { + struct tend_desc *previous; + int num; + descriptor d[1]; /* actual size is in num */ +}; +typedef struct tend_desc gcu_tended; + +/* global chain of such structures used by iconx (rinit.r) */ +extern gcu_tended *tend; + +/* int parameter to pass to gcu_initialize */ +#define gcu_max(vars) ( (sizeof(vars) - sizeof(gcu_tended) )/sizeof(descriptor) ) + +/* initialize all descriptors to &null and assign the number */ +static void gcu_initialize(int maxindex, void *descriptors) { + int i; + gcu_tended *desc = (gcu_tended *)descriptors; + desc->num = maxindex+1; + for( i = 0; i <= maxindex; ++i ) (desc->d)[i] = nulldesc; +} + +/* add descriptors in a gcu_tended structure to the tended list */ +static void gcu_aware_push(void *descriptors) { + gcu_tended *desc = (gcu_tended *)descriptors; + desc->previous = tend; + tend = descriptors; +} + +/* remove descriptors in a gcu_tended structure from the tended list */ +static void gcu_aware_pop() { + tend = tend->previous; +} + +/****************end of Garbage Collection utilities****************/ + + +/****************start of list utilities****************/ + +int Zlist(descriptor argv[]); /* resolved in iconx: icon function list(i,X):L */ +int Osubsc(descriptor argv[]); /* resolved in iconx: icon operator L[i]:v */ +int Oasgn(descriptor argv[]); /* resolved in iconx: icon operator v:=X */ + +typedef int (*iconfunction)(descriptor argv[]); + +/* safely call an icon built-in function or operator with two arguments from C. */ +static descriptor iconcall2(iconfunction F, descriptor x1, descriptor x2) { + struct { /* structure like struct tend_desc with extra descriptors at the bottom */ + gcu_tended other; /* vital: used to chain onto the tend list */ + descriptor stack[3]; /* GC is aware of these once this struct is pushed onto the tend list */ + } tended; + gcu_initialize( gcu_max(tended), &tended ); /* vital: call before icon may be made aware of this */ + gcu_aware_push( &tended ); /* GC is now aware of tended.stack */ + tended.stack[0] = nulldesc; + tended.stack[1] = x1; + tended.stack[2] = x2; + F(tended.stack); /* No error handling for the uses below */ + gcu_aware_pop(); /* vital: GC is now unaware of tended.stack */ + return tended.stack[0]; +} + +/* returns list(n, &null) --- allocates memory */ +static descriptor newlist(int length) { + descriptor len; + Mkinteger(length, &len); + return iconcall2( &Zlist, len, nulldesc ); +} + +/* returns list[index] := value */ +static descriptor assign(descriptor list, int index, descriptor value) { + descriptor i; + Mkinteger(index, &i); + return iconcall2( &Oasgn, iconcall2(&Osubsc, list, i), value ); +} + +/* returns .list[index] */ +static descriptor subscript(descriptor list, int index) { + descriptor i, result; + Mkinteger(index, &i); + result = iconcall2(&Osubsc, list, i); + /* result of an icon subscripting operation is a variable */ + deref(&result, &result); /* deref resolved in iconx */ + return result; +} + +/****************end of list utilities****************/ + + +/* make icon list of mysql error information */ +static descriptor error_info(int mysqlNumber, const char * mysqlError) { + descriptor number; + struct { + gcu_tended other; + descriptor text, ls; + } tended; + gcu_initialize( gcu_max(tended), &tended ); + gcu_aware_push( &tended ); + tended.ls = newlist(2); + Mkinteger(mysqlNumber, &number); + Mkstring((char *)mysqlError, &tended.text); + assign( tended.ls, 1, number ); + assign( tended.ls, 2, tended.text ); + gcu_aware_pop(); + return tended.ls; +} + +/* make mySQL row retrieved from query results into icon list */ +static descriptor convertrow(MYSQL_ROW row, int numfields) { + int i; + struct { + gcu_tended other; + descriptor x, ls; + } tended; + gcu_initialize( gcu_max(tended), &tended ); + gcu_aware_push( &tended ); + tended.ls = newlist(numfields); + for( i = 1; i <= numfields; ++i ) { + if( row[i-1] ) Mkstring( row[i-1], &tended.x ); + else tended.x = nulldesc; + assign( tended.ls, i, tended.x ); + } + gcu_aware_pop(); + return tended.ls; +} + +/*-------------------------------------------------- + * Called with a list, mysqldb attempts to connect. + * Only one database can be connected to at a time. + * Needs the database name, username, password, + * and optionally the host, and if so optionally + * the port number, all passed in a list. The host + * defaults to localhost, and the port number to + * the default port number for mySQL. + * + * Called with a string, mysqldb attempts to + * execute that string as a mySQL query. + * + * Called with no parameters, mysqldb closes + * the connection if it is open. + * + * Returns a list of lists for a SELECT query, or + * the number of rows affected for other queries. + * Otherwise, fails if everything works, returns + * error information if not, except if incorrect + * argument types are supplied, in which case the + * result is an error. + * --------------------------------------------------*/ +int mysqldb(int argc, descriptor argv[]) { + static MYSQL dbh; /* connection sticks around between calls */ + static int connected = 0; + + MYSQL_RES *result; + MYSQL_ROW row; + char *querystring, *hoststring, + *databasestring, *userstring, *passwordstring; + int i, len, rowsize, portnum; + struct { + gcu_tended other; + descriptor ls, host, port, database, user, password, answer; + } tended; + gcu_initialize( gcu_max(tended), &tended ); + gcu_aware_push( &tended ); + + + if( argc == 0 ) { /* close connection */ + if( connected ) mysql_close(&dbh); + connected = 0; + gcu_aware_pop(); + Fail; + } /* end close connection */ + + if( argc >= 1 && IconType(argv[1]) == 'L' ) { /* connect to MySQL */ + if( connected ) + ReturnDescriptor( error_info(-1, "mysqldb: already connected") ); + if( !mysql_init(&dbh) ) + ReturnDescriptor( error_info(-1, "mysqldb: cannot initialize mySQL!") ); + + tended.ls = argv[1]; + hoststring = "localhost"; /* host defaults to localhost */ + portnum = 0; /* port defaults to 0 giving the mySQL default */ + + switch( ListLen(tended.ls) ) { + default: + ReturnDescriptor( error_info(-1, "mysqldb: list of dbname, user, pwd, [host, [port]] expected") ); + case 5 : + tended.port = subscript(tended.ls, 5); + if( !cnv_int(&tended.port,&tended.port) ) ReturnError(tended.port,101); + portnum = IntegerVal(tended.port); + case 4 : + tended.host = subscript(tended.ls, 4); + if ( !cnv_str(&tended.host,&tended.host) ) ReturnError(tended.host,103); + hoststring = StringVal(tended.host); + case 3 : + tended.password = subscript(tended.ls, 3); + if ( !cnv_str(&tended.password,&tended.password) ) ReturnError(tended.password,103); + passwordstring = StringVal(tended.password); + tended.user = subscript(tended.ls, 2); + if ( !cnv_str(&tended.user,&tended.user) ) ReturnError(tended.user,103); + userstring = StringVal(tended.user); + tended.database = subscript(tended.ls, 1); + if ( !cnv_str(&tended.database,&tended.database) ) ReturnError(tended.database,103); + databasestring = StringVal(tended.database); + } + + if( mysql_real_connect(&dbh, hoststring, userstring, + passwordstring, databasestring, portnum, NULL, 0) ) { + connected = 1; + gcu_aware_pop(); + Fail; + } + else ReturnDescriptor( error_info(mysql_errno(&dbh), mysql_error(&dbh)) ); + } /* end connect to MySQL */ + + if( argc >= 1 && IconType(argv[1]) == 's' ) { /* execute a query */ + if( !connected ) + ReturnDescriptor( error_info(-1, "mysqldb: not connected") ); + querystring = StringVal(argv[1]); + + if( mysql_query(&dbh, querystring) ) + ReturnDescriptor( error_info(mysql_errno(&dbh), mysql_error(&dbh)) ); + + result = mysql_store_result(&dbh); + + if( !result ) /* not a SELECT query or some sort of error */ + if( mysql_field_count(&dbh) != 0 ) + ReturnDescriptor( error_info(mysql_errno(&dbh), mysql_error(&dbh)) ); + else { /* not a SELECT query */ + gcu_aware_pop(); + RetInteger( mysql_affected_rows(&dbh) ); + } + + /* SELECT query */ + tended.answer = newlist( mysql_num_rows(result) ); + rowsize = mysql_num_fields(result); + i = 0; + while( row = mysql_fetch_row(result) ) + assign( tended.answer, ++i, convertrow(row, rowsize) ); + mysql_free_result(result); + ReturnDescriptor(tended.answer); + } /* end execute a query */ + + /* wrong argument type to mysqldb */ + ReturnError(argv[1], 110); /* list or string expected */ +} diff --git a/ipl/packs/loadfunc/Makefile b/ipl/packs/loadfunc/Makefile index 66c72d7..6c9cc2f 100644 --- a/ipl/packs/loadfunc/Makefile +++ b/ipl/packs/loadfunc/Makefile @@ -3,7 +3,7 @@ # It is assumed that the standard C functions will be found by iconx. include ../../../Makedefs -CFLAGS = -O $(CFDYN) -I../../cfuncs +CFLAGS = -O $(CFDYN) -I../../cfuncs ICONT = icont IFLAGS = -us @@ -28,7 +28,8 @@ libnames.icn: Makefile echo '$$define FUNCLIB "./$(FUNCLIB)"' >libnames.icn $(FUNCLIB): $(FUNCS) - CC="$(CC)" CFLAGS="$(CFLAGS)" sh $(MKLIB) $(FUNCLIB) $(FUNCS) + CC="$(CC)" CFLAGS="$(CFLAGS)" BIN="../../../bin" \ + sh $(MKLIB) $(FUNCLIB) $(FUNCS) # Copy progs to ../../iexe: diff --git a/ipl/packs/loadfuncpp/Makefile b/ipl/packs/loadfuncpp/Makefile new file mode 100644 index 0000000..15cce8b --- /dev/null +++ b/ipl/packs/loadfuncpp/Makefile @@ -0,0 +1,107 @@ +# loadfuncpp -- a C++ interface for icon. See doc/index.htm. + +# Requires GNU make and g++. + +CC=g++ + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "solaris")),) +#TARGET=sun +#CC=cc +TARGET=other +else +TARGET=other +endif +endif +endif + + + +#ICON_PATH = $(shell cd $(PWD)/../../..; pwd) +ICON_PATH = ../../.. + +ICON_BUILD_PATH = $(ICON_PATH) + +ICON_BIN_PATH = $(ICON_PATH)/bin +ICON_LIB_PATH = $(ICON_PATH)/lib +ICON_HDR_PATH = $(ICON_BUILD_PATH)/src/h + +ICON_HDR_FILE = \"$(ICON_HDR_PATH)/rt.h\" + +FLAGS_cygwin = -Wl,--enable-auto-import +FLAGS_cygwin_default = $(ICON_BIN_PATH)/iconx.a +FLAGS_cygwin_iexample = $(ICON_BIN_PATH)/iload.a + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +IMPLIB_cygwin = -Wl,--out-implib=iload.a +PIC_other = -fPIC +PIC_mac = -flat_namespace + +COPY_cygwin =cp iload.a $(ICON_BIN_PATH)/ + +COPY_PACKAGE_cygwin=cp iload.a package/bin + +DEPS_cygwin_default = $(ICON_BIN_PATH)/iconx.a +DEPS_cygwin_iexample = $(ICON_BIN_PATH)/iload.a + +DEPS_default = $(ICON_BIN_PATH)/iload.so $(ICON_BIN_PATH)/iloadgpx.so $(ICON_BIN_PATH)/iloadnogpx.so +SLIBS = iload.so iloadgpx.so iloadnogpx.so + +.PHONY : default clean iconsrc iexample package + + +default : $(DEPS_default) $(DEPS_$(TARGET)_default) $(ICON_LIB_PATH)/loadfuncpp.u1 + +iload.so : %.so : %.cpp loadfuncpp.h iload.h + $(CC) $(PIC_$(TARGET)) $(SHARED_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)_default) $(FLAGS_$(TARGET)) $(IMPLIB_$(TARGET)) -DRTT=$(ICON_HDR_FILE) + +iloadgpx.so iloadnogpx.so : %.so : %.cpp loadfuncpp.h iload.h $(DEPS_$(TARGET)_iexample) + $(CC) $(PIC_$(TARGET)) $(SHARED_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)_default) $(FLAGS_$(TARGET)_iexample) $(FLAGS_$(TARGET)) -DRTT=$(ICON_HDR_FILE) + +$(DEPS_default) : $(ICON_BIN_PATH)/%.so : %.so + cp $< $(ICON_BIN_PATH) + +$(ICON_BIN_PATH)/iload.a : iload.a + cp $< $(ICON_BIN_PATH) + +iload.a : iload.so + +$(ICON_LIB_PATH)/loadfuncpp.u1 : loadfuncpp.u1 + cp loadfuncpp.u? $(ICON_LIB_PATH) + +loadfuncpp.u1 : loadfuncpp.icn + icont -cs loadfuncpp.icn + +clean Clean: + rm -f iexample *.exe *.u? *.so *.o *% *~ core .#* + +iconsrc: $(ICON_BIN_PATH) $(ICON_LIB_PATH) $(ICON_HDR_PATH) + @ echo "install Icon 9.5+ from source in $(ICON_PATH)" + @ exit 1 + +iexample: iexample.so $(DEPS_$(TARGET)_iexample) + icont -s iexample.icn + +iexample.so : iexample.cpp loadfuncpp.h + $(CC) $(PIC_$(TARGET)) $(SHARED_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)_iexample) $(FLAGS_$(TARGET)) + +package : $(SLIBS) loadfuncpp.u1 + mkdir package + mkdir package/bin + cp iload*.so package/bin + $(COPY_PACKAGE_$(TARGET)) + mkdir package/lib + cp loadfuncpp.u? package/lib + mkdir package/h + cp loadfuncpp.h package/h + tar -cf $(TARGET).tar package + gzip $(TARGET).tar + rm -rf package/ diff --git a/ipl/packs/loadfuncpp/doc/Makefile b/ipl/packs/loadfuncpp/doc/Makefile new file mode 100644 index 0000000..586d7d6 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/Makefile @@ -0,0 +1,51 @@ + +#Automatically generated from Makefile.mak and examples.txt by ../savex.icn + +# icont -ucs file.icn -> u1, u2, goes in the /opt/icon/lib/. +# g++ stuff -> .os, goes in the /opt/icon/bin/. + + +ifndef TARGET + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +endif + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +PIC_other = -fPIC +PIC_mac = -flat_namespace + +EXAMPLES = bang.exe divide.exe divide2.exe dull.exe generator.exe isexternal.exe iterate.exe keyword.exe makelist.exe object.exe +DYNAMICS = bang.so divide.so divide2.so dull.so generator.so isexternal.so iterate.so keyword.so makelist.so object.so + +%.so : %.cpp loadfuncpp.h + g++ $(SHARED_$(TARGET)) $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : loadfuncpp.h + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* diff --git a/ipl/packs/loadfuncpp/doc/Makefile.mak b/ipl/packs/loadfuncpp/doc/Makefile.mak new file mode 100644 index 0000000..7a10f86 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/Makefile.mak @@ -0,0 +1,34 @@ + +ifndef TARGET +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +PIC_other = -fPIC + +EXAMPLES = #exe# +DYNAMICS = #so# + +%.so : %.cpp loadfuncpp.h + g++ -shared $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : loadfuncpp.h + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* diff --git a/ipl/packs/loadfuncpp/doc/bang.cpp b/ipl/packs/loadfuncpp/doc/bang.cpp new file mode 100644 index 0000000..c300169 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/bang.cpp @@ -0,0 +1,35 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + + + +struct addup: public iterate { + safe total; + int count; + + addup(): total(0L), count(0) {} + + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 10; + } +}; + +extern "C" int sumlist(value argv[]) { + addup sum; + sum.bang(argv[1]); + argv[0] = sum.total; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/bang.icn b/ipl/packs/loadfuncpp/doc/bang.icn new file mode 100644 index 0000000..bf0aba9 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/bang.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + + +procedure main() + sumlist := loadfuncpp("./bang.so", "sumlist", 1) + write( sumlist([1,2,3,4,5]) ) +end + + diff --git a/ipl/packs/loadfuncpp/doc/compile.htm b/ipl/packs/loadfuncpp/doc/compile.htm new file mode 100644 index 0000000..04a8514 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/compile.htm @@ -0,0 +1,57 @@ + + + + + + loadfuncpp + + + + + +

+
+

+ + + + +
+


+ Loadfuncpp

+

Compiler Options

+

Carl Sturtivant, January 2009

+
+
+

When compiling a shared object (or dll) to dynamically load functions into Icon via loadfuncpp, try the following + compilation options, which have been successfully used to build libraries with version 0.91alpha on the systems + below.
+
+ Everything is simplest if all shared objects are placed in the icon/bin directory and all linkable Icon (.u1/.u2 + files) are placed in the icon/lib directory. +

+

Linux

+

g++ -fPIC -shared -o file.so file.cpp

+

Cygwin

+

g++ -shared -o file.so file.cpp iload_so_directory/iload.a

+

Macintosh

+

g++ -flat_namespace -bundle -undefined suppress -o + file.so + file.cpp +

Solaris

+

g++ -fPIC -shared -o file.so file.cpp +

+
+ +

+ + + + diff --git a/ipl/packs/loadfuncpp/doc/divide.cpp b/ipl/packs/loadfuncpp/doc/divide.cpp new file mode 100644 index 0000000..a9f3d99 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide.cpp @@ -0,0 +1,20 @@ + + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int div(value argv[]) { + safe x(argv[1]), y(argv[2]), z; + z = ( x/y, x%y ); + argv[0] = z; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/divide.icn b/ipl/packs/loadfuncpp/doc/divide.icn new file mode 100644 index 0000000..9e5c0b8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + div := loadfuncpp("./divide.so", "div", 2) + ls := div(79, 10) + every write(!ls) +end + + diff --git a/ipl/packs/loadfuncpp/doc/divide2.cpp b/ipl/packs/loadfuncpp/doc/divide2.cpp new file mode 100644 index 0000000..a9f3d99 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide2.cpp @@ -0,0 +1,20 @@ + + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int div(value argv[]) { + safe x(argv[1]), y(argv[2]), z; + z = ( x/y, x%y ); + argv[0] = z; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/divide2.icn b/ipl/packs/loadfuncpp/doc/divide2.icn new file mode 100644 index 0000000..48da848 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide2.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + div := loadfuncpp("./divide2.so", "div", 2) + ls := div(79, 10) + every write(!ls) +end + + diff --git a/ipl/packs/loadfuncpp/doc/dull.cpp b/ipl/packs/loadfuncpp/doc/dull.cpp new file mode 100644 index 0000000..f1683ee --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/dull.cpp @@ -0,0 +1,15 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int dull(value argv[]) { + argv[0] = nullvalue; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/doc/dull.icn b/ipl/packs/loadfuncpp/doc/dull.icn new file mode 100644 index 0000000..128f8a1 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/dull.icn @@ -0,0 +1,9 @@ + +link loadfuncpp + + +procedure main() + dull := loadfuncpp("./dull.so", "dull", 1) + write(image( dull() )) +end + diff --git a/ipl/packs/loadfuncpp/doc/examples.txt b/ipl/packs/loadfuncpp/doc/examples.txt new file mode 100644 index 0000000..3b6a98e --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/examples.txt @@ -0,0 +1,10 @@ +bang +divide +divide2 +dull +generator +isexternal +iterate +keyword +makelist +object diff --git a/ipl/packs/loadfuncpp/doc/generator.cpp b/ipl/packs/loadfuncpp/doc/generator.cpp new file mode 100644 index 0000000..5f99158 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/generator.cpp @@ -0,0 +1,31 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +class sequence: public generator { + safe current, inc; + public: + sequence(safe start, safe increment) { + current = start - increment; + inc = increment; + } + virtual bool hasNext() { + return true; + } + virtual value giveNext() { + return current = current + inc; + } +}; + +extern "C" int seq2(value argv[]){ + sequence seq(argv[1], argv[2]); + return seq.generate(argv); +} + + diff --git a/ipl/packs/loadfuncpp/doc/generator.icn b/ipl/packs/loadfuncpp/doc/generator.icn new file mode 100644 index 0000000..cf46dff --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/generator.icn @@ -0,0 +1,9 @@ + +link loadfuncpp + + +procedure main() + seq2 := loadfuncpp("./generator.so", "seq2", 1) + every write( seq2(1001, 99) \ 30 ) +end + diff --git a/ipl/packs/loadfuncpp/doc/hello.php b/ipl/packs/loadfuncpp/doc/hello.php new file mode 100644 index 0000000..d96e074 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/hello.php @@ -0,0 +1,10 @@ + + + Hello World + + + + + diff --git a/ipl/packs/loadfuncpp/doc/icall.txt b/ipl/packs/loadfuncpp/doc/icall.txt new file mode 100644 index 0000000..700929f --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/icall.txt @@ -0,0 +1,140 @@ + +A Technique to Call Icon from C under Icon Version 9 + Carl Sturtivant, 2008/2/20 Confidential Draft #1 + + +1. Summary. + +A new Icon function written in C with a special interface may be +dynamically loaded from a shared object using the built-in function +loadfunc [GT95]. We show how such a function may in turn call an Icon +procedure using the technique described below, provided that the +procedure call itself does not suspend, but only returns or fails. Note +that this does not impose constraints of any kind upon other procedures +executed as a consequence of calling the original procedure. In +particular, the Icon procedure called from C may in turn lead to a call +of another Icon function written in C calling Icon recursively. The +technique described has been implemented and briefly tested with Icon +9.51(?). + + +2. Overview. + +If the body of an Icon function written in C is to call an Icon +procedure that does not suspend and retrieve its return value, all +without modifying iconx, then there are a number of hurdles to jump. +The procedure descriptor, and those of its arguments must be pushed +onto the Icon stack, and the interpreter induced to believe it needs to +execute an icode instruction to invoke it, one that is not present in +the icode it loaded. Once the procedure returns (or fails) the +interpreter must be induced to return control to C just after the point +where the attempt to call it occurred, rather than simply to go on to +the next icode instruction. Then the result of the call needs to be +popped off the Icon stack so that it is in the same state as before the +call, since C does not normally modify the Icon stack. (Other details +of the state of the interpreter will be restored by the mechanism +whereby a procedure is called in Icon.) In all other respects, the main +interpreter loop must continue to behave as before. + +These hurdles are insurmountable, so long as the code of the main +interpreter loop is inviolate. The code of that loop as it is +incorporated into iconx is inviolate, since a design goal is that the +technique should work with the existing implementation. Therefore, we +take a copy of that loop, and modify it to the ends above, and execute +it only in order to call Icon. (The original interpreter continues to +be used for all other purposes.) Dynamic linking allows the new +interpreter loop to refer to all C globals and functions in iconx, and +so nothing else need be copied, these things are merely referred to. In +fact it takes very little modification of the copy to achieve these +goals, and the result is a C function called icall to which the +procedure and its arguments are passed to effect the call to Icoan. To +simplify this interface, the arguments are passed as a single Icon +list. The resulting function then has similar semantics as the binary +"!" operator in Icon, (which we henceforth call 'apply' as it applies a +procedure to its argument list) except that it may be called from C. + + +3. Implementation. + +The main interpreter loop written in RTL resides in the file +src/runtime/interp.r in the Icon distribution. This was translated into +the corresponding C file xinterp.c by the RTL translator rtt with the +command 'rtt -x interp.r'. Now this C file is edited into a file +compiled into a single C function called icall, taking two descriptors +(a procedure and a list of arguments) and returning an integer code. +The effect of calling icall is to apply the procedure to its arguments, +and restore the state of the interpreter, leaving the result of the +call just beyond the stack pointer for retrieval. + +The contents of xinterp.c consist of some global variables and a +function interp containing the interpreter loop. The global variable +declarations are all modified by prefixing them with 'extern', so that +they now simply refer to those used by the interpreter loop inside +iconx. The function interp that returns an integer signal and has two +parameters: an integer fsig used when the interpreter is called +recursively to simulate suspension, and cargp, a pointer into the Icon +stack. The function interp is renamed icall. + +Examination of src/runtime/init.r indicates that the signal 0 is passed +to interp when it is initially called non-recursively to start up +iconx. So fsig is removed from the parameter list and made a local +variable initialized to 0. Similarly cargp is made a local variable, +and icall is given two parameters theProc and arglist used to pass that +necessary for the call to Icon. Immediately after the initial +declarations inside icall, the Icon stack pointer sp is used to +initialize cargp to refer to the first descriptor on the stack beyond +sp, which is assigned the procedure desciptor parameter of icall. The +desciptor beyond that is assigned the argument list descriptor +parameter, and the stack pointer augmented to refer to its last word. A +new local variable result_sp is initialized to location on the stack of +the last word of the procedure descriptor. This is used by the +mechanism to return to C described below. Now the details of pushing +the procedure descriptor and the argument list descriptor onto the +stack are complete. + +The body of interp consists of some straight-line code followed by the +interpreter loop, which contains some code to get the next icode +instruction followed by a switch to jump to the correct code to execute +it, all inside and endless loop. Just before the loop starts, an +unconditional goto is inserted, jumping to a newly inserted label +called aptly 'apply' which is placed just after the switch label +(called Op_Apply in interp.r) which precedes the code to implement the +icode 'apply' instruction, that implements the apply operator (binary +"!") in Icon. This instruction expects to find a procedure descriptor +and a list descriptor on the stack, and then causes the icode +instructions of the procedure to be accordingly invoked. Now the +details of calling the procedure are complete. What is left to insert +is the mechanism to return to C. + +When the procedure that we called returns or fails, it will execute a +'pret' instruction or a 'pfail' instruction. However, these +instructions may also be executed by Icon procedures called from the +one we called. At the end of the code for 'pret' inside the switch in +the interpreter is a 'break' to leave the switch and go round to get +the next icode instruction. Just before that 'break' we can tell if our +procedure call is the one returning by comparing the Icon stack pointer +sp to the one we saved, result_sp, which our procedure call will have +restored sp to when it overwrote the procedure descriptor with the +result of the call. So if they are equal, we can clean up (decrement +ilevel, move sp just before the former procedure descriptor) and +return, finishing the call to icall. Now C can retrieve the result of +the call just beyond the stack pointer. The 'pfail' code is similar, +just before a jump to efail, which we do not execute since the context +of our call is not an Icon expression. C can determine success or +failure from the integer code returned. This completes the mechanism to +return to C. + + +4. Conclusions + +Overall this mechanism depends upon few things, mainly upon the fact +that when a procedure is called, the Icon stack below the part used for +the call is not modified during the call. Our copy of the interpreter +loop is identical to the original with the exception of the code added +for the C return mechanism, which is only exceptionally executed. And +the Icon procedure call mechanism itself will save and restore the +interpreter state apart from the stack pointer which we abuse at the +start and restore at the end. The compiled result with gcc was about 10 +Kbyte. A simple test confirmed that call and return occur in the +correct order, from Icon to C to Icon returning to C returning to Icon. + diff --git a/ipl/packs/loadfuncpp/doc/index.htm b/ipl/packs/loadfuncpp/doc/index.htm new file mode 100644 index 0000000..dad9df8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/index.htm @@ -0,0 +1,87 @@ + + + + + + loadfuncpp + + + + + +
+

+ + + + +
+


+ Loadfuncpp

+

A Dynamic Library used to aid Adding
+ External Functions written in C++ to
+ The Icon Programming Language

+

Carl Sturtivant, February 2010, version 0.91alpha

+
+
+

Features

+
+
    +
  • Works with the existing Icon runtime system with no modification +
  • Call Icon with call syntax from C++ and vice-versa, recursively +
  • Has a simple way to create new Icon datatypes by inheritance +
  • Write new Icon functions in C++ that suspend a sequence of results +
  • Iterate in C++ through result sequences generated by Icon +
  • All Icon functions, keywords and operators made available in C++ +
  • Takes care of garbage collection safety automatically +
    +
+
+
+
+
+
+

documentation
+ experimental binaries
+ compilation options

+
+
+
+
+

News

+
+

2010/2/10 (I am releasing this now having moved on to a new implementation of the language entirely.) There + are no known bugs, but bugs almost certainly exist. This pack needs systematic in-depth testing for subtle issues + connected to garbage collection. Specifically, the mechanism to call Icon from C++ pushes onto the top of the Icon + stack a region used by a copy of the interpreter loop that's used to execute the Icon procedure called from C++. + I have not investigated how the Icon stack is garbage collected, and this region does not extend the stack the + way that Icon does. If this proves unsafe for garbage collection, the stack region for such a call may have to + have suitable frames containing pointers to the lower part of the stack (or vice-versa) placed in it to repair + this deficiency. Also, the way garbage collection safety of Icon values in C++ variables is ensured is to use the + constructor to implicitly link them onto the far end of the main co-expression's safe list, and unlink them from + there using the destructor. This is almost certainly safe from the usual call and return mechanism in iconx for + protecting local variables, but needs testing and verification.
+
+ 2009/1/20 fixed a bug where a call of any C++ external function that in turn calls Icon and afterIcon returns calls + Icon::runerr would not correctly report the name and arguments of said function in the resulting traceback. Upped + the version number to 0.91alpha.
+
+ 2009/1/20 loadfuncpp now searches for a shared object on the path defined by the environment variable FPATH with + the icon/bin directory appended if you specify no path. FPATH undefined leads loadfuncpp to search the current + directory followed by the icon/bin directory.
+
+ 2009/1/12 loadfuncpp has been completely overhauled, and the old version is now obsolete. + Many small functions have been added to eliminate ambiguities in programs that use loadfuncpp, and the central + class has been renamed and a class eliminated. Small pieces of missing functionality have been added. The documentation + has been modified accordingly. It is now close to it's final form, and in need of some serious beta testing, and + I have someone who has agreed to do that. Once this is done, loadfuncpp will be made available as a pack with the + Icon 9.5 source distribution. +

+
+
+ +

+ + + + diff --git a/ipl/packs/loadfuncpp/doc/isexternal.cpp b/ipl/packs/loadfuncpp/doc/isexternal.cpp new file mode 100644 index 0000000..ef5d219 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/isexternal.cpp @@ -0,0 +1,31 @@ + + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + + +#include "loadfuncpp.h" +using namespace Icon; + +class myval: public external { + public: + virtual value name() { return "my external"; } +}; + +extern "C" int myext(value argv[]) { + argv[0] = new myval(); + return SUCCEEDED; +} + +extern "C" int ismine(value argv[]) { + if( argv[1].isExternal("my external") ) + argv[0] = "Yes!"; + else + argv[0] = "No!"; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/isexternal.icn b/ipl/packs/loadfuncpp/doc/isexternal.icn new file mode 100644 index 0000000..bfa509a --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/isexternal.icn @@ -0,0 +1,14 @@ + +link loadfuncpp + +procedure main() + myext := loadfuncpp("./isexternal.so", "myext", 0) + ismine := loadfuncpp("./isexternal.so", "ismine", 1) + x := myext() + write(image(x)) + write(image(type(x))) + write("is mine? ", ismine(x)) + write("is also mine? ", ismine(3)) +end + + diff --git a/ipl/packs/loadfuncpp/doc/iterate.cpp b/ipl/packs/loadfuncpp/doc/iterate.cpp new file mode 100644 index 0000000..9a57e59 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/iterate.cpp @@ -0,0 +1,34 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + int count; + + addup(): total(0L), count(0) {} + + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 10; + } +}; + + +extern "C" int sum10(value argv[]){ + addup sum; + sum.every(argv[1], argv[2]); + argv[0] = sum.total; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/iterate.icn b/ipl/packs/loadfuncpp/doc/iterate.icn new file mode 100644 index 0000000..1fd1cb7 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/iterate.icn @@ -0,0 +1,13 @@ + +link loadfuncpp + + +procedure main() + sum10 := loadfuncpp("./iterate.so", "sum10", 2) + write( sum10(f,[]) ) +end + +procedure f() + suspend 1 to 15 +end + diff --git a/ipl/packs/loadfuncpp/doc/keyword.cpp b/ipl/packs/loadfuncpp/doc/keyword.cpp new file mode 100644 index 0000000..3e3bde8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/keyword.cpp @@ -0,0 +1,16 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int assignprog(value argv[]) { + safe newname(argv[1]); + &progname = newname; + return FAILED; +} + diff --git a/ipl/packs/loadfuncpp/doc/keyword.icn b/ipl/packs/loadfuncpp/doc/keyword.icn new file mode 100644 index 0000000..0340f9c --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/keyword.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + + +procedure main() + assignprog := loadfuncpp("./keyword.so", "assignprog", 1) + assignprog("Silly") + write(&progname) +end + diff --git a/ipl/packs/loadfuncpp/doc/loadfuncpp.css b/ipl/packs/loadfuncpp/doc/loadfuncpp.css new file mode 100644 index 0000000..975cbcb --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/loadfuncpp.css @@ -0,0 +1,41 @@ +body { background-color: #FFFFFF; + color: #0066CC; + font-family: Georgia, "Times New Roman", serif; +} +h1 { background-color: #CCFFFF; + color: #0099FF; + line-height: 200%; + font-family: Georgia, "Times New Roman", serif; +} +h2 { background-color: #CCFFFF; + color: #0099FF; + font-family: Georgia, "Times New Roman", serif; + line-height: 100% +} +h3 { background-color: #CCFFFF; + font-family: Georgia, "Times New Roman", serif; + line-height: 90% +} +h4 { background-color: #FFFFFF; + color: #FF9900; + font-family: Georgia, "Times New Roman", serif; + line-height: 100% +} +a {color: #333300; +} +p {font-size: 120%; +} +ul {font-weight: bold; +} +#wrapper { width: 850px; + margin-left: auto; + margin-right: auto; +} +.nav { font-weight: bold; + font-size: 1.25em; +} +#footer {font-size: .75em; + font-style: italic; +} + + diff --git a/ipl/packs/loadfuncpp/doc/loadfuncpp.h b/ipl/packs/loadfuncpp/doc/loadfuncpp.h new file mode 100644 index 0000000..934bca9 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/loadfuncpp.h @@ -0,0 +1,470 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include this and link to iload.cpp which + * contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include +#include + +enum kind { Null, Integer, BigInteger, Real, Cset, File, Procedure, Record, List, + Set=10, Table=12, String, Constructor, Coexpression=18, External, Variable }; + +enum special_value { NullString, StringLiteral, NewString, NullChar, Illegal }; + +enum { + SUCCEEDED = 7, // Icon function call returned: A_Continue + FAILED = 1 // Icon function call failed: A_Resume +}; + +class value; //Icon value (descriptor) +class safe; //for garbage-collection-safe Icon valued C++ variables and parameters of all kinds +class keyword; //Icon keyword represented as an object with unary & +class variadic; //for garbage-collection-safe variadic function argument lists +class proc_block; //block specifying a procedure to iconx +class external_block; //block specifying an external value to iconx +class external_ftable; //function pointers specifying external value behavior to iconx +class external; //C++ Object specifying an external value + +typedef int iconfunc(value argv[]); //type of icon built in functions or operators with a fixed number of arguments +typedef int iconfvbl(int argc, value argv[]); //type of icon built in functions with a variable number of arguments + +extern const value nullvalue; //for default arguments +extern const value nullstring; +extern const value nullchar; +extern const value illegal; //for unwanted trailing arguments +extern void syserror(const char*); //fatal termination Icon-style with error message +#define Fs_Read 0001 /* file open for reading */ +#define Fs_Write 0002 /* file open for writing */ +extern value IconFile(int fd, int status, char* fname); //make an Icon file descriptor + +namespace Icon { +//all keywords excepting &fail, &cset (avoiding a name collision with function cset) +extern keyword allocated; +extern keyword ascii; +extern keyword clock; +extern keyword collections; +extern keyword current; +extern keyword date; +extern keyword dateline; +extern keyword digits; +extern keyword dump; +extern keyword e; +extern keyword error; +extern keyword errornumber; +extern keyword errortext; +extern keyword errorvalue; +extern keyword errout; +extern keyword features; +extern keyword file; +extern keyword host; +extern keyword input; +extern keyword lcase; +extern keyword letters; +extern keyword level; +extern keyword line; +extern keyword main; +extern keyword null; +extern keyword output; +extern keyword phi; +extern keyword pi; +extern keyword pos; +extern keyword progname; +extern keyword random; +extern keyword regions; +extern keyword source; +extern keyword storage; +extern keyword subject; +extern keyword time; +extern keyword trace; +extern keyword ucase; +extern keyword version; +}; //namespace Icon + +static void initialize_keywords(); + +class keyword { //objects representing Icon keywords + friend void initialize_keywords(); + iconfunc* f; + public: + safe operator&(); //get the keyword's value (could be an Icon 'variable') +}; + + +class value { //a descriptor with class +//data members modelled after 'typedef struct { word dword, vword; } descriptor;' from icall.h + private: + long dword; + long vword; + public: + friend class safe; + friend value IconFile(FILE* fd, int status, char* fname); + value(); //&null + value(special_value, const char* text = ""); + value(int argc, value* argv); //makes a list of parameters passed in from Icon + value(int); + value(long); + value(float); + value(double); + value(char*); + value(const char*); + value(proc_block&); + value(proc_block*); + value(external*); + operator int(); + operator long(); + operator float(); + operator double(); + operator char*(); + operator external*(); + operator proc_block*() const; + bool operator==(const value&) const; + value& dereference(); + value intify(); + bool isNull(); + bool notNull(); + bool isExternal(const value&); + value size() const; + kind type(); + bool toString(); //attempted conversion in place + bool toCset(); + bool toInteger(); + bool toReal(); + bool toNumeric(); + value subscript(const value&) const; //produces an Icon 'variable' + value& assign(const value&); //dereferences Icon style + value put(value x = nullvalue); + value push(value x = nullvalue); + void dump() const; + void printimage() const; + int compare(const value&) const; //comparator-style result: used for Icon sorting + value negative() const; // -x + value complement() const; // ~x + value refreshed() const; // ^x + value random() const; // ?x + value plus(const value&) const; + value minus(const value&) const; + value multiply(const value&) const; + value divide(const value&) const; + value remainder(const value&) const; + value power(const value&) const; + value union_(const value&) const; // x ++ y + value intersection(const value&) const; // x ** y + value difference(const value&) const; // x -- y + value concatenate(const value&) const; // x || y + value listconcatenate(const value&) const;// x ||| y + value slice(const value&, const value&) const; // x[y:z] + value& swap(value&); // x :=: y + value activate(const value& y = nullvalue) const; // y @ x ('*this' is activated) + value apply(const value&) const; // x!y (must return, not fail or suspend) +}; //class value + + +class generator { +//class to inherit from for defining loadable functions that are generators + public: + int generate(value argv[]); //call to suspend everything produced by next() + protected: //override these, and write a constructor + virtual bool hasNext(); + virtual value giveNext(); +}; //class generator + + +class iterate { +//class to inherit from for iterating over f!arg or !x + public: + void every(const value& g, const value& arg); //perform the iteration over g!arg + void bang(const value& x); //perform the iteration over !x + //override these, write a constructor and the means of recovering the answer + virtual bool wantNext(const value& x); + virtual void takeNext(const value& x); +}; + + + +class safe_variable { +//data members modelled after 'struct tend_desc' from rstructs.h + friend class value; + friend inline int safecall_0(iconfunc*, value&); + friend inline int safecall_1(iconfunc*, value&, const value&); + friend inline int safecall_2(iconfunc*, value&, const value&, const value&); + friend inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); + friend inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); + friend inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_v0(iconfvbl*, value&); + friend inline int safecall_v1(iconfvbl*, value&, const value&); + friend inline int safecall_v2(iconfvbl*, value&, const value&, const value&); + friend inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); + friend inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + protected: + safe_variable *previous; + int num; + value val; + safe_variable(); + safe_variable(int); + safe_variable(long); + safe_variable(double); + safe_variable(value); + safe_variable(proc_block&); + safe_variable(proc_block*); + safe_variable(int, value*); + inline void push(safe_variable*& tendlist, int numvalues=1); + inline void pop(safe_variable*& tendlist); +}; //class safe_variable + + +class variadic: public safe_variable { + public: + variadic(int); + variadic(long); + variadic(float); + variadic(double); + variadic(char*); + variadic(value); + variadic(const safe&); + variadic(const safe&, const safe&); + variadic& operator,(const safe&); + operator value(); + ~variadic(); +}; //class variadic + + +class external_block { +//modelled on 'struct b_external' in icon/src/h/rstructs.h + friend class external; + friend class value; + static long extra_bytes; //silent extra parameter to new + long title; + long blksize; + long id; + external_ftable* funcs; + external* val; + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing + external_block(); +}; + +class external { + friend class value; + static external_block* blockptr; //silent extra result of new + protected: + long id; + public: + static void* operator new(size_t); //allocated by new external_block() + static void operator delete(void*); //do nothing + external(); + virtual ~external() {} //root class + virtual long compare(external*); + virtual value name(); + virtual external* copy(); + virtual value image(); +}; + + +class safe: public safe_variable { +//use for a garbage collection safe icon valued safe C++ variable + friend class variadic; + friend class global; + public: + safe(); //&null + safe(const safe&); + safe(int); + safe(long); + safe(float); + safe(double); + safe(char*); + safe(const value&); + safe(const variadic&); + safe(proc_block&); + safe(proc_block*); + safe(int, value*); //from parameters sent in from Icon + ~safe(); + safe& operator=(const safe&); + //augmenting assignments here + safe& operator+=(const safe&); + safe& operator-=(const safe&); + safe& operator*=(const safe&); + safe& operator/=(const safe&); + safe& operator%=(const safe&); + safe& operator^=(const safe&); + safe& operator&=(const safe&); + safe& operator|=(const safe&); + // ++ and -- here + safe& operator++(); + safe& operator--(); + safe operator++(int); + safe operator--(int); + //conversion to value + operator value() const; + //procedure call + safe operator()(); + safe operator()(const safe&); + safe operator()(const safe& x1, const safe& x2, + const safe& x3 = illegal, const safe& x4 = illegal, + const safe& x5 = illegal, const safe& x6 = illegal, + const safe& x7 = illegal, const safe& x8 = illegal); + safe operator[](const safe&); + + friend safe operator*(const safe&); //size + friend safe operator-(const safe&); + friend safe operator~(const safe&); //set complement + friend safe operator+(const safe&, const safe&); + friend safe operator-(const safe&, const safe&); + friend safe operator*(const safe&, const safe&); + friend safe operator/(const safe&, const safe&); + friend safe operator%(const safe&, const safe&); + friend safe operator^(const safe&, const safe&); //exponentiation + friend safe operator|(const safe&, const safe&); //union + friend safe operator&(const safe&, const safe&); //intersection + friend safe operator&&(const safe&, const safe&); //set or cset difference + friend safe operator||(const safe&, const safe&); //string concatenation + friend bool operator<(const safe&, const safe&); + friend bool operator>(const safe&, const safe&); + friend bool operator<=(const safe&, const safe&); + friend bool operator>=(const safe&, const safe&); + friend bool operator==(const safe&, const safe&); + friend bool operator!=(const safe&, const safe&); + friend variadic operator,(const safe&, const safe&); //variadic argument list construction + + safe slice(const safe&, const safe&); // x[y:z] + safe apply(const safe&); // x ! y + safe listcat(const safe&); // x ||| y + safe& swap(safe&); // x :=: y + safe create(); // create !x + safe create(const safe&); // create x!y + safe activate(const safe& y = nullvalue); // y@x + safe refresh(); // ^x + safe random(); // ?x + safe dereference(); // .x + bool isIllegal() const; //is an illegal value used for trailing arguments +}; //class safe + + +//Icon built-in functions +namespace Icon { + safe abs(const safe&); + safe acos(const safe&); + safe args(const safe&); + safe asin(const safe&); + safe atan(const safe&, const safe&); + safe center(const safe&, const safe&, const safe&); + safe char_(const safe&); + safe chdir(const safe&); + safe close(const safe&); + safe collect(); + safe copy(const safe&); + safe cos(const safe&); + safe cset(const safe&); + safe delay(const safe&); + safe delete_(const safe&, const safe&); + safe detab(const variadic&); + safe detab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe display(const safe&, const safe&); + safe dtor(const safe&); + safe entab(const variadic&); + safe entab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe errorclear(); + safe exit(const safe&); + safe exp(const safe&); + safe flush(const safe&); + safe function(); //generative: returns a list + safe get(const safe&); + safe getch(); + safe getche(); + safe getenv(const safe&); + safe iand(const safe&, const safe&); + safe icom(const safe&); + safe image(const safe&); + safe insert(const safe&, const safe&, const safe&); + safe integer(const safe&); + safe ior(const safe&, const safe&); + safe ishift(const safe&, const safe&); + safe ixor(const safe&, const safe&); + safe kbhit(); + safe left(const safe&, const safe&, const safe&); + safe list(const safe&, const safe&); + safe loadfunc(const safe&, const safe&); + safe log(const safe&); + safe map(const safe&, const safe&, const safe&); + safe member(const safe&, const safe&); + safe name(const safe&); + safe numeric(const safe&); + safe open(const safe&, const safe&); + safe ord(const safe&); + safe pop(const safe&); + safe proc(const safe&, const safe&); + safe pull(const safe&); + safe push(const variadic&); + safe push( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe put(const variadic&); + safe put( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe read(const safe&); + safe reads(const safe&, const safe&); + safe real(const safe&); + safe remove(const safe&); + safe rename(const safe&, const safe&); + safe repl(const safe&, const safe&); + safe reverse(const safe&); + safe right(const safe&, const safe&, const safe&); + safe rtod(const safe&); + safe runerr(const safe&, const safe&); + safe runerr(const safe&); + safe seek(const safe&, const safe&); + safe serial(const safe&); + safe set(const safe&); + safe sin(const safe&); + safe sort(const safe&, const safe&); + safe sortf(const safe&, const safe&); + safe sqrt(const safe&); + safe stop(); + safe stop(const variadic&); + safe stop( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe string(const safe&); + safe system(const safe&); + safe table(const safe&); + safe tan(const safe&); + safe trim(const safe&, const safe&); + safe type(const safe&); + safe variable(const safe&); + safe where(const safe&); + safe write(); + safe write(const variadic&); + safe write( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe writes(const variadic&); + safe writes( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + //generative functions follow, crippled to return a single value + safe any(const safe&, const safe&, const safe&, const safe&); + safe many(const safe&, const safe&, const safe&, const safe&); + safe upto(const safe&, const safe&, const safe&, const safe&); + safe find(const safe&, const safe&, const safe&, const safe&); + safe match(const safe&, const safe&, const safe&, const safe&); + safe bal(const safe&, const safe&, const safe&, const safe&, const safe&, const safe&); + safe move(const safe&); + safe tab(const safe&); +}; //namespace Icon + diff --git a/ipl/packs/loadfuncpp/doc/loadfuncpp.htm b/ipl/packs/loadfuncpp/doc/loadfuncpp.htm new file mode 100644 index 0000000..50fc4b8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/loadfuncpp.htm @@ -0,0 +1,42 @@ + + + + + + loadfuncpp + + + + + +

+
+

+ + + + +
+


+ Loadfuncpp

+

Experimental Binary Distribution

+

Carl Sturtivant, February 2010

+
+
+

All versions are in the public domain as of now.
+
+ All versions are provisional, experimental and hacked off at speed; sane behavior + is no more than probable so use at your own risk.

+ +

Read the documentation for information on installation + and use. Everything is simplest if all shared objects are placed in the icon/bin directory and all linkable Icon + (.u1/.u2 files) are placed in the icon/lib directory. +

+
+
+ +

+ + + + diff --git a/ipl/packs/loadfuncpp/doc/makelist.cpp b/ipl/packs/loadfuncpp/doc/makelist.cpp new file mode 100644 index 0000000..90b8c5d --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/makelist.cpp @@ -0,0 +1,16 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int makelist(int argc, value argv[]) { + safe arglist(argc, argv); + argv[0] = arglist; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/doc/makelist.icn b/ipl/packs/loadfuncpp/doc/makelist.icn new file mode 100644 index 0000000..e5e4cd8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/makelist.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + + +procedure main() + makelist := loadfuncpp("./makelist.so", "makelist") + write(image( ls := makelist(1,2,3) )) + every write(!ls) +end + diff --git a/ipl/packs/loadfuncpp/doc/manual.htm b/ipl/packs/loadfuncpp/doc/manual.htm new file mode 100644 index 0000000..38046e1 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/manual.htm @@ -0,0 +1,1558 @@ + + + + + + loadfuncpp + + + + + +
+

+ + + + +
+


+ Loadfuncpp

+

How to Write External Functions and Libraries
+ for The Icon Programming Language in C++

+

Carl Sturtivant, February 2010, version 0.91alpha

+
+

Contents

+ +

Summary

+

Since 1996 a new function for Version 9 of Icon + could be written in C following a certain interface, + and compiled into a shared library, where such is a shared object (.so) under Unix-like operating systems. More recently this has been implemented + using dynamically linked libraries (DLLs) under cygwin. The library could then be dynamically loaded by an Icon program calling the built-in + function loadfunc which is passed + the location and name of the library and the name of the C function desired, and which returns an Icon function + that can subsequently be called. A suite of useful examples of this technique is a part of the distribution of Icon.

+

Writing a significantly complex external function for use by loadfunc is potentially difficult for two reasons. First, an Icon structure (or other value, + string, list, set, table, et cetera) referred to solely by variables inside external code could be garbage collected + by Icon. Second, working directly with Icon data more complex than numbers, strings and files requires a thorough + understanding of the implementation + of Icon. The Icon runtime system is implemented in an extension of C that is automatically translated into C. The design of the Icon virtual machine + is not object oriented, and contains a great deal of straight-line code. Icon structures are operated upon as combinations + of complex linked blocks. Writing code to work directly with such is lengthy, error prone and time consuming.

+

Loadfuncpp is a tool that makes writing external functions for Icon a relatively simple matter, requiring very + little understanding of the implementation of the Icon virtual machine. Loadfuncpp exploits the close compatibility + of C and C++ to provide a clean abstract interface to Icon. External functions for Icon are declared with C linkage, + and the Icon virtual machine requires no modification to use external functions written using loadfuncpp.

+

Beginning C++ programmers with programming experience in other languages should have little difficulty with + using loadfuncpp. It is not necessary to use templates, exceptions, or RTTI to use loadfuncpp. Little beyond some + C experience plus how to define a simple class with virtual and non-virtual member functions is needed to use loadfuncpp. + So C programmers with OOP experience but without C++ experience will also find loadfuncpp not difficult to use.

+

Loadfuncpp makes extensive use of operator overloading and other techniques to provide in C++ essentially the + same suite of operations, functions and capabilities that are available to the Icon programmer in Icon. The use + of these facilities in C++ is at most an order of magnitude more difficult than the corresponding Icon, and is + often much easier than that. These facilities include the ability to write external functions that suspend a sequence + of results, and the ability to call an Icon procedure that returns a value, which may in turn call a function that + calls Icon recursively in the same fashion.

+

These facilities also include the ability to create, activate and refresh coexpressions, the ability to write + external functions that are new string matching or string analysis functions, and the ability to work with all kinds + of Icon data as if they were built-in types. Loadfuncpp also provides garbage collection safety as a matter of + course, largely transparently to the C++ programmer. Loadfuncpp also provides a simple way to add new datatypes + to Icon using the new external values + added to Icon version 9.5 in 2008. These are used extensively by loadfuncpp, and so loadfuncpp cannot be used with + versions of Icon prior to 9.5.

+

Loadfuncpp consists of three shared libraries (iload.so, loadnogpx.so and iloadgpx.so) normally placed in the + icon/bin directory (all are actually DLLs under cygwin despite the .so filename extension, and import library called + iload.a is used to link to them under cygwin) together with a small amount of Icon in loadfuncpp.icn, compiled + into loadfuncpp.u1 and loadfuncpp.u2 (using 'icont -c loadfuncpp.icn') which are normally placed in the icon/lib + directory. Loadfuncpp may then be used by an Icon program by adding the line 'link loadfuncpp' which makes the + function loadfuncpp available to Icon.

+

The function loadfuncpp is used in place of loadfunc to dynamically load external functions written to use the + loadfuncpp interface. The library containing loadfuncpp is itself loaded by an implicit call to loadfunc. The first + call to loadfuncpp loads iload.so (and also loads iloadgpx.so if the Icon installation supports graphics and iloadnogpx.so + if not) and replaces loadfuncpp by an external function in iload.so of the same name. This sequence of events makes + the C++ interface in iload.so available to all libraries subsequently loaded by Icon through calls of loadfuncpp.

+

Installation

+

Installation of Loadfuncpp is in three parts. First ensuring a correct Icon installation. Second placing the + loadfuncpp files appropriately. And third, ensuring that environment variables are set appropriately if the default + locations of loadfuncpp files are not used.

+

Correct Icon Installation

+

You will need to install Icon version 9.5 Loadfuncpp to run. To verify you are running the correct version of + Icon, use `icont -V` and + `iconx -V`. +

Default Placement of Loadfuncpp Files

+

Loadfuncpp consists of the following files. Starting now (2010/2/8) loadfuncpp is available as an experimental source distribution. I intend to do no further work on it. Use make and + examine the following files. +

+

+ + + + + + + + + + + + + + + + + + + + + +
+

iload.so +

+

C++ part of the loadfuncpp interface to iconx +

+

loadfuncpp.icn +

+

Icon part of the loadfuncpp interface to iconx +

+

iloadgpx.so +

+

C++ interface needed with the graphics build of Icon +

+

iloadnogpx.so +

+

C++ interface needed with the non-graphics build of Icon +

+

loadfuncpp.h +

+

C++ header for writing new external functions +

+

+
+

The default installation of these files is as follows. (Here we assume that the directory containing your Icon + installation is called icon.) I recommend that you use these locations unless there is a compelling reason not + to.

+

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+

iload.so +

+

icon/bin +

+

iload.a +

+

icon/bin (cygwin only) +

+

loadfuncpp.u1 +

+

icon/lib (from loadfuncpp.icn) +

+

loadfuncpp.u2 +

+

icon/lib (from loadfuncpp.icn) +

+

iloadgpx.so +

+

icon/bin +

+

iloadnogpx.so +

+

icon/bin +

+

loadfuncpp.h +

+

wherever is convenient to #include in C++ source +

+
+ Under cygwin only there is one additional file used when linking + a dynamic library that uses loadfuncpp. This is the windows import library iload.a, and is most naturally placed + in the same directory as iload.so, as it contains the information necessary to link against it. +

Alternative Placement of Loadfuncpp Files

+

Alternatively, you can place iload.so and iloadgpx.so anywhere you please and set the environment variable FPATH + to include the directories containing iload.so and iloadgpx.so. FPATH should be a space or colon separated string + of locations. You can compile loadfuncpp.icn using `icont -c loadfuncpp.icn` and place the resulting files (loadfuncpp.u1 + and loadfuncpp.u2) in any directory and set the environment variable IPATH to include that directory. IPATH should + also be a space or colon separated string of locations. +

Loadfuncpp Installation Test

+

Once loadfuncpp is installed, you may test your installation by creating a small new external function and load + and call it from Icon. Here's how.

+

+

    +
  • Create a new directory, place a copy of loadfuncpp.h in it and work there +
  • Edit a new file called (say) hello.cpp to contain the following code +

    + + + + +
    + 
    #include "loadfuncpp.h"
+
+extern "C" int hello(value argv[]) {
+    argv[0] = "Hello World";
+    return SUCCEEDED;
+}
    +
    + +

  • Compile hello.cpp into a shared object hello.so using one of these compiler + options +
  • Edit a new file called (say) hello.icn to contain the following code and ensure that hello.so is in the same + directory +

    + + + + +
    + 
    link loadfuncpp
+
+procedure main()
+    hello := loadfuncpp("./hello.so", "hello", 0)
+    write( hello() )
+end
    +
    + +

  • Compile hello.icn by typing `icont hello.icn` and run it by typing `./hello` and you should get the output + Hello World appearing in the console. +
+
+
+
    +

    +

+

+

+
+

Manual

+

This manual assumes that you have a working installation of Loadfuncpp and Icon + as described above. An installation of Icon alone is not sufficient, nor can Loadfuncpp be used with any Icon version + prior to 9.5, as it relies upon the presence of external values which are first implemented as a part of that version.

+

Writing, Loading and Calling a new External Function

+
+
+

A new Icon external function written in C++ takes one of the following forms. +

+
+
+

+ + + + +
+ 
#include "loadfuncpp.h"
+
+extern "C" int fixed_arity(value argv[]) {
+    // ... has a fixed number of arguments
+    return SUCCEEDED; //or FAILED
+}
+
+extern "C" int variable_arity(int argc, value argv[]){
+    // ... has a variable number of arguments
+    return SUCCEEDED; //or FAILED
+}
+
+

+
+

The C++ type 'value' is an Icon value (called a descriptor), + representing null or an integer, real, string, cset, list, table, set, file, procedure, coexpression, record, external value or an Icon variable. + When such a function is called from Icon, its arguments are passed in the array argv starting from argv[1], and + argv[0] is taken to be the value returned to Icon by the function. In the function variable_arity the number of + arguments is also passed in argc. So the following is a one argument external function that returns its only argument. +

+

+ + + + +
+ 
#include "loadfuncpp.h"
+
+extern "C" int ident(value argv[]) {
+    argv[0] = argv[1];
+    return SUCCEEDED;
+}
+
+

+
+

The int returned to C++ is a signal to Icon indicating whether the call succeeded or failed. These are represented + by the constants SUCCEEDED and FAILED respectively, defined in loadfuncpp.h. However there is also a simple mechanism + in loadfuncpp to write external functions that suspend a sequence of values when called + in Icon.

+

Functions compiled into a shared object are loaded into Icon by calls + of loadfuncpp. Such calls indicate to Icon whether the loaded function has a variable or a fixed number of arguments, + and if the latter, how many. For example the preceding functions might be loaded into Icon as follows if the body + of fixed_arity was written to use two arguments. +

+

+ + + + +
+ 
link loadfuncpp
+
+procedure main()
+    fixed := loadfuncpp("./mylib.so", "fixed_arity", 2)
+    variadic := loadfuncpp("./mylib.so", "variable_arity")
+    #fixed and variadic now contain Icon functions
+    #and may be treated like any other such values
+end
+
+

+
+

If the number of arguments is not specified when loading a function of fixed arity + then calling the result from Icon will lead to a memory violation. (Similar behavior will likely occur if a function + of variable arity is loaded with a specific arity specified, or if too small an arity is specified for a fixed + arity function.) Beware!
+
+ A relative or absolute path to the shared object may be used as the first argument to loadfuncpp, in which case + loadfuncpp will look exactly where specified for it and nowhere else. Alternatively, just the filename of the + shared object may be specified, in which case Icon will search FPATH for the file. If FPATH is not set in the + environment Icon runs in, then iconx defines FPATH to consist of the current directory followed by the icon/bin + directory. If FPATH is set in the environment Icon is run in, then iconx appends the icon/bin directory. In either + case FPATH should be a space or colon separated series of directories, with no spaces in their paths. (This restriction + will be cleaned up "soon".)

+

All of the C++ in this manual requires '#include "loadfuncpp.h"' and all of the Icon requires 'link + loadfuncpp'. Hereafter this will be assumed implicitly.

+

Here is an external function of no arguments that returns null, represented in C++ by the constant nullvalue. +

+

+ + + + +
+ 
extern "C" int dull(value argv[]){
+    argv[0] = nullvalue;
+    return SUCCEEDED;
+}
+
+

+
+

If this is compiled into the shared object 'dull.so' in the current directory then it might be called by Icon + as follows. +

+

+ + + + +
+ 
dull := loadfuncpp("./dull.so", "dull", 0)
+write(image( dull() ))
+
+

+
+

The value of argv[0] when an external function is called is of type procedure, and is the Icon value representing + the external function being called. So failure to assign to argv[0] means that Icon loads a function that returns + itself.

+

The C++ class value is intended to be used primarily in the interface to Icon. Icon structures in variables + of this class are not safe from garbage collection. Icon does guarantee that argv[] is garbage collection safe + however.

+

Working with Icon values

+

Variables of the C++ class safe are intended to hold Icon values with guaranteed garbage collection safety. + The interface to Icon is largely available through the class safe. Most computation with Icon values in external + functions may be implemented through use of the overloaded operators in using this class, + along with its member functions that represent additional Icon operators. Loadfuncpp + also provides the Icon keywords and in the namespace 'Icon' provides + a C++ variant of each of the built-in functions in Icon.

+

Assignment and Initialization among safe and value

+

Assignment of a safe to a safe has the semantics of an Icon assignment. Specifically, if the left operand contains + an Icon value that is an Icon variable (i.e. an Icon value used + to refer to the storage containing another Icon value so that the latter can be modified) then the assignment modifies + the value referred to by that Icon variable, not the C++ variable whose value is the Icon variable.

+

Assignment is possible among the classes safe and value, and has simple semantics: even values that are Icon + variables are copied. Initialization of variables of the class safe is possible from any of safe and value, with + the same simple semantics. In both cases the semantics is the same as Icon assignment, except in the case of an + Icon variable, which is merely copied, so that the variable assigned or initialized now contains the same Icon + variable. This lack of dereferencing is useful if an external function needs to return an Icon variable, in the + same way that an Icon procedure may.

+
+
+

A variable of class safe may also be initialized from an array of values as follows. +

+
+
+

+ + + + +
+ 
extern "C" int makelist(int argc, value argv[]){
+    safe arglist(argc, argv);
+    argv[0] = arglist;
+    return SUCCEEDED;
+}
+
+

+
+

Such initialization creates an Icon list containing the values in the array starting from position 1. So the + above function called from Icon returns a list of its arguments.

+

A variable of class safe may be initialized by or assigned a C string, which causes an Icon string that is a + copy of the original to be created, so that the original can safely be modified or destroyed later. If such copying + is unwanted because the C string is a literal or constant, then the two argument value constructor may be used + as follows. +

+

+ + + + +
+ 
extern "C" int f(value argv[]){
+    safe text = value(StringLiteral, "Hello");
+    // ...
+    return SUCCEEDED;
+}
+
+

+
+

A variable of class safe may also be initialized by or assigned a C++ long or int causing the creation of an + Icon integer. Similarly initialization or assignment of a double causes the creation of an Icon real.

+

Icon operations on variables of class safe

+

Here is a table of the overloaded operators and member functions implementing Icon operators for the class safe. + These are listed with their Icon equivalents, and with a note of any restrictions or extensions. The unary + ! operator in Icon is a generator and is supplied through loadfuncpp by other means.

+
+
+

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+

functions of safe for Icon operators +

+

  +

+

unary +

+

Icon equivalent +

+

  +

+

*x +

+

*x +

+

  +

+

~x +

+

~x +

+

  +

+

-x +

+

-x +

+

  +

+

++x +

+

x +:= 1 +

+

  +

+

--x +

+

x -:= 1 +

+

  +

+

binary +

+

Icon equivalent +

+

  +

+

= +

+

:= +

+

  +

+

+= -= *= +

+

+:= -:= *:= +

+

  +

+

/= %= ^= +

+

/:= %:= ^:= +

+

  +

+

+ +

+

+ +

+

  +

+

- +

+

- +

+

  +

+

* +

+

* +

+

  +

+

/ +

+

/ +

+

  +

+

% +

+

% +

+

  +

+

x^y +

+

x^y +

+

  +

+

x | y +

+

x ++ y +

+

  +

+

x & y +

+

x ** y +

+

  +

+

x && y +

+

x -- y +

+

  +

+

x || y +

+

x || y +

+

  +

+

|= +

+

++:= +

+

  +

+

&= +

+

**:= +

+

  +

+

== +

+

=== +

+

  +

+

!= +

+

~=== +

+

  +

+

< > <= >= +

+

none +

+

The comparison used when sorting +

+

x[y] +

+

x[y] +

+

  +

+

variadic +

+

Icon Equivalent +

+

  +

+

x(...) +

+

x(...) +

+

Icon procedure call +

+

(a,b ...) +

+

[a,b ...] +

+

Variadic list construction +

+

member function +

+

Icon equivalent +

+

  +

+

x.slice(y,z)  +

+

x[y:z] +

+

  +

+

x.apply(y) +

+

x ! y +

+

Apply Icon procedure to arguments +

+

x.listcat(y) +

+

x ||| y +

+

  +

+

x.swap(y) +

+

x :=: y +

+

  +

+

x.create() +

+

create !x +

+

  +

+

x.create(y) +

+

create x ! y +

+

  +

+

x.activate(y) +

+

y@x +

+

y defaults to &null +

+

x.refresh() +

+

^x +

+

  +

+

x.random() +

+

?x +

+

  +

+

x.dereference() +

+

.x +

+

  +

+

+
+
+

Icon Built-in Functions

+

All of the functions built in to Icon are available in C++ in the namespace 'Icon'. The C++ counterpart of an + Icon built-in function returns &null if the original function would have failed. Those functions that are generators + have been made to produce a single result. Those functions that are variadic have been + made C++ compatible too; with a small number of arguments this can usually safely be ignored. The table below lists + each C++ variant of each Icon function that is a generator, along with a comment indicating how it has been modified + for C++ compatibility.

+
+
+

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+

Function +

+

  +

+

bal +

+

returns the first result generated only +

+

find +

+

returns the first result generated only +

+

function +

+

returns a list of the results originally generated +

+

key +

+

returns a list of the results originally generated +

+

move +

+

cannot be resumed +

+

tab +

+

cannot be resumed +

+

upto +

+

returns the first result generated only +

+

+
+
+

Here is an example of the use of such Icon built-in functions in a new external function. The following function + returns the set of its arguments.

+
+

+ + + + +
+ 
extern "C" int makeset(int argc, value argv[]){
+    safe arglist(argc, argv);
+    argv[0] = Icon::set(arglist);
+    return SUCCEEDED;
+}
+
+

+
+

Icon Keywords

+

All of the Icon keywords have been made available apart from &cset (to avoid a possible name collision), + and &fail. The keywords are implemented through a keyword class with the unary '&' operator overloaded + and are used thus in C++, as in the following example.

+
+

+ + + + +
+ 
extern "C" int assignprog(value argv[]){
+    safe newname(argv[1]);
+    &progname = newname; //Icon assignment semantics
+    return FAILED;
+}
+
+

+
+

The preceding function assigns a new value to the keyword &progname, just as in Icon. In all cases a keyword + is used with the unary '&' operator, and therefore appears just as in an Icon program. The keywords that are + generators in Icon produce a list of values in C++.

+

Types, Conversions and Errors

+

A well designed external function will probably do some type checking and conversions of its arguments, and + perhaps give a run-time error if they are problematic.

+

The member function type() in the value class returns one of the following constants + indicating its Icon type: Null, Integer, BigInteger, + Real, Cset, File, Procedure, + Record, List, Set, Table, + String, Constructor, Coexpression, + External, or Variable. Constructor means a record constructor, + and BigInteger is an integer with a binary representation larger than a machine word.

+

The member functions isNull() and notNull() in the value + class each return a boolean indicating whether or not the Icon type is null. The member functions toInteger(), + toReal(), toNumeric(), toString() + and toCset() in the value class each endeavors to perform a conversion in place to the + corresponding type following the same conventions as Icon. Each returns a boolean indicating whether the conversion + succeeded. If the conversion failed, then the Icon value remains unchanged. These functions are intended for use + with the arguments of an external function supplied to C++ before they are converted to the class safe and the + real computation begins. (The use of these functions on the entries in argv[] is garbage-collection safe because + Icon protects argv[].) For example to check that we have a string where we would need one as follows. +

+

+ + + + +
+ 
extern "C" int assignprog(value argv[]){
+    if( !argv[1].toString() ) {
+        Icon::runerr(103, argv[1]);
+        return FAILED; //in case &error is set
+    }
+    safe newname(argv[1]);
+    &progname = newname; //Icon assignment semantics
+    return FAILED;
+}
+
+

+
+

The function syserror(const char*) unconditionally and fatally terminates execution + with an Icon style error message referring to the point of execution in Icon together with the error message supplied + as a C string argument. This nicely complements Icon::runerr.
+
+ To avoid problems with C++ conversion/overloading ambiguities, the class safe has been provided with a conversion + to the class value only, and no conversions to the types char*, int, long or double. On the other hand, the value + class has such conversions and so an explicit conversion to value can be used in many contexts to permit an implicit + conversion to a built-in type. See below for details.
+
+ The overloaded operators for the class safe defining much of Icon's repertoire in C++ have been defined outside + the class safe, with the exception of those such as assignment, subscripting and call that C++ insists be non-static + member functions, and almost all such as well as all other member functions have parameters of type safe only. + This is so that the wide repertoire of conversions of other types to safe defined by loadfuncpp may be of maximum + utility.
+
+ Conversions of char*, double, int and long to safe as well as value are defined, those from the built-in types + creating copies on the Icon heap. Specifically, the conversion from char* to safe or to value assumes a null terminated + C string, and produces a correspondingly copied Icon string.
+
+ Conversions of value to long and double have been defined. These behave as expected for Icon integers and reals + respectively, but perform no conversions within Icon values (from integer to real or vice-versa).
+
+ There is also a conversion from value to char* defined. This does not make a C string, but rather simply + produces a pointer to the start of an Icon string, which is not null terminated, and can move in the event of a + garbage collection. If null termination is desired, then concatenate the loadfuncpp constant value nullchar before + converting to char*, and if a copy outside of Icon is needed, then you will have to explicitly make one. Here is + an example. +

+

+ + + + +
+ 
extern "C" int assignprog(value argv[]){
+    if( !argv[1].toString() ) {
+        Icon::runerr(103, argv[1]);
+        return FAILED; //in case &error is set
+    }
+    safe newname(argv[1]);
+    char* s = value(newname || nullchar); //can move
+    char sbuf[100];
+    sprintf(sbuf, "%s", s);
+    //use the local copy sbuf
+    //...
+}
+
+ +

+

The non-member functions bytestointeger and integertobytes + are useful to overtly convert to and from Icon integers of any size (i.e. type Integer + or BigInteger behind the scenes). Both functions take a value and return a value. In + this context Icon strings are considered to be representations of natural numbers. Each character is considered + a base 256 digit in the obvious way, and the digits are defined to be in order from most to least significant. + The empty string represents zero. bytestointeger takes such a string and produces the + corresponding Icon integer. integertobytes takes an Icon integer and produces an Icon + string representing its absolute value in the preceding sense. Neither function attempts type conversions, so for + meaningful results they must be passed respectively a string value and an integer value.
+
+ The non-member functions base64, base64tointeger and base64tostring are useful to overtly convert strings and integers of any size to and from + the commonly used base64 encoding. Each function takes a value + and returns a value, and none attempts any type conversion of its arguments. base64 + may be passed an Icon integer or string and produces a string containing the base64 encoding thereof. The sign + of an integer is ignored, so the base64 encoding of its absolute value is produced. base64tointeger + may be passed an Icon string that is a strict base64 encoding in which case it returns the corresponding Icon integer, + and similarly base64tostring may be passed an Icon string that is a strict base64 encoding + in which case it returns the corresponding Icon string. By strict base64 encoding is meant that the string's length + is a multiple of four, that the end of the string is a sequence of between zero and two "=" characters + (used to pad the file length to a multiple of four when encoding), and apart from that the remaining characters + in the string are either lower or upper case letters, or digits, or the characters "/" and "+". + Failure to supply a string containing a strict base64 encoding to either function will cause null to be returned.

+

Variadic Functions and + Dynamic List Construction

+

Some built-in Icon functions take an arbitrary number of arguments. Unfortunately, C++ as of the present standard + has no convenient way to define a function with an arbitrary number of arguments of the same type. So variadic + functions included in the namespace 'Icon' such as writes are defined in two versions. + The first has at most eight arguments, with defaults and glue code to account for fewer being supplied. This takes + care of most uses of such functions.

+

The second uses a single argument of the class variadic, which is a wrapper for an Icon list of the arguments. + The operator ',' (comma) has been overloaded so as to combine two locals into a variadic, and to combine a variadic + and a safe so as to append the safe's value to the variadic's list. A variadic has a conversion to safe that in + effect removes the wrapper, and there are other sundry conversions and overloads of comma. These enable lists to + be constructed in place, providing a syntactic equivalent of things like [x,y,z] in + Icon, namely (x,y,z) in C++. The second implementation of writes may then be called + as writes((x,y,z)). The second pair of parentheses is necessary as comma is not regarded + as an operator by C++ when it is in a parameter list. Here is an example of the use of dynamic list construction.

+
+

+ + + + +
+ 
extern "C" int divide(value argv[]){
+    safe x(argv[1]), y(argv[2]);
+    argv[0] = (x / y, x % y);
+    return SUCCEEDED;
+}
+
+

+
+

Calling Icon from C++

+

The class safe has overloaded the function call operator '()' so that a safe may be called with function call + syntax. If the value of the safe is an Icon procedure (or function or record constructor) the effect is to call + Icon from C++. There are two kinds of restrictions on these calls.

+

The first restriction is because C++ requires a specific arity + when overloading the function call operator, and has no convenient way to handle an arbitrary number of parameters + of the same type. This restriction is the same one affecting the calling of variadic functions, + and is overcome in the same way with two implementations. One with a single argument of + class variadic necessitating two pairs of parentheses when the call is made, and the other + with up to eight arguments and useful for most procedure calls.

+

The second restriction is because there are three ways Icon can pass control back to a caller: by returning + a value, by failing and by suspending a value. However, there is only one way for C++ to receive control back from + a call it has made: by a value (possibly void) being returned. For this reason a call of an Icon procedure from + C++ will return &null if the procedure fails, and will return rather than suspend if the procedure suspends + a value. In either case, the call always returns cleanly with a single value. It is possible to iterate + through the values suspended by an Icon procedure in C++ through a different mechanism.

+

Working with Generators from C++

+

Generators and the flow of control in Icon have no counterpart in C++. Nevertheless, it is useful to be able + to both implement generators for Icon in C++, and iterate through generator sequences produced by Icon in C++, + as well as create coexpressions in C++. All these facilities are provided by loadfuncpp.

+

Writing External Functions that are Generators

+

Here is an example of a generator function written in C++. It is a C++ implementation of the built-in Icon function + seq, without the restriction to machine size integers.

+
+

+ + + + +
+ 
class sequence: public generator {
+    safe current, inc;
+  public:
+    sequence(local start, local increment) {
+        current = start - increment;
+        inc = increment;
+    }
+    virtual bool hasNext() { 
+        return true; 
+    }
+    virtual value giveNext() {
+        return current += inc;
+    }
+};
+
+extern "C" int seq2(value argv[]){
+    sequence seq(argv[1], argv[2]);
+    return seq.generate(argv);
+}
+
+

+
+

This exemplifies all the features of loadfuncpp that enable generator functions to be written. First a C++ version + of the generator is written as a class that inherits from the loadfuncpp class generator. Some data members are + added to maintain state as generation occurs, and a constructor is written to initialize those data members. Finally + the virtual functions hasNext() and giveNext() with exactly + the above prototypes are overloaded. The sequence generated by an object of this class is defined to be that produced + by repeatedly calling hasNext() to determine if there is a next member of the sequence, + and if there is, calling giveNext() to get it.

+

Now the external function itself simply creates a generator object of the above class, presumably using values + passed to it from Icon to initialize that object's state. Then the inherited member function generate + is called, passing the original argument array for technical reasons, and the signal it returns is passed back + to Icon. The effect of this call is to iterate through the calls of giveNext() while + hasNext() returns true, suspending the results produced by each call of giveNext() + to Icon. In a nutshell the call to generate suspends the sequence of results produced + by the object to Icon. The reason that generate needs to be passed argv is that it needs + to send its results to Icon by assigning to argv[0], in just as a single result is passed back.

+

Calling Icon Procedures that are Generators from C++

+

Here is an example of how to iterate over the results of a call of an Icon procedure. In the example the procedure + to be called and its argument list are presumed to be the arguments passed to the external function, which then + computes the sum of the first ten results suspended by the call, or the sum of all the results if less than ten + results are computed.

+
+

+ + + + +
+ 
class addup: public iterate {
+  public:
+    safe total;
+    int count;
+
+    addup(): total(0), count(0) {}
+	
+    virtual void takeNext(const value& x) {
+        total += x;
+    }
+    virtual bool wantNext(const value& x) {
+        return ++count <= 10;
+    }
+};
+
+extern "C" int sum10(value argv[]){
+    addup sum;
+    sum.every(argv[1], argv[2]);
+    argv[0] = sum.total;
+    return SUCCEEDED;
+}
+
+

+
+

This exemplifies all the features of loadfuncpp that enable the results of a call to Icon to be iterated over + in C++. First a class representing the loop that will iterate over the generator sequence is written, inheriting + from the loadfuncpp class iterate. The data members of that class model the variables used in the loop, and the + constructor models the initialization of those loop variables. It is convenient that these be public along with + everything else; the class could be declared as a struct to achieve this. The two inherited virtual member functions + wantNext() and takeNext() with exactly the above prototypes + are then overridden. The function wantNext() models the loop condition: it returns true + if the loop will process the next result produced by the generator, and false if the loop should be terminated. + The function takeNext() models the loop body: it will be passed each result produced + by the generator, and may modify the loop variables accordingly.

+

Now the external function itself simply creates an object of this class, using the constructor to initialize + the loop variables, or simply assigning to them directly. This models setup code before the loop proper starts. + Then the inherited member function every is called with the generator function and its + argument list as arguments to the call. The call of every models executing the loop + body by calling the generator function applied to its argument list and repeatedly alternately calling wantNext() + to see if the loop should continue and takeNext() to pass the loop body the next result + produced by the call to Icon. The loop is terminated either by wantNext() returning + false or by the sequence of results generated by the call to Icon coming to an end, whichever occurs first.

+

Iterating over Exploded Structures in C++

+

This feature of loadfuncpp enables iteration over the results that would be generated in Icon by an expression + of the form !x, with one important difference: if x is a + table, then the results iterated over are those that would be produced by the Icon expression key(x). + The technique use to perform such an iteration is almost identical to that used to iterate over + the results of a call to an Icon procedure. The only difference is that a different inherited member function + (bang) is called to run the iteration. Here is an example that sums the first ten elements + of a list by quite unnecessarily using this technique.

+
+

+ + + + +
+ 
class addup: public iterate {
+  public:
+    safe total;
+    int count;
+
+    addup(): total(0), count(0) {}
+
+    virtual void takeNext(const value& x) {
+        total += x;
+    }
+    virtual bool wantNext(const value& x) {
+        return ++count <= 10;
+    }
+};
+
+extern "C" int sumlist(value argv[]) {
+    addup sum;
+    sum.bang(argv[1]);
+    argv[0] = sum.total;
+    return SUCCEEDED;
+}
+
+

+
+

Working with Coexpressions in C++

+

There are a handful of member functions in the class safe that provide an essentially complete set of operations + on coexpressions. These are straightforward to use and are summarized here.

+
+
+

+ + + + + + + + + + + + + + + + + + + + + + + + + + +
+

safe function +

+

Icon equivalent +

+

  +

+

x.create() +

+

create !x +

+

  +

+

x.create(y) +

+

create x!y +

+

  +

+

x.activate(y) +

+

y@x +

+

y defaults to &null +

+

x.refresh() +

+

^x +

+

  +

+

+
+
+

Working with External + Values

+

A new kind of external value is easily defined and used via inheritance from the loadfuncpp class external, + which permanently hides the low level machinery of the C specification. Here is an example of such that illustrates the use of the available features.

+
+

+ + + + +
+ 
class Widget: public external {
+    long state;
+  public:
+    Widget(long x): state(x) {}
+  	
+    virtual value name() {
+        return "Widget";
+    }  	
+    virtual external* copy() {
+        return new Widget(state);
+    }
+    virtual value image() {
+        char sbuf[100];
+        sprintf(sbuf, "Widget_%ld(%ld)", id, state);
+        return value(NewString, sbuf);
+    }
+    virtual long compare(external* ep) {
+        //negative:less, zero:equal, positive:greater
+        Widget* wp = (Widget*)ep;
+        return this->state - wp->state;
+    }  	
+};
+
+extern "C" int widget(value argv[]) {
+    if( argv[1].type() != Integer ) {
+        Icon::runerr(101, argv[1]);
+        return FAILED;
+    }
+    argv[0] = new Widget(argv[1]);
+    return SUCCEEDED;
+}
+
+extern "C" int widgetint(value argv[]) {
+    if( argv[1].type() != External ) {
+        Icon::runerr(131, argv[1]);
+        return FAILED;
+    }
+    if( !argv[1].isExternal("Widget") ) {
+        Icon::runerr(132, argv[1]);
+        return FAILED;
+    }
+    external* ep = argv[1]; //implied conversion
+    Widget* wp = (Widget*)ep; //can move if GC occurs!
+    argv[0] = ep->state;
+    return SUCCEEDED;
+}
+
+

+
+

The example defines an external function widget that returns an external value to + Icon, and an external function widgetint that returns an integer extracted from a Widget + to Icon. Of course a real library would have in addition a number of external functions to work with Widgets; these + could call additional member functions in the Widget class to do the necessary work.

+

Overriding the inherited virtual functions name(), copy(), + image() and compare() automatically redefines the behavior + respectively of the built-in Icon functions type, copy and image and the Icon operators === and ~=== when applied + to Widgets, as well as the order for sorting Widgets among themselves in Icon. Such overriding is optional, and + the defaults defined in the C specification + will apply otherwise. Specifically, the default copy is not to copy but to return the original.

+

There are automatic conversions to and from external* so that new widgets may be + assigned to values or safes, and vice versa when appropriate. The operator new has been overloaded so that an external + is allocated by Icon as a part of an Icon external block on the Icon heap. The class external has a protected data + member id that contains the serial number of the external value (assigned by Icon when + it allocates the external block). Using id may be convenient when overriding the image() member function, as above.

+

External blocks are assumed by Icon not to contain any Icon descriptors, so do not declare any data members of the classes value or safe when inheriting + from external, unless you wish to invite disaster when a garbage collection occurs. Take into account that external + blocks may be relocated or garbage collected by Icon. It is not possible to arrange for a destructor or anything + else to be called when that occurs. If calling a destructor is essential, then place a pointer to the real object + in the external object, and allocate and manage the real object yourself.

+

Using Icon Records as Objects

+

A new procedure that is a copy of another with an Icon record bound to it may be created by calling the procedure + bindself. The new procedure behaves exactly as the old one, except that a call of the + procedure self from within it returns the record attached to it by bindself. + This enables a record to contain a procedure that behaves like a method by virtue of being bound to it, as illustrated + by the following example. +

+

+ + + + +
+ 
link loadfuncpp
+
+record object(val, print)
+
+procedure print()
+    obj := self() | fail
+    write( obj.val )
+end
+
+procedure newObject(x)
+    obj := object(x) #don't assign print method yet
+    #print will be a copy bound to the record it's embedded in
+    obj.print := bindself(print, obj)
+    return obj 
+end
+
+procedure main()
+    obj := newObject("Hello")
+    obj.print()
+end
+
+ +

+

Note that self fails if called from a procedure that is not bound to a record i.e. + one that has not been returned by bindself. It is possible to use bindself to bind a + record to a procedure that already has a record bound to it. This simply replaces the bound record, which is useful + for copying records that are to be treated as objects in this way, e.g. when copying a prototype object when simulating + an object based inheritance scheme. +

+
+ +

+ + + + diff --git a/ipl/packs/loadfuncpp/doc/object.cpp b/ipl/packs/loadfuncpp/doc/object.cpp new file mode 100644 index 0000000..a8ac211 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/object.cpp @@ -0,0 +1,15 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int dummy(value argv[]) { + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/object.icn b/ipl/packs/loadfuncpp/doc/object.icn new file mode 100644 index 0000000..5fe2ba4 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/object.icn @@ -0,0 +1,23 @@ + +link loadfuncpp + +record object(val, print) + +procedure print() + obj := self() | fail + write( obj.val ) +end + +procedure newObject(x) + obj := object(x) #don't assign print method yet + #print will be a copy bound to the record it's embedded in + obj.print := bindself(print, obj) + return obj +end + +procedure main() + obj := newObject("Hello") + obj.print() +end + + diff --git a/ipl/packs/loadfuncpp/examples/Makefile b/ipl/packs/loadfuncpp/examples/Makefile new file mode 100644 index 0000000..06bfc3f --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/Makefile @@ -0,0 +1,51 @@ + +#Automatically generated from Makefile.mak and examples.txt by ../savex.icn + +ifndef TARGET + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +endif + + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +IMPLIB_cygwin = -Wl,--out-implib=iload.a +PIC_other = -fPIC +PIC_mac = -flat_namespace + + + +EXAMPLES = callicon.exe coexp.exe extwidget.exe iterate.exe iterate2.exe iterate3.exe jmexample.exe kwd_vbl.exe methodcall.exe mkexternal.exe runerr.exe stop.exe +DYNAMICS = callicon.so coexp.so extwidget.so iterate.so iterate2.so iterate3.so jmexample.so kwd_vbl.so methodcall.so mkexternal.so runerr.so stop.so + +%.so : %.cpp loadfuncpp.h loadfuncpp.u1 + g++ $(SHARED_$(TARGET)) $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so iload.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : iload.so loadfuncpp.h loadfuncpp.u1 + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* *.u? diff --git a/ipl/packs/loadfuncpp/examples/Makefile.mak b/ipl/packs/loadfuncpp/examples/Makefile.mak new file mode 100644 index 0000000..28c87a3 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/Makefile.mak @@ -0,0 +1,34 @@ + +ifndef TARGET +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +PIC_other = -fPIC + +EXAMPLES = #exe# +DYNAMICS = #so# + +%.so : %.cpp loadfuncpp.h loadfuncpp.u1 + g++ -shared $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so iload.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : iload.so loadfuncpp.h loadfuncpp.u1 + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* diff --git a/ipl/packs/loadfuncpp/examples/arglist.cpp b/ipl/packs/loadfuncpp/examples/arglist.cpp new file mode 100644 index 0000000..a62d347 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/arglist.cpp @@ -0,0 +1,18 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make ' to build. + * For available s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + + +extern "C" int iexample(int argc, value argv[]) { + safe x(argc, argv); //make the arguments into an Icon list + argv[0] = x; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/examples/arglist.icn b/ipl/packs/loadfuncpp/examples/arglist.icn new file mode 100644 index 0000000..bb17a46 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/arglist.icn @@ -0,0 +1,7 @@ + +procedure main() + loadfunc("./iload.so", "loadfuncpp") + f := loadfunc("./iexample.so", "iexample") + every write( !( f(1,2,3,4) ) ) +end + diff --git a/ipl/packs/loadfuncpp/examples/callicon.cpp b/ipl/packs/loadfuncpp/examples/callicon.cpp new file mode 100644 index 0000000..7d0a224 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/callicon.cpp @@ -0,0 +1,18 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make ' to build. + * For available s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + + + +extern "C" int iexample(int argc, value argv[]) { + argv[0] = argv[1].apply(argv[2]); + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/examples/callicon.icn b/ipl/packs/loadfuncpp/examples/callicon.icn new file mode 100644 index 0000000..c3e10ee --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/callicon.icn @@ -0,0 +1,24 @@ + +link loadfuncpp + +procedure main() + icall := loadfuncpp("./callicon.so", "iexample") + + write( icall(f, ["Argument passed"]) ) +end + +procedure f(arg) + write(arg) + write("Called from C++") + every write( g(arg) ) + x := create g(arg) + while writes(@x) + write() + return "Result string!" +end + +procedure g(arg) + suspend !arg +end + + diff --git a/ipl/packs/loadfuncpp/examples/carl.icn b/ipl/packs/loadfuncpp/examples/carl.icn new file mode 100644 index 0000000..2d7c6a4 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/carl.icn @@ -0,0 +1,50 @@ + +#here's cat in icon (line by line): + +procedure main() + while write(read()) #fails when eof +end + +#here's writing out the command line arguments + +procedure main(arg) #passed a list of strings + every write( !arg) # ! (bang) makes a generator sequence +end + +#here's finding all lines in standard input containing "frog" + +procedure main() + while line := read() do line ? #string matching subject is line + if find("frog") then write(line) +end + +#here's finding the text on each line that contains "frog" that +#lies before the first occurrence of "frog" + +procedure main() + while line := read() do line ? #string matching subject is line + write( tab(find("frog")) ) +end + +#here's generating the first 1000 squares + +procedure main() + every write( squares() ) \1000 #truncate generator to 1000 results +end + +procedure squares() + n := 0 + repeat { + n +:= 1 + suspend n^2 #shoot out next element of generator sequence + } +end + +procedure main() + (n := 1) | |( n +:= 1, n^2 ) +end + +#So that +procedure main() + every write( (n := 1) | |( n +:= 1, n^2 ) ) \1000 +end diff --git a/ipl/packs/loadfuncpp/examples/coexp.cpp b/ipl/packs/loadfuncpp/examples/coexp.cpp new file mode 100644 index 0000000..6c3b1d1 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/coexp.cpp @@ -0,0 +1,20 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make ' to build. + * For available s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + +extern "C" int activate(int argc, value argv[]) { + argv[0] = argv[1].activate(); + return SUCCEEDED; +} + +extern "C" int refresh(int argc, value argv[]) { + argv[0] = argv[1].refreshed(); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/coexp.icn b/ipl/packs/loadfuncpp/examples/coexp.icn new file mode 100644 index 0000000..5f38014 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/coexp.icn @@ -0,0 +1,15 @@ + +link loadfuncpp + +procedure main() + activate := loadfuncpp("./coexp.so", "activate") + refresh := loadfuncpp("./coexp.so", "refresh") + x := create 1 to 7 + @x + @x + write( activate(x) ) + x := refresh(x) + write( activate(x) ) +end + + diff --git a/ipl/packs/loadfuncpp/examples/compare.icn b/ipl/packs/loadfuncpp/examples/compare.icn new file mode 100644 index 0000000..c6823ec --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/compare.icn @@ -0,0 +1,7 @@ + +procedure main() + loadfunc("./iload.so", "loadfuncpp") + f := loadfunc("./iexample.so", "iexample") + write( f(100,10) ) +end + diff --git a/ipl/packs/loadfuncpp/examples/examples.txt b/ipl/packs/loadfuncpp/examples/examples.txt new file mode 100644 index 0000000..40eb40a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/examples.txt @@ -0,0 +1,12 @@ +callicon +coexp +extwidget +iterate +iterate2 +iterate3 +jmexample +kwd_vbl +methodcall +mkexternal +runerr +stop diff --git a/ipl/packs/loadfuncpp/examples/extwidget.cpp b/ipl/packs/loadfuncpp/examples/extwidget.cpp new file mode 100644 index 0000000..bb42364 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/extwidget.cpp @@ -0,0 +1,35 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +#include + +class Widget: public external { + long state; + public: + Widget(long x): state(x) {} + + virtual value name() { + return "Widget"; + } + virtual external* copy() { + return new Widget(state); + } + virtual value image() { + char sbuf[100]; + sprintf(sbuf, "Widget_%ld(%ld)", id, state); + return value(NewString, sbuf); + } +}; + +extern "C" int iexample(int argc, value argv[]) { + argv[0] = new Widget(99); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/extwidget.icn b/ipl/packs/loadfuncpp/examples/extwidget.icn new file mode 100644 index 0000000..b924fd7 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/extwidget.icn @@ -0,0 +1,14 @@ + +link loadfuncpp + +procedure main() + iexample := loadfuncpp("./extwidget.so", "iexample") + external := iexample() + external2 := copy(external) + write( type(external) ) + write( image(external) ) + write( type(external2) ) + write( image(external2) ) +end + + diff --git a/ipl/packs/loadfuncpp/examples/factorials.icn b/ipl/packs/loadfuncpp/examples/factorials.icn new file mode 100644 index 0000000..908ea97 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/factorials.icn @@ -0,0 +1,27 @@ +procedure main () + every n := 1 to 10 do { + write (n, "! = ", memoized_factorial ( n ) ); + } + n := 135; write(n, "! = ", memoized_factorial ( n ) ); + n := 155; write(n, "! = ", memoized_factorial ( n ) ); +end +procedure memoized_factorial ( k ) + static results; + static k_limit; + static k_old; + initial { + results := [1]; + k_limit := 10 ^ 5; + k_old := 1; + } + if (k < k_limit) then { + while (k > *results) do results := results ||| list(*results) + every n := (k_old + 1) to k do { + results[n] := n * results[n - 1]; + } + k_old := k; + return results[k]; + } else { + return ((k / &e) ^ n) * sqrt(2 * &pi * n); + } +end diff --git a/ipl/packs/loadfuncpp/examples/hello.icn b/ipl/packs/loadfuncpp/examples/hello.icn new file mode 100644 index 0000000..5a24d9a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/hello.icn @@ -0,0 +1,3 @@ +procedure main () + write ( "Yarrr, matey, bilge the yardarm!" ); +end diff --git a/ipl/packs/loadfuncpp/examples/hexwords.icn b/ipl/packs/loadfuncpp/examples/hexwords.icn new file mode 100644 index 0000000..43c35ca --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/hexwords.icn @@ -0,0 +1,18 @@ +procedure printable(word) + if ("" == word) then { + return ""; + } else { + return map(map(word, "oOiIzZeEsStT", "001122335577"), &lcase, &ucase); + } +end +procedure main(arg) + word_file := "/usr/share/dict/words"; + find := '0123456789abcdefABCDEFoOiIzZeEsStT'; + usage := "Finds all the words in a word file that can be written using /^[A-Fa-f0-9$/"; + words := open(word_file) | stop("Unable to open: " || word_file) + while word := trim(read(words)) do { + if ('' == word -- find) then { + write(printable(word) || " " || word); + } + } +end diff --git a/ipl/packs/loadfuncpp/examples/hexwords_oneline.icn b/ipl/packs/loadfuncpp/examples/hexwords_oneline.icn new file mode 100644 index 0000000..6e11041 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/hexwords_oneline.icn @@ -0,0 +1,8 @@ +procedure printable(word) + return "" == word | map(map(word, "oOiIzZeEsStT", "001122335577"), &lcase, &ucase); +end +procedure main() + find := '0123456789abcdefABCDEFoOiIzZeEsS'; + words := open(word_file := "/usr/share/dict/words") | stop("Unable to open: " || word_file); + every write(printable( | 1 ( | (word := trim(read(words))) , not("" == word) , ('' == word -- find)))); +end diff --git a/ipl/packs/loadfuncpp/examples/iterate.cpp b/ipl/packs/loadfuncpp/examples/iterate.cpp new file mode 100644 index 0000000..9f60d13 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate.cpp @@ -0,0 +1,26 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + addup(): total((long)0) {} + virtual void takeNext(const value& x) { + total = total + x; + } +}; + +extern "C" int iexample(int argc, value argv[]) { + addup sum; + sum.every(argv[1], argv[2]); + argv[0] = sum.total; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/iterate.icn b/ipl/packs/loadfuncpp/examples/iterate.icn new file mode 100644 index 0000000..0d6de0e --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate.icn @@ -0,0 +1,13 @@ + +link loadfuncpp + + +procedure main() + total := loadfuncpp("./iterate.so", "iexample") + write( total(g, [1,2,3,4,5]) ) +end + +procedure g(ls[]) + suspend !ls +end + diff --git a/ipl/packs/loadfuncpp/examples/iterate2.cpp b/ipl/packs/loadfuncpp/examples/iterate2.cpp new file mode 100644 index 0000000..c32bdf9 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate2.cpp @@ -0,0 +1,31 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + int count; + addup(): total((long)0), count(0) {} + + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 3; + } +}; + +extern "C" int iexample(int argc, value argv[]) { + addup sum; + sum.every(argv[1], argv[2]); + argv[0] = sum.total; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/iterate2.icn b/ipl/packs/loadfuncpp/examples/iterate2.icn new file mode 100644 index 0000000..3863ba1 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate2.icn @@ -0,0 +1,13 @@ + +link loadfuncpp + + +procedure main() + total := loadfuncpp("./iterate2.so", "iexample") + write( total(g, [1,2,3,4,5]) ) +end + +procedure g(ls[]) + suspend !ls +end + diff --git a/ipl/packs/loadfuncpp/examples/iterate3.cpp b/ipl/packs/loadfuncpp/examples/iterate3.cpp new file mode 100644 index 0000000..1b1dd70 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate3.cpp @@ -0,0 +1,32 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + int count; + addup(): total((long)0) { + count = 0; + } + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 3; + } +}; + +extern "C" int iexample(value argv[]) { + addup sum; + sum.bang(argv[1]); + argv[0] = sum.total; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/iterate3.icn b/ipl/packs/loadfuncpp/examples/iterate3.icn new file mode 100644 index 0000000..1f6414d --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate3.icn @@ -0,0 +1,9 @@ + +link loadfuncpp + + +procedure main() + total := loadfuncpp("./iterate3.so", "iexample", 1) #arity present + write( total([1,2,3,4,5]) ) +end + diff --git a/ipl/packs/loadfuncpp/examples/jmexample.cpp b/ipl/packs/loadfuncpp/examples/jmexample.cpp new file mode 100644 index 0000000..a367fd5 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/jmexample.cpp @@ -0,0 +1,52 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make ' to build. + * For available s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + +enum { JMUP, JMDOWN }; +class sequence: public generator { + long count; + long limit; + int direction; + bool hasNext() { + switch(direction) { + case JMUP: + return count <= limit; + case JMDOWN: + return count >= limit; + default: + return false; + } + } + value giveNext() { + switch(direction) { + case JMUP: + return count++; + case JMDOWN: + return count--; + default: + return nullvalue; + } + } + public: + sequence(value start, value end) { + count = start; + limit = end; + direction = ((count < limit) ? JMUP : JMDOWN); + }; +}; + +extern "C" int jm_test_1(int argc, value argv[]) { + if( argc != 2 ) { + return FAILED; + } + sequence s(argv[1], argv[2]); + return s.generate(argv); +} + + diff --git a/ipl/packs/loadfuncpp/examples/jmexample.icn b/ipl/packs/loadfuncpp/examples/jmexample.icn new file mode 100644 index 0000000..d2cc973 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/jmexample.icn @@ -0,0 +1,8 @@ + +link loadfuncpp + +procedure main() + f := loadfuncpp("./jmexample.so", "jm_test_1") + every write(f(1, 10) | f(10, 1) | f(10, 10) | f(-1, 1)) +end + diff --git a/ipl/packs/loadfuncpp/examples/kwd_vbl.cpp b/ipl/packs/loadfuncpp/examples/kwd_vbl.cpp new file mode 100644 index 0000000..d754304 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/kwd_vbl.cpp @@ -0,0 +1,17 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int iexample(int argc, value argv[]) { + safe y = argv[1]; + &progname = y; + argv[0] = &progname; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/kwd_vbl.icn b/ipl/packs/loadfuncpp/examples/kwd_vbl.icn new file mode 100644 index 0000000..4d4c9e8 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/kwd_vbl.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + keyword := loadfuncpp("./kwd_vbl.so", "iexample") + x := keyword("frog") + write(&progname) +end + + diff --git a/ipl/packs/loadfuncpp/examples/loadfuncpp.h b/ipl/packs/loadfuncpp/examples/loadfuncpp.h new file mode 100644 index 0000000..5704f60 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/loadfuncpp.h @@ -0,0 +1,481 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include this and link to iload.cpp which + * contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include +#include + +enum kind { Null, Integer, BigInteger, Real, Cset, File, Procedure, Record, List, + Set=10, Table=12, String, Constructor, Coexpression=18, External, Variable }; + +enum special_value { NullString, StringLiteral, NewString, NullChar, Illegal }; + +enum { + SUCCEEDED = 7, // Icon function call returned: A_Continue + FAILED = 1 // Icon function call failed: A_Resume +}; + +class value; //Icon value (descriptor) +class safe; //for garbage-collection-safe Icon valued C++ variables and parameters of all kinds +class keyword; //Icon keyword represented as an object with unary & +class variadic; //for garbage-collection-safe variadic function argument lists +class proc_block; //block specifying a procedure to iconx +class external_block; //block specifying an external value to iconx +class external_ftable; //function pointers specifying external value behavior to iconx +class external; //C++ Object specifying an external value + +typedef int iconfunc(value argv[]); //type of icon built in functions or operators with a fixed number of arguments +typedef int iconfvbl(int argc, value argv[]); //type of icon built in functions with a variable number of arguments + +extern const value nullvalue; //for default arguments +extern const value nullstring; +extern const value nullchar; +extern const value illegal; //for unwanted trailing arguments +extern void syserror(const char*); //fatal termination Icon-style with error message +#define Fs_Read 0001 // file open for reading +#define Fs_Write 0002 // file open for writing +extern value IconFile(int fd, int status, char* fname); //make an Icon file descriptor +extern value integertobytes(value); //get the bytes of an Icon long integer as an Icon string (ignore sign) +extern value bytestointeger(value); //get the bytes of a new Icon long integer from an Icon string +extern value base64(value); //convert string or integer to base64 encoding (string) +extern value base64tointeger(value); //decode base64 string to integer +extern value base64tostring(value); //decode base64 string to string + +namespace Icon { +//all keywords excepting &fail, &cset (avoiding a name collision with function cset) +extern keyword allocated; +extern keyword ascii; +extern keyword clock; +extern keyword collections; +extern keyword current; +extern keyword date; +extern keyword dateline; +extern keyword digits; +extern keyword dump; +extern keyword e; +extern keyword error; +extern keyword errornumber; +extern keyword errortext; +extern keyword errorvalue; +extern keyword errout; +extern keyword features; +extern keyword file; +extern keyword host; +extern keyword input; +extern keyword lcase; +extern keyword letters; +extern keyword level; +extern keyword line; +extern keyword main; +extern keyword null; +extern keyword output; +extern keyword phi; +extern keyword pi; +extern keyword pos; +extern keyword progname; +extern keyword random; +extern keyword regions; +extern keyword source; +extern keyword storage; +extern keyword subject; +extern keyword time; +extern keyword trace; +extern keyword ucase; +extern keyword version; +}; //namespace Icon + +static void initialize_keywords(); + +class keyword { //objects representing Icon keywords + friend void initialize_keywords(); + iconfunc* f; + public: + safe operator&(); //get the keyword's value (could be an Icon 'variable') +}; + + +class value { //a descriptor with class +//data members modelled after 'typedef struct { word dword, vword; } descriptor;' from icall.h + private: + long dword; + long vword; + public: + friend class safe; + friend value IconFile(FILE* fd, int status, char* fname); + friend value integertobytes(value); + friend value bytestointeger(value); + friend value base64(value); + friend value base64tointeger(value); + friend value base64tostring(value); + value(); //&null + value(special_value, const char* text = ""); + value(int argc, value* argv); //makes a list of parameters passed in from Icon + value(int); + value(long); + value(float); + value(double); + value(char*); + value(const char*); + value(const char*, long); + value(proc_block&); + value(proc_block*); + value(external*); + operator int(); + operator long(); + operator float(); + operator double(); + operator char*(); + operator external*(); + operator proc_block*() const; + bool operator==(const value&) const; + value& dereference(); + value intify(); + bool isNull(); + bool notNull(); + bool isExternal(const value&); + value size() const; + kind type(); + bool toString(); //attempted conversion in place + bool toCset(); + bool toInteger(); + bool toReal(); + bool toNumeric(); + value subscript(const value&) const; //produces an Icon 'variable' + value& assign(const value&); //dereferences Icon style + value put(value x = nullvalue); + value push(value x = nullvalue); + void dump() const; + void printimage() const; + int compare(const value&) const; //comparator-style result: used for Icon sorting + value negative() const; // -x + value complement() const; // ~x + value refreshed() const; // ^x + value random() const; // ?x + value plus(const value&) const; + value minus(const value&) const; + value multiply(const value&) const; + value divide(const value&) const; + value remainder(const value&) const; + value power(const value&) const; + value union_(const value&) const; // x ++ y + value intersection(const value&) const; // x ** y + value difference(const value&) const; // x -- y + value concatenate(const value&) const; // x || y + value listconcatenate(const value&) const;// x ||| y + value slice(const value&, const value&) const; // x[y:z] + value& swap(value&); // x :=: y + value activate(const value& y = nullvalue) const; // y @ x ('*this' is activated) + value apply(const value&) const; // x!y (must return, not fail or suspend) +}; //class value + + +class generator { +//class to inherit from for defining loadable functions that are generators + public: + int generate(value argv[]); //call to suspend everything produced by next() + protected: //override these, and write a constructor + virtual bool hasNext(); + virtual value giveNext(); +}; //class generator + + +class iterate { +//class to inherit from for iterating over f!arg or !x + public: + void every(const value& g, const value& arg); //perform the iteration over g!arg + void bang(const value& x); //perform the iteration over !x + //override these, write a constructor and the means of recovering the answer + virtual bool wantNext(const value& x); + virtual void takeNext(const value& x); +}; + + + +class safe_variable { +//data members modelled after 'struct tend_desc' from rstructs.h + friend class value; + friend inline int safecall_0(iconfunc*, value&); + friend inline int safecall_1(iconfunc*, value&, const value&); + friend inline int safecall_2(iconfunc*, value&, const value&, const value&); + friend inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); + friend inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); + friend inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_v0(iconfvbl*, value&); + friend inline int safecall_v1(iconfvbl*, value&, const value&); + friend inline int safecall_v2(iconfvbl*, value&, const value&, const value&); + friend inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); + friend inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + protected: + safe_variable *previous; + int num; + value val; + safe_variable(); + safe_variable(int); + safe_variable(long); + safe_variable(double); + safe_variable(value); + safe_variable(proc_block&); + safe_variable(proc_block*); + safe_variable(int, value*); + inline void push(safe_variable*& tendlist, int numvalues=1); + inline void pop(safe_variable*& tendlist); +}; //class safe_variable + + +class variadic: public safe_variable { + public: + variadic(int); + variadic(long); + variadic(float); + variadic(double); + variadic(char*); + variadic(value); + variadic(const safe&); + variadic(const safe&, const safe&); + variadic& operator,(const safe&); + operator value(); + ~variadic(); +}; //class variadic + + +class external_block { +//modelled on 'struct b_external' in icon/src/h/rstructs.h + friend class external; + friend class value; + static long extra_bytes; //silent extra parameter to new + long title; + long blksize; + long id; + external_ftable* funcs; + external* val; + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing + external_block(); +}; + +class external { + friend class value; + static external_block* blockptr; //silent extra result of new + protected: + long id; + public: + static void* operator new(size_t); //allocated by new external_block() + static void operator delete(void*); //do nothing + external(); + virtual ~external() {} //root class + virtual long compare(external*); + virtual value name(); + virtual external* copy(); + virtual value image(); +}; + + +class safe: public safe_variable { +//use for a garbage collection safe icon valued safe C++ variable + friend class variadic; + friend class global; + public: + safe(); //&null + safe(const safe&); + safe(int); + safe(long); + safe(float); + safe(double); + safe(char*); + safe(const value&); + safe(const variadic&); + safe(proc_block&); + safe(proc_block*); + safe(int, value*); //from parameters sent in from Icon + ~safe(); + safe& operator=(const safe&); + //augmenting assignments here + safe& operator+=(const safe&); + safe& operator-=(const safe&); + safe& operator*=(const safe&); + safe& operator/=(const safe&); + safe& operator%=(const safe&); + safe& operator^=(const safe&); + safe& operator&=(const safe&); + safe& operator|=(const safe&); + // ++ and -- here + safe& operator++(); + safe& operator--(); + safe operator++(int); + safe operator--(int); + //conversion to value + operator value() const; + //procedure call + safe operator()(); + safe operator()(const safe&); + safe operator()(const safe& x1, const safe& x2, + const safe& x3 = illegal, const safe& x4 = illegal, + const safe& x5 = illegal, const safe& x6 = illegal, + const safe& x7 = illegal, const safe& x8 = illegal); + safe operator[](const safe&); + + friend safe operator*(const safe&); //size + friend safe operator-(const safe&); + friend safe operator~(const safe&); //set complement + friend safe operator+(const safe&, const safe&); + friend safe operator-(const safe&, const safe&); + friend safe operator*(const safe&, const safe&); + friend safe operator/(const safe&, const safe&); + friend safe operator%(const safe&, const safe&); + friend safe operator^(const safe&, const safe&); //exponentiation + friend safe operator|(const safe&, const safe&); //union + friend safe operator&(const safe&, const safe&); //intersection + friend safe operator&&(const safe&, const safe&); //set or cset difference + friend safe operator||(const safe&, const safe&); //string concatenation + friend bool operator<(const safe&, const safe&); + friend bool operator>(const safe&, const safe&); + friend bool operator<=(const safe&, const safe&); + friend bool operator>=(const safe&, const safe&); + friend bool operator==(const safe&, const safe&); + friend bool operator!=(const safe&, const safe&); + friend variadic operator,(const safe&, const safe&); //variadic argument list construction + + safe slice(const safe&, const safe&); // x[y:z] + safe apply(const safe&); // x ! y + safe listcat(const safe&); // x ||| y + safe& swap(safe&); // x :=: y + safe create(); // create !x + safe create(const safe&); // create x!y + safe activate(const safe& y = nullvalue); // y@x + safe refresh(); // ^x + safe random(); // ?x + safe dereference(); // .x + bool isIllegal() const; //is an illegal value used for trailing arguments +}; //class safe + + +//Icon built-in functions +namespace Icon { + safe abs(const safe&); + safe acos(const safe&); + safe args(const safe&); + safe asin(const safe&); + safe atan(const safe&, const safe&); + safe center(const safe&, const safe&, const safe&); + safe char_(const safe&); + safe chdir(const safe&); + safe close(const safe&); + safe collect(); + safe copy(const safe&); + safe cos(const safe&); + safe cset(const safe&); + safe delay(const safe&); + safe delete_(const safe&, const safe&); + safe detab(const variadic&); + safe detab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe display(const safe&, const safe&); + safe dtor(const safe&); + safe entab(const variadic&); + safe entab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe errorclear(); + safe exit(const safe&); + safe exp(const safe&); + safe flush(const safe&); + safe function(); //generative: returns a list + safe get(const safe&); + safe getch(); + safe getche(); + safe getenv(const safe&); + safe iand(const safe&, const safe&); + safe icom(const safe&); + safe image(const safe&); + safe insert(const safe&, const safe&, const safe&); + safe integer(const safe&); + safe ior(const safe&, const safe&); + safe ishift(const safe&, const safe&); + safe ixor(const safe&, const safe&); + safe kbhit(); + safe left(const safe&, const safe&, const safe&); + safe list(const safe&, const safe&); + safe loadfunc(const safe&, const safe&); + safe log(const safe&); + safe map(const safe&, const safe&, const safe&); + safe member(const safe&, const safe&); + safe name(const safe&); + safe numeric(const safe&); + safe open(const safe&, const safe&); + safe ord(const safe&); + safe pop(const safe&); + safe proc(const safe&, const safe&); + safe pull(const safe&); + safe push(const variadic&); + safe push( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe put(const variadic&); + safe put( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe read(const safe&); + safe reads(const safe&, const safe&); + safe real(const safe&); + safe remove(const safe&); + safe rename(const safe&, const safe&); + safe repl(const safe&, const safe&); + safe reverse(const safe&); + safe right(const safe&, const safe&, const safe&); + safe rtod(const safe&); + safe runerr(const safe&, const safe&); + safe runerr(const safe&); + safe seek(const safe&, const safe&); + safe serial(const safe&); + safe set(const safe&); + safe sin(const safe&); + safe sort(const safe&, const safe&); + safe sortf(const safe&, const safe&); + safe sqrt(const safe&); + safe stop(); + safe stop(const variadic&); + safe stop( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe string(const safe&); + safe system(const safe&); + safe table(const safe&); + safe tan(const safe&); + safe trim(const safe&, const safe&); + safe type(const safe&); + safe variable(const safe&); + safe where(const safe&); + safe write(); + safe write(const variadic&); + safe write( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe writes(const variadic&); + safe writes( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + //generative functions follow, crippled to return a single value + safe any(const safe&, const safe&, const safe&, const safe&); + safe many(const safe&, const safe&, const safe&, const safe&); + safe upto(const safe&, const safe&, const safe&, const safe&); + safe find(const safe&, const safe&, const safe&, const safe&); + safe match(const safe&, const safe&, const safe&, const safe&); + safe bal(const safe&, const safe&, const safe&, const safe&, const safe&, const safe&); + safe move(const safe&); + safe tab(const safe&); +}; //namespace Icon + diff --git a/ipl/packs/loadfuncpp/examples/methodcall.cpp b/ipl/packs/loadfuncpp/examples/methodcall.cpp new file mode 100644 index 0000000..0f13195 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/methodcall.cpp @@ -0,0 +1,18 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +#include + +extern "C" int iexample(int argc, value argv[]) { + + + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/methodcall.icn b/ipl/packs/loadfuncpp/examples/methodcall.icn new file mode 100644 index 0000000..ab48d06 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/methodcall.icn @@ -0,0 +1,23 @@ + +link loadfuncpp + + +record thing(val, method) + +procedure method(x) + object := self() | stop("not bound to a record") + object.val := x +end + +procedure main() + + obj := thing() + obj.method := bindself(method, obj) + + write(image(obj.method)) + + obj.method(99) + + write( obj.val ) +end + diff --git a/ipl/packs/loadfuncpp/examples/mkexternal.cpp b/ipl/packs/loadfuncpp/examples/mkexternal.cpp new file mode 100644 index 0000000..39c9b84 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/mkexternal.cpp @@ -0,0 +1,15 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int iexample(int argc, value argv[]) { + argv[0] = new external(); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/mkexternal.icn b/ipl/packs/loadfuncpp/examples/mkexternal.icn new file mode 100644 index 0000000..ec388cf --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/mkexternal.icn @@ -0,0 +1,14 @@ + +link loadfuncpp + +procedure main() + iexample := loadfuncpp("./mkexternal.so", "iexample") + external := iexample() + external2 := copy(external) + write( type(external) ) + write( image(external) ) + write( type(external2) ) + write( image(external2) ) +end + + diff --git a/ipl/packs/loadfuncpp/examples/newprimes.icn b/ipl/packs/loadfuncpp/examples/newprimes.icn new file mode 100644 index 0000000..4f2391a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/newprimes.icn @@ -0,0 +1,4 @@ +procedure main() + #limit to the first 10000 primes + every write(!(p := 1, a := [2])| 1(|(p +:= 2), not(p % !a = 0), put(a, p))) \1000 +end diff --git a/ipl/packs/loadfuncpp/examples/numbernamer.icn b/ipl/packs/loadfuncpp/examples/numbernamer.icn new file mode 100644 index 0000000..1996c8d --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/numbernamer.icn @@ -0,0 +1,61 @@ + +procedure main(arg) + every write( number(!arg, 0) ) +end + +procedure number(n, state) + static small, large, units + initial { + small := ["one", "two", "three", "four", "five", "six", "seven", "eight", + "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", + "fifteen", "sixteen", "seventeen", "eighteen", "nineteen"] + large := ["ten", "twenty", "thirty", "forty", "fifty", "sixty", + "seventy", "eighty", "ninety"] + units := ["thousand", "million", "billion", "trillion", "quadrillion", + "quintillion", "sextillion", "septillion", "octillion", "nonillion"] + } + n := integer(n) | fail + if 0 = n then return "zero" + if 0 > n then return "minus " || number(-n) + if 20 > n then return small[n] + if 100 > n then { + x := n / 10 + r := n % 10 + if (0 = r) then { + return large[x] + } else { + return large[x] || "-" || number(r, state) + } + } + if (1000 > n) then { + x := n / 100 + r := n % 100 + if (0 = r) then { + return number(x, 1) || " hundred" + } else { + if (0 = state) then { + return number(x, 1) || " hundred and " || number(r, 1) + } else { + return number(x, 1) || " hundred " || number(r, 1) + } + } + } + + every i := 1 to *units do { + j := (*units - i + 1) + k := j * 3 + m := 10^k + x := n / m + r := n % m + if (0 < x) then { + if (0 = r) then { + return number(x, 1) || " " || units[j] + } else if ( 100 > r) then { + return number(x, 1) || " " || units[j] || " and " || number(r, 1) + } else { + return number(x, 1) || " " || units[j] || ", " || number(r, 0) + } + } + } + return "Error NaN: " || n +end diff --git a/ipl/packs/loadfuncpp/examples/primes.icn b/ipl/packs/loadfuncpp/examples/primes.icn new file mode 100644 index 0000000..ecbd1f1 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/primes.icn @@ -0,0 +1,26 @@ +procedure main() + #limit to the first x primes + local x; + x := 20; + every write(!(p := 1, a := [2])| 1(|(p +:= 2), not(p % !a = 0), put(a, p))) \x + list_primes(x); +end + +procedure list_primes(prime_limit) + local p; + local a; + local s; + initial { + p := 1; + a := [2]; + } + until (prime_limit <= *a) do { + p +:= 2; + s := sqrt(p); + + if (not(p % !a = 0)) then { + put(a, p); + } + } + every write(!a) +end diff --git a/ipl/packs/loadfuncpp/examples/runerr.cpp b/ipl/packs/loadfuncpp/examples/runerr.cpp new file mode 100644 index 0000000..e572133 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/runerr.cpp @@ -0,0 +1,31 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + +#include + +extern "C" int iexample(value argv[]) { + safe callme(argv[1]), text(argv[2]); + printf("Calling callme\n"); + callme(); + printf("Callme returned\n"); + printf("Calling callme\n"); + callme(); + printf("Callme returned\n"); + //Icon::runerr(123, text); + return FAILED; +} + +extern "C" int iexample2(value argv[]) { + //Icon::display(&Icon::level, &Icon::output); + safe nextcall(argv[1]), rerr(argv[2]); + nextcall(); + rerr(123, "Bye!"); + //Icon::runerr(123, "Bye!"); + return FAILED; +} diff --git a/ipl/packs/loadfuncpp/examples/runerr.icn b/ipl/packs/loadfuncpp/examples/runerr.icn new file mode 100644 index 0000000..8c39c9a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/runerr.icn @@ -0,0 +1,32 @@ + +link loadfuncpp + +procedure main() + x := [1,2,3] + main2() +end + +global newdisplay + +procedure main2() + newrunerr := loadfuncpp("runerr.so", "iexample", 2) + newdisplay := loadfuncpp("runerr.so", "iexample2", 2) +#&trace := -1 + newrunerr(callme, "Hello!") + write("We don't get here!") +end + +procedure callme() + initial { + write("callme() called! first time!") + return + } + write("callme() called for second time!") + newdisplay(nextcall, runerr) + #runerr(123, "callme error termination!") + return +end + +procedure nextcall() + write("Call to nextcall") +end diff --git a/ipl/packs/loadfuncpp/examples/stop.cpp b/ipl/packs/loadfuncpp/examples/stop.cpp new file mode 100644 index 0000000..74373dd --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/stop.cpp @@ -0,0 +1,16 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int iexample(int argc, value argv[]) { + safe x = argv[1]; + stop(x); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/stop.icn b/ipl/packs/loadfuncpp/examples/stop.icn new file mode 100644 index 0000000..6177bad --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/stop.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + newstop := loadfuncpp("./stop.so", "iexample") + newstop("Stop!") + write("We don't get here!") +end + + diff --git a/ipl/packs/loadfuncpp/examples/sums.icn b/ipl/packs/loadfuncpp/examples/sums.icn new file mode 100644 index 0000000..062fceb --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/sums.icn @@ -0,0 +1,8 @@ +procedure main() + local n, sum # Declare two local variables + sum := 0 # Set the sum to zero + every n := 1 to 5 do # For n equal to 1, 2, 3, 4, 5 ... + sum := sum + n; # ...add n to the sum + + write ( "The sum of all numbers from 1 to 5 is ", sum ); +end diff --git a/ipl/packs/loadfuncpp/examples/sums2.icn b/ipl/packs/loadfuncpp/examples/sums2.icn new file mode 100644 index 0000000..a5c136e --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/sums2.icn @@ -0,0 +1,6 @@ +procedure main() + local sum; + sum := 0; + every sum +:= 1 to 5 + write ( "The sum of all numbers from 1 to 5 is ", sum ); +end diff --git a/ipl/packs/loadfuncpp/hex.txt b/ipl/packs/loadfuncpp/hex.txt new file mode 100644 index 0000000..d5f438c --- /dev/null +++ b/ipl/packs/loadfuncpp/hex.txt @@ -0,0 +1 @@ +2d3a674a9265858a427fb642aaf89a62 diff --git a/ipl/packs/loadfuncpp/iexample.cpp b/ipl/packs/loadfuncpp/iexample.cpp new file mode 100644 index 0000000..f51a794 --- /dev/null +++ b/ipl/packs/loadfuncpp/iexample.cpp @@ -0,0 +1,27 @@ + +#include "loadfuncpp.h" + +extern "C" int integertobytes(value argv[]) { + argv[0] = integertobytes(argv[1]); + return SUCCEEDED; +} + +extern "C" int bytestointeger(value argv[]) { + argv[0] = bytestointeger(argv[1]); + return SUCCEEDED; +} + +extern "C" int base64(value argv[]) { + argv[0] = base64(argv[1]); + return SUCCEEDED; +} + +extern "C" int base64tostring(value argv[]) { + argv[0] = base64tostring(argv[1]); + return SUCCEEDED; +} + +extern "C" int base64tointeger(value argv[]) { + argv[0] = base64tointeger(argv[1]); + return SUCCEEDED; +} diff --git a/ipl/packs/loadfuncpp/iexample.icn b/ipl/packs/loadfuncpp/iexample.icn new file mode 100644 index 0000000..1d615f3 --- /dev/null +++ b/ipl/packs/loadfuncpp/iexample.icn @@ -0,0 +1,37 @@ + +link loadfuncpp + +global integertobytes, bytestointeger, base64, base64tostring, base64tointeger + +procedure main() + integertobytes := loadfuncpp("iexample.so", "integertobytes", 1) + bytestointeger := loadfuncpp("iexample.so", "bytestointeger", 1) + base64 := loadfuncpp("iexample.so", "base64", 1) + base64tostring := loadfuncpp("iexample.so", "base64tostring", 1) + base64tointeger := loadfuncpp("iexample.so", "base64tointeger", 1) + + #test1() + test2() + #test3() +end + +procedure test3() + while write(base64tointeger(base64(integer(read())))) +end + +procedure test2() + while write(base64tostring(base64(read()))) +end + +procedure test1() + i := 16rBEADEDCEDEDBEEFEDCEDEDBEADEDBEEFED + + s := "\x00" || integertobytes(i) + ii := bytestointeger(s) + ss := integertobytes(ii) + + write( image(s) ) + write( image(ss) ) + write(i) + write(ii) +end diff --git a/ipl/packs/loadfuncpp/iload.cpp b/ipl/packs/loadfuncpp/iload.cpp new file mode 100644 index 0000000..2a39c3a --- /dev/null +++ b/ipl/packs/loadfuncpp/iload.cpp @@ -0,0 +1,2669 @@ + + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include loadfuncpp.h and link dynamically to + * this, which contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include +#include + +#include "loadfuncpp.h" +#include "iload.h" + + +/* + * References to the part of loadfuncpp written in Icon + */ + +//variables to refer to the Icon procedures in loadfuncpp.icn +static value _loadfuncpp_pathfind; +static value _loadfuncpp_reduce; +static value _loadfuncpp_create; +static value _loadfuncpp_activate; +static value _loadfuncpp_kcollections; +static value _loadfuncpp_kfeatures; +static value _loadfuncpp_kregions; +static value _loadfuncpp_kstorage; +static value _loadfuncpp_function; +static value _loadfuncpp_key; +static value _loadfuncpp_bang; +static value _loadfuncpp_any; +static value _loadfuncpp_many; +static value _loadfuncpp_upto; +static value _loadfuncpp_find; +static value _loadfuncpp_match; +static value _loadfuncpp_bal; +static value _loadfuncpp_move; +static value _loadfuncpp_tab; +static value _loadfuncpp_apply; + +static void initialize_procs() { //called below, on load + _loadfuncpp_pathfind = Value::libproc("_loadfuncpp_pathfind"); + _loadfuncpp_reduce = Value::libproc("_loadfuncpp_reduce"); + _loadfuncpp_create = Value::libproc("_loadfuncpp_create"); + _loadfuncpp_activate = Value::libproc("_loadfuncpp_activate"); + _loadfuncpp_kcollections = Value::libproc("_loadfuncpp_kcollections"); + _loadfuncpp_kfeatures = Value::libproc("_loadfuncpp_kfeatures"); + _loadfuncpp_kregions = Value::libproc("_loadfuncpp_kregions"); + _loadfuncpp_kstorage = Value::libproc("_loadfuncpp_kstorage"); + _loadfuncpp_function = Value::libproc("_loadfuncpp_function"); + _loadfuncpp_key = Value::libproc("_loadfuncpp_key"); + _loadfuncpp_bang = Value::libproc("_loadfuncpp_bang"); + _loadfuncpp_any = Value::libproc("_loadfuncpp_any"); + _loadfuncpp_many = Value::libproc("_loadfuncpp_many"); + _loadfuncpp_upto = Value::libproc("_loadfuncpp_upto"); + _loadfuncpp_find = Value::libproc("_loadfuncpp_find"); + _loadfuncpp_match = Value::libproc("_loadfuncpp_match"); + _loadfuncpp_bal = Value::libproc("_loadfuncpp_bal"); + _loadfuncpp_move = Value::libproc("_loadfuncpp_move"); + _loadfuncpp_tab = Value::libproc("_loadfuncpp_tab"); + _loadfuncpp_apply = Value::libproc("_loadfuncpp_apply"); +} + +//callbacks to Icon for generative keywords and functions +static int K_collections(value* argv) { + argv[0] = _loadfuncpp_kcollections.apply(Value::list()); + return SUCCEEDED; +} + +static int K_features(value* argv) { + argv[0] = _loadfuncpp_kfeatures.apply(Value::list()); + return SUCCEEDED; +} + +static int K_regions(value* argv) { + argv[0] = _loadfuncpp_kregions.apply(Value::list()); + return SUCCEEDED; +} + +static int K_storage(value* argv) { + argv[0] = _loadfuncpp_kstorage.apply(Value::list()); + return SUCCEEDED; +} + +static int Z_function(value* argv) { + argv[0] = _loadfuncpp_function.apply(Value::list()); + return SUCCEEDED; +} + +static int Z_key(value* argv) { + value arg(1,argv); + argv[0] = _loadfuncpp_key.apply(arg); + return SUCCEEDED; +} + +static int Z_any(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_any.apply(arg); + return SUCCEEDED; +} + +static int Z_many(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_many.apply(arg); + return SUCCEEDED; +} + +static int Z_upto(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_upto.apply(arg); + return SUCCEEDED; +} + +static int Z_find(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_find.apply(arg); + return SUCCEEDED; +} + +static int Z_match(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_match.apply(arg); + return SUCCEEDED; +} + +static int Z_bal(value* argv) { + value arg(6,argv); + argv[0] = _loadfuncpp_bal.apply(arg); + return SUCCEEDED; +} + +static int Z_move(value* argv) { + value arg(1,argv); + argv[0] = _loadfuncpp_move.apply(arg); + return SUCCEEDED; +} + +static int Z_tab(value* argv) { + value arg(1,argv); + argv[0] = _loadfuncpp_tab.apply(arg); + return SUCCEEDED; +} + + + +/* + * Keywords and their initialization + */ + +namespace Icon { +//all non-graphics keywords excepting &fail, &cset (name collision with function cset) +keyword allocated; +keyword ascii; +keyword clock; +keyword collections; +keyword current; +keyword date; +keyword dateline; +keyword digits; +keyword dump; +keyword e; +keyword error; +keyword errornumber; +keyword errortext; +keyword errorvalue; +keyword errout; +keyword features; +keyword file; +keyword host; +keyword input; +keyword lcase; +keyword letters; +keyword level; +keyword line; +keyword main; +keyword null; +keyword output; +keyword phi; +keyword pi; +keyword pos; +keyword progname; +keyword random; +keyword regions; +keyword source; +keyword storage; +keyword subject; +keyword time; +keyword trace; +keyword ucase; +keyword version; +}; //namespace Icon + + +static void initialize_keywords() { + Icon::allocated.f = Kallocated; + Icon::ascii.f = Kascii; + Icon::clock.f = Kclock; + Icon::collections.f = K_collections; //generative: K_ + Icon::current.f = Kcurrent; + Icon::date.f = Kdate; + Icon::dateline.f = Kdateline; + Icon::digits.f = Kdigits; + Icon::dump.f = Kdump; + Icon::e.f = Ke; + Icon::error.f = Kerror; + Icon::errornumber.f = Kerrornumber; + Icon::errortext.f = Kerrortext; + Icon::errorvalue.f = Kerrorvalue; + Icon::errout.f = Kerrout; + Icon::features.f = K_features; //generative: K_ + Icon::file.f = Kfile; + Icon::host.f = Khost; + Icon::input.f = Kinput; + Icon::lcase.f = Klcase; + Icon::letters.f = Kletters; + Icon::level.f = Klevel; + Icon::line.f = Kline; + Icon::main.f = Kmain; + Icon::null.f = Knull; + Icon::output.f = Koutput; + Icon::phi.f = Kphi; + Icon::pi.f = Kpi; + Icon::pos.f = Kpos; + Icon::progname.f = Kprogname; + Icon::random.f = Krandom; + Icon::regions.f = K_regions; //generative: K_ + Icon::source.f = Ksource; + Icon::storage.f = K_storage; //generative: K_ + Icon::subject.f = Ksubject; + Icon::time.f = Ktime; + Icon::trace.f = Ktrace; + Icon::ucase.f = Kucase; + Icon::version.f = Kversion; +} + +safe keyword::operator&() { + value result; + safecall_0(*f, result); + return result; +} + +/* + * Implementation of the value class. + */ + +const value nullstring(NullString); +const value nullvalue; //statically initialized by default to &null +const value nullchar(NullChar); +const value illegal(Illegal); + +value::value() { +//default initialization is to &null + dword = D_Null; + vword = 0; +} + +value::value(special_value sv, const char *text) { + switch( sv ) { + case NullString: + dword = 0; + vword = (long)""; + break; + case StringLiteral: + dword = strlen(text); + vword = (long)text; + break; + case NewString: + dword = strlen(text); + vword = (long)alcstr((char*)text, dword); + break; + case NullChar: + dword = 1; + vword = (long)"\0"; + break; + case Illegal: + dword = D_Illegal; + vword = 0; + break; + default: + dword = D_Null; + vword = 0; + } +} + +value::value(int argc, value* argv) { //assumes these are passed in from Icon + safe argv0 = argv[0]; //which guarantees their GC safety + Ollist(argc, argv); + *this = argv[0]; + argv[0] = argv0; +} + +value::value(int n) { + dword = D_Integer; + vword = n; +} + +value::value(long n) { + dword = D_Integer; + vword = n; +} + +value::value(float x) { + dword = D_Real; + vword = (long)alcreal(x); +} + +value::value(double x) { + dword = D_Real; + vword = (long)alcreal(x); +} + +value::value(char* s) { + dword = strlen(s); + vword = (long)alcstr(s, dword); +} + +value::value(const char* s) { + dword = strlen(s); + vword = (long)alcstr((char*)s, dword); +} + +value::value(const char* s, long len) { + dword = len; + vword = (long)alcstr((char*)s, dword); +} + +value::value(proc_block& pb) { + dword = D_Proc; + vword = (long)&pb; +} + +value::value(proc_block* pbp) { + dword = D_Proc; + vword = (long)pbp; +} + +value::value(external* ep) { + char* ptr = (char*)ep - sizeof(external_block)/sizeof(char); + dword = D_External; + vword = (long)ptr; +} + +value::operator int() { + if( this->type() != Integer ) + syserror("loadfuncpp: int cannot be produced from non-Integer"); + return vword; +} + +value::operator long() { + if( this->type() != Integer ) + syserror("loadfuncpp: long cannot be produced from non-Integer"); + return vword; +} + +value::operator float() { + if( this->type() != Real ) + syserror("loadfuncpp: double cannot be produced from non-Real"); + return getdbl(this); +} + +value::operator double() { + if( this->type() != Real ) + syserror("loadfuncpp: double cannot be produced from non-Real"); + return getdbl(this); +} + +value::operator char*() { + if( this->type() != String ) + syserror("loadfuncpp: char* cannot be produced from non-String"); + return (char*)vword; +} + +value::operator external*() { + if( dword != D_External ) return 0; //too ruthless + return (external*)((external_block*)vword + 1); +} + +value::operator proc_block*() const { + if( dword != D_Proc ) return 0; //too ruthless + return (proc_block*)vword; +} + +void value::dump() const { + fprintf(stderr, "\n%lx\n%lx\n", dword, vword); + fflush(stderr); +} + +bool value::operator==(const value& v) const { + return dword==v.dword && vword==v.vword; +} + +value& value::dereference() { + deref(this, this); //dereference in place + return *this; +} + +value value::intify() { //integer representation of vword pointer + switch( this->type() ) { + default: + return vword; + case Null: case Integer: case Real: + return nullvalue; + } +} + +bool value::isNull() { + return (dword & TypeMask) == T_Null; +} + +bool value::notNull() { + return (dword & TypeMask) != T_Null; +} + +value value::size() const { + value result; + safecall_1(&Osize, result, *this); + return result; +} + +kind value::type() { + if( !( dword & F_Nqual ) ) return String; + if( dword & F_Var ) return Variable; + return kind(dword & TypeMask); +} + +bool value::toCset() { + return safecall_1(&Zcset, *this, *this) == SUCCEEDED; +} + +bool value::toInteger() { + return safecall_1(&Zinteger, *this, *this) == SUCCEEDED; +} + +bool value::toReal() { + return safecall_1(&Zreal, *this, *this) == SUCCEEDED; +} + +bool value::toNumeric() { + return safecall_1(&Znumeric, *this, *this) == SUCCEEDED; +} + +bool value::toString() { + return safecall_1(&Zstring, *this, *this) == SUCCEEDED; +} + +value value::subscript(const value& v) const { + value result; + safecall_2(&Osubsc, result, *this, v); + return result; +} + +value& value::assign(const value& v) { + if( dword & F_Var ) //lhs value is an Icon 'Variable' + safecall_2(&Oasgn, *this, *this, v); + else { + dword = v.dword; + vword = v.vword; + deref(this,this); //in case rhs is an Icon 'Variable' + } + return *this; +} + +value value::put(value x) { + value result; + safecall_v2(&Zput, result, *this, x); + return result; +} + +value value::push(value x) { + value result; + safecall_v2(&Zpush, result, *this, x); + return result; +} + +void value::printimage() const { + value result; + safecall_1(&Zimage, result, *this); + safecall_v1(&Zwrites, result, result); +} + +int value::compare(const value& x) const { + return anycmp(this, &x); +} + +value value::negative() const { + value result; + if( safecall_1(&Oneg, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::complement() const { + value result; + if( safecall_1(&Ocompl, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::refreshed() const { + value result; + if( safecall_1(&Orefresh, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::random() const { + value result; + if( safecall_1(&Orandom, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::plus(const value& x) const { + value result; + if( safecall_2(&Oplus, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::minus(const value& x) const { + value result; + if( safecall_2(&Ominus, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::multiply(const value& x) const { + value result; + if( safecall_2(&Omult, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::divide(const value& x) const { + value result; + if( safecall_2(&Odivide, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::remainder(const value& x) const { + value result; + if( safecall_2(&Omod, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::power(const value& x) const { + value result; + if( safecall_2(&Opowr, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::union_(const value& x) const { + value result; + if( safecall_2(&Ounion, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::intersection(const value& x) const { + value result; + if( safecall_2(&Ointer, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::difference(const value& x) const { + value result; + if( safecall_2(&Odiff, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::concatenate(const value& x) const { + value result; + if( safecall_2(&Ocater, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::listconcatenate(const value& x) const { + value result; + if( safecall_2(&Olconcat, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::slice(const value& x, const value& y) const { + value result; + if( safecall_3(&Osect, result, *this, x, y) == FAILED ) + return nullvalue; + return result; +} + +value& value::swap(value& x) { + safecall_2(&Oswap, *this, *this, x); + return *this; +} + +value value::activate(const value& x) const { + value arg = Value::pair(*this, x); + return _loadfuncpp_activate.apply(arg); +} + +value value::apply(const value& x) const { + return Value::call(*this, x); +} + + + +/* + * Implementation of the generator class + */ + +int generator::generate(value argv[]) { +//suspend all values generated and return the eventual signal + int signal = FAILED; + while( this->hasNext() && signal == FAILED ) { + argv[0] = this->giveNext(); + signal = interp(SUSPEND, argv); + } + return signal; +} + +bool generator::hasNext() { return false; } //empty sequence for the root class +value generator::giveNext() { return nullvalue; } + + + +/* + * Implementation of class iterate + */ + +class wrap: public external { //an iterate object as Icon data + public: + iterate* data; + wrap(iterate* ip): data(ip) {} +}; + +extern "C" int update_iteration(value argv[]) { + external* ep = argv[1]; + iterate* ip = ((wrap*)ep)->data; + argv[0] = nullvalue; + if( ip->wantNext(argv[2]) ) { + ip->takeNext(argv[2]); + return SUCCEEDED; + } + else return FAILED; +} + +static proc_block updatepb("update_iteration", &update_iteration, 2); +static value update(updatepb); + +void iterate::every(const value& g, const value& arg) { + value nullary(new wrap(this)); + variadic v(nullary); + _loadfuncpp_reduce.apply((v,update,g,arg)); +} + +void iterate::bang(const value& x) { + value nullary(new wrap(this)); + variadic v(nullary); + _loadfuncpp_bang.apply((v,update,x)); +} + +bool iterate::wantNext(const value& v) { return true; } //use whole sequence +void iterate::takeNext(const value& v) {} + + + +/* + * Implementation of the safe_variable class + */ +safe_variable::safe_variable() : val() {}; + +safe_variable::safe_variable(int n) : val(n) {}; + +safe_variable::safe_variable(long n) : val(n) {}; + +safe_variable::safe_variable(double x) : val(x) {}; + +safe_variable::safe_variable(value v) : val(v) {}; + +safe_variable::safe_variable(proc_block& pb) : val(pb) {}; + +safe_variable::safe_variable(proc_block* pbp) : val(pbp) {}; + +safe_variable::safe_variable(int argc, value* argv) : val(argc, argv) {}; + +inline void safe_variable::push(safe_variable*& tendlist, int numvalues) { + previous = tendlist; + num = numvalues; + tendlist = this; +} + +inline void safe_variable::pop(safe_variable*& tendlist) { + if( tendlist == this ) { //we are at the head of the tend list + tendlist = tendlist->previous; //pop us off + return; + } +#if 0 + if( tendlist == tend ) //warning is for safe tend list only + { + fprintf(stderr, "loadfuncpp warning: pop needed from interior of tended list\n"); + fflush(stderr); + } +#endif + safe_variable *last = 0, *current = tendlist; + do { //search tendlist + last = current; + current = current->previous; + } while( current != this && current != 0); + if( current == 0 ) + syserror("loadfuncpp bug: failed to find variable on tended list so as to remove it."); + last->previous = current->previous; //slice us out +} + + + +/* + * Implementation of the variadic class (variable length argument list) + */ + +variadic::variadic(int n) { + value v(n); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(long n) { + value v(n); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(float x) { + value v(x); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(double x) { + value v(x); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(char* s) { + value v(s); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(value v) { + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(const safe& x) { + val = Value::list(1, x.val); + push(global_tend); +} + +variadic::variadic(const safe& x, const safe& y) { + val = Value::pair(x, y); + push(global_tend); +} + +variadic& variadic::operator,(const safe& x) { + val.put(x.val); + return *this; +} + +variadic::operator value() { + return val; +} + +variadic::~variadic() { pop(global_tend); } + + +/* + * Implementation of the safe class + */ + +safe::safe() : safe_variable() { push(global_tend); } + +safe::safe(const safe& x) : safe_variable(x.val) { push(global_tend); } + +safe::safe(int n) : safe_variable(n) { push(global_tend); } + +safe::safe(long n) : safe_variable(n) { push(global_tend); } + +safe::safe(float x) : safe_variable(x) { push(global_tend); } + +safe::safe(double x) : safe_variable(x) { push(global_tend); } + +safe::safe(char* s) : safe_variable(s) { push(global_tend); } + +safe::safe(const value& v) : safe_variable(v) { push(global_tend); } + +safe::safe(const variadic& v) : safe_variable(v) { push(global_tend); } + +safe::safe(proc_block& pb) : safe_variable(pb) { push(global_tend); } + +safe::safe(proc_block* pbp) : safe_variable(pbp) { push(global_tend); } + +safe::safe(int argc, value* argv) : safe_variable(argc, argv) { push(global_tend); } + +safe::~safe() { pop(global_tend); } + +safe& safe::operator=(const safe& x) { + val.assign(x.val); //Icon style assignment + return *this; +} + +safe& safe::operator^=(const safe& x) { + *this = *this ^ x; + return *this; +} + +safe& safe::operator+=(const safe& x) { + *this = *this + x; + return *this; +} + +safe& safe::operator-=(const safe& x) { + *this = *this - x; + return *this; +} + +safe& safe::operator*=(const safe& x) { + *this = *this * x; + return *this; +} + +safe& safe::operator/=(const safe& x) { + *this = *this / x; + return *this; +} + +safe& safe::operator%=(const safe& x) { + *this = *this % x; + return *this; +} + +safe& safe::operator&=(const safe& x) { + *this = *this & x; + return *this; +} + +safe& safe::operator|=(const safe& x) { + *this = *this | x; + return *this; +} + +safe& safe::operator++() { + *this -= 1; + return *this; +} + +safe& safe::operator--() { + *this += 1; + return *this; +} + +safe safe::operator++(int) { + safe temp(*this); + *this += 1; + return temp; +} + +safe safe::operator--(int) { + safe temp(*this); + *this -= 1; + return temp; +} + +safe::operator value() const { + return val; //low-level copy +} + +safe safe::operator() () { + value empty = Value::list(); + return this->apply(empty); +} + +safe safe::operator() (const safe& x) { + value singleton = Value::list(1, x); + return this->apply(singleton); +} + +safe safe::operator()(const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return this->apply( (x1,x2) ); + if( x4.isIllegal() ) + return this->apply( (x1,x2,x3) ); + if( x5.isIllegal() ) + return this->apply( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return this->apply( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return this->apply( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return this->apply( (x1,x2,x3,x4,x5,x6,x7) ); + return this->apply( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe safe::operator[](const safe& x) { + return val.subscript(x.val); +} + +safe operator*(const safe& x){ + return x.val.size(); +} + +safe operator-(const safe& x){ + return x.val.negative(); +} + +safe operator~(const safe& x){ //set complement + return x.val.complement(); +} + +safe operator+(const safe& x, const safe& y){ + return x.val.plus(y.val); +} + +safe operator-(const safe& x, const safe& y){ + return x.val.minus(y.val); +} + +safe operator*(const safe& x, const safe& y){ + return x.val.multiply(y.val); +} + +safe operator/(const safe& x, const safe& y){ + return x.val.divide(y.val); +} + +safe operator%(const safe& x, const safe& y){ + return x.val.remainder(y.val); +} + +safe operator^(const safe& x, const safe& y){ //exponentiation + return x.val.power(y.val); +} + +safe operator|(const safe& x, const safe& y){ //union + return x.val.union_(y.val); +} + +safe operator&(const safe& x, const safe& y){ //intersection + return x.val.intersection(y.val); +} + +safe operator&&(const safe& x, const safe& y){ //set or cset difference + return x.val.difference(y.val); +} + +safe operator||(const safe& x, const safe& y){ //string concatenation + return x.val.concatenate(y.val); +} + +bool operator<(const safe& x, const safe& y){ + return x.val.compare(y.val) < 0; +} + +bool operator>(const safe& x, const safe& y){ + return x.val.compare(y.val) > 0; +} + +bool operator<=(const safe& x, const safe& y){ + return x.val.compare(y.val) <= 0; +} + +bool operator>=(const safe& x, const safe& y){ + return x.val.compare(y.val) >= 0; +} + +bool operator==(const safe& x, const safe& y){ + return x.val.compare(y.val) == 0; +} + +bool operator!=(const safe& x, const safe& y){ + return x.val.compare(y.val) != 0; +} + +variadic operator,(const safe& x, const safe& y){ //variadic argument list construction + return variadic(x.val, y.val); +} + +safe safe::slice(const safe& y, const safe& z){ // x[y:z] + return this->val.slice(y, z); +} + +safe safe::apply(const safe& y){ // x ! y + safe result; + result = _loadfuncpp_apply.apply( (this->val, y.val) ); + return result; +} + +safe safe::listcat(const safe& y){ // x ||| y + value x(*this); + return x.listconcatenate(y); +} + +safe& safe::swap(safe& y){ // x :=: y + value& x(this->val); + value& yv(y.val); + x.swap(yv); + return *this; +} + +safe safe::create(){ // create !x + return _loadfuncpp_create.apply(Value::list(1, *this)); +} + +safe safe::create(const safe& y){ // create x!y + return _loadfuncpp_create.apply(Value::pair(*this, y)); +} + +safe safe::activate(const safe& y){ // y@x + return _loadfuncpp_activate.apply(Value::pair(*this, y)); +} + +safe safe::refresh(){ // ^x + return this->val.refreshed(); +} + +safe safe::random(){ // ?x + return this->val.random(); +} + +safe safe::dereference(){ // .x + value var(this->val); + var.dereference(); + return var; +} + +bool safe::isIllegal() const { + return this->val == illegal; +} + + + +/* + * iconx callback support + */ + +inline int safecall_0(iconfunc *F, value& out) { + struct { + safe_variable tend; //contains an additional unused value + value stack[1]; + } vars; + vars.stack[0] = nullvalue; + vars.tend.push(tend,2); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_1(iconfunc *F, value& out, const value& x1) { + struct { + safe_variable tend; //contains an additional unused value + value stack[2]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.tend.push(tend,3); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_2(iconfunc *F, value& out, const value& x1, const value& x2) { + struct { + safe_variable tend; //contains an additional unused value + value stack[3]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.tend.push(tend,4); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_3(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3) { + struct { + safe_variable tend; //contains an additional unused value + value stack[4]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.tend.push(tend,5); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_4(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3, const value& x4) { + struct { + safe_variable tend; //contains an additional unused value + value stack[5]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.stack[4] = x4; + vars.tend.push(tend,6); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_5(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3, const value& x4, const value& x5) { + struct { + safe_variable tend; //contains an additional unused value + value stack[6]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.stack[4] = x4; + vars.stack[5] = x5; + vars.tend.push(tend,7); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_6(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3, const value& x4, const value& x5, const value& x6) { + struct { + safe_variable tend; //contains an additional unused value + value stack[7]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.stack[4] = x4; + vars.stack[5] = x5; + vars.stack[6] = x6; + vars.tend.push(tend,8); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v0(iconfvbl *F, value& out) { + struct { + safe_variable tend; //contains an additional unused value + value stack[1]; + } vars; + vars.stack[0] = nullvalue; + vars.tend.push(tend,2); + int result = F(0, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v1(iconfvbl *F, value& out, const value& x1) { + struct { + safe_variable tend; //contains an additional unused value + value stack[2]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1]= x1; + vars.tend.push(tend,3); + int result = F(1, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v2(iconfvbl *F, value& out, const value& x1, const value& x2) { + struct { + safe_variable tend; //contains an additional unused value + value stack[3]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.tend.push(tend,4); + int result = F(2, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v3(iconfvbl *F, value& out, const value& x1, const value& x2, const value& x3) { + struct { + safe_variable tend; //contains an additional unused value + value stack[4]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.tend.push(tend,5); + int result = F(3, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_vbl(iconfvbl* F, safe& out, const variadic& arg) { + int argc = arg.val.size(); + //C++ makes allocating trailing variable sized arrays + //inside structs difficult, so do this C-style + safe_variable* pvars = (safe_variable*)malloc(sizeof(safe_variable)+(argc+1)*sizeof(value)); + value* stack = (value*)(pvars + 1); //get past the safe_variable at the start of the block + stack[0] = nullvalue; + for(int i=1; i<=argc; ++i) + stack[i] = arg.val.subscript(i).dereference(); + pvars->push(tend, argc+2); + int result = F(argc, stack); + if( result == SUCCEEDED ) + out = stack[0]; + pvars->pop(tend); + free(pvars); +} + + + +/* + * Procedure related + */ + +//Icon procedure block: used to make new Icon procedures as values to return + +proc_block::proc_block(value procname, iconfvbl *function) { + init(procname); + nparam = -1; //a variable number of arguments + entryp = function; +} + +proc_block::proc_block(value procname, iconfunc *function, int arity) { + init(procname); + nparam = arity; + entryp = (iconfvbl*)function; +} + +proc_block::proc_block(value procname, iconfvbl *function, int arity) { + init(procname); + nparam = -1; //a variable number of arguments + entryp = function; +} + +long proc_block::extra_bytes = 0; + +extern long extl_ser; //serial number counter for alcexternal + +static void* alcproc(long nbytes) { + proc_block* pbp = (proc_block*)alcexternal(nbytes, 0, 0); //a hack for now + --extl_ser; + pbp->title = T_Proc; + pbp->blksize = nbytes; + return (void*)pbp; +} + +void* proc_block::operator new(size_t nbytes) { //allocated in Icon's block region + return alcproc(nbytes + extra_bytes); +} + +void proc_block::operator delete(void*) { + return; //do nothing +} + +proc_block::proc_block(proc_block* pbp) { + *this = *pbp; //copy the C++ legitimate part +} + +proc_block* proc_block::bind(proc_block* pbp, const value& rec) { + extra_bytes = pbp->blksize - sizeof(proc_block) + sizeof(value); //one more slot + proc_block* ans = new proc_block(pbp); // copies the C++ legitimate part + ans->blksize = sizeof(proc_block) + extra_bytes; + extra_bytes = 0; + int nsafe = ans->ndynam + ans->nparam; + for( int pos=1; poslnames[pos] = pbp->lnames[pos]; + ans->lnames[nsafe] = rec; //set the last array slot to rec + ans->pname = "bound to record"; //improve this to use the proc name and rec image + return ans; +} + +extern "C" int bindself(value argv[]) { + if( argv[1].type() != Procedure || + argv[2].type() != Record ) { + argv[0] = nullvalue; + return FAILED; + } + argv[0] = proc_block::bind(argv[1], argv[2]); + return SUCCEEDED; +} + + + +/* + * External values related + */ + +extern "C" { //these call virtual functions, so only one function list needed + static int extcmp(int argc, value argv[]) { + external *ep = argv[1], *ep2 = argv[2]; + argv[0] = ep->compare(ep2); + return 0; + } + static int extcopy(int argc, value argv[]) { + external* ep = argv[1]; + argv[0] = ep->copy(); + return 0; + } + static int extname(int argc, value argv[]) { + external* ep = argv[1]; + argv[0] = ep->name(); + return 0; + } + static int extimage(int argc, value argv[]) { + external* ep = argv[1]; + argv[0] = ep->image(); + return 0; + } +}; //end extern "C" + +static void initialize_ftable(); //just below + +static struct external_ftable { //C callback table for all C++ made external values + iconfvbl* cmp; + iconfvbl* copy; + iconfvbl* name; + iconfvbl* image; + external_ftable() { initialize_ftable(); } +} ftable; + +static void initialize_ftable() { + ftable.cmp = &extcmp; + ftable.copy = &extcopy; + ftable.name = &extname; + ftable.image = &extimage; +} + +long external_block::extra_bytes; //silent extra parameter to external_block::new + +static void* external_block::operator new(size_t nbytes) { + return alcexternal(nbytes + extra_bytes, &ftable, 0); //extra_bytes for C++ external +} + +static void external_block::operator delete(void* p) { + return; //don't delete +} + +external_block::external_block() { + //val = (external*)((long*)&val + 1); //add a trashable pointer to the (to be appended) external + val = 0; +} + +external_block* external::blockptr; //silent extra result of external::new for external() + +static void* external::operator new(size_t nbytes) { + external_block::extra_bytes = nbytes; //pass our requirements to external_block::new + blockptr = new external_block(); //with extra_bytes; pass our requirements to external() + char* ptr = (char*)blockptr + sizeof(external_block)/sizeof(char); //beginning of extra_bytes + return (void*)ptr; //where the external will be appended +} + +static void external::operator delete(void* p) { + return; //don't delete +} + +external::external() { + id = blockptr->id; //set by new +} + +external* external::copy() { + return this; +} + +value external::image() { //need new string every time! + char sbuf[100]; + long vptr = *((long*)this); + sprintf(sbuf, "external_%ld(%lX)", id, vptr); + return value(NewString, sbuf); +} + +value external::name() { + return value(StringLiteral, "external"); +} + +long external::compare(external* ep) { + return this->id - ep->id; +} + +bool value::isExternal(const value& type) { //needs external_block declaration + if( dword != D_External ) return false; + value result; + external_block* ebp = (external_block*)vword; + iconfvbl* name = (ebp->funcs)->name; + value stack[2]; + stack[1] = *this; + name(1, stack); + return !stack[0].compare(type); +} + + + +/* + * Startup code (on load) + */ + +//new variant of loadfunc sidestepping loadfunc's glue, a three argument function + +extern "C" int loadfuncpp(value argv[]) { //three arguments + if( argv[3].isNull() ) argv[3]=-1; + //assumption: a path is specified iff a slash or backslash is in the filename, + if( argv[1].toString() ) { + safe fname(argv[1]), fullname; + int ispath = value( *(Icon::cset(fname) & Icon::cset((char*)"\\/")) ); + if( !ispath ) { //search FPATH for the file + fullname = _loadfuncpp_pathfind.apply((fname, Icon::getenv((char*)"FPATH"))); + if( fullname == nullvalue ) { + Icon::runerr(216, argv[1]); + return FAILED; + } + argv[1] = value(fullname); + } + } + return rawloadfuncpp(argv); +} + +static void replace_loadfunc() { + static proc_block pb("loadfuncpp", loadfuncpp, 3); //three arguments + value proc(pb), var = Value::variable("loadfunc"); + var.assign(proc); +} + +//set up a tend list for global variables on the tail of &main's +struct safe_tend { //struct with isomorphic data footprint to a safe_variable + safe_variable *previous; + int num; + value val; +} sentinel; + +safe_variable*& global_tend = sentinel.previous; + +static void add_to_end(safe_variable*& tend_list) { + safe_tend *last = 0, *current = (safe_tend*)tend_list; + while( current != 0 ) { + last = current; + current = (safe_tend*)(current->previous); + } + if( last == 0 ) tend_list = (safe_variable*)&sentinel; + else last->previous = (safe_variable*)&sentinel; +} + +static void make_global_tend_list() { + sentinel.previous = 0; + sentinel.num = 1; + sentinel.val = nullvalue; + if( k_current == k_main ) add_to_end(tend); //add to the active tend list + else add_to_end( ((coexp_block*)(long(k_main)))->es_tend ); +} + +struct load { + load() { //startup code here + replace_loadfunc(); //store loadfuncpp in global loadfunc temporarily + make_global_tend_list(); + initialize_procs(); + initialize_keywords(); +//fprintf(stderr, "\nStartup code ran!\n");fflush(stderr); + } +}; +static load startup; //force static initialization so as to run startup code + + + +/* + * Useful helper functions + */ + +namespace Value { + +value pair(value x, value y) { + value newlist; + if( safecall_v2(&Ollist, newlist, x, y) == FAILED ) + return nullvalue; + return newlist; +} + +value list(value n, value init) { + value newlist; + if( safecall_2(&Zlist, newlist, n, init) == FAILED ) + return nullvalue; + return newlist; +} + +void runerr(value n, value x) { + value v; + safecall_v2(&Zrunerr, v, n, x); +} + +value set(value list) { + value newset; + if( safecall_1(&Zset, newset, list) == FAILED ) + return nullvalue; + return newset; +} + +value table(value init) { + value newtable; + if( safecall_1(&Ztable, newtable, init) == FAILED ) + return nullvalue; + return newtable; +} + +value variable(value name) { + value var; + if( safecall_1(&Zvariable, var, name) == FAILED ) + return nullvalue; + return var; +} + +value proc(value name, value arity) { + value procedure; + if( safecall_2(&Zproc, procedure, name, arity) == FAILED ) + return nullvalue; + return procedure; +} + +value libproc(value name, value arity) { + value procedure; + if( safecall_2(&Zproc, procedure, name, arity) == SUCCEEDED ) + return procedure; + syserror("loadfuncpp: unable to find required Icon procedure through 'link loadfunc'\n"); + return nullvalue; +} + +}; //namespace Value + + + +/* + * Built-in Icon functions + */ +namespace Icon { +safe abs(const safe& x1) { + value result; + safecall_1(&Zabs, result, x1); + return result; +} + +safe acos(const safe& x1) { + value result; + safecall_1(&Zacos, result, x1); + return result; +} + +safe args(const safe& x1) { + value result; + safecall_1(&Zargs, result, x1); + return result; +} + +safe asin(const safe& x1) { + value result; + safecall_1(&Zasin, result, x1); + return result; +} + +safe atan(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zatan, result, x1, x2); + return result; +} + +safe center(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zcenter, result, x1, x2, x3); + return result; +} + +safe char_(const safe& x1) { + value result; + safecall_1(&Zchar, result, x1); + return result; +} + +safe chdir(const safe& x1) { + value result; + safecall_1(&Zchdir, result, x1); + return result; +} + +safe close(const safe& x1) { + value result; + safecall_1(&Zclose, result, x1); + return result; +} + +safe collect() { + value result; + safecall_0(&Zcollect, result); + return result; +} + +safe copy(const safe& x1) { + value result; + safecall_1(&Zcopy, result, x1); + return result; +} + +safe cos(const safe& x1) { + value result; + safecall_1(&Zcos, result, x1); + return result; +} + +safe cset(const safe& x1) { + value result; + safecall_1(&Zcset, result, x1); + return result; +} + +safe delay(const safe& x1) { + value result; + safecall_1(&Zdelay, result, x1); + return result; +} + +safe delete_(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zdelete, result, x1, x2); + return result; +} + +safe detab(const variadic& x1) { + safe result; + safecall_vbl(&Zdetab, result, x1); + return result; +} + +safe detab( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return detab( (x1,x2) ); + if( x4.isIllegal() ) + return detab( (x1,x2,x3) ); + if( x5.isIllegal() ) + return detab( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return detab( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return detab( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return detab( (x1,x2,x3,x4,x5,x6,x7) ); + return detab( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe display(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zdisplay, result, x1, x2); + return result; +} + +safe dtor(const safe& x1) { + value result; + safecall_1(&Zdtor, result, x1); + return result; +} + +safe entab(const variadic& x1) { + safe result; + safecall_vbl(&Zentab, result, x1); + return result; +} + +safe errorclear() { + value result; + safecall_0(&Zerrorclear, result); + return result; +} + +safe exit(const safe& x1) { + value result; + safecall_1(&Zexit, result, x1); + return result; +} + +safe exp(const safe& x1) { + value result; + safecall_1(&Zexp, result, x1); + return result; +} + +safe flush(const safe& x1) { + value result; + safecall_1(&Zflush, result, x1); + return result; +} + +safe function() { + value result; + safecall_0(&Z_function, result); //generative: Z_ + return result; +} + +safe get(const safe& x1) { + value result; + safecall_1(&Zget, result, x1); + return result; +} + +safe getch() { + value result; + safecall_0(&Zgetch, result); + return result; +} + +safe getche() { + value result; + safecall_0(&Zgetche, result); + return result; +} + +safe getenv(const safe& x1) { + value result; + safecall_1(&Zgetenv, result, x1); + return result; +} + +safe iand(const safe& x1, const safe& x2) { + value result; + safecall_2(&Ziand, result, x1, x2); + return result; +} + +safe icom(const safe& x1) { + value result; + safecall_1(&Zicom, result, x1); + return result; +} + +safe image(const safe& x1) { + value result; + safecall_1(&Zimage, result, x1); + return result; +} + +safe insert(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zinsert, result, x1, x2, x3); + return result; +} + +safe integer(const safe& x1) { + value result; + safecall_1(&Zinteger, result, x1); + return result; +} + +safe ior(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zior, result, x1, x2); + return result; +} + +safe ishift(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zishift, result, x1, x2); + return result; +} + +safe ixor(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zixor, result, x1, x2); + return result; +} + +safe kbhit() { + value result; + safecall_0(&Zkbhit, result); + return result; +} + +safe key(const safe& x1) { + value result; + safecall_1(&Z_key, result, x1); //generative: Z_ + return result; +} + +safe left(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zleft, result, x1, x2, x3); + return result; +} + +safe list(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zlist, result, x1, x2); + return result; +} + +safe loadfunc(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zloadfunc, result, x1, x2); + return result; +} + +safe log(const safe& x1) { + value result; + safecall_1(&Zlog, result, x1); + return result; +} + +safe map(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zmap, result, x1, x2, x3); + return result; +} + +safe member(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zmember, result, x1, x2); + return result; +} + +safe name(const safe& x1) { + value result; + safecall_1(&Zname, result, x1); + return result; +} + +safe numeric(const safe& x1) { + value result; + safecall_1(&Znumeric, result, x1); + return result; +} + +safe open(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zopen, result, x1, x2); + return result; +} + +safe ord(const safe& x1) { + value result; + safecall_1(&Zord, result, x1); + return result; +} + +safe pop(const safe& x1) { + value result; + safecall_1(&Zpop, result, x1); + return result; +} + +safe proc(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zproc, result, x1, x2); + return result; +} + +safe pull(const safe& x1) { + value result; + safecall_1(&Zpull, result, x1); + return result; +} + +safe push(const variadic& x1) { + safe result; + safecall_vbl(&Zpush, result, x1); + return result; +} + +safe push( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return push( (x1,x2) ); + if( x4.isIllegal() ) + return push( (x1,x2,x3) ); + if( x5.isIllegal() ) + return push( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return push( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return push( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return push( (x1,x2,x3,x4,x5,x6,x7) ); + return push( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe put(const variadic& x1) { + safe result; + safecall_vbl(&Zput, result, x1); + return result; +} + +safe put( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return put( (x1,x2) ); + if( x4.isIllegal() ) + return put( (x1,x2,x3) ); + if( x5.isIllegal() ) + return put( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return put( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return put( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return put( (x1,x2,x3,x4,x5,x6,x7) ); + return put( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe read(const safe& x1) { + value result; + safecall_1(&Zread, result, x1); + return result; +} + +safe reads(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zreads, result, x1, x2); + return result; +} + +safe real(const safe& x1) { + value result; + safecall_1(&Zreal, result, x1); + return result; +} + +safe remove(const safe& x1) { + value result; + safecall_1(&Zremove, result, x1); + return result; +} + +safe rename(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zrename, result, x1, x2); + return result; +} + +safe repl(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zrepl, result, x1, x2); + return result; +} + +safe reverse(const safe& x1) { + value result; + safecall_1(&Zreverse, result, x1); + return result; +} + +safe right(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zright, result, x1, x2, x3); + return result; +} + +safe rtod(const safe& x1) { + value result; + safecall_1(&Zrtod, result, x1); + return result; +} + +safe runerr(const safe& x1, const safe& x2) { + value result; + safecall_v2(&Zrunerr, result, x1, x2); + return result; +} + +safe runerr(const safe& x1) { + value result; + safecall_v1(&Zrunerr, result, x1); + return result; +} + +safe seek(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zseek, result, x1, x2); + return result; +} + +safe serial(const safe& x1) { + value result; + safecall_1(&Zserial, result, x1); + return result; +} + +safe set(const safe& x1) { + value result; + safecall_1(&Zset, result, x1); + return result; +} + +safe sin(const safe& x1) { + value result; + safecall_1(&Zsin, result, x1); + return result; +} + +safe sort(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zsort, result, x1, x2); + return result; +} + +safe sortf(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zsortf, result, x1, x2); + return result; +} + +safe sqrt(const safe& x1) { + value result; + safecall_1(&Zsqrt, result, x1); + return result; +} + +safe stop() { + safe result, nullarg; + safecall_vbl(&Zstop, result, nullarg); + return result; +} + +safe stop(const variadic& x1) { + safe result; + safecall_vbl(&Zstop, result, x1); + return result; +} + +safe stop( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return stop( (x1,x2) ); + if( x4.isIllegal() ) + return stop( (x1,x2,x3) ); + if( x5.isIllegal() ) + return stop( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return stop( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return stop( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return stop( (x1,x2,x3,x4,x5,x6,x7) ); + return stop( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe string(const safe& x1) { + value result; + safecall_1(&Zstring, result, x1); + return result; +} + +safe system(const safe& x1) { + value result; + safecall_1(&Zsystem, result, x1); + return result; +} + +safe table(const safe& x1) { + value result; + safecall_1(&Ztable, result, x1); + return result; +} + +safe tan(const safe& x1) { + value result; + safecall_1(&Ztan, result, x1); + return result; +} + +safe trim(const safe& x1, const safe& x2) { + value result; + safecall_2(&Ztrim, result, x1, x2); + return result; +} + +safe type(const safe& x1) { + value result; + safecall_1(&Ztype, result, x1); + return result; +} + +safe variable(const safe& x1) { + value result; + safecall_1(&Zvariable, result, x1); + return result; +} + +safe where(const safe& x1) { + value result; + safecall_1(&Zwhere, result, x1); + return result; +} + +safe write() { + safe result, nullarg; + safecall_vbl(&Zwrite, result, nullarg); + return result; +} + +safe write(const variadic& x1) { + safe result; + safecall_vbl(&Zwrite, result, x1); + return result; +} + +safe write( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return write( (x1,x2) ); + if( x4.isIllegal() ) + return write( (x1,x2,x3) ); + if( x5.isIllegal() ) + return write( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return write( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return write( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return write( (x1,x2,x3,x4,x5,x6,x7) ); + return write( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe writes(const variadic& x1) { + safe result; + safecall_vbl(&Zwrites, result, x1); + return result; +} + +safe writes( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return writes( (x1,x2) ); + if( x4.isIllegal() ) + return writes( (x1,x2,x3) ); + if( x5.isIllegal() ) + return writes( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return writes( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return writes( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return writes( (x1,x2,x3,x4,x5,x6,x7) ); + return writes( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +//generative functions crippled to return a single value follow + +safe any(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_any, result, x1, x2, x3, x4); + return result; +} + +safe many(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_many, result, x1, x2, x3, x4); + return result; +} + +safe upto(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_upto, result, x1, x2, x3, x4); + return result; +} + +safe find(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_find, result, x1, x2, x3, x4); + return result; +} + +safe match(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_match, result, x1, x2, x3, x4); + return result; +} + +safe bal(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue, const safe& x5=nullvalue, const safe& x6=nullvalue) { + value result; + safecall_6(&Z_bal, result, x1, x2, x3, x4, x5, x6); + return result; +} + +safe move(const safe& x1) { + value result; + safecall_1(&Z_move, result, x1); + return result; +} + +safe tab(const safe& x1) { + value result; + safecall_1(&Z_tab, result, x1); + return result; +} + +}; //namespace Icon + +/* + * Useful functions + */ + +//pass this on to external libraries, so they don't have to link against iconx (cygwin) +void syserror(const char* s) { syserr((char *)s); } + +value IconFile(FILE* fd, int status, char* fname) { + value answer, filename(NewString, fname); + answer.dword = D_File; + answer.vword = (long)alcfile(fd, status, &filename); + return answer; +} + +//large integer related and base64 related functions follow + +struct bignum { //after b_bignum in rstructs.h + long title; + long blksize; + long msd, lsd; + int sign; + unsigned int digit[1]; +}; + +//Endian/wordsize nonsense follows, to help get at bytes in the digits of Icon BigIntegers + +//repair moves the non-zero bytes we care about in a DIGIT (see rlrgint.r) +//that are in the least significant half of the bytes of a uint +//into the left hand end (in RAM) of the unint in big endian order + +//for solaris that does not define this macro +#ifndef BYTE_ORDER +#define BYTE_ORDER 4321 +#endif + +#if BYTE_ORDER==1234 || BYTE_ORDER==4321 +const int DIGITBYTES=2; + +#if BYTE_ORDER==1234 +inline unsigned int repair(unsigned int x) { + return (x & 0x0000FF00) >> 8 | (x & 0x000000FF) << 8; +} +inline long bigendian(long n) { + n = (n & 0xFFFF0000) >> 16 | (n & 0x0000FFFF) << 16; + return (n & 0xFF00FF00) >> 8 | (n & 0x00FF00FF) << 8; +} +#endif + +#if BYTE_ORDER==4321 +inline unsigned int repair(unsigned int x) { + return x << 2; +} +inline long bigendian(long n) { + return n; +} +#endif + +#endif + +#if BYTE_ORDER==12345678 || BYTE_ORDER==87654321 +const int DIGITBYTES=4; + +#if BYTE_ORDER==12345678 +inline unsigned int repair(unsigned int x) { + x = (x & 0x00000000FFFF0000) >> 16 | (x & 0x000000000000FFFF) << 16; + return (x & 0x00000000FF00FF00) >> 8 | (x & 0x0000000000FF00FF) << 8; +} +inline long bigendian(long n) { + n = (n & 0xFFFFFFFF00000000) >> 32 | (n & 0x00000000FFFFFFFF) << 32; + n = (n & 0xFFFF0000FFFF0000) >> 16 | (n & 0x0000FFFF0000FFFF) << 16; + return (n & 0xFF00FF00FF00FF00) >> 8 | (n & 0x00FF00FF00FF00FF) << 8; +} +#endif + +#if BYTE_ORDER==87654321 +inline unsigned int repair(unsigned int x) { + return x << 4; +} +inline long bigendian(long n) { + return n; +} +#endif + +#endif + +value integertobytes(value bigint){ //get the bytes of an Icon long integer as an Icon string (ignore sign) + safe n(bigint); + if( n == 0 ) return nullchar; + switch( bigint.type() ) { + case Integer: { + long x = bigint; + x = bigendian(x); + char *sbuf = (char *)&x; + int len = sizeof(long); + while( !*sbuf ) { //skip leading zeros in base 256 + ++sbuf; + --len; + } + return value(sbuf, len); + break; + } + case BigInteger: { + bignum *bp = ((bignum*)(bigint.vword)); + unsigned int current; + long pos = 0, len = (bp->lsd - bp->msd + 1) * DIGITBYTES; + char *source, *buf = new char[len], *sbuf; + sbuf = buf; + for(long i = bp->msd; i <= bp->lsd; ++i) { + current = repair(bp->digit[i]); + source = (char *)¤t; + for(int b=0; b < DIGITBYTES; ++b) + sbuf[pos++] = source[b]; + } + while( !*sbuf ) { //skip leading zeros in base 256 + ++sbuf; + --len; + } + value bytestring(sbuf, len); + delete[] buf; + return bytestring; + } + default: + return nullvalue; + } +} + +value bytestointeger(value bytestring){ //get the bytes of a new Icon long integer from an Icon string + if( bytestring.type() != String ) return nullvalue; + while( *(char*)bytestring.vword == 0 && bytestring.dword != 0 ) { //skip leading zeros + --bytestring.dword; + ++bytestring.vword; + } + safe s(bytestring); + long size = value(*s); + if( size == 0 ) return 0; + unsigned char *bytes = (unsigned char *)((char*)bytestring); + long n = 0; + if( size < sizeof(long) || //doesn't overflow a signed long + (size == sizeof(long) && ( bytes[0] <= 0x7F )) ) { + for(int i = 0; i < size; ++i) + n = (n << 8) + bytes[i]; + return n; + } + static const int RATIO = sizeof(unsigned int)/2; + long len = (size + RATIO - 1)/RATIO; //number of digits + bignum *bp = (bignum *)alcbignum(len); + bytestring = s; //in case the allocation caused a garbage collection + bytes = (unsigned char *)((char*)bytestring); + long pos = 0; + const int FIRST = len*RATIO==size ? RATIO : len*RATIO-size; //bytes in the first digit + n = 0; + for(int p=0; p < FIRST; ++p) + n = (n << 8) + bytes[pos++]; + bp->digit[0] = n; + for(long i = bp->msd + 1; i <= bp->lsd; ++i) { + n = 0; + for(int p=0; p < RATIO; ++p) + n = (n << 8) + bytes[pos++]; + bp->digit[i] = n; + } + value answer; + answer.dword = D_Lrgint; + answer.vword = (long)bp; + return answer; +} + +//base64 utilities +typedef unsigned char uchar; +static char chr[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; + +//3 bytes -> four base64 chars +inline void threetofour(uchar *three, uchar* four) { + unsigned long n = three[0]; + n = (((n << 8) + three[1]) << 8) + three[2]; + four[3] = chr[n & 0x3F]; + n = n >> 6; + four[2] = chr[n & 0x3F]; + n = n >> 6; + four[1] = chr[n & 0x3F]; + n = n >> 6; + four[0] = chr[n & 0x3F]; +} + +//two trailing bytes -> four base64 chars +inline void twotofour(uchar *three, uchar* four) { + unsigned long n = three[0]; + n = ((n << 8) + three[1]) << 2; + four[3] = '='; + four[2] = chr[n & 0x3F]; + n = n >> 6; + four[1] = chr[n & 0x3F]; + n = n >> 6; + four[0] = chr[n & 0x3F]; +} + +//one trailing byte -> four base64 chars +inline void onetofour(uchar *three, uchar* four) { + unsigned long n = three[0]; + n = n << 4; + four[3] = four[2] = '='; + four[1] = chr[n & 0x3F]; + n = n >> 6; + four[0] = chr[n & 0x3F]; +} + +//convert to base64, return the length of the encoded string +inline long b64(char *in, long len, char* out) { + char *start = out; + long num = len/3; + int rem = len%3; + for(long i = 0; i < num; ++i) { + threetofour((uchar*)in, (uchar*)out); + in += 3; + out += 4; + } + switch( rem ) { + case 1: + onetofour((uchar*)in, (uchar*)out); + out += 4; + break; + case 2: + twotofour((uchar*)in, (uchar*)out); + out += 4; + break; + } + return out - start; +} + +//constant denoting an invalid character in a putative base64 encoding +static const int NONSENSE = -1; + +//convert a base64 char into its corresponding 6 bits +inline int undo(uchar ch) { + switch( ch ) { + default: return NONSENSE; + case 'A': return 0; case 'B': return 1; case 'C': return 2; case 'D': return 3; + case 'E': return 4; case 'F': return 5; case 'G': return 6; case 'H': return 7; + case 'I': return 8; case 'J': return 9; case 'K': return 10; case 'L': return 11; + case 'M': return 12; case 'N': return 13; case 'O': return 14; case 'P': return 15; + case 'Q': return 16; case 'R': return 17; case 'S': return 18; case 'T': return 19; + case 'U': return 20; case 'V': return 21; case 'W': return 22; case 'X': return 23; + case 'Y': return 24; case 'Z': return 25; case 'a': return 26; case 'b': return 27; + case 'c': return 28; case 'd': return 29; case 'e': return 30; case 'f': return 31; + case 'g': return 32; case 'h': return 33; case 'i': return 34; case 'j': return 35; + case 'k': return 36; case 'l': return 37; case 'm': return 38; case 'n': return 39; + case 'o': return 40; case 'p': return 41; case 'q': return 42; case 'r': return 43; + case 's': return 44; case 't': return 45; case 'u': return 46; case 'v': return 47; + case 'w': return 48; case 'x': return 49; case 'y': return 50; case 'z': return 51; + case '0': return 52; case '1': return 53; case '2': return 54; case '3': return 55; + case '4': return 56; case '5': return 57; case '6': return 58; case '7': return 59; + case '8': return 60; case '9': return 61; case '+': return 62; case '/': return 63; + } +} + +//four base64 chars -> three bytes +inline long unfour(uchar* four, uchar* three) { + int ch; + if( (ch = undo(four[0])) == NONSENSE ) return NONSENSE; + long n = ch; + if( (ch = undo(four[1])) == NONSENSE ) return NONSENSE; + n = (n << 6) + ch; + if( (ch = undo(four[2])) == NONSENSE ) return NONSENSE; + n = (n << 6) + ch; + if( (ch = undo(four[3])) == NONSENSE ) return NONSENSE; + n = (n << 6) + ch; + three[2] = n & 0xFF; + n = n >> 8; + three[1] = n & 0xFF; + three[0] = n >> 8; +} + +//decode a base64 string; return NONSENSE if anything doesn't make strict sense +inline long unb64(char* in, long len, char* out) { + char* start = out; + if( len == 0 ) return 0; + if( len%4 != 0 ) return NONSENSE; + int last = 0; + if( in[len-1] == '=' ) { + last = 1; + if( in[len-2] == '=' ) last = 2; + } + if( last ) len -= 4; + + for(long i = 0; i < len/4; ++i) { + if( unfour((uchar*)in, (uchar*)out) == NONSENSE ) + return NONSENSE; + in += 4; + out += 3; + } + long n; + int ch0, ch1, ch2; + switch( last ) { + case 1: + if( (ch0 = undo((uchar)in[0])) == NONSENSE ) + return NONSENSE; + if( (ch1 = undo((uchar)in[1])) == NONSENSE ) + return NONSENSE; + if( (ch2 = undo((uchar)in[2])) == NONSENSE ) + return NONSENSE; + n = ((((ch0 << 6) + ch1) << 6) + ch2) >> 2; + out[1] = n & 0xFF; + out[0] = n >> 8; + out += 2; + break; + case 2: + if( (ch0 = undo((uchar)in[0])) == NONSENSE ) + return NONSENSE; + if( (ch1 = undo((uchar)in[1])) == NONSENSE ) + return NONSENSE; + n = (ch0 << 6) + ch1; + out[0] = n >> 4; + out += 1; + break; + } + return out - start; +} + +//convert string or integer to base64 string +value base64(value x) { + switch( x.type() ) { + default: + return nullvalue; + case Integer: + case BigInteger: + x = integertobytes(x); + case String: { + char* enc = new char[4*x.dword/3+8]; //safety first + long len = b64((char*)x.vword, x.dword, enc); + value answer(enc, len); + delete[] enc; + return answer; + } + } +} + +//decode base64 encoding of a string +value base64tostring(value s) { + if( s.type() != String || + s.dword % 4 != 0) + return nullvalue; + if( s.dword == 0 ) return nullstring; + long len; + char* dec = new char[3 * s.dword/4]; //safety first + if( (len = unb64((char*)s.vword, s.dword, dec)) == NONSENSE ) { + delete[] dec; + return nullvalue; + } + value answer(dec, len); + delete[] dec; + return answer; +} + +//decode base64 encoding of an integer +value base64tointeger(value s) { + return bytestointeger(base64tostring(s)); +} + + + +/* + * 1. Calling Icon from C++ (mostly in iloadgpx.cpp and iloadnogpx.cpp) + * 2. loadfuncpp itself + * 3. binding records to procedure blocks + */ + +namespace ifload { +//remove interference with icon/src/h/rt.h +#undef D_Null +#undef D_Integer +#undef D_Lrgint +#undef D_Real +#undef D_File +#undef D_Proc +#undef D_External +#undef Fs_Read +#undef Fs_Write +#undef F_Nqual +#undef F_Var + +#include "xfload.cpp" //inline linkage --- three argument raw loadfunc +}; //end namespace ifload; put things that need Icon's rt.h included by xfload.cpp below here + +//call to the modified loadfunc in xfload.cpp +static int rawloadfuncpp(value argv[]) { + return ifload::Z_loadfunc((ifload::dptr)argv); +} + + +//get the record from the bottom of an extended procedure block +//(procedure bound to record) obtained from the procedure that +//called our procedure self(). Fail if no record is bound. +extern "C" int getbinding(value* argv) { + value* pp = (value*)((ifload::pfp)->pf_argp); //get saved procedure + if( pp==0 ) syserror("loadfuncpp bug: attempt to find caller of self() failed!"); + proc_block* pbp = *pp; + int nsafe = pbp->ndynam + pbp->nparam; + if( (pbp->blksize) - sizeof(proc_block) == (nsafe-1) * sizeof(value) ) { + argv[0] = nullvalue; + return FAILED; + } + argv[0] = pbp->lnames[nsafe]; + return SUCCEEDED; +} + + +#if __CYGWIN__ //cygwin linkage problem workaround +namespace icall { + using namespace ifload; + //icall assigned from whichever of iloadgpx.so and iloadnogpx.so is loaded, on load thereof +extern "C" { + typedef int icallfunction(dptr procptr, dptr arglistptr, dptr result); +}; + icallfunction *icall2; +}; + +value Value::call(const value& proc, const value& arglist) { + value result; + (*(icall::icall2))( (icall::dptr)(&proc), (icall::dptr)(&arglist), (icall::dptr)(&result) ); + return result; +} +#endif //cygwin linkage problem workaround + diff --git a/ipl/packs/loadfuncpp/iload.h b/ipl/packs/loadfuncpp/iload.h new file mode 100644 index 0000000..7b9c693 --- /dev/null +++ b/ipl/packs/loadfuncpp/iload.h @@ -0,0 +1,342 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include loadfuncpp.h and link dynamically to + * iload.cpp, which contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + + +#include +#include + +#if LONG_MAX == 2147483647L //32 bit icon implementation word +#define D_Null 0xA0000000 +#define D_Integer 0xA0000001 +#define D_Lrgint 0xB0000002 +#define D_Real 0xB0000003 +#define D_File 0xB0000005 +#define D_Proc 0xB0000006 +#define D_External 0xB0000013 +#define D_Illegal 0xA0000063 +#define F_Nqual 0x80000000 +#define F_Var 0x40000000 +#else //64 bit icon implementation word +#define D_Null 0xA000000000000000 +#define D_Integer 0xA000000000000001 +#define D_Lrgint 0xB000000000000002 +#define D_Real 0xB000000000000003 +#define D_File 0xB000000000000005 +#define D_Proc 0xB000000000000006 +#define D_External 0xB000000000000013 +#define D_Illegal 0xA000000000000063 +#define F_Nqual 0x8000000000000000 +#define F_Var 0x4000000000000000 +#endif + +#define T_Null 0 // null value +#define T_Integer 1 // integer +#define T_Lrgint 2 // long integer +#define T_Real 3 // real number +#define T_Cset 4 // cset +#define T_File 5 // file +#define T_Proc 6 // procedure +#define T_Record 7 // record +#define T_List 8 // list +#define T_Set 10 // set +#define T_Table 12 // table +#define T_Coexpr 18 // coexpression +#define T_External 19 // external value + +#define TypeMask 63 // type mask + +#define SUSPEND 1 // Call the interpreter suspending from a C function: G_Csusp + +extern "C" { //callbacks in iconx + +void deref(value*, value*); //dereference an icon 'variable' descriptor +char* alcstr(char*, int); //allocate an icon string by copying +char *alcreal(double); //allocate double by copying +char *alcbignum(long); //allocate Icon large integer block w/ given number of DIGITS +double getdbl(value*); //retrieve double +char* alcfile(FILE *fp, int stat, value *name); +int anycmp(const value*, const value*); //comparator used when sorting in Icon +//alcexternal in iconx for Icon 9.5 and above +external* alcexternal(long nbytes, external_ftable* ftable, external* ep); + +void syserr(char*); //fatally terminate Icon-style with error message + +int interp(int fsig, value *cargp); //the Icon interpreter, called recursively when suspending + + +//the prototypes of all icon functions and operators in iconx needed to do the dirty work +iconfunc Oasgn; +iconfunc Osubsc; +iconfunc Osize; +iconfunc Oneg; +iconfunc Ocompl; +iconfunc Orefresh; +iconfunc Orandom; +iconfunc Oplus; +iconfunc Ominus; +iconfunc Omult; +iconfunc Odivide; +iconfunc Omod; +iconfunc Opowr; +iconfunc Ounion; +iconfunc Ointer; +iconfunc Odiff; +iconfunc Ocater; +iconfunc Olconcat; +iconfunc Osect; +iconfunc Oswap; + +iconfvbl Ollist; + +iconfunc Zloadfunc; +iconfunc Zproc; +iconfunc Zvariable; + +iconfunc Zlist; +iconfunc Zset; +iconfunc Ztable; + +iconfunc Zstring; +iconfunc Zcset; +iconfunc Zinteger; +iconfunc Zreal; +iconfunc Znumeric; + +iconfvbl Zput; +iconfvbl Zpush; + +iconfvbl Zrunerr; +iconfvbl Zwrites; +iconfunc Zimage; + +iconfunc Zabs; +iconfunc Zacos; +iconfunc Zargs; +iconfunc Zasin; +iconfunc Zatan; +iconfunc Zcenter; +iconfunc Zchar; +iconfunc Zchdir; +iconfunc Zclose; +iconfunc Zcollect; +iconfunc Zcopy; +iconfunc Zcos; +iconfunc Zdelay; +iconfunc Zdelete; +iconfunc Zdisplay; +iconfunc Zdtor; +iconfunc Zerrorclear; +iconfunc Zexit; +iconfunc Zexp; +iconfunc Zflush; +iconfunc Zget; +iconfunc Zgetch; +iconfunc Zgetche; +iconfunc Zgetenv; +iconfunc Ziand; +iconfunc Zicom; +iconfunc Zinsert; +iconfunc Zior; +iconfunc Zishift; +iconfunc Zixor; +iconfunc Zkbhit; +iconfunc Zleft; +iconfunc Zlog; +iconfunc Zmap; +iconfunc Zmember; +iconfunc Zname; +iconfunc Zopen; +iconfunc Zord; +iconfunc Zpop; +iconfunc Zpull; +iconfunc Zread; +iconfunc Zreads; +iconfunc Zremove; +iconfunc Zrename; +iconfunc Zrepl; +iconfunc Zreverse; +iconfunc Zright; +iconfunc Zrtod; +iconfunc Zseek; +iconfunc Zserial; +iconfunc Zsin; +iconfunc Zsort; +iconfunc Zsortf; +iconfunc Zsqrt; +iconfunc Zsystem; +iconfunc Ztan; +iconfunc Ztrim; +iconfunc Ztype; +iconfunc Zwhere; + +iconfvbl Zdetab; +iconfvbl Zentab; +iconfvbl Zpush; +iconfvbl Zput; +iconfvbl Zstop; +iconfvbl Zwrite; + +iconfunc Kallocated; +iconfunc Kascii; +iconfunc Kclock; +//iconfunc Kcol; +iconfunc Kcollections; +//iconfunc Kcolumn; +//iconfunc Kcontrol; +iconfunc Kcset; +iconfunc Kcurrent; +iconfunc Kdate; +iconfunc Kdateline; +iconfunc Kdigits; +iconfunc Kdump; +iconfunc Ke; +iconfunc Kerror; +iconfunc Kerrornumber; +iconfunc Kerrortext; +iconfunc Kerrorvalue; +iconfunc Kerrout; +//iconfunc Keventcode; +//iconfunc Keventsource; +//iconfunc Keventvalue; +iconfunc Kfail; +iconfunc Kfeatures; +iconfunc Kfile; +iconfunc Khost; +iconfunc Kinput; +//iconfunc Kinterval; +iconfunc Klcase; +//iconfunc Kldrag; +iconfunc Kletters; +iconfunc Klevel; +iconfunc Kline; +//iconfunc Klpress; +//iconfunc Klrelease; +iconfunc Kmain; +//iconfunc Kmdrag; +//iconfunc Kmeta; +//iconfunc Kmpress; +//iconfunc Kmrelease; +iconfunc Knull; +iconfunc Koutput; +iconfunc Kphi; +iconfunc Kpi; +iconfunc Kpos; +iconfunc Kprogname; +iconfunc Krandom; +//iconfunc Krdrag; +iconfunc Kregions; +iconfunc Kresize; +//iconfunc Krow; +//iconfunc Krpress; +//iconfunc Krrelease; +//iconfunc Kshift; +iconfunc Ksource; +iconfunc Kstorage; +iconfunc Ksubject; +iconfunc Ktime; +iconfunc Ktrace; +iconfunc Kucase; +iconfunc Kversion; +iconfunc Kwindow; +//iconfunc Kx; +//iconfunc Ky; + +} //end extern "C" + +struct proc_block { + long title; /* T_Proc */ + long blksize; /* size of block */ + iconfvbl *entryp; /* entry point for C routine */ + long nparam; /* number of parameters */ + long ndynam; /* number of dynamic locals */ + long nstatic; /* number of static locals */ + long fstatic; /* index (in global table) of first static */ + value pname; /* procedure name (string qualifier) */ + value lnames[1]; /* list of local names (qualifiers) */ + private: + inline void init(value procname) { + title = T_Proc; + blksize = sizeof(proc_block); + ndynam = -1; //treat as a built-in function + nstatic = 0; + fstatic = 0; + pname = procname; + lnames[0] = nullstring; + } + static long extra_bytes; + public: + proc_block(value procname, iconfvbl *function); + proc_block(value procname, iconfunc *function, int arity); + proc_block(value procname, iconfvbl *function, int arity); + proc_block(proc_block*); + static proc_block* bind(proc_block*, const value&); + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing +}; + +struct coexp_block { + long title; + long size; + long id; + coexp_block* next; + void* es_pfp; + void* es_efp; + void* es_gfp; + safe_variable* es_tend; + value* es_argp; + //... +}; + +// name/proc-block table of built-in functions +struct pstrnm { char* pstrep; proc_block *pblock; }; +extern pstrnm pntab[]; //table of original procedure blocks (src/runtime/data.r) +extern int pnsize; //size of said table +extern "C" { +int dp_pnmcmp(struct pstrmn*, value*); //comparison function +char* qsearch(char*, char*, int, int, int (*)(struct pstrmn*, value*)); //search for a name +} + +inline int safecall_0(iconfunc*, value&); +inline int safecall_1(iconfunc*, value&, const value&); +inline int safecall_2(iconfunc*, value&, const value&, const value&); +inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); +inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); +inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); +inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); +inline int safecall_v0(iconfvbl*, value&); +inline int safecall_v1(iconfvbl*, value&, const value&); +inline int safecall_v2(iconfvbl*, value&, const value&, const value&); +inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); +inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + +//iconx GC tend list +extern safe_variable* tend; +//our global GC tend list +extern safe_variable*& global_tend; + +extern value k_current, k_main; //descriptors for ¤t and &main + +//useful helper functions +namespace Value { + value list(value n = (long)0, value init = nullvalue); + value pair(value, value); + value set(value list=nullvalue); + void runerr(value i, value x = nullvalue); + value table(value init = nullvalue); + value variable(value name); + value proc(value name, value arity = nullvalue); + value libproc(value name, value arity = nullvalue); + value call(const value& proc, const value& arglist); + value create(const value&, const value&); // create x!y + value reduce(const value&, const value&, const value&, const value&); +}; //end namespace Value + +//raw call to the modified three argument loadfunc +static int rawloadfuncpp(value argv[]); + diff --git a/ipl/packs/loadfuncpp/iloadgpx.cpp b/ipl/packs/loadfuncpp/iloadgpx.cpp new file mode 100644 index 0000000..fa774f0 --- /dev/null +++ b/ipl/packs/loadfuncpp/iloadgpx.cpp @@ -0,0 +1,64 @@ + + +#include "loadfuncpp.h" +#include "iload.h" + +#define GPX 1 //enables polling for events when calling Icon from C++ + +namespace icall { +//remove interference with icon/src/h/rt.h +#undef D_Null +#undef D_Integer +#undef D_Lrgint +#undef D_Real +#undef D_File +#undef D_Proc +#undef D_External +#undef Fs_Read +#undef Fs_Write +#undef F_Nqual +#undef F_Var + +#include "xinterp.cpp" + +#ifdef __CYGWIN__ +extern "C" { + typedef int icallfunction(dptr procptr, dptr arglistptr, dptr result); +}; + extern icallfunction *icall2; +#endif //cywgin + +}; + +#ifdef __CYGWIN__ + +//linking constraints make us do our own linking +class linkicall { + public: + linkicall() { //assign our icall to a function pointer in iload.so + icall::icall2 = &(icall::icall); + } +}; +static linkicall load; + +#else //not cygwin +//call an Icon procedure that always returns a value and never suspends +value Value::call(const value& proc, const value& arglist) { + value result; + icall::icall( (icall::dptr)(&proc), (icall::dptr)(&arglist), (icall::dptr)(&result) ); + return result; +} + +#endif //not cywgin + +//succeed if graphics are present, fail otherwise +extern "C" int iconx_graphics(value argv[]) { + argv[0] = nullvalue; + return SUCCEEDED; +} + +//put Icon graphics keywords and functions here +//plus access to the event queue for new I/O events associated with sockets + + + diff --git a/ipl/packs/loadfuncpp/iloadnogpx.cpp b/ipl/packs/loadfuncpp/iloadnogpx.cpp new file mode 100644 index 0000000..de1f25f --- /dev/null +++ b/ipl/packs/loadfuncpp/iloadnogpx.cpp @@ -0,0 +1,63 @@ + + +#include "loadfuncpp.h" +#include "iload.h" + +#define GPX 0 //prevents polling for events when calling Icon from C++ + +namespace icall { +//remove interference with icon/src/h/rt.h +#undef D_Null +#undef D_Integer +#undef D_Lrgint +#undef D_Real +#undef D_File +#undef D_Proc +#undef D_External +#undef Fs_Read +#undef Fs_Write +#undef F_Nqual +#undef F_Var + +#include "xinterp.cpp" + +#ifdef __CYGWIN__ +extern "C" { + typedef int icallfunction(dptr procptr, dptr arglistptr, dptr result); +}; + extern icallfunction *icall2; +#endif //cywgin + +}; + +#ifdef __CYGWIN__ + +//linking constraints make us do our own linking +class linkicall { + public: + linkicall() { //assign our icall to a function pointer in iload.so + icall::icall2 = &(icall::icall); + } +}; +static linkicall load; + +#else //not cygwin + +//call an Icon procedure that always returns a value and never suspends +value Value::call(const value& proc, const value& arglist) { + value result; + icall::icall( (icall::dptr)(&proc), (icall::dptr)(&arglist), (icall::dptr)(&result) ); + return result; +} + +#endif //not cywgin + +//succeed if graphics are present, fail otherwise +extern "C" int iconx_graphics(value argv[]) { + return FAILED; +} + + + + + diff --git a/ipl/packs/loadfuncpp/loadfuncpp.h b/ipl/packs/loadfuncpp/loadfuncpp.h new file mode 100644 index 0000000..5704f60 --- /dev/null +++ b/ipl/packs/loadfuncpp/loadfuncpp.h @@ -0,0 +1,481 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include this and link to iload.cpp which + * contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include +#include + +enum kind { Null, Integer, BigInteger, Real, Cset, File, Procedure, Record, List, + Set=10, Table=12, String, Constructor, Coexpression=18, External, Variable }; + +enum special_value { NullString, StringLiteral, NewString, NullChar, Illegal }; + +enum { + SUCCEEDED = 7, // Icon function call returned: A_Continue + FAILED = 1 // Icon function call failed: A_Resume +}; + +class value; //Icon value (descriptor) +class safe; //for garbage-collection-safe Icon valued C++ variables and parameters of all kinds +class keyword; //Icon keyword represented as an object with unary & +class variadic; //for garbage-collection-safe variadic function argument lists +class proc_block; //block specifying a procedure to iconx +class external_block; //block specifying an external value to iconx +class external_ftable; //function pointers specifying external value behavior to iconx +class external; //C++ Object specifying an external value + +typedef int iconfunc(value argv[]); //type of icon built in functions or operators with a fixed number of arguments +typedef int iconfvbl(int argc, value argv[]); //type of icon built in functions with a variable number of arguments + +extern const value nullvalue; //for default arguments +extern const value nullstring; +extern const value nullchar; +extern const value illegal; //for unwanted trailing arguments +extern void syserror(const char*); //fatal termination Icon-style with error message +#define Fs_Read 0001 // file open for reading +#define Fs_Write 0002 // file open for writing +extern value IconFile(int fd, int status, char* fname); //make an Icon file descriptor +extern value integertobytes(value); //get the bytes of an Icon long integer as an Icon string (ignore sign) +extern value bytestointeger(value); //get the bytes of a new Icon long integer from an Icon string +extern value base64(value); //convert string or integer to base64 encoding (string) +extern value base64tointeger(value); //decode base64 string to integer +extern value base64tostring(value); //decode base64 string to string + +namespace Icon { +//all keywords excepting &fail, &cset (avoiding a name collision with function cset) +extern keyword allocated; +extern keyword ascii; +extern keyword clock; +extern keyword collections; +extern keyword current; +extern keyword date; +extern keyword dateline; +extern keyword digits; +extern keyword dump; +extern keyword e; +extern keyword error; +extern keyword errornumber; +extern keyword errortext; +extern keyword errorvalue; +extern keyword errout; +extern keyword features; +extern keyword file; +extern keyword host; +extern keyword input; +extern keyword lcase; +extern keyword letters; +extern keyword level; +extern keyword line; +extern keyword main; +extern keyword null; +extern keyword output; +extern keyword phi; +extern keyword pi; +extern keyword pos; +extern keyword progname; +extern keyword random; +extern keyword regions; +extern keyword source; +extern keyword storage; +extern keyword subject; +extern keyword time; +extern keyword trace; +extern keyword ucase; +extern keyword version; +}; //namespace Icon + +static void initialize_keywords(); + +class keyword { //objects representing Icon keywords + friend void initialize_keywords(); + iconfunc* f; + public: + safe operator&(); //get the keyword's value (could be an Icon 'variable') +}; + + +class value { //a descriptor with class +//data members modelled after 'typedef struct { word dword, vword; } descriptor;' from icall.h + private: + long dword; + long vword; + public: + friend class safe; + friend value IconFile(FILE* fd, int status, char* fname); + friend value integertobytes(value); + friend value bytestointeger(value); + friend value base64(value); + friend value base64tointeger(value); + friend value base64tostring(value); + value(); //&null + value(special_value, const char* text = ""); + value(int argc, value* argv); //makes a list of parameters passed in from Icon + value(int); + value(long); + value(float); + value(double); + value(char*); + value(const char*); + value(const char*, long); + value(proc_block&); + value(proc_block*); + value(external*); + operator int(); + operator long(); + operator float(); + operator double(); + operator char*(); + operator external*(); + operator proc_block*() const; + bool operator==(const value&) const; + value& dereference(); + value intify(); + bool isNull(); + bool notNull(); + bool isExternal(const value&); + value size() const; + kind type(); + bool toString(); //attempted conversion in place + bool toCset(); + bool toInteger(); + bool toReal(); + bool toNumeric(); + value subscript(const value&) const; //produces an Icon 'variable' + value& assign(const value&); //dereferences Icon style + value put(value x = nullvalue); + value push(value x = nullvalue); + void dump() const; + void printimage() const; + int compare(const value&) const; //comparator-style result: used for Icon sorting + value negative() const; // -x + value complement() const; // ~x + value refreshed() const; // ^x + value random() const; // ?x + value plus(const value&) const; + value minus(const value&) const; + value multiply(const value&) const; + value divide(const value&) const; + value remainder(const value&) const; + value power(const value&) const; + value union_(const value&) const; // x ++ y + value intersection(const value&) const; // x ** y + value difference(const value&) const; // x -- y + value concatenate(const value&) const; // x || y + value listconcatenate(const value&) const;// x ||| y + value slice(const value&, const value&) const; // x[y:z] + value& swap(value&); // x :=: y + value activate(const value& y = nullvalue) const; // y @ x ('*this' is activated) + value apply(const value&) const; // x!y (must return, not fail or suspend) +}; //class value + + +class generator { +//class to inherit from for defining loadable functions that are generators + public: + int generate(value argv[]); //call to suspend everything produced by next() + protected: //override these, and write a constructor + virtual bool hasNext(); + virtual value giveNext(); +}; //class generator + + +class iterate { +//class to inherit from for iterating over f!arg or !x + public: + void every(const value& g, const value& arg); //perform the iteration over g!arg + void bang(const value& x); //perform the iteration over !x + //override these, write a constructor and the means of recovering the answer + virtual bool wantNext(const value& x); + virtual void takeNext(const value& x); +}; + + + +class safe_variable { +//data members modelled after 'struct tend_desc' from rstructs.h + friend class value; + friend inline int safecall_0(iconfunc*, value&); + friend inline int safecall_1(iconfunc*, value&, const value&); + friend inline int safecall_2(iconfunc*, value&, const value&, const value&); + friend inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); + friend inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); + friend inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_v0(iconfvbl*, value&); + friend inline int safecall_v1(iconfvbl*, value&, const value&); + friend inline int safecall_v2(iconfvbl*, value&, const value&, const value&); + friend inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); + friend inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + protected: + safe_variable *previous; + int num; + value val; + safe_variable(); + safe_variable(int); + safe_variable(long); + safe_variable(double); + safe_variable(value); + safe_variable(proc_block&); + safe_variable(proc_block*); + safe_variable(int, value*); + inline void push(safe_variable*& tendlist, int numvalues=1); + inline void pop(safe_variable*& tendlist); +}; //class safe_variable + + +class variadic: public safe_variable { + public: + variadic(int); + variadic(long); + variadic(float); + variadic(double); + variadic(char*); + variadic(value); + variadic(const safe&); + variadic(const safe&, const safe&); + variadic& operator,(const safe&); + operator value(); + ~variadic(); +}; //class variadic + + +class external_block { +//modelled on 'struct b_external' in icon/src/h/rstructs.h + friend class external; + friend class value; + static long extra_bytes; //silent extra parameter to new + long title; + long blksize; + long id; + external_ftable* funcs; + external* val; + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing + external_block(); +}; + +class external { + friend class value; + static external_block* blockptr; //silent extra result of new + protected: + long id; + public: + static void* operator new(size_t); //allocated by new external_block() + static void operator delete(void*); //do nothing + external(); + virtual ~external() {} //root class + virtual long compare(external*); + virtual value name(); + virtual external* copy(); + virtual value image(); +}; + + +class safe: public safe_variable { +//use for a garbage collection safe icon valued safe C++ variable + friend class variadic; + friend class global; + public: + safe(); //&null + safe(const safe&); + safe(int); + safe(long); + safe(float); + safe(double); + safe(char*); + safe(const value&); + safe(const variadic&); + safe(proc_block&); + safe(proc_block*); + safe(int, value*); //from parameters sent in from Icon + ~safe(); + safe& operator=(const safe&); + //augmenting assignments here + safe& operator+=(const safe&); + safe& operator-=(const safe&); + safe& operator*=(const safe&); + safe& operator/=(const safe&); + safe& operator%=(const safe&); + safe& operator^=(const safe&); + safe& operator&=(const safe&); + safe& operator|=(const safe&); + // ++ and -- here + safe& operator++(); + safe& operator--(); + safe operator++(int); + safe operator--(int); + //conversion to value + operator value() const; + //procedure call + safe operator()(); + safe operator()(const safe&); + safe operator()(const safe& x1, const safe& x2, + const safe& x3 = illegal, const safe& x4 = illegal, + const safe& x5 = illegal, const safe& x6 = illegal, + const safe& x7 = illegal, const safe& x8 = illegal); + safe operator[](const safe&); + + friend safe operator*(const safe&); //size + friend safe operator-(const safe&); + friend safe operator~(const safe&); //set complement + friend safe operator+(const safe&, const safe&); + friend safe operator-(const safe&, const safe&); + friend safe operator*(const safe&, const safe&); + friend safe operator/(const safe&, const safe&); + friend safe operator%(const safe&, const safe&); + friend safe operator^(const safe&, const safe&); //exponentiation + friend safe operator|(const safe&, const safe&); //union + friend safe operator&(const safe&, const safe&); //intersection + friend safe operator&&(const safe&, const safe&); //set or cset difference + friend safe operator||(const safe&, const safe&); //string concatenation + friend bool operator<(const safe&, const safe&); + friend bool operator>(const safe&, const safe&); + friend bool operator<=(const safe&, const safe&); + friend bool operator>=(const safe&, const safe&); + friend bool operator==(const safe&, const safe&); + friend bool operator!=(const safe&, const safe&); + friend variadic operator,(const safe&, const safe&); //variadic argument list construction + + safe slice(const safe&, const safe&); // x[y:z] + safe apply(const safe&); // x ! y + safe listcat(const safe&); // x ||| y + safe& swap(safe&); // x :=: y + safe create(); // create !x + safe create(const safe&); // create x!y + safe activate(const safe& y = nullvalue); // y@x + safe refresh(); // ^x + safe random(); // ?x + safe dereference(); // .x + bool isIllegal() const; //is an illegal value used for trailing arguments +}; //class safe + + +//Icon built-in functions +namespace Icon { + safe abs(const safe&); + safe acos(const safe&); + safe args(const safe&); + safe asin(const safe&); + safe atan(const safe&, const safe&); + safe center(const safe&, const safe&, const safe&); + safe char_(const safe&); + safe chdir(const safe&); + safe close(const safe&); + safe collect(); + safe copy(const safe&); + safe cos(const safe&); + safe cset(const safe&); + safe delay(const safe&); + safe delete_(const safe&, const safe&); + safe detab(const variadic&); + safe detab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe display(const safe&, const safe&); + safe dtor(const safe&); + safe entab(const variadic&); + safe entab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe errorclear(); + safe exit(const safe&); + safe exp(const safe&); + safe flush(const safe&); + safe function(); //generative: returns a list + safe get(const safe&); + safe getch(); + safe getche(); + safe getenv(const safe&); + safe iand(const safe&, const safe&); + safe icom(const safe&); + safe image(const safe&); + safe insert(const safe&, const safe&, const safe&); + safe integer(const safe&); + safe ior(const safe&, const safe&); + safe ishift(const safe&, const safe&); + safe ixor(const safe&, const safe&); + safe kbhit(); + safe left(const safe&, const safe&, const safe&); + safe list(const safe&, const safe&); + safe loadfunc(const safe&, const safe&); + safe log(const safe&); + safe map(const safe&, const safe&, const safe&); + safe member(const safe&, const safe&); + safe name(const safe&); + safe numeric(const safe&); + safe open(const safe&, const safe&); + safe ord(const safe&); + safe pop(const safe&); + safe proc(const safe&, const safe&); + safe pull(const safe&); + safe push(const variadic&); + safe push( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe put(const variadic&); + safe put( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe read(const safe&); + safe reads(const safe&, const safe&); + safe real(const safe&); + safe remove(const safe&); + safe rename(const safe&, const safe&); + safe repl(const safe&, const safe&); + safe reverse(const safe&); + safe right(const safe&, const safe&, const safe&); + safe rtod(const safe&); + safe runerr(const safe&, const safe&); + safe runerr(const safe&); + safe seek(const safe&, const safe&); + safe serial(const safe&); + safe set(const safe&); + safe sin(const safe&); + safe sort(const safe&, const safe&); + safe sortf(const safe&, const safe&); + safe sqrt(const safe&); + safe stop(); + safe stop(const variadic&); + safe stop( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe string(const safe&); + safe system(const safe&); + safe table(const safe&); + safe tan(const safe&); + safe trim(const safe&, const safe&); + safe type(const safe&); + safe variable(const safe&); + safe where(const safe&); + safe write(); + safe write(const variadic&); + safe write( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe writes(const variadic&); + safe writes( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + //generative functions follow, crippled to return a single value + safe any(const safe&, const safe&, const safe&, const safe&); + safe many(const safe&, const safe&, const safe&, const safe&); + safe upto(const safe&, const safe&, const safe&, const safe&); + safe find(const safe&, const safe&, const safe&, const safe&); + safe match(const safe&, const safe&, const safe&, const safe&); + safe bal(const safe&, const safe&, const safe&, const safe&, const safe&, const safe&); + safe move(const safe&); + safe tab(const safe&); +}; //namespace Icon + diff --git a/ipl/packs/loadfuncpp/loadfuncpp.icn b/ipl/packs/loadfuncpp/loadfuncpp.icn new file mode 100644 index 0000000..318ee99 --- /dev/null +++ b/ipl/packs/loadfuncpp/loadfuncpp.icn @@ -0,0 +1,241 @@ + +procedure loadfuncpp(fname, entry, arity) +#the first call loads the glue library, and loads and assigns the external loadfuncpp + local iload, fpath, oldloadfunc, real_loadfunc + real_loadfunc := _loadfuncpp_proc("loadfunc") + iload := _loadfuncpp_iload() + oldloadfunc := loadfunc #catch22: loadfunc cannot correctly return loadfuncpp + real_loadfunc(iload, "loadfuncpp") #implicitly assigns loadfuncpp to loadfunc on load + loadfuncpp := loadfunc #replace this loadfuncpp with the one loaded + loadfunc := oldloadfunc #put the old loadfunc back + self(iload) #initialize self from iload.so; calls loadfuncpp + bindself(iload) #initialize bindself from iload.so; calls loadfuncpp + loadfuncpp(_loadfuncpp_iloadgpx(), "iconx_graphics", 0) #calling Icon + return loadfuncpp(fname, entry, arity) #call the new loadfuncpp just loaded +end + +procedure self() + static getbinding + initial { + getbinding := loadfuncpp(_loadfuncpp_iload(), "getbinding", 0) | + stop("loadfuncpp: support function 'getbinding' not found in iload.so") + fail + } + return getbinding() #must be called from self() +end + +procedure bindself(proc, rec) + bindself := loadfuncpp(_loadfuncpp_iload(), "bindself", 2) | + stop("loadfuncpp: support functon 'bindself' not found in iload.so") + return bindself(proc, rec) +end + +invocable "_loadfuncpp_pathfind", "_loadfuncpp_reduce", "_loadfuncpp_create", + "_loadfuncpp_activate", "_loadfuncpp_kcollections", "_loadfuncpp_kfeatures", + "_loadfuncpp_kregions", "_loadfuncpp_kstorage", "_loadfuncpp_function", + "_loadfuncpp_bang", "_loadfuncpp_apply", "_loadfuncpp_any", "_loadfuncpp_many", + "_loadfuncpp_upto", "_loadfuncpp_find", "_loadfuncpp_match", "_loadfuncpp_bal", + "_loadfuncpp_move", "_loadfuncpp_tab", "_loadfuncpp_proc", "_loadfuncpp_key", + "_loadfuncpp_iload", "_loadfuncpp_iloadgpx" + +procedure _loadfuncpp_iload() + local getenv, fpath + static iload + initial { + getenv := _loadfuncpp_proc("getenv") + iload := _loadfuncpp_pathfind("iload.so", fpath:= getenv("FPATH")) | + stop("Cannot find iload.so on FPATH where \nFPATH=", fpath) + } + return iload +end + +procedure _loadfuncpp_iloadgpx() + local getenv, fpath, libname + static iloadgpx + initial { + if \Event then libname := "iloadgpx.so" else libname := "iloadnogpx.so" + getenv := _loadfuncpp_proc("getenv") + iloadgpx := _loadfuncpp_pathfind(libname, fpath:= getenv("FPATH")) | + stop("Cannot find ", libname, " on FPATH where \nFPATH=", fpath) + } + return iloadgpx +end + +procedure _loadfuncpp_pathfind(fname, path, psep) + local f, dir, fullname + static close, open, tab, upto, trim, many, pos + initial { + close := _loadfuncpp_proc("close") + open := _loadfuncpp_proc("open") + tab := _loadfuncpp_proc("tab") + upto := _loadfuncpp_proc("upto") + trim := _loadfuncpp_proc("trim") + many := _loadfuncpp_proc("many") + pos := _loadfuncpp_proc("pos") + } + /psep := ' :' #good for cygwin, unix variants (including OS X) + fname ? { + if ="/" & close(open(fname)) then + return fname #full absolute path works + while tab(upto('/') + 1) + fname := tab(0) #get final component of path + } + /path := "" + path := ". " || path + path ? while not pos(0) do { + dir := tab(upto(psep) | 0) + fullname := trim(dir, '/') || "/" || fname + if close(open(fullname)) then + return fullname + tab(many(psep)) + } + return #must return +end + +procedure _loadfuncpp_reduce(nullary, binary, g, arg) + local result + result := nullary + every binary(result, g!arg) + return result +end + +procedure _loadfuncpp_create(g, arg) + return create g!arg +end + +procedure _loadfuncpp_activate(coexp, val) + return val@coexp | &null +end + +procedure _loadfuncpp_kcollections() + local ls + ls := [] + every put(ls, &collections) + return ls +end + +procedure _loadfuncpp_kfeatures() + local ls + ls := [] + every put(ls, &features) + return ls +end + +procedure _loadfuncpp_kregions() + local ls + ls := [] + every put(ls, ®ions) + return ls +end + +procedure _loadfuncpp_kstorage() + local ls + ls := [] + every put(ls, &storage) + return ls +end + +procedure _loadfuncpp_function() + local ls + static function + initial function := _loadfuncpp_proc("function") + ls := [] + every put(ls, function()) + return ls +end + +procedure _loadfuncpp_key(t) + local ls + static key + initial key := _loadfuncpp_proc("key") + ls := [] + every put(ls, key(t)) + return ls +end + +procedure _loadfuncpp_bang(nullary, binary, x) + local result + result := nullary + if type(x)=="table" + then every binary(result, key(x)) + else every binary(result, !x) + return result +end + +procedure _loadfuncpp_any(c,s,i1,i2) + static any + initial any := _loadfuncpp_proc("any") + return any(c,s,i1,i2) | &null +end + +procedure _loadfuncpp_many(c,s,i1,i2) + static many + initial many := _loadfuncpp_proc("many") + return many(c,s,i1,i2) | &null +end + +procedure _loadfuncpp_upto(c,s,i1,i2) + static upto + initial upto := _loadfuncpp_proc("upto") + return upto(c,s,i1,i2) | &null +end + +procedure _loadfuncpp_find(s1,s2,i1,i2) + static find + initial find := _loadfuncpp_proc("find") + return find(s1,s2,i1,i2) | &null +end + +procedure _loadfuncpp_match(s1,s2,i1,i2) + static match + initial match := _loadfuncpp_proc("match") + return match(s1,s2,i1,i2) | &null +end + +procedure _loadfuncpp_bal(c1,c2,c3,s,i1,i2) + static bal + initial bal := _loadfuncpp_proc("bal") + return bal(c1,c2,c3,s,i1,i2) | &null +end + +procedure _loadfuncpp_move(i) + static move + initial move := _loadfuncpp_proc("move") + return move(i) | &null +end + +procedure _loadfuncpp_tab(i) + static tab + initial tab := _loadfuncpp_proc("tab") + return tab(i) | &null +end + +procedure _loadfuncpp_apply(f, arg) + return f!arg | &null +end + +#use to find built-in functions so they can be nobbled +#prior to the first call of loadfuncpp without affecting us +#this is a defensive measure to protect a reasonable programmer +#NOT an attempt to be secure against all ways to subvert loadfuncpp +procedure _loadfuncpp_proc(function) + static Proc + local errmsg + initial { + #called when procedure loadfuncpp is first called to load the real loadfuncpp + errmsg := "loadfuncpp: built-in function 'proc' not found" + Proc := proc("proc",0) | stop(errmsg) + image(Proc)=="function proc" | stop(errmsg) + args(Proc)=2 | stop(errmsg) + Proc("proc",0)===Proc | stop(errmsg) #good enough, not perfect + } + return Proc(function,0) | &null +end + + + + + + + + diff --git a/ipl/packs/loadfuncpp/loadfuncpp_build.sh b/ipl/packs/loadfuncpp/loadfuncpp_build.sh new file mode 100755 index 0000000..60b85ae --- /dev/null +++ b/ipl/packs/loadfuncpp/loadfuncpp_build.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +set -o verbose #echo on + +#loadfuncpp itself +make clean +make + +pushd cgi +make +popd + +#pushd icondb +#make +#popd + +pushd socket +make clean +make +popd + +pushd system +make clean +make +popd + +pushd openssl +make clean +make +popd + +set +o verbose #echo off diff --git a/ipl/packs/loadfuncpp/savex.icn b/ipl/packs/loadfuncpp/savex.icn new file mode 100644 index 0000000..7000f5d --- /dev/null +++ b/ipl/packs/loadfuncpp/savex.icn @@ -0,0 +1,41 @@ + +procedure main(arg) + usage := "Copies iexample.icn and iexample.cpp to doc/.icn\n" || + "and .cpp to doc/.cpp\nUsage: savex " + exname := !arg | stop(usage) + examples := open("doc/examples.txt") | stop("Unable to open doc/examples.txt") + template := open("doc/Makefile.mak") | stop("Unable to open doc/Makefile.mak") + makefile := open("doc/Makefile", "w") | stop("Unable to open doc/Makefile") + in := open("iexample.icn") | stop("Unable to open iexample.icn") + out := open("doc/"||exname||".icn", "w") | stop("Unable to open "||exname||".icn") + ls := [exname] + while put(ls, ""~==trim(read(examples), ' \t')) + ls := sort(ls) + write(makefile, "\n#Automatically generated from Makefile.mak and examples.txt by ../savex.icn") + while line := read(template) do line ? { + if writes(makefile, tab(find("#exe#"))) then { + every writes(makefile, !ls, ".exe ") + write(makefile) + next + } + if writes(makefile, tab(find("#so#"))) then { + every writes(makefile, !ls, ".so ") + write(makefile) + next + } + write(makefile, line) + } + while line := read(in) do line ? { + if p := find("iexample.so") then { + writes(out, tab(p)) + writes(out, exname) + ="iexample" + write(out, tab(0)) + } else write(out, line) + } + every close(examples|template|makefile|in|out) + system("cp iexample.cpp doc/" || exname || ".cpp") + examples := open("doc/examples.txt", "w") | stop("Unable to open doc/examples.txt") + every write(examples, !ls) +end + diff --git a/ipl/packs/loadfuncpp/xfload.cpp b/ipl/packs/loadfuncpp/xfload.cpp new file mode 100644 index 0000000..2120248 --- /dev/null +++ b/ipl/packs/loadfuncpp/xfload.cpp @@ -0,0 +1,239 @@ +/* + * Sun Mar 23 09:43:59 2008 + * This file was produced by + * rtt: Icon Version 9.5.a-C, Autumn, 2007 + */ +// and then modified by cs + + +#define COMPILER 0 +extern "C" { +#include RTT +} + +//#line 42 "fload.r" + +//int glue(); //cs +//int makefunc(dptr d, char *name, int (*func)()); //cs +//int Zloadfunc (dptr r_args); //cs +//FncBlock(loadfunc, 2, 0) //cs + +//cs new makefunc that allocates a proc_block +static int newmakefunc(dptr d, char *name, int (*func)(), int arity) { + value nom(NewString,name); + proc_block* pbp; + if( arity < 0 ) pbp = new proc_block(nom, (iconfvbl*)func); + else pbp = new proc_block(nom, (iconfunc*)func, arity); + if( pbp==0 ) return 0; + d->dword = D_Proc; + d->vword.bptr = (union block *)pbp; + return 1; +} +//cs end of new makefunc + +//int Zloadfunc(r_args) //cs +//dptr r_args; //cs +inline int Z_loadfunc(dptr r_args) //cs + { + if (!cnv_c_str(&(r_args[1]), &(r_args[1]))) { + { + err_msg( + +//#line 50 "fload.r" + + 103, &(r_args[1])); + return A_Resume; + } + } + +//#line 51 "fload.r" + + if (!cnv_c_str(&(r_args[2]), &(r_args[2]))) { + { + err_msg( + +//#line 52 "fload.r" + + 103, &(r_args[2])); + return A_Resume; + } + } +//cs new third parameter: arity + C_integer r_i2; + if (!cnv_c_int(&(r_args[3]), &(r_i2))) { + err_msg(101, &(r_args[3])); + return A_Resume; + } +//cs end new third arity parameter + +//#line 58 "fload.r" + + { + int (*func)(); + static char *curfile; + static void *handle; + char *funcname2; + +//#line 67 "fload.r" + + if (!handle || !curfile || strcmp(r_args[1].vword.sptr, curfile) != 0) { + if (curfile) + free((pointer)curfile); + curfile = salloc(r_args[1].vword.sptr); + handle = dlopen(r_args[1].vword.sptr, 1 | RTLD_GLOBAL); + } + +//#line 76 "fload.r" + + if (handle) { + func = (int (*)())dlsym(handle, r_args[2].vword.sptr); + if (!func) { + +//#line 83 "fload.r" + + //funcname2 = malloc(strlen(r_args[2].vword.sptr) + 2); //cs + funcname2 = (char*)malloc(strlen(r_args[2].vword.sptr) + 2); //cs + if (funcname2) { + *funcname2 = '_'; + strcpy(funcname2 + 1, r_args[2].vword.sptr); + func = (int (*)())dlsym(handle, funcname2); + free(funcname2); + } + } + } + if (!handle || !func) { + //fprintf(stderr, "\nloadfunc(\"%s\",\"%s\"): %s\n", //cs + fprintf(stderr, "\nloadfuncpp(\"%s\",\"%s\"): %s\n", //cs + r_args[1].vword.sptr, r_args[2].vword.sptr, dlerror()); + { + err_msg( + +//#line 95 "fload.r" + + 216, NULL); + return A_Resume; + } + } + +// if (!makefunc(&r_args[0], r_args[2].vword.sptr, func)) //cs + if (!newmakefunc(&r_args[0], r_args[2].vword.sptr, func, r_i2)) //cs + { + err_msg( + +//#line 101 "fload.r" + + 305, NULL); + return A_Resume; + } + { + return A_Continue; + } + } + } + + +#if 0 //cs --- not used: we use a proc_block constructor, and no glue + +//#line 111 "fload.r" + +int makefunc(d, name, func) +dptr d; +char *name; +int (*func)(); + { + struct b_proc *blk; + + blk = (struct b_proc *)malloc(sizeof(struct b_proc)); + if (!blk) + return 0; + blk->title = T_Proc; + blk->blksize = sizeof(struct b_proc); + +//#line 127 "fload.r" + + blk->entryp.ccode = glue; + +//#line 130 "fload.r" + + blk->nparam = -1; + blk->ndynam = -1; + blk->nstatic = 0; + blk->fstatic = 0; + blk->pname.dword = strlen(name); + blk->pname.vword.sptr = salloc(name); + blk->lnames[0].dword = 0; + blk->lnames[0].vword.sptr = (char *)func; + + d->dword = D_Proc; + d->vword.bptr = (union block *)blk; + return 1; + } + +//#line 190 "fload.r" + +int glue(argc, dargv) +int argc; +dptr dargv; + { + int status, (*func)(); + struct b_proc *blk; + struct descrip r; + struct { + struct tend_desc *previous; + int num; + struct descrip d[1]; + } r_tend; + + r_tend.d[0].dword = D_Null; + r_tend.num = 1; + r_tend.previous = tend; + tend = (struct tend_desc *)&r_tend; + +//#line 199 "fload.r" + + blk = (struct b_proc *)dargv[0].vword.bptr; + func = (int (*)())blk->lnames[0].vword.sptr; + + r_tend.d[0] = dargv[0]; + dargv[0] = nulldesc; + status = (*func)(argc, dargv); + + if (status == 0) { + tend = r_tend.previous; + +//#line 207 "fload.r" + + return A_Continue; + } + +//#line 208 "fload.r" + + if (status < 0) { + tend = r_tend.previous; + +//#line 209 "fload.r" + + return A_Resume; + } + r = dargv[0]; + dargv[0] = r_tend.d[0]; + if (((r).dword == D_Null)) + do {err_msg((int)status, NULL);{ + tend = r_tend.previous; + return A_Resume; + } + } + while (0); + +//#line 215 "fload.r" + + do {err_msg((int)status, &r);{ + tend = r_tend.previous; + return A_Resume; + } + } + while (0); + } + +#endif //cs unused + diff --git a/ipl/packs/loadfuncpp/xinterp.cpp b/ipl/packs/loadfuncpp/xinterp.cpp new file mode 100644 index 0000000..dba8f27 --- /dev/null +++ b/ipl/packs/loadfuncpp/xinterp.cpp @@ -0,0 +1,1647 @@ +/* + * Tue Feb 12 18:19:56 2008 + * This file was produced by + * rtt: Icon Version 9.5.a-C, Autumn, 2007 + */ +//and then modified by cs + + +extern "C" { //cs + +#define COMPILER 0 +#include RTT + +//#line 8 "interp.r" + +extern fptr fncentry[]; + +//#line 22 "interp.r" + +//word lastop; +extern word lastop; //cs + +//#line 28 "interp.r" + +//struct ef_marker *efp; +extern struct ef_marker *efp; //cs +//struct gf_marker *gfp; +extern struct gf_marker *gfp; //cs +//inst ipc; +extern inst ipc; //cs +//word *sp = NULL; +extern word *sp; //cs + +//int ilevel; +extern int ilevel; //cs +//struct descrip value_tmp; +extern struct descrip value_tmp; //cs +//struct descrip eret_tmp; +extern struct descrip eret_tmp; //cs + +//int coexp_act; +extern int coexp_act; //cs + +//#line 40 "interp.r" + +//dptr xargp; +extern dptr xargp; //cs +//word xnargs; +extern word xnargs; //cs + +//#line 155 "interp.r" + +//int interp(fsig, cargp) +//int fsig; +//dptr cargp; +static int icall(dptr procptr, dptr arglistptr, dptr result) //cs + { + register word opnd; + register word *rsp; + register dptr rargp; + register struct ef_marker *newefp; + register struct gf_marker *newgfp; + register word *wd; + register word *firstwd, *lastwd; + word *oldsp; + int type, signal, args; +// extern int (*optab[])(); + extern int (*optab[])(dptr); //cs +// extern int (*keytab[])(); + extern int (*keytab[])(dptr); //cs + struct b_proc *bproc; + word savedlastop = lastop; //cs --- so that Icon::runerr works as expected through ttrace + dptr oldxargp = xargp; //cs --- save the arguments passed to the C++ function calling Icon + int oldxnargs = xnargs; //cs --- ditto + dptr lval; //cs + int fsig = 0; //cs + dptr cargp = (dptr)(sp+1); //cs + dptr return_cargp = cargp; //cs + word *saved_sp = sp; //cs + word *return_sp = sp + 2; //cs + + cargp[0] = *procptr; //cs + cargp[1] = *arglistptr; //cs + sp += 4; //cs + +//#line 189 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + PerilDelta) > (char *)stackend) + fatalerr(301, NULL); + +//#line 195 "interp.r" + +#if GPX //cs + if (!pollctr--) { + pollctr = pollevent(); + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 201 "interp.r" + + ilevel++; + + rsp = sp;; + +//#line 215 "interp.r" + + if (fsig == G_Csusp) { + +//#line 218 "interp.r" + + oldsp = rsp; + +//#line 223 "interp.r" + + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = fsig; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 235 "interp.r" + + if (gfp != 0) { + if (gfp->gf_gentype == G_Psusp) + firstwd = (word *)gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)gfp + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)cargp + 1; + +//#line 249 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + gfp = newgfp; + } + +//#line 257 "interp.r" + + goto apply; //cs + + for (; ; ) { + +//#line 330 "interp.r" + + lastop = (word)(*ipc.op++); + + if( rsp < return_sp ) //cs + syserror("loadfuncpp: call of Icon from C++ must return a value, yet failed instead"); + +//#line 348 "interp.r" + + switch ((int)lastop) { + +//#line 359 "interp.r" + + case 51: + ipc.op[-1] = (90); + PushValSP(rsp, D_Cset); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 90: + PushValSP(rsp, D_Cset); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 60: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 75: + ipc.op[-1] = (91); + PushValSP(rsp, D_Real); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + PushValSP(rsp, opnd); + ipc.opnd[-1] = (opnd); + break; + + case 91: + PushValSP(rsp, D_Real); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 77: + ipc.op[-1] = (92); + PushValSP(rsp, (*ipc.opnd++)); + opnd = (word)strcons + (*ipc.opnd++); + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 92: + PushValSP(rsp, (*ipc.opnd++)); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 407 "interp.r" + + case 81: + PushValSP(rsp, D_Var); + PushValSP(rsp, &glbl_argp[(*ipc.opnd++) + 1]); + break; + + case 84: + ipc.op[-1] = (93); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &globals[opnd]); + ipc.opnd[-1] = ((word)&globals[opnd]); + break; + + case 93: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 83: + PushValSP(rsp, D_Var); + PushValSP(rsp, &pfp->pf_locals[(*ipc.opnd++)]); + break; + + case 82: + ipc.op[-1] = (94); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &statics[opnd]); + ipc.opnd[-1] = ((word)&statics[opnd]); + break; + + case 94: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 448 "interp.r" + + case 4: + case 19: + case 23: + case 34: + case 37: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 453 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 455 "interp.r" + + ; + + case 43: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 458 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 460 "interp.r" + + ; + + case 21: + case 22: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 464 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 465 "interp.r" + + ; + + case 32: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 474 "interp.r" + + case 40: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 475 "interp.r" + + ; + Deref(rargp[1]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 477 "interp.r" + + ; + + case 2: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 481 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 482 "interp.r" + + ; + +//#line 486 "interp.r" + + case 3: + case 5: + case 6: + case 8: + case 9: + case 16: + case 17: + case 18: + case 31: + case 42: + case 30: + case 7: + case 10: + case 11: + case 12: + case 13: + case 14: + case 15: + case 20: + case 24: + case 25: + case 26: + case 27: + case 29: + case 28: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 511 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 514 "interp.r" + + ; + + case 1: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 517 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 518 "interp.r" + + ; + + case 39: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 522 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 523 "interp.r" + + ; + + case 38: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 527 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 528 "interp.r" + + ; + +//#line 531 "interp.r" + + case 33: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 532 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 533 "interp.r" + + ; + + case 35: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 537 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 538 "interp.r" + + ; + +//#line 542 "interp.r" + + case 36: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 4; + xargp = rargp; + sp = rsp;; + +//#line 544 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 545 "interp.r" + + ; + +//#line 548 "interp.r" + + case 41: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 549 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + Deref(rargp[3]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 553 "interp.r" + + ; + + case 98: + +//#line 559 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 570 "interp.r" + + break; + +//#line 573 "interp.r" + + case 108: + { + +//#line 583 "interp.r" + + break; + } + + case 64: + +//#line 590 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 606 "interp.r" + + break; + +//#line 610 "interp.r" + + case 44: + PushDescSP(rsp, k_subject); + PushValSP(rsp, D_Integer); + PushValSP(rsp, k_pos); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 614 "interp.r" + + ; + + signal = Obscan(2, rargp); + + goto C_rtn_term; + + case 55: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 621 "interp.r" + + ; + + signal = Oescan(1, rargp); + + goto C_rtn_term; + +//#line 629 "interp.r" + + case 89: { + apply: //cs + union block *bp; + int i, j; + + value_tmp = *(dptr)(rsp - 1); + Deref(value_tmp); + switch (Type(value_tmp)) { + case T_List: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = (int)bp->list.size; + +//#line 647 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + args * sizeof(struct descrip) > + (char *)stackend)) + fatalerr(301, NULL); + +//#line 653 "interp.r" + + for (bp = bp->list.listhead; + +//#line 657 "interp.r" + + bp != NULL; + + bp = bp->lelem.listnext) { + for (i = 0; i < bp->lelem.nused; i++) { + j = bp->lelem.first + i; + if (j >= bp->lelem.nslots) + j -= bp->lelem.nslots; + PushDescSP(rsp, bp->lelem.lslots[j]); + } + } + goto invokej; + } + + case T_Record: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = bp->record.recdesc->proc.nfields; + for (i = 0; i < args; i++) { + PushDescSP(rsp, bp->record.fields[i]); + } + goto invokej; + } + + default: { + + xargp = (dptr)(rsp - 3); + err_msg(126, &value_tmp); + goto efail; + } + } + } + + case 61: { + args = (int)(*ipc.opnd++); + invokej: + { + int nargs; + dptr carg; + + sp = rsp;; + type = invoke(args, &carg, &nargs); + rsp = sp;; + + if (type == I_Fail) + goto efail_noev; + if (type == I_Continue) + break; + else { + + rargp = carg; + +//#line 712 "interp.r" + +#if GPX //cs + pollctr >>= 1; + if (!pollctr) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 726 "interp.r" + + bproc = (struct b_proc *)BlkLoc(*rargp); + +//#line 734 "interp.r" + + if (type == I_Vararg) { +// int (*bfunc)(); + int (*bfunc)(int, dptr); //cs +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(int,dptr))(bproc->entryp.ccode); + +//#line 741 "interp.r" + + signal = (*bfunc)(nargs, rargp); + } + else + +//#line 746 "interp.r" + + { +// int (*bfunc)(); + int (*bfunc)(dptr); +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(dptr))(bproc->entryp.ccode); + +//#line 753 "interp.r" + + signal = (*bfunc)(rargp); + } + +//#line 767 "interp.r" + + goto C_rtn_term; + } + } + } + + case 62: + + PushNullSP(rsp); + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 776 "interp.r" + + ; + + signal = (*(keytab[(int)opnd]))(rargp); + goto C_rtn_term; + + case 65: + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - opnd; + xargp = rargp; + sp = rsp;; + +//#line 793 "interp.r" + + ; + +//#line 796 "interp.r" + + { + int i; + for (i = 1; i <= opnd; i++) + Deref(rargp[i]); + } + + signal = Ollist((int)opnd, rargp); + + goto C_rtn_term; + +//#line 808 "interp.r" + + case 67: + ipc.op[-1] = (96); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)opnd; + goto mark; + + case 96: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)(*ipc.opnd++); + mark: + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 85: + mark0: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = 0; + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 78: + +//#line 849 "interp.r" + + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + +//#line 855 "interp.r" + + Unmark_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + + sp = rsp;; + +//#line 866 "interp.r" + + return A_Unmark_uw; + } + + efp = efp->ef_efp; + break; + +//#line 874 "interp.r" + + case 56: { + +//#line 879 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Esusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + gfp = newgfp; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 892 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 1; + efp = efp->ef_efp; + +//#line 909 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + break; + } + + case 66: { + struct descrip sval; + +//#line 924 "interp.r" + +// dptr lval = (dptr)((word *)efp - 2); + lval = (dptr)((word *)efp - 2); //cs + +//#line 929 "interp.r" + + if (--IntVal(*lval) > 0) { + +//#line 934 "interp.r" + + sval = *(dptr)(rsp - 1); + +//#line 941 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 3; + if (gfp == 0) + gfp = efp->ef_gfp; + efp = efp->ef_efp; + +//#line 960 "interp.r" + + rsp -= 2; + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushDescSP(rsp, sval); + } + else { + +//#line 973 "interp.r" + + *lval = *(dptr)(rsp - 1); + +//#line 981 "interp.r" + + gfp = efp->ef_gfp; + +//#line 987 "interp.r" + + Lsusp_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 997 "interp.r" + + return A_Lsusp_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + } + break; + } + + case 72: { + +//#line 1015 "interp.r" + + struct descrip tmp; + dptr svalp; + struct b_proc *sproc; + +//#line 1025 "interp.r" + + svalp = (dptr)(rsp - 1); + if (Var(*svalp)) { + sp = rsp;; + retderef(svalp, (word *)glbl_argp, sp); + rsp = sp;; + } + +//#line 1035 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Psusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + newgfp->gf_argp = glbl_argp; + newgfp->gf_pfp = pfp; + gfp = newgfp; + rsp += ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + +//#line 1051 "interp.r" + + if (pfp->pf_gfp != 0) { + newgfp = (struct gf_marker *)(pfp->pf_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)pfp->pf_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)pfp->pf_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)pfp->pf_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)glbl_argp - 1; + efp = efp->ef_efp; + +//#line 1068 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + --k_level; + if (k_trace) { + k_trace--; + sproc = (struct b_proc *)BlkLoc(*glbl_argp); + strace(&(sproc->pname), svalp); + } + +//#line 1083 "interp.r" + + if (pfp->pf_scan != NULL) { + +//#line 1089 "interp.r" + + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1106 "interp.r" + + efp = pfp->pf_efp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + break; + } + +//#line 1115 "interp.r" + + case 54: { + +//#line 1124 "interp.r" + + eret_tmp = *(dptr)&rsp[-1]; + gfp = efp->ef_gfp; + Eret_uw: + +//#line 1131 "interp.r" + + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1140 "interp.r" + + return A_Eret_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + PushDescSP(rsp, eret_tmp); + break; + } + +//#line 1149 "interp.r" + + case 71: { + +//#line 1163 "interp.r" + + struct b_proc *rproc; + rproc = (struct b_proc *)BlkLoc(*glbl_argp); + +//#line 1173 "interp.r" + + *glbl_argp = *(dptr)(rsp - 1); + if (Var(*glbl_argp)) { + sp = rsp;; + retderef(glbl_argp, (word *)glbl_argp, sp); + rsp = sp;; + } + + --k_level; + if (k_trace) { + k_trace--; + rtrace(&(rproc->pname), glbl_argp); + } + Pret_uw: + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1196 "interp.r" + + return A_Pret_uw; + } + +//#line 1203 "interp.r" + + rsp = (word *)glbl_argp + 1; + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1219 "interp.r" + +//cs return to C++ + if( rsp == return_sp ) { + --ilevel; + *result = *return_cargp; + sp = saved_sp; + lastop = savedlastop; + xargp = oldxargp; + xnargs = oldxnargs; + return 0; + } +//cs end return to C++ + break; + } + +//#line 1224 "interp.r" + + case 53: + efail: + +//#line 1229 "interp.r" + + efail_noev: + +//#line 1233 "interp.r" + + if (gfp == 0) { + +//#line 1251 "interp.r" + + ipc = efp->ef_failure; + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + efp = efp->ef_efp; + + if (ipc.op == 0) + goto efail; + break; + } + else + { + +//#line 1267 "interp.r" + + struct descrip tmp; + register struct gf_marker *resgfp = gfp; + + type = (int)resgfp->gf_gentype; + + if (type == G_Psusp) { + glbl_argp = resgfp->gf_argp; + if (k_trace) { + k_trace--; + sp = rsp;; + atrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + rsp = sp;; + } + } + ipc = resgfp->gf_ipc; + efp = resgfp->gf_efp; + gfp = resgfp->gf_gfp; + rsp = (word *)resgfp - 1; + if (type == G_Psusp) { + pfp = resgfp->gf_pfp; + +//#line 1292 "interp.r" + + if (pfp->pf_scan != NULL) { + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1313 "interp.r" + + ++k_level; + } + + switch (type) { + +//#line 1336 "interp.r" + + case G_Csusp: + ; + --ilevel; + sp = rsp;; + +//#line 1344 "interp.r" + + return A_Resume; + + case G_Esusp: + ; + goto efail_noev; + + case G_Psusp: + ; + break; + } + + break; + } + + case 68: { + +//#line 1374 "interp.r" + + --k_level; + if (k_trace) { + k_trace--; + failtrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + } + Pfail_uw: + + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1388 "interp.r" + + return A_Pfail_uw; + } + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1406 "interp.r" + + goto efail_noev; + } + +//#line 1410 "interp.r" + + case 45: + PushNullSP(rsp); + PushValSP(rsp, ((word *)efp)[-2]); + PushValSP(rsp, ((word *)efp)[-1]); + break; + + case 46: + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + efp->ef_failure.opnd = (word *)opnd; + break; + + case 52: + PushNullSP(rsp); + rsp[1] = rsp[-3]; + rsp[2] = rsp[-2]; + rsp += 2; + break; + + case 57: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 1432 "interp.r" + + ; + + signal = Ofield(2, rargp); + + goto C_rtn_term; + + case 58: + ipc.op[-1] = (95); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + ipc.opnd = (word *)opnd; + break; + + case 95: + opnd = (*ipc.opnd++); + ipc.opnd = (word *)opnd; + break; + + case 59: + *--ipc.op = 58; + opnd = sizeof((*ipc.op)) + sizeof((*rsp)); + opnd += (word)ipc.opnd; + ipc.opnd = (word *)opnd; + break; + + case 63: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1459 "interp.r" + + ; + + if (Olimit(0, rargp) == A_Resume) { + +//#line 1468 "interp.r" + + goto efail_noev; + } + else { + +//#line 1476 "interp.r" + + rsp = (word *)rargp + 1; + } + goto mark0; + +//#line 1486 "interp.r" + + case 69: + PushNullSP(rsp); + break; + + case 70: + rsp -= 2; + break; + + case 73: + PushValSP(rsp, D_Integer); + PushValSP(rsp, 1); + break; + + case 74: + PushValSP(rsp, D_Integer); + PushValSP(rsp, -1); + break; + + case 76: + rsp += 2; + rsp[-1] = rsp[-3]; + rsp[0] = rsp[-2]; + break; + +//#line 1512 "interp.r" + + case 50: + +//#line 1515 "interp.r" + + PushNullSP(rsp); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1516 "interp.r" + + ; + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + + signal = Ocreate((word *)opnd, rargp); + + goto C_rtn_term; + +//#line 1528 "interp.r" + + case 47: { + +//#line 1534 "interp.r" + + struct b_coexpr *ncp; + dptr dp; + + sp = rsp;; + dp = (dptr)(sp - 1); + xargp = dp - 2; + + Deref(*dp); + if (dp->dword != D_Coexpr) { + err_msg(118, dp); + goto efail; + } + + ncp = (struct b_coexpr *)BlkLoc(*dp); + + signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3)); + rsp = sp;; + if (signal == A_Resume) + goto efail_noev; + else + rsp -= 2; + + break; + } + + case 49: { + +//#line 1564 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + ++BlkLoc(k_current)->coexpr.size; + co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); + rsp = sp;; + + break; + } + +//#line 1577 "interp.r" + + case 48: { + +//#line 1582 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + co_chng(ncp, NULL, NULL, A_Cofail, 1); + rsp = sp;; + + break; + } + + case 86: + +//#line 1596 "interp.r" + + goto interp_quit; + +//#line 1599 "interp.r" + + default: { + char buf[50]; + + sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", + (long)lastop, lastop); + syserr(buf); + } + } + continue; + + C_rtn_term: + rsp = sp;; + + switch (signal) { + + case A_Resume: + +//#line 1622 "interp.r" + + goto efail_noev; + + case A_Unmark_uw: + +//#line 1631 "interp.r" + + goto Unmark_uw; + + case A_Lsusp_uw: + +//#line 1640 "interp.r" + + goto Lsusp_uw; + + case A_Eret_uw: + +//#line 1649 "interp.r" + + goto Eret_uw; + + case A_Pret_uw: + +//#line 1658 "interp.r" + + goto Pret_uw; + + case A_Pfail_uw: + +//#line 1667 "interp.r" + + goto Pfail_uw; + } + + rsp = (word *)rargp + 1; + +//#line 1682 "interp.r" + + continue; + } + + interp_quit: + --ilevel; + if (ilevel != 0) + syserror("interp: termination with inactive generators."); + + return 0; + } + +} //cs --- extern "C" diff --git a/ipl/packs/loadfuncpp/xinterp64.cpp b/ipl/packs/loadfuncpp/xinterp64.cpp new file mode 100644 index 0000000..63ffe37 --- /dev/null +++ b/ipl/packs/loadfuncpp/xinterp64.cpp @@ -0,0 +1,1642 @@ +/* + * Tue Feb 12 18:19:56 2008 + * This file was produced by + * rtt: Icon Version 9.5.a-C, Autumn, 2007 + */ +//and then modified by cs + + +extern "C" { //cs + +#define COMPILER 0 +#include RTT + +//#line 8 "interp.r" + +extern fptr fncentry[]; + +//#line 22 "interp.r" + +//word lastop; +extern word lastop; //cs + +//#line 28 "interp.r" + +//struct ef_marker *efp; +extern struct ef_marker *efp; //cs +//struct gf_marker *gfp; +extern struct gf_marker *gfp; //cs +//inst ipc; +extern inst ipc; //cs +//word *sp = NULL; +extern word *sp; //cs + +//int ilevel; +extern int ilevel; //cs +//struct descrip value_tmp; +extern struct descrip value_tmp; //cs +//struct descrip eret_tmp; +extern struct descrip eret_tmp; //cs + +//int coexp_act; +extern int coexp_act; //cs + +//#line 40 "interp.r" + +//dptr xargp; +extern dptr xargp; //cs +//word xnargs; +extern word xnargs; //cs + +//#line 155 "interp.r" + +//int interp(fsig, cargp) +//int fsig; +//dptr cargp; +static int icall(dptr procptr, dptr arglistptr, dptr result) //cs + { + register word opnd; + register word *rsp; + register dptr rargp; + register struct ef_marker *newefp; + register struct gf_marker *newgfp; + register word *wd; + register word *firstwd, *lastwd; + word *oldsp; + int type, signal, args; +// extern int (*optab[])(); + extern int (*optab[])(dptr); //cs +// extern int (*keytab[])(); + extern int (*keytab[])(dptr); //cs + struct b_proc *bproc; + dptr lval; //cs + int fsig = 0; //cs + dptr cargp = (dptr)(sp+1); //cs + dptr return_cargp = cargp; //cs + word *saved_sp = sp; //cs + word *return_sp = sp + 2; //cs + + cargp[0] = *procptr; //cs + cargp[1] = *arglistptr; //cs + sp += 4; //cs + +//#line 189 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + PerilDelta) > (char *)stackend) + fatalerr(301, NULL); + +//#line 195 "interp.r" + +#if GPX //cs + if (!pollctr--) { + pollctr = pollevent(); + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 201 "interp.r" + + ilevel++; + + rsp = sp;; + +//#line 215 "interp.r" + + if (fsig == G_Csusp) { + +//#line 218 "interp.r" + + oldsp = rsp; + +//#line 223 "interp.r" + + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = fsig; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 235 "interp.r" + + if (gfp != 0) { + if (gfp->gf_gentype == G_Psusp) + firstwd = (word *)gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)gfp + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)cargp + 1; + +//#line 249 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + gfp = newgfp; + } + +//#line 257 "interp.r" + + goto apply; //cs + + for (; ; ) { + +//#line 330 "interp.r" + + lastop = (word)(*ipc.op++); + + if( rsp < return_sp ) //cs + syserror("loadfuncpp: call of Icon from C++ must return a value, yet failed instead"); + +//#line 348 "interp.r" + + switch ((int)lastop) { + +//#line 359 "interp.r" + + case 51: + ipc.op[-1] = (90); + PushValSP(rsp, D_Cset); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 90: + PushValSP(rsp, D_Cset); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 60: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 75: + ipc.op[-1] = (91); + PushValSP(rsp, D_Real); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + PushValSP(rsp, opnd); + ipc.opnd[-1] = (opnd); + break; + + case 91: + PushValSP(rsp, D_Real); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 77: + ipc.op[-1] = (92); + PushValSP(rsp, (*ipc.opnd++)); + opnd = (word)strcons + (*ipc.opnd++); + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 92: + PushValSP(rsp, (*ipc.opnd++)); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 407 "interp.r" + + case 81: + PushValSP(rsp, D_Var); + PushValSP(rsp, &glbl_argp[(*ipc.opnd++) + 1]); + break; + + case 84: + ipc.op[-1] = (93); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &globals[opnd]); + ipc.opnd[-1] = ((word)&globals[opnd]); + break; + + case 93: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 83: + PushValSP(rsp, D_Var); + PushValSP(rsp, &pfp->pf_locals[(*ipc.opnd++)]); + break; + + case 82: + ipc.op[-1] = (94); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &statics[opnd]); + ipc.opnd[-1] = ((word)&statics[opnd]); + break; + + case 94: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 448 "interp.r" + + case 4: + case 19: + case 23: + case 34: + case 37: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 453 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 455 "interp.r" + + ; + + case 43: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 458 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 460 "interp.r" + + ; + + case 21: + case 22: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 464 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 465 "interp.r" + + ; + + case 32: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 474 "interp.r" + + case 40: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 475 "interp.r" + + ; + Deref(rargp[1]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 477 "interp.r" + + ; + + case 2: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 481 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 482 "interp.r" + + ; + +//#line 486 "interp.r" + + case 3: + case 5: + case 6: + case 8: + case 9: + case 16: + case 17: + case 18: + case 31: + case 42: + case 30: + case 7: + case 10: + case 11: + case 12: + case 13: + case 14: + case 15: + case 20: + case 24: + case 25: + case 26: + case 27: + case 29: + case 28: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 511 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 514 "interp.r" + + ; + + case 1: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 517 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 518 "interp.r" + + ; + + case 39: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 522 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 523 "interp.r" + + ; + + case 38: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 527 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 528 "interp.r" + + ; + +//#line 531 "interp.r" + + case 33: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 532 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 533 "interp.r" + + ; + + case 35: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 537 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 538 "interp.r" + + ; + +//#line 542 "interp.r" + + case 36: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 4; + xargp = rargp; + sp = rsp;; + +//#line 544 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 545 "interp.r" + + ; + +//#line 548 "interp.r" + + case 41: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 549 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + Deref(rargp[3]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 553 "interp.r" + + ; + + case 98: + +//#line 559 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 570 "interp.r" + + break; + +//#line 573 "interp.r" + + case 108: + { + +//#line 583 "interp.r" + + break; + } + + case 64: + +//#line 590 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 606 "interp.r" + + break; + +//#line 610 "interp.r" + + case 44: + PushDescSP(rsp, k_subject); + PushValSP(rsp, D_Integer); + PushValSP(rsp, k_pos); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 614 "interp.r" + + ; + + signal = Obscan(2, rargp); + + goto C_rtn_term; + + case 55: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 621 "interp.r" + + ; + + signal = Oescan(1, rargp); + + goto C_rtn_term; + +//#line 629 "interp.r" + + case 89: { + apply: //cs + union block *bp; + int i, j; + + value_tmp = *(dptr)(rsp - 1); + Deref(value_tmp); + switch (Type(value_tmp)) { + case T_List: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = (int)bp->list.size; + +//#line 647 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + args * sizeof(struct descrip) > + (char *)stackend)) + fatalerr(301, NULL); + +//#line 653 "interp.r" + + for (bp = bp->list.listhead; + +//#line 657 "interp.r" + + bp != NULL; + + bp = bp->lelem.listnext) { + for (i = 0; i < bp->lelem.nused; i++) { + j = bp->lelem.first + i; + if (j >= bp->lelem.nslots) + j -= bp->lelem.nslots; + PushDescSP(rsp, bp->lelem.lslots[j]); + } + } + goto invokej; + } + + case T_Record: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = bp->record.recdesc->proc.nfields; + for (i = 0; i < args; i++) { + PushDescSP(rsp, bp->record.fields[i]); + } + goto invokej; + } + + default: { + + xargp = (dptr)(rsp - 3); + err_msg(126, &value_tmp); + goto efail; + } + } + } + + case 61: { + args = (int)(*ipc.opnd++); + invokej: + { + int nargs; + dptr carg; + + sp = rsp;; + type = invoke(args, &carg, &nargs); + rsp = sp;; + + if (type == I_Fail) + goto efail_noev; + if (type == I_Continue) + break; + else { + + rargp = carg; + +//#line 712 "interp.r" + +#if GPX //cs + pollctr >>= 1; + if (!pollctr) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 726 "interp.r" + + bproc = (struct b_proc *)BlkLoc(*rargp); + +//#line 734 "interp.r" + + if (type == I_Vararg) { +// int (*bfunc)(); + int (*bfunc)(int, dptr); //cs +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(int,dptr))(bproc->entryp.ccode); + +//#line 741 "interp.r" + + signal = (*bfunc)(nargs, rargp); + } + else + +//#line 746 "interp.r" + + { +// int (*bfunc)(); + int (*bfunc)(dptr); +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(dptr))(bproc->entryp.ccode); + +//#line 753 "interp.r" + + signal = (*bfunc)(rargp); + } + +//#line 767 "interp.r" + + goto C_rtn_term; + } + } + } + + case 62: + + PushNullSP(rsp); + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 776 "interp.r" + + ; + + signal = (*(keytab[(int)opnd]))(rargp); + goto C_rtn_term; + + case 65: + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - opnd; + xargp = rargp; + sp = rsp;; + +//#line 793 "interp.r" + + ; + +//#line 796 "interp.r" + + { + int i; + for (i = 1; i <= opnd; i++) + Deref(rargp[i]); + } + + signal = Ollist((int)opnd, rargp); + + goto C_rtn_term; + +//#line 808 "interp.r" + + case 67: + ipc.op[-1] = (96); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)opnd; + goto mark; + + case 96: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)(*ipc.opnd++); + mark: + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 85: + mark0: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = 0; + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 78: + +//#line 849 "interp.r" + + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + +//#line 855 "interp.r" + + Unmark_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + + sp = rsp;; + +//#line 866 "interp.r" + + return A_Unmark_uw; + } + + efp = efp->ef_efp; + break; + +//#line 874 "interp.r" + + case 56: { + +//#line 879 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Esusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + gfp = newgfp; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 892 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 1; + efp = efp->ef_efp; + +//#line 909 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + break; + } + + case 66: { + struct descrip sval; + +//#line 924 "interp.r" + +// dptr lval = (dptr)((word *)efp - 2); + lval = (dptr)((word *)efp - 2); //cs + +//#line 929 "interp.r" + + if (--IntVal(*lval) > 0) { + +//#line 934 "interp.r" + + sval = *(dptr)(rsp - 1); + +//#line 941 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 3; + if (gfp == 0) + gfp = efp->ef_gfp; + efp = efp->ef_efp; + +//#line 960 "interp.r" + + rsp -= 2; + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushDescSP(rsp, sval); + } + else { + +//#line 973 "interp.r" + + *lval = *(dptr)(rsp - 1); + +//#line 981 "interp.r" + + gfp = efp->ef_gfp; + +//#line 987 "interp.r" + + Lsusp_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 997 "interp.r" + + return A_Lsusp_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + } + break; + } + + case 72: { + +//#line 1015 "interp.r" + + struct descrip tmp; + dptr svalp; + struct b_proc *sproc; + +//#line 1025 "interp.r" + + svalp = (dptr)(rsp - 1); + if (Var(*svalp)) { + sp = rsp;; + retderef(svalp, (word *)glbl_argp, sp); + rsp = sp;; + } + +//#line 1035 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Psusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + newgfp->gf_argp = glbl_argp; + newgfp->gf_pfp = pfp; + gfp = newgfp; + rsp += ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + +//#line 1051 "interp.r" + + if (pfp->pf_gfp != 0) { + newgfp = (struct gf_marker *)(pfp->pf_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)pfp->pf_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)pfp->pf_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)pfp->pf_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)glbl_argp - 1; + efp = efp->ef_efp; + +//#line 1068 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + --k_level; + if (k_trace) { + k_trace--; + sproc = (struct b_proc *)BlkLoc(*glbl_argp); + strace(&(sproc->pname), svalp); + } + +//#line 1083 "interp.r" + + if (pfp->pf_scan != NULL) { + +//#line 1089 "interp.r" + + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1106 "interp.r" + + efp = pfp->pf_efp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + break; + } + +//#line 1115 "interp.r" + + case 54: { + +//#line 1124 "interp.r" + + eret_tmp = *(dptr)&rsp[-1]; + gfp = efp->ef_gfp; + Eret_uw: + +//#line 1131 "interp.r" + + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1140 "interp.r" + + return A_Eret_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + PushDescSP(rsp, eret_tmp); + break; + } + +//#line 1149 "interp.r" + + case 71: { + +//#line 1163 "interp.r" + + struct b_proc *rproc; + rproc = (struct b_proc *)BlkLoc(*glbl_argp); + +//#line 1173 "interp.r" + + *glbl_argp = *(dptr)(rsp - 1); + if (Var(*glbl_argp)) { + sp = rsp;; + retderef(glbl_argp, (word *)glbl_argp, sp); + rsp = sp;; + } + + --k_level; + if (k_trace) { + k_trace--; + rtrace(&(rproc->pname), glbl_argp); + } + Pret_uw: + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1196 "interp.r" + + return A_Pret_uw; + } + +//#line 1203 "interp.r" + + rsp = (word *)glbl_argp + 1; + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1219 "interp.r" + +//cs return to C++ + if( rsp == return_sp ) { + //printf("Op_Pret caused a return to C++\n");fflush(stdout); + --ilevel; + *result = *return_cargp; + sp = saved_sp; + return 0; + } +//cs end return to C++ + break; + } + +//#line 1224 "interp.r" + + case 53: + efail: + +//#line 1229 "interp.r" + + efail_noev: + +//#line 1233 "interp.r" + + if (gfp == 0) { + +//#line 1251 "interp.r" + + ipc = efp->ef_failure; + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + efp = efp->ef_efp; + + if (ipc.op == 0) + goto efail; + break; + } + else + { + +//#line 1267 "interp.r" + + struct descrip tmp; + register struct gf_marker *resgfp = gfp; + + type = (int)resgfp->gf_gentype; + + if (type == G_Psusp) { + glbl_argp = resgfp->gf_argp; + if (k_trace) { + k_trace--; + sp = rsp;; + atrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + rsp = sp;; + } + } + ipc = resgfp->gf_ipc; + efp = resgfp->gf_efp; + gfp = resgfp->gf_gfp; + rsp = (word *)resgfp - 1; + if (type == G_Psusp) { + pfp = resgfp->gf_pfp; + +//#line 1292 "interp.r" + + if (pfp->pf_scan != NULL) { + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1313 "interp.r" + + ++k_level; + } + + switch (type) { + +//#line 1336 "interp.r" + + case G_Csusp: + ; + --ilevel; + sp = rsp;; + +//#line 1344 "interp.r" + + return A_Resume; + + case G_Esusp: + ; + goto efail_noev; + + case G_Psusp: + ; + break; + } + + break; + } + + case 68: { + +//#line 1374 "interp.r" + + --k_level; + if (k_trace) { + k_trace--; + failtrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + } + Pfail_uw: + + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1388 "interp.r" + + return A_Pfail_uw; + } + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1406 "interp.r" + + goto efail_noev; + } + +//#line 1410 "interp.r" + + case 45: + PushNullSP(rsp); + PushValSP(rsp, ((word *)efp)[-2]); + PushValSP(rsp, ((word *)efp)[-1]); + break; + + case 46: + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + efp->ef_failure.opnd = (word *)opnd; + break; + + case 52: + PushNullSP(rsp); + rsp[1] = rsp[-3]; + rsp[2] = rsp[-2]; + rsp += 2; + break; + + case 57: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 1432 "interp.r" + + ; + + signal = Ofield(2, rargp); + + goto C_rtn_term; + + case 58: + ipc.op[-1] = (95); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + ipc.opnd = (word *)opnd; + break; + + case 95: + opnd = (*ipc.opnd++); + ipc.opnd = (word *)opnd; + break; + + case 59: + *--ipc.op = 58; + opnd = sizeof((*ipc.op)) + sizeof((*rsp)); + opnd += (word)ipc.opnd; + ipc.opnd = (word *)opnd; + break; + + case 63: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1459 "interp.r" + + ; + + if (Olimit(0, rargp) == A_Resume) { + +//#line 1468 "interp.r" + + goto efail_noev; + } + else { + +//#line 1476 "interp.r" + + rsp = (word *)rargp + 1; + } + goto mark0; + +//#line 1486 "interp.r" + + case 69: + PushNullSP(rsp); + break; + + case 70: + rsp -= 2; + break; + + case 73: + PushValSP(rsp, D_Integer); + PushValSP(rsp, 1); + break; + + case 74: + PushValSP(rsp, D_Integer); + PushValSP(rsp, -1); + break; + + case 76: + rsp += 2; + rsp[-1] = rsp[-3]; + rsp[0] = rsp[-2]; + break; + +//#line 1512 "interp.r" + + case 50: + +//#line 1515 "interp.r" + + PushNullSP(rsp); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1516 "interp.r" + + ; + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + + signal = Ocreate((word *)opnd, rargp); + + goto C_rtn_term; + +//#line 1528 "interp.r" + + case 47: { + +//#line 1534 "interp.r" + + struct b_coexpr *ncp; + dptr dp; + + sp = rsp;; + dp = (dptr)(sp - 1); + xargp = dp - 2; + + Deref(*dp); + if (dp->dword != D_Coexpr) { + err_msg(118, dp); + goto efail; + } + + ncp = (struct b_coexpr *)BlkLoc(*dp); + + signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3)); + rsp = sp;; + if (signal == A_Resume) + goto efail_noev; + else + rsp -= 2; + + break; + } + + case 49: { + +//#line 1564 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + ++BlkLoc(k_current)->coexpr.size; + co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); + rsp = sp;; + + break; + } + +//#line 1577 "interp.r" + + case 48: { + +//#line 1582 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + co_chng(ncp, NULL, NULL, A_Cofail, 1); + rsp = sp;; + + break; + } + + case 86: + +//#line 1596 "interp.r" + + goto interp_quit; + +//#line 1599 "interp.r" + + default: { + char buf[50]; + + sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", + (long)lastop, lastop); + syserr(buf); + } + } + continue; + + C_rtn_term: + rsp = sp;; + + switch (signal) { + + case A_Resume: + +//#line 1622 "interp.r" + + goto efail_noev; + + case A_Unmark_uw: + +//#line 1631 "interp.r" + + goto Unmark_uw; + + case A_Lsusp_uw: + +//#line 1640 "interp.r" + + goto Lsusp_uw; + + case A_Eret_uw: + +//#line 1649 "interp.r" + + goto Eret_uw; + + case A_Pret_uw: + +//#line 1658 "interp.r" + + goto Pret_uw; + + case A_Pfail_uw: + +//#line 1667 "interp.r" + + goto Pfail_uw; + } + + rsp = (word *)rargp + 1; + +//#line 1682 "interp.r" + + continue; + } + + interp_quit: + --ilevel; + if (ilevel != 0) + syserror("interp: termination with inactive generators."); + + return 0; + } + +} //cs --- extern "C" diff --git a/ipl/procs/calls.icn b/ipl/procs/calls.icn index 6ebb8a1..00f6114 100644 --- a/ipl/procs/calls.icn +++ b/ipl/procs/calls.icn @@ -6,7 +6,7 @@ # # Author: Ralph E. Griswold # -# Date: March 25, 2002 +# Date: March 6, 2008 # ############################################################################ # @@ -137,7 +137,7 @@ procedure read_calltable(f) T := table() - every line := read(f) do + while line := read(f) do line ? { name := tab(upto('="')) | fail move(1) diff --git a/ipl/procs/echo.icn b/ipl/procs/echo.icn new file mode 100644 index 0000000..5a90c97 --- /dev/null +++ b/ipl/procs/echo.icn @@ -0,0 +1,227 @@ +############################################################################ +# +# File: echo.icn +# +# Subject: Procedure to perform "variable interpolation" a la Perl +# +# Authors: Charles L Hethcoat III and Carl Sturtivant +# +# Date: February 9, 2010 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# echo() substitutes global variables for occurrences of $name in &subject, +# and writes the result to standard output. +# +############################################################################ +# +# Background: +# +# String "interpolation", as used in Perl, Tcl, Bash, and so on, +# involves a special notation used within a string that causes the +# value of a variable to be inserted into the string at runtime. A +# common notation for this is a dollar sign, e. g. "The price is +# $price pfennig." If a variable named "price" has the value 10, then +# on output the string becomes "The price is 10 pfennig." +# +# Interpolation is lacking in Icon, so we must use the fussier syntax +# of an Icon write() procedure: write("The price is ", price, +# "pfennig."). Here is a slightly more complex example, assuming +# variables `price' = 10, `article' == "thimble", and `currency' == +# "pfennig": +# +# write("The price of a ", article, " is ", price, " ", currency, ".") +# +# This can be annoying and error-prone if we must use many such +# strings in a program. +# +# The echo() procedure provides a very nice solution for Icon +# programmers. Compare the preceding write() call to this: +# +# "The price of a $article is $price $currency" ? echo() +# +# Is this not much simpler? Both examples will print out the string +# +# "The price of a thimble is 10 pfennig." +# +# but interpolation with echo() greatly reduces the low-level +# syntactic requirements (and reduces the number of characters to type +# from 68 to 54). It is much easier to write, read, and check. If +# many such lines of code are needed, the difference adds up. +# Consider, for example, how this would pay off if your program needs +# to generate hundreds of lines of HTML or PostScript. +# +############################################################################ +# +# Usage: +# +# A string to +# be printed with interpolated values should be set up in a scanning +# environment, using echo() as the scanning procedure, as in +# "foo$variable" ? echo(). Here is an actual example for testing: +# +# link echo +# global month, day, year +# +# procedure main() +# month := "February" +# day := 30 +# year := 2010 +# "Free beer on $month $day, $year." ? echo() +# end +# +# Assuming echo.icn has been compiled with the -c option beforehand, +# compiling, linking, and running this program produces the string +# "Free beer on February 30, 2010." on standard output. +# +############################################################################ +# +# Notes: +# +# Since there is no way for any Icon procedure to discover the values of +# any another procedure's local variables, all variables to be used via +# the echo() procedure must be global. This restriction ought not to be +# too serious for smaller programs, or even longer ones if they are of +# simple construction. But it may be a limitation for sophisticated +# Icon programming projects. You will have to be the judge. +# +# If x is a global variable with value 10, +# +# "x" ? echo() prints "x" +# "$x" ? echo() prints "10" +# "$$x" ? echo() prints "$x" +# "$$$x" ? echo() prints "$10" +# "$$$$x" ? echo() prints "$$x" +# "$$$$$x" ? echo() prints "$$10" +# +# and so on. The rule is: take dollar signs off in pairs from the +# left. Each pair prints ONE literal dollar sign on the output. +# +# If there were an odd number of dollar signs to begin with, then one +# will be left over, and this will print the value of the variable (10). +# +# If there were an even number to begin with, then none are left, and a +# literal "x" is printed. +# +# There is an extended notation that helps disambiguate some usage +# scenarios. Here are some examples: +# +# "${x}" is the same as $x. +# "${x}:" is the same as $x:. +# "${x}${y}" is the same as $x$y. +# +# However, "${x}avier" is NOT the same as $xavier! Can you see why? +# +# You may use any variable names you like. There are no restrictions. +# echo() uses no global variable names of its own, but receives the +# string it interpolates in a string scanning environment. +# +############################################################################ +# +# Using echo() on a larger scale , with input from a generator: +# +# global time, date, save, wombats +# +# link echo +# +# procedure main() +# time := &clock +# date := &date +# save := ?100000 +# wombats := 22 +# "It is now $time on $date and you have savings of $$$save." | +# "The number of wombats is $wombats." | +# "It is now ${time} on ${date} and you have ${wombats} wombats." | +# "There is no global variable named \"$foo\"." | +# "This does not work: It is now ${&clock}." | +# "" | +# "The previous input line printed an empty output line." ? echo() +# end +# +# Because echo() always fails (in the Icon sense), evaluation of +# +# a | b | c | d ? echo() +# +# will group as +# +# (a | b | c | d) ? echo() +# +# because of operator precedence, and the left-hand expression produces +# _a_ first, which is assigned to &subject. Then echo() is evaluated -- +# and fails. This makes the whole expression fail, so Icon backtracks +# to the first expression, resumes its evaluation to produce its second +# value b, which is assigned to &subject and then echo() is called, +# which fails, and so forth, until all possibilities are exhausted. +# +############################################################################ +# +# Taking input from a template file: +# +# You can create a template file (with $-strings in it) and use an Icon +# program to read it and write it out to standard output. Your main +# Icon program will supply the needed variable values for the $-strings +# in the template. +# +# As an example, suppose your program will generate a hundred business +# cards for you as a PostScript file. You have a template file named +# template.ps with $-strings such as $firstname, $lastname, $address, +# $companyname, and so on --- all embedded in it at the proper places. +# Your main program will read this template and substitute the actual +# name and address information. +# +# This is one way your program can read template.ps and pass it to +# echo(): +# +# ... +# firstname := "Joe" +# lastname := "Smith" +# # ... etc. ... +# reads("template.ps",1000000) ? echo() +# ... +# +# When this is run, your customized business cards appear on standard +# output. +# +############################################################################ +# +# This trick relies upon concatenation having a higher precedence +# than alternation: +# +# "................" || +# "................" || +# "................" | +# "................" || +# "................" | +# "................" || +# "................" ? echo() +# +# This prints out three messages, one specified on three lines, one on +# two, and one on two. The alternations fix the newlines provided at the +# end of each message by echo(). +# +# &subject is the empty string if it's unassigned. So echo() called +# without ? will under those circumstances print a blank line. +# +############################################################################ + +procedure echo() #: interpolate variables and print + + $define idchars 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_' + while writes(tab(find("$")) ) do { + move(1) + writes( ="$" | + variable(tab(many(idchars)) | + 2( ="{", tab(find("}")), ="}" ) + ) + ) | + tab(many(idchars)) | + ( ="{" & tab(find("}")) & ="}" ) + } + write(tab(0)) + $undef idchars + +end diff --git a/ipl/procs/printf.icn b/ipl/procs/printf.icn index b5f99b9..b264692 100644 --- a/ipl/procs/printf.icn +++ b/ipl/procs/printf.icn @@ -6,7 +6,7 @@ # # Author: William H. Mitchell # -# Date: July 20, 2005 +# Date: February 13, 2006 # ############################################################################ # @@ -14,30 +14,19 @@ # ############################################################################ # -# Contributors: Cheyenne Wills, Phillip Lee Thomas, Michael Glass +# Contributors: Cheyenne Wills, Phillip Lee Thomas, +# Michael Glass, Gregg M. Townsend # ############################################################################ # # This procedure behaves somewhat like the standard printf. # Supports d, e, s, o, and x formats like printf. An "r" format -# prints real numbers in a manner similar to that of printf's "f", -# but will produce a result in an exponential format if the number -# is larger than the largest integer plus one. Though "e" differs -# from printf in some details, it always produces exponential format. +# prints real numbers in a manner similar to that of printf's "f". +# Though "e" differs from printf in some details, it always produces +# exponential format. # -# Left or right justification and field width control are pro- -# vided as in printf. %s, %r, and %e handle precision specifications. -# -# The %r format is quite a bit of a hack, but it meets the -# author's requirements for accuracy and speed. Code contributions -# for %f, %e, and %g formats that work like printf are welcome. -# -# Possible new formats: -# -# %t -- print a real number as a time in hh:mm -# %R -- roman numerals -# %w -- integers in English -# %b -- binary +# Left or right justification and field width control are provided +# as in printf. %s, %r, and %e handle precision specifications. # ############################################################################ @@ -100,86 +89,52 @@ procedure _doprnt(format, args) end procedure hexstr(n) - local h, neg - static BigNeg, hexdigs, hexfix - - initial { - BigNeg := -2147483647-1 - hexdigs := "0123456789abcdef" - hexfix := "89abcdef" - } - - n := integer(n) - if n = BigNeg then - return "80000000" - h := "" - if n < 0 then { - n := -(BigNeg - n) - neg := 1 - } - repeat { - h := hexdigs[n%16+1]||h - if (n /:= 16) = 0 then - break - } - if \neg then { - h := right(h,8,"0") - h[1] := hexfix[h[1]+1] - } - return h + return _basestr(n, 4) end + procedure octstr(n) - local h, neg - static BigNeg, octdigs, octfix + return _basestr(n, 3) +end - initial { - BigNeg := -2147483647-1 - octdigs := "01234567" - octfix := "23" - } +procedure _basestr(n, b) + local s, mask - n := integer(n) - if n = BigNeg then - return "20000000000" - h := "" - if n < 0 then { - n := -(BigNeg - n) - neg := 1 - } - repeat { - h := octdigs[n%8+1]||h - if (n /:= 8) = 0 then - break - } - if \neg then { - h := right(h,11,"0") - h[1] := octfix[h[1]+1] + n := integer(n) | return image(n) + + if n = 0 then + return "0" + + # backwards compatibility hack + # treat 31-bit negative integers as positive values + if -16r80000000 <= n <= -1 then + n +:= 16r100000000 + + s := "" + mask := ishift(1, b) - 1 + while n ~= 0 & n ~= -1 do { + s := "0123456789abcdef" [1 + iand(n, mask)] || s + n := ishift(n, -b) } - return h + return s end procedure fixnum(x, prec) - local int, frac, f1, f2, p10 + local s /prec := 6 x := real(x) | return image(x) - int := integer(x) | return image(x) - frac := image(x - int) - if find("e", frac) then { - frac ?:= { - f1 := tab(upto('.')) & - move(1) & - f2 := tab(upto('e')) & - move(1) & - p10 := -integer(tab(0)) & - repl("0",p10-1) || f1 || f2 - } - } + + if x < 0 then { + s := "-" + x := -x + } else - frac ?:= (tab(upto('.')) & move(1) & tab(0)) - frac := adjustfracprec(frac, prec) - int +:= if int >= 0 then frac[2] else -frac[2] - return int || "." || frac[1] + s := "" + + x := string(integer(x * 10 ^ prec + 0.5)) + if *x <= prec then + x := right(x, prec + 1, "0") + return s || x[1:-prec] || "." || x[-prec:0] end @@ -302,10 +257,10 @@ procedure adjustfracprec(fracpart, prec) carryout := 1 } # In the usual case, round up simply increments the - # fractional part. (We put back any trailing + # fractional part. (We put back any leading # zeros that got lost.) else { - fracpart := left(integer(fracpart)+1, prec, "0") + fracpart := right(integer(fracpart)+1, prec, "0") } } } diff --git a/ipl/procs/random.icn b/ipl/procs/random.icn index 8dc58f2..2749bb7 100644 --- a/ipl/procs/random.icn +++ b/ipl/procs/random.icn @@ -6,7 +6,7 @@ # # Authors: Ralph E. Griswold and Gregg M. Townsend # -# Date: June 24, 2002 +# Date: November 5, 2009 # ############################################################################ # @@ -87,18 +87,19 @@ procedure rand_int(i) #: model ?i end procedure randomize() #: randomize - local f, s + local f, s, i static ncalls initial ncalls := 0 ncalls +:= 1 if f := open("/dev/urandom", "ru") then { - s := reads(f, 3) + s := reads(f, 4) close(f) if *\s > 0 then { - &random := ncalls % 113 - every &random := 256 * &random + ord(!s) + &random := 1 + every i := ord(!s) do + &random := 167 * &random + i return } } diff --git a/ipl/progs/diffsum.icn b/ipl/progs/diffsum.icn index 3414922..99c6e05 100644 --- a/ipl/progs/diffsum.icn +++ b/ipl/progs/diffsum.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: May 31, 1994 +# Date: August 14, 2007 # ############################################################################ # @@ -26,7 +26,7 @@ # ############################################################################ -global oldname, newname +global oldname, newname, ixname, ixprev global added, deleted, chgadd, chgdel procedure main(args) @@ -42,9 +42,13 @@ procedure main(args) chgadd := chgdel := 0 while line := read(f) do line ? { - if =" " then + if any(' @') then next - else if ="***" then { + else if ="Index: " then { + ixprev := ixname + ixname := tab(0) + } + else if =("+++" | "***")then { chgadd := 0 chgdel := +1 } @@ -71,12 +75,15 @@ procedure main(args) else if ="Only " then only() } + ixprev := ixname report() end procedure report() local net + if oldname := \ixprev then + newname := "" if added > 0 | deleted > 0 then { net := string(added - deleted) if net > 0 then @@ -85,6 +92,7 @@ procedure report() } added := deleted := 0 chgadd := chgdel := 0 + ixprev := &null return end diff --git a/ipl/progs/hebeng.icn b/ipl/progs/hebeng.icn index 5dca84a..29b4c7f 100644 --- a/ipl/progs/hebeng.icn +++ b/ipl/progs/hebeng.icn @@ -38,7 +38,7 @@ # ############################################################################ -$ifdef _MACINTOSH +$ifdef _PROICON global outfilename, outvar, outwin,hebrew_string_flag, hebrew_text_flag, screenwidth,screenheight,markers @@ -290,7 +290,7 @@ local newline,substring return newline end -$else # not Macintosh +$else # not ProIcon procedure main() stop("sorry, ", &progname, " only runs under Macintosh ProIcon") end diff --git a/ipl/progs/lindsys.icn b/ipl/progs/lindsys.icn index bd92940..fcec498 100644 --- a/ipl/progs/lindsys.icn +++ b/ipl/progs/lindsys.icn @@ -6,7 +6,7 @@ # # Author: Ralph E. Griswold # -# Date: October 23, 1998 +# Date: May 10, 2006 # ############################################################################ # @@ -80,7 +80,7 @@ # Note: An earlier version of this program had the ability to # extract an L-System specification by name from a file with # multiple specifications. This version does not -- the former -# functionality was deemed to cumbersome. +# functionality was deemed too cumbersome. # # References: # diff --git a/ipl/progs/unclog.icn b/ipl/progs/unclog.icn index ec7fe41..9fc1e1e 100644 --- a/ipl/progs/unclog.icn +++ b/ipl/progs/unclog.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: May 2, 2005 +# Date: August 14, 2007 # ############################################################################ # @@ -59,6 +59,7 @@ procedure main(args) # read description of modification while line := read(f) do { + if line ? ="branches:" then next if line ? =("-----------" | "===========") then break s ||:= "\n" || line } diff --git a/ipl/progs/weblinks.icn b/ipl/progs/weblinks.icn index b46fad5..8fd62c1 100644 --- a/ipl/progs/weblinks.icn +++ b/ipl/progs/weblinks.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: September 27, 2001 +# Date: March 29, 2006 # ############################################################################ # @@ -63,6 +63,8 @@ # # -v report tracing and successes, if selected, more verbosely # +# -i invert output (sort by referencing page, not by status) +# # -r root # specify starting point for file names beginning with "/" # (e.g. -r /cs/www). This is needed if such references are @@ -120,7 +122,6 @@ # allow longer history persistence # history is clumsy -- hard to recheck a connection that failed # add option to retry failed entries (but believe cached successes) -# add option to sort report by referencing page $define URLCOLS 56 # number of columns allotted for tracing URLs @@ -137,6 +138,7 @@ global home global prune global bounds +global invert global recurse global trace global verbose @@ -166,7 +168,8 @@ procedure main(args) # process command line - opts := options(args, "b:p:r:h:Rstv") + opts := options(args, "b:p:r:h:iRstv") + invert := opts["i"] recurse := opts["R"] successes := opts["s"] trace := opts["t"] @@ -339,14 +342,29 @@ procedure check(url) end procedure report() - local l, url, stat + local l, url, stat, s, t, u l := sort(done, 4) + t := table() while (url := get(l)) & (stat := get(l)) do { if \successes | (any('3456789', stat) & stat ~== "302 Found") then { - write(pad(stat || ":", STATCOLS), " ", url) - if \verbose | any('3456789', stat) then - every write(" referenced by:\t", !sort(refto[url])) + s := pad(stat || ":", STATCOLS) || " " || url + if \invert then + every u := !refto[url] do + put(\t[u] | (t[u] := []), s) + else { + write(s) + if \verbose | any('3456789', stat) then + every write(" referenced by:\t", !sort(refto[url])) + } + } + } + + if \invert then { + l := sort(t, 3) + while (url := get(l)) & (stat := get(l)) do { + write(url) + every write(" ", !stat) } } -- cgit v1.2.3